[commit: ghc] wip/gadtpm: Extract the type from a PmPat (pmPatType) + enabled tyOracle (056a846)

[git at git.haskell.org]

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

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

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

commit 056a846b6011ada2ecc207b4eb11e0d25c206f65
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Wed Jun 24 17:56:05 2015 +0200

    Extract the type from a PmPat (pmPatType) + enabled tyOracle


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

056a846b6011ada2ecc207b4eb11e0d25c206f65
 compiler/deSugar/Check.hs | 28 +++++++++++++++++++---------
 1 file changed, 19 insertions(+), 9 deletions(-)

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 620cf23..7c62156 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -39,6 +39,7 @@ import ErrUtils
 import TcMType (genInstSkolTyVarsX)
 import IOEnv (tryM, failM)
 
+import Data.List (find)
 import Data.Maybe (isJust)
 import Control.Monad ( when, forM, zipWithM, liftM, liftM2, liftM3 )
 
@@ -47,7 +48,6 @@ import Var (EvVar)
 import Type
 
 import TcRnTypes  ( pprInTcRnIf ) -- Shouldn't be here
-import TysPrim    ( anyTy )       -- Shouldn't be here
 import UniqSupply -- ( UniqSupply
                   -- , splitUniqSupply      -- :: UniqSupply -> (UniqSupply, UniqSupply)
                   -- , listSplitUniqSupply  -- :: UniqSupply -> [UniqSupply]
@@ -453,12 +453,12 @@ covered usupply vec (Constraint cs vsa)
   = cs `mkConstraint` covered usupply vec vsa
 
 -- CGuard
-covered usupply (GBindAbs p e : ps) vsa
+covered usupply (pat@(GBindAbs p e) : ps) vsa
   | vsa' <- tailValSetAbs $ covered usupply2 (p++ps) (VarAbs y `mkCons` vsa)
   = cs `mkConstraint` vsa'
   where
     (usupply1, usupply2) = splitUniqSupply usupply
-    y  = mkPmId usupply1 anyTy -- CHECKME: Which type to use?
+    y  = mkPmId usupply1 (pmPatType pat)
     cs = [TmConstraint y e]
 
 -- CVar
@@ -502,11 +502,11 @@ uncovered usupply vec (Union vsa1 vsa2) = uncovered usupply1 vec vsa1 `mkUnion`
 uncovered usupply vec (Constraint cs vsa) = cs `mkConstraint` uncovered usupply vec vsa
 
 -- UGuard
-uncovered usupply (GBindAbs p e : ps) vsa
+uncovered usupply (pat@(GBindAbs p e) : ps) vsa
   = cs `mkConstraint` (tailValSetAbs $ uncovered usupply2 (p++ps) (VarAbs y `mkCons` vsa))
   where
     (usupply1, usupply2) = splitUniqSupply usupply
-    y  = mkPmId usupply1 anyTy -- CHECKME: Which type to use?
+    y  = mkPmId usupply1 (pmPatType pat)
     cs = [TmConstraint y e]
 
 -- UVar
@@ -556,12 +556,12 @@ divergent usupply vec (Union vsa1 vsa2) = divergent usupply1 vec vsa1 `mkUnion`
 divergent usupply vec (Constraint cs vsa) = cs `mkConstraint` divergent usupply vec vsa
 
 -- DGuard
-divergent usupply (GBindAbs p e : ps) vsa
+divergent usupply (pat@(GBindAbs p e) : ps) vsa
   | vsa' <- tailValSetAbs $ divergent usupply2 (p++ps) (VarAbs y `mkCons` vsa)
   = cs `mkConstraint` vsa'
   where
     (usupply1, usupply2) = splitUniqSupply usupply
-    y  = mkPmId usupply1 anyTy -- CHECKME: Which type to use?
+    y  = mkPmId usupply1 (pmPatType pat)
     cs = [TmConstraint y e]
 
 -- DVar
@@ -590,6 +590,16 @@ divergent _usupply []               (Cons _ _) = panic "divergent: length mismat
 -- ----------------------------------------------------------------------------
 -- | Basic utilities
 
+-- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type
+-- of the first (or the single -WHEREVER IT IS- valid to use?) pattern
+pmPatType :: PmPat abs -> Type
+pmPatType (GBindAbs { gabs_pats = pats })
+  = ASSERT (patVecArity pats == 1) (pmPatType p)
+  where Just p = find ((==1) . patternArity) pats
+pmPatType (ConAbs { cabs_con = con, cabs_arg_tys = tys })
+  = mkTyConApp (dataConTyCon con) tys
+pmPatType (VarAbs { vabs_id = x }) = idType x
+
 mkOneConFull :: Id -> UniqSupply -> DataCon -> (ValAbs, [PmConstraint])
 --  *  x :: T tys, where T is an algebraic data type
 --     NB: in the case of a data familiy, T is the *representation* TyCon
@@ -818,8 +828,8 @@ splitConstraints (c : rest)
 satisfiable :: [PmConstraint] -> PmM Bool
 satisfiable constraints = do
   let (ty_cs, tm_cs, bot_cs) = splitConstraints constraints
-  -- sat <- tyOracle (listToBag ty_cs)
-  sat <- return True -- Leave it like this until you fix type constraint generation
+  sat <- tyOracle (listToBag ty_cs)
+  -- sat <- return True -- Leave it like this until you fix type constraint generation
   case sat of
     True -> case tmOracle tm_cs of
       Left eq -> pprInTcRnIf (ptext (sLit "this is inconsistent:") <+> ppr eq) >> return False