[commit: ghc] wip/gadtpm: Data Families PROB: looking for the source of it (967c6c7)

[git at git.haskell.org]

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

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

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

commit 967c6c7aa9c3d1cecc9d7e146c54f240250438f6
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Sat Feb 21 17:15:25 2015 +0100

    Data Families PROB: looking for the source of it


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

967c6c7aa9c3d1cecc9d7e146c54f240250438f6
 compiler/basicTypes/Var.hs      |  5 +++--
 compiler/deSugar/Check.hs       | 20 +++++++++++++++++---
 compiler/typecheck/TcRnTypes.hs | 10 ++++++++++
 compiler/typecheck/TcSMonad.hs  |  8 ++++----
 4 files changed, 34 insertions(+), 9 deletions(-)

diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs
index 925ffe3..cd26f48 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) <> getPprStyle (ppr_debug var)
+  ppr var = ppr (varName var) <> ptext (sLit "_") <> ppr (varUnique var) <> getPprStyle (ppr_debug var)
 
 ppr_debug :: Var -> PprStyle -> SDoc
 ppr_debug (TyVar {}) sty
@@ -307,7 +307,8 @@ mkTcTyVar name kind details
 
 tcTyVarDetails :: TyVar -> TcTyVarDetails
 tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details
-tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
+tcTyVarDetails tv@(TyVar {}) =  pprPanic "tcTyVarDetails" (ptext (sLit "TyVar") $$ ppr tv)
+tcTyVarDetails tv@(Id {})    =  pprPanic "tcTyVarDetails" (ptext (sLit "Id") $$ ppr tv)
 
 setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
 setTcTyVarDetails tv details = tv { tc_tv_details = details }
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index e43a86c..fa335bd 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -49,6 +49,10 @@ import Control.Monad ( forM, foldM, zipWithM )
 
 import MonadUtils -- MonadIO
 
+
+import TcRnTypes (pprInTcRnIf)
+import Var (varType)
+
 {-
 This module checks pattern matches for:
 \begin{enumerate}
@@ -131,6 +135,8 @@ checkpm :: [Type] -> [EquationInfo] -> DsM (Maybe PmResult)
 checkpm tys eq_info
   | null eq_info = return (Just ([],[],[])) -- If we have an empty match, do not reason at all
   | otherwise = do
+      loc <- getSrcSpanDs
+      pprInTcRnIf (ptext (sLit "Checking match at") <+> ppr loc <+> ptext (sLit "with signature:") <+> ppr tys)
       uncovered0 <- initial_uncovered tys
       let allvanilla = all isVanillaEqn eq_info
       -- Need to pass this to process_vector, so that tc can be avoided
@@ -545,10 +551,12 @@ inferTyPmPat (PmLitCon ty _) = return (ty, emptyBag)
 inferTyPmPat (PmConPat con args) = do
   (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    = dataConOrigTyCon  con                     -- Type constructor
+  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
@@ -569,9 +577,15 @@ wt :: [Type] -> OutVec -> PmM Bool
 wt sig (_, vec)
   | length sig == length vec = do
       (tys, cs) <- inferTyPmPats vec
-      cs' <- zipWithM newEqPmM sig tys -- The vector should match the signature type
+      cs' <- zipWithM newEqPmM (map expandTypeSynonyms sig) tys -- The vector should match the signature type
       env_cs <- getDictsDs
-      isSatisfiable (listToBag cs' `unionBags` cs `unionBags` env_cs)
+      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)
+      let constraints = listToBag cs' `unionBags` cs `unionBags` env_cs
+      pprInTcRnIf (ptext (sLit "Constraints:") <+> ppr (mapBag varType constraints))
+      isSatisfiable constraints
   | otherwise = pprPanic "wt: length mismatch:" (ppr sig $$ ppr vec)
 
 {-
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 8ad9e1d..9c21c19 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -91,6 +91,9 @@ module TcRnTypes(
         pprEvVars, pprEvVarWithType,
         pprArising, pprArisingAt,
 
+        -- Debugging
+        pprInTcRnIf,
+
         -- Misc other types
         TcId, TcIdSet, HoleSort(..)
 
@@ -2228,3 +2231,10 @@ data TcPluginResult
     -- These are removed from the inert set,
     -- and the evidence for them is recorded.
     -- The second field contains new work, that should be processed by
+
+--- - CHECKING MY PRINTING
+pprInTcRnIf :: SDoc -> TcRnIf gbl lcl ()
+pprInTcRnIf doc = do
+  dflags <- getDynFlags
+  liftIO (putStrLn (showSDoc dflags doc))
+
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 6e50c96..3721f92 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -962,10 +962,10 @@ checkInsoluble :: TcS Bool
 -- True if there are any insoluble constraints
 checkInsoluble
   = do { icans <- getInertCans
-       -- ; let insols = inert_insols icans
-       -- ; if isEmptyBag insols
-       --     then return ()
-       --     else wrapTcS $ pprInTcRnIf (ptext (sLit "insolubles:") $$ ppr insols) -- just to see
+       ; let insols = inert_insols icans
+       ; if isEmptyBag insols
+           then return ()
+           else wrapTcS $ pprInTcRnIf (ptext (sLit "insolubles:") $$ ppr insols) -- just to see
        ; return (not (isEmptyBag (inert_insols icans))) }
 
 lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))