[commit: ghc] wip/gadtpm: Probably fixed the data family issue (e44c631)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/gadtpm
Link       : http://ghc.haskell.org/trac/ghc/changeset/e44c63196b6351261e0c734be134c8bcdee6e9ac/ghc

>---------------------------------------------------------------

commit e44c63196b6351261e0c734be134c8bcdee6e9ac
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Mon Feb 23 23:23:31 2015 +0100

    Probably fixed the data family issue


>---------------------------------------------------------------

e44c63196b6351261e0c734be134c8bcdee6e9ac
 compiler/basicTypes/Var.hs |  2 +-
 compiler/deSugar/Check.hs  | 43 ++++++++++++++++++++++++++++---------------
 2 files changed, 29 insertions(+), 16 deletions(-)

diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs
index cd26f48..d121793 100644
--- a/compiler/basicTypes/Var.hs
+++ b/compiler/basicTypes/Var.hs
@@ -205,7 +205,7 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
 -}
 
 instance Outputable Var where
-  ppr var = ppr (varName var) <> ptext (sLit "_") <> ppr (varUnique var) <> getPprStyle (ppr_debug var)
+  ppr var = parens $ ppr (varName var) <> ptext (sLit "_") <> ppr (varUnique var) <> getPprStyle (ppr_debug var) <+> dcolon <+> ppr (varType var)
 
 ppr_debug :: Var -> PprStyle -> SDoc
 ppr_debug (TyVar {}) sty
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index fa335bd..ec852ff 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -52,6 +52,7 @@ import MonadUtils -- MonadIO
 
 import TcRnTypes (pprInTcRnIf)
 import Var (varType)
+import Type
 
 {-
 This module checks pattern matches for:
@@ -549,20 +550,26 @@ inferTyPmPat (PmVarPat ty _) = return (ty, emptyBag) -- instTypePmM ty >>= \ty'
 inferTyPmPat (PmLitPat ty _) = return (ty, emptyBag)
 inferTyPmPat (PmLitCon ty _) = return (ty, emptyBag)
 inferTyPmPat (PmConPat con args) = do
+  -- ----------------------------------------------------------------
+  pprInTcRnIf (ptext (sLit "Iferring type for pattern:") <+> ppr (PmConPat con args))
+  pprInTcRnIf (ptext (sLit "dataConUserType =") <+> ppr (dataConUserType con))
+  pprInTcRnIf (ptext (sLit "dataConSig      =") <+> ppr (dataConSig con))
+  -- ----------------------------------------------------------------
   (tys, cs) <- inferTyPmPats args -- Infer argument types and respective constraints (Just like the paper)
-  subst  <- mkConSigSubst con      -- Create the substitution theta (Just like the paper)
-  let tycon    = dataConTyCon con -- JUST A TEST dataConOrigTyCon  con                     -- Type constructor
-      arg_tys  = substTys    subst (dataConOrigArgTys con) -- Argument types
-      univ_tys = substTyVars subst (dataConUnivTyVars con) -- Universal variables (to instantiate tycon)
-      tau      = mkTyConApp tycon univ_tys                 -- Type of the pattern
-
-  pprInTcRnIf (ptext (sLit "pattern:") <+> ppr (PmConPat con args) <+> ptext (sLit "has univ tys length:") <+> ppr (length univ_tys))
-  con_thetas <- mapM (nameType "varcon") $ substTheta subst (dataConTheta con) -- Constraints from the constructor signature
-  eq_thetas  <- foldM (\acc (ty1, ty2) -> do
-                          eq_theta <- newEqPmM ty1 ty2
-                          return (eq_theta `consBag` acc))
-                      cs (tys `zip` arg_tys)
-  return (tau, listToBag con_thetas `unionBags` eq_thetas)
+
+  let (tvs, thetas', arg_tys', res_ty') = dataConSig con -- take apart the constructor
+      tkvs = varSetElemsKvsFirst (closeOverKinds (mkVarSet tvs)) -- as, bs and their kinds
+  (subst, _tvs) <- -- create the substitution for both as and bs
+    getSrcSpanDs >>= \loc -> genInstSkolTyVars loc tkvs
+  let res_ty  = substTy  subst res_ty' -- result type
+      arg_tys = substTys subst arg_tys'
+  thetas <- mapM (nameType "varcon") $ substTheta subst thetas'
+
+  arg_thetas <- foldM (\acc (ty1, ty2) -> do
+                         eq_theta <- newEqPmM ty1 ty2
+                         return (eq_theta `consBag` acc))
+                      cs (tys `zip` arg_tys) -- All thetas from the argument patterns and tau_i ~ t_i for all arguments
+  return (res_ty, listToBag thetas `unionBags` arg_thetas)
 
 inferTyPmPats :: [PmPat Id] -> PmM ([Type], Bag EvVar)
 inferTyPmPats pats = do
@@ -581,8 +588,9 @@ wt sig (_, vec)
       env_cs <- getDictsDs
       loc <- getSrcSpanDs
       pprInTcRnIf (ptext (sLit "Checking in location:") <+> ppr loc)
-      pprInTcRnIf (ptext (sLit "Checking vector") <+> ppr vec <+> ptext (sLit "with inferred type:") <+> ppr tys)
-      pprInTcRnIf (ptext (sLit "With given signature:") <+> ppr sig)
+      pprInTcRnIf (ptext (sLit "Checking vector") <+> ppr vec <+> ptext (sLit "with inferred type:") <+>
+                          sep (punctuate comma (map pprTyWithKind tys)))
+      pprInTcRnIf (ptext (sLit "With given signature:") <+> sep (punctuate comma (map pprTyWithKind sig)))
       let constraints = listToBag cs' `unionBags` cs `unionBags` env_cs
       pprInTcRnIf (ptext (sLit "Constraints:") <+> ppr (mapBag varType constraints))
       isSatisfiable constraints
@@ -766,3 +774,8 @@ To check this match, we should perform arbitrary computations at compile time
 returning a @Nothing at .
 -}
 
+
+--
+pprTyWithKind :: Type -> SDoc
+pprTyWithKind ty = parens (ppr ty <+> dcolon <+> pprKind (typeKind ty))
+