[commit: ghc] wip/gadtpm: tiny (d26c493)

[git at git.haskell.org]

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

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

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

commit d26c49350efaf8e9a38fa2bfa09ae6924d5fe055
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Wed Jun 24 12:54:53 2015 +0200

    tiny


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

d26c49350efaf8e9a38fa2bfa09ae6924d5fe055
 compiler/basicTypes/UniqSupply.hs |  4 ++++
 compiler/deSugar/Check.hs         | 20 +++++++++-----------
 2 files changed, 13 insertions(+), 11 deletions(-)

diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs
index 3d0573d..62700a6 100644
--- a/compiler/basicTypes/UniqSupply.hs
+++ b/compiler/basicTypes/UniqSupply.hs
@@ -18,6 +18,7 @@ module UniqSupply (
 
         -- * Unique supply monad and its abstraction
         UniqSM, MonadUnique(..),
+        liftUs,
 
         -- ** Operations on the monad
         initUs, initUs_,
@@ -180,6 +181,9 @@ instance MonadUnique UniqSM where
     getUniqueM  = getUniqueUs
     getUniquesM = getUniquesUs
 
+liftUs :: MonadUnique m => UniqSM a -> m a
+liftUs m = getUniqueSupplyM >>= return . flip initUs_ m
+
 getUniqueUs :: UniqSM Unique
 getUniqueUs = USM (\us -> case takeUniqFromSupply us of
                           (u,us') -> (# u, us' #))
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 499aba8..c7a0632 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -201,8 +201,6 @@ check tys eq_info
       mb_res  <- check' eq_info (initial_uncovered usupply tys)
       return $ mb_res >>= \(rs, is, us) -> return (rs, is, valSetAbsToList us)
 
-liftUs :: UniqSM a -> DsM a
-
 check' :: [EquationInfo] -> ValSetAbs -> DsM (Maybe ([EquationInfo], [EquationInfo], ValSetAbs))
 check' [] missing = do
   missing' <- pruneValSetAbs missing
@@ -211,8 +209,8 @@ check' [] missing = do
     Just u  -> Just ([], [], u)
 check' (eq:eqs) missing = do
   -- Translate and process current clause
-  translated <- liftUs translateEqnInfo eq
-  pm_result <- patVectProc translated missing
+  translated <- liftUs (translateEqnInfo eq)
+  pm_result  <- patVectProc translated missing
 
   -- Recursively reason about the rest of the match
   case pm_result of
@@ -373,7 +371,7 @@ translatePatVec pats = mapM translatePat pats
 -- Temporary function (drops the guard (MR at the moment))
 translateEqnInfo :: EquationInfo -> UniqSM PatVec
 translateEqnInfo (EqnInfo { eqn_pats = ps })
-  = translatePatVec ps
+  = concat <$> translatePatVec ps
 -- -----------------------------------------------------------------------
 
 translateConPatVec :: DataCon -> HsConPatDetails Id -> UniqSM PatVec
@@ -438,10 +436,10 @@ covered :: UniqSupply -> PatVec -> ValSetAbs -> ValSetAbs
 --      Constraint cs vsa -> mkConstraint cs (traverse f us vsa)
 --      Cons va vsa       -> traverseCons f us pv va vsa
 
-traverse2 f us (p gs : pv) va vsa = ....
-
-traverse2 f us (x    : pv) va vsa = ....
-traverse2 f us (p gd : pv) va vsa = ....
+-- traverse2 f us (p gs : pv) va vsa = ....
+-- 
+-- traverse2 f us (x    : pv) va vsa = ....
+-- traverse2 f us (p gd : pv) va vsa = ....
 
 -- 
 -- 
@@ -847,7 +845,7 @@ satisfiable constraints = do
 -- False => Set is definitely empty
 -- Fact:  anySatValSetAbs s = pruneValSetAbs /= Empty
 --        (but we implement it directly for efficiency)
-anySatValSetAbs :: ValSetAbs -> PmM Bool
+anySatValSetAbs :: ValSetAbs -> PmM (Maybe Bool) -- TO BOOL
 anySatValSetAbs = anySatValSetAbs' []
   where
     anySatValSetAbs' :: [PmConstraint] -> ValSetAbs -> PmM (Maybe Bool)
@@ -865,7 +863,7 @@ anySatValSetAbs = anySatValSetAbs' []
 
 -- | For exhaustiveness check
 -- Prune the set by removing unsatisfiable paths
-pruneValSetAbs :: ValSetAbs -> PmM ValSetAbs
+pruneValSetAbs :: ValSetAbs -> PmM (Maybe ValSetAbs) -- TO BOOL
 pruneValSetAbs = pruneValSetAbs' []
   where
     pruneValSetAbs' :: [PmConstraint] -> ValSetAbs -> PmM (Maybe ValSetAbs)