[make E.FromHs conversion happen in the 'Ce' monad.
John Meacham <john@repetae.net>**20060228152819] hunk ./E/FromHs.hs 13
+import Control.Monad.RWS
hunk ./E/FromHs.hs 40
+import E.Program
hunk ./E/FromHs.hs 44
+import FrontEnd.TiData
hunk ./E/FromHs.hs 46
+import Util.Gen
hunk ./E/FromHs.hs 324
+newtype Ce t a = Ce (StateT Int t a)
+    deriving(Monad,Functor,MonadTrans,MonadIO,MonadState Int)
+
+instance Monad m => UniqueProducer (Ce m) where
+    newUniq = do
+        i <- get
+        put $! (i + 1)
+        return i
hunk ./E/FromHs.hs 335
-convertDecls classHierarchy assumps dataTable hsDecls = return (map anninst $ concatMap cDecl hsDecls) where
+convertDecls classHierarchy assumps dataTable hsDecls = evalStateT ans 2 where
+    Ce ans = do
+        nds <- mapM cDecl hsDecls
+        return (map anninst $ concat nds)
hunk ./E/FromHs.hs 345
-    cDecl :: HsDecl -> [(Name,TVr,E)]
+    cDecl :: Monad m => HsDecl -> Ce m [(Name,TVr,E)]
hunk ./E/FromHs.hs 348
-        expr x    = [(name,var,lamt x)]
+        expr x    = return [(name,var,lamt x)]
hunk ./E/FromHs.hs 363
-        expr x     = [(name,var,lamt x)]
+        expr x     = return [(name,var,lamt x)]
hunk ./E/FromHs.hs 367
-        expr x = [(name,var,lamt x)]
+        expr x = return [(name,var,lamt x)]
hunk ./E/FromHs.hs 401
-    cDecl (HsPatBind sl p (HsUnGuardedRhs exp) []) | (HsPVar n) <- simplifyHsPat p, n == sillyName' = let
-        in [(v_silly,tvr,cExpr exp)]
-    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- simplifyHsPat p = let
-        name = toName Name.Val n
-        var = tVr (nameToInt name) ty -- lp ps (hsLet wh e)
-        (ty,lamt) = pval name
-        in [(name,var,lamt $ hsLetE wh (cRhs sl rhs))]
-    cDecl (HsFunBind [(HsMatch sl n ps rhs wh)]) | ps' <- map simplifyHsPat ps, all isHsPVar ps' = [(name,var,lamt $ lp  ps' (hsLetE wh (cRhs sl rhs))) ] where
-        name = toName Name.Val n
-        var = tVr ( nameToInt name) ty -- lp ps (hsLet wh e)
-        (ty,lamt) = pval name
-    cDecl (HsFunBind ms@((HsMatch sl n ps _ _):_)) = [(name,v,lamt $ z $ cMatchs bs (matchesConv ms) (ump sl rt))] where
-        name = toName Name.Val n
-        v = tVr (nameToInt name) t -- lp ps (hsLet wh e)
-        (t,lamt) = pval name
-        (targs,eargs) = argTypes t
-        bs' = [(tVr (n) t) | n <- localVars | t <- take numberPatterns eargs]
-        bs  = map EVar bs'
-        rt = discardArgs (length targs + numberPatterns) t
-        numberPatterns = length ps
-        z e = foldr (eLam) e bs'
-    cDecl HsNewTypeDecl {  hsDeclName = dname, hsDeclArgs = dargs, hsDeclCon = dcon, hsDeclDerives = derives } = makeDerives dname dargs [dcon] (map (toName ClassName) derives)
-    cDecl HsDataDecl {  hsDeclName = dname, hsDeclArgs = dargs, hsDeclCons = dcons, hsDeclDerives = derives } = makeDerives dname dargs dcons (map (toName ClassName) derives)
+    cDecl (HsPatBind sl p (HsUnGuardedRhs exp) []) | (HsPVar n) <- simplifyHsPat p, n == sillyName' = do
+        e <- cExpr exp
+        return [(v_silly,tvr,e)]
+
+    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- simplifyHsPat p = do
+        let name = toName Name.Val n
+            var = tVr (nameToInt name) ty
+            (ty,lamt) = pval name
+        rhs <- cRhs sl rhs
+        lv <- hsLetE wh rhs
+        return [(name,var,lamt lv)]
+    cDecl (HsFunBind [(HsMatch sl n ps rhs wh)]) | ps' <- map simplifyHsPat ps, all isHsPVar ps' = do
+        let name = toName Name.Val n
+            var = tVr ( nameToInt name) ty
+            (ty,lamt) = pval name
+        rhs <- cRhs sl rhs
+        lv <- hsLetE wh rhs
+        return [(name,var,lamt $ lp  ps' lv)]
+    cDecl (HsFunBind ms@((HsMatch sl n ps _ _):_)) = do
+        let name = toName Name.Val n
+            v = tVr (nameToInt name) t -- lp ps (hsLet wh e)
+            (t,lamt) = pval name
+            (targs,eargs) = argTypes t
+            bs' = [(tVr (n) t) | n <- localVars | t <- take numberPatterns eargs]
+            bs  = map EVar bs'
+            rt = discardArgs (length targs + numberPatterns) t
+            numberPatterns = length ps
+            z e = foldr (eLam) e bs'
+        ms <- cMatchs bs (matchesConv ms) (ump sl rt)
+        return [(name,v,lamt $ z ms )]
+    cDecl HsNewTypeDecl {  hsDeclName = dname, hsDeclArgs = dargs, hsDeclCon = dcon, hsDeclDerives = derives } = return $ makeDerives dname dargs [dcon] (map (toName ClassName) derives)
+    cDecl HsDataDecl {  hsDeclName = dname, hsDeclArgs = dargs, hsDeclCons = dcons, hsDeclDerives = derives } = return $ makeDerives dname dargs dcons (map (toName ClassName) derives)
hunk ./E/FromHs.hs 434
-    cDecl _ = []
+    cDecl _ = return []
hunk ./E/FromHs.hs 438
-    cExpr (HsAsPat n' (HsVar n)) = foldl eAp (EVar (tv n)) (map ty $ specialize t t') where
+    cExpr :: Monad m => HsExp -> Ce m E
+    cExpr (HsAsPat n' (HsVar n)) = return $ foldl eAp (EVar (tv n)) (map tipe $ specialize t t') where
hunk ./E/FromHs.hs 442
-    --cExpr (HsAsPat n' (HsVar n)) = spec t t' $ EVar (tv n) where
-        --(Forall _ (_ :=> t)) = getAssump n
-        --Forall [] ((_ :=> t')) = getAssump n'
-    cExpr (HsAsPat n' (HsCon n)) =  constructionExpression dataTable (toName DataConstructor n) rt where
-        --Forall [] ((_ :=> t')) = getAssump n'
+    cExpr (HsAsPat n' (HsCon n)) = return $ constructionExpression dataTable (toName DataConstructor n) rt where
hunk ./E/FromHs.hs 444
-        (_,rt) = argTypes' (ty t')
-    cExpr (HsLit (HsString s)) = E.Values.toE s
-    cExpr (HsLit (HsInt i)) = intConvert i
-    cExpr (HsLit (HsChar ch)) = toE ch
-    cExpr (HsLit (HsFrac i))  = toE i
-    cExpr (HsLambda sl ps e)
-        | all isHsPVar ps' =  lp ps' (cExpr e)
-        | otherwise = error $ "Invalid HSLambda at: " ++ show sl
-        where
-        ps' = map simplifyHsPat ps
-    cExpr (HsInfixApp e1 v e2) = eAp (eAp (cExpr v) (cExpr e1)) (cExpr e2)
-    cExpr (HsLeftSection op e) = eAp (cExpr op) (cExpr e)
-    cExpr (HsApp (HsRightSection e op) e') = eAp (eAp (cExpr op) (cExpr e')) (cExpr e)
-    cExpr (HsRightSection e op) = eLam var (eAp (eAp cop (EVar var)) ce)  where
-        (_,TVr { tvrType = ty}:_) = fromPi (getType cop)
-        var = (tVr ( nv) ty)
-        cop = cExpr op
-        ce = cExpr e
-        fvSet = (freeVars cop `Set.union` freeVars ce)
-        (nv:_) = [ v  | v <- localVars, not $  v `Set.member` fvSet  ]
-    cExpr (HsApp e1 e2) = eAp (cExpr e1) (cExpr e2)
+        (_,rt) = argTypes' (tipe t')
+    cExpr (HsLit (HsString s)) = return $ E.Values.toE s
+    cExpr (HsLit (HsInt i)) = return $ intConvert i
+    cExpr (HsLit (HsChar ch)) = return $ toE ch
+    cExpr (HsLit (HsFrac i))  = return $ toE i
+    cExpr (HsLambda sl ps e) | all isHsPVar ps' = do
+        e <- cExpr e
+        return $ lp ps' e
+      where ps' = map simplifyHsPat ps
+    cExpr (HsInfixApp e1 v e2) = do
+        v <- cExpr v
+        e1 <- cExpr e1
+        e2 <- cExpr e2
+        return $ eAp (eAp v e1) e2
+    cExpr (HsLeftSection op e) = liftM2 eAp (cExpr op) (cExpr e)
+    cExpr (HsApp (HsRightSection e op) e') = do
+        op <- cExpr op
+        e' <- cExpr e'
+        e <- cExpr e
+        return $ eAp (eAp op e') e
+    cExpr (HsRightSection e op) = do
+        cop <- cExpr op
+        ce <- cExpr e
+        let (_,TVr { tvrType = ty}:_) = fromPi (getType cop)
+        [var] <- newVars [ty]
+        return $ eLam var (eAp (eAp cop (EVar var)) ce)
+    cExpr (HsApp e1 e2) = liftM2 eAp (cExpr e1) (cExpr e2)
hunk ./E/FromHs.hs 473
-    cExpr (HsNegApp e) = (doNegate (cExpr e))
+    cExpr (HsNegApp e) = liftM doNegate (cExpr e)
hunk ./E/FromHs.hs 475
-    cExpr (HsIf e a b) = eIf (cExpr e) (cExpr a) (cExpr b)
+    cExpr (HsIf e a b) = liftM3 eIf (cExpr e) (cExpr a) (cExpr b)
hunk ./E/FromHs.hs 477
-    cExpr (HsAsPat n hs@(HsCase e alts)) = ans where
-        ans = cMatchs [cExpr e] (altConv alts) (EError ("No Match in Case expression at " ++ show (srcLoc hs))  ty)
-        ty = cType n
-    cExpr (HsTuple es) = eTuple (map cExpr es)
-    cExpr (HsAsPat n (HsList xs)) = cl xs where
-        cl (x:xs) = eCons (cExpr x) (cl xs)
-        cl [] = eNil (cType n)
-    cExpr e = error ("Cannot convert: " ++ show e)
-    hsLetE [] e =  e
-    hsLetE dl e =  ELetRec [ (b,c) | (_,b,c) <- (concatMap cDecl dl)] e
-    hsLet dl e = hsLetE dl (cExpr e)
+    cExpr (HsAsPat n hs@(HsCase e alts)) = do
+        let ty = cType n
+        scrut <- cExpr e
+        cMatchs [scrut] (altConv alts) (EError ("No Match in Case expression at " ++ show (srcLoc hs))  ty)
+    cExpr (HsTuple es) = liftM eTuple (mapM cExpr es)
+    cExpr (HsAsPat n (HsList xs)) = do
+        let cl (x:xs) = liftM2 eCons (cExpr x) (cl xs)
+            cl [] = return $ eNil (cType n)
+        cl xs
+    cExpr e = fail ("Cannot convert: " ++ show e)
+    hsLetE [] e = return  e
+    hsLetE dl e = do
+        nds <- mconcatMapM cDecl dl
+        return $ ELetRec [ (b,c) | (_,b,c) <- nds] e
+    hsLet dl e = do
+        e <- cExpr e
+        hsLetE dl e
hunk ./E/FromHs.hs 495
-    ty x = tipe x
-    kd x = kind x
-    cMatchs :: [E] -> [([HsPat],HsRhs,[HsDecl])] -> E -> E
-    cMatchs bs ms els = convertMatches funcs dataTable tv cType bs (processGuards ms) els
+    cMatchs :: Monad m => [E] -> [([HsPat],HsRhs,[HsDecl])] -> E -> Ce m E
+    cMatchs bs ms els = do
+        pg <- processGuards ms
+        convertMatches funcs dataTable tv cType bs pg els
hunk ./E/FromHs.hs 500
-    cGuard (HsUnGuardedRhs e) _ = cExpr e
-    cGuard (HsGuardedRhss (HsGuardedRhs _ g e:gs)) els = eIf (cExpr g) (cExpr e) (cGuard (HsGuardedRhss gs) els)
-    cGuard (HsGuardedRhss []) e = e
+    cGuard (HsUnGuardedRhs e) = liftM const $ cExpr e
+    cGuard (HsGuardedRhss (HsGuardedRhs _ g e:gs)) = do
+        g <- cExpr g
+        e <- cExpr e
+        fg <- cGuard (HsGuardedRhss gs)
+        return (\els -> eIf g e (fg els))
+    cGuard (HsGuardedRhss []) = return id
hunk ./E/FromHs.hs 521
-        f (HsGuardedRhs _ g e:gs) = eIf (cExpr g) (cExpr e) (f gs)
-        f [] = ump sl $ getType (cExpr e)
-    processGuards xs = [ (map simplifyHsPat ps,hsLetE wh . cGuard e) | (ps,e,wh) <- xs ]
+        f (HsGuardedRhs _ g e:gs) = liftM3 eIf (cExpr g) (cExpr e) (f gs)
+        f [] = do
+            e <- cExpr e
+            return $ ump sl $ getType e
+    processGuards xs = flip mapM xs $ \ (ps,e,wh) -> do
+        cg <- cGuard e
+        nds <- mconcatMapM cDecl wh
+        let elet = ELetRec [ (b,c) | (_,b,c) <- nds]
+        return (map simplifyHsPat ps,elet . cg )
hunk ./E/FromHs.hs 532
-    cClassDecl (HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon name) _)) decls) = ans where
-        ds = map simplifyDecl decls
-        cr = findClassRecord classHierarchy (toName ClassName name)
-        ans = cClass cr ++ concatMap method [  n | n :>: _ <- classAssumps cr]
-        method n = [(defaultName,tVr (nameToInt defaultName) ty,els) | els <- mels] where
-            defaultName = defaultInstanceName n
-            (TVr { tvrType = ty}) = tv (nameName n)
-            mels = case [ d | d <- ds, maybeGetDeclName d == Just n] of
-                [] -> []
-                (d:_) | ~[(_,_,v)] <- cDecl d -> [v]
-        cClass classRecord =  [ f n (nameToInt n) (convertOneVal t) | n :>: t <- classAssumps classRecord ] where
-            f n i t = (n,setProperties [prop_METHOD,prop_PLACEHOLDER] $ tVr i t, foldr ELam (EPrim (primPrim ("Placeholder: " ++ show n)) [] ft) args)  where
-                (ft',as) = fromPi t
-                (args,rargs) = span (sortStarLike . getType) as
-                ft :: E
-                ft = foldr EPi ft' rargs
+    cClassDecl (HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon name) _)) decls) = do
+        let ds = map simplifyDecl decls
+            cr = findClassRecord classHierarchy (toName ClassName name)
+            method n = do
+                let defaultName = defaultInstanceName n
+                    (TVr { tvrType = ty}) = tv (nameName n)
+                tels <- case [ d | d <- ds, maybeGetDeclName d == Just n] of
+                    [] -> return []
+                    (d:_) -> cDecl d >>= \ [(_,_,v)] -> return [v]
+                return [(defaultName,tVr (toId defaultName) ty,els) | els <- tels ]
+            cClass classRecord =  [ f n (nameToInt n) (convertOneVal t) | n :>: t <- classAssumps classRecord ] where
+                f n i t = (n,setProperties [prop_METHOD,prop_PLACEHOLDER] $ tVr i t, foldr ELam (EPrim (primPrim ("Placeholder: " ++ show n)) [] ft) args)  where
+                    (ft',as) = fromPi t
+                    (args,rargs) = span (sortStarLike . getType) as
+                    ft = foldr EPi ft' rargs
+        mthds <- mconcatMapM method  [  n | n :>: _ <- classAssumps cr]
+        return (cClass cr ++ mthds)
hunk ./E/FromHs.hs 591
-convertMatches funcs dataTable tv cType bs ms err = evalState (match bs ms err) (20 + 2*length bs)  where
+convertMatches funcs dataTable tv cType bs ms err = match bs ms err where
hunk ./E/FromHs.hs 596
-    match :: [E] -> [([HsPat],E->E)] -> E -> State Int E
+    match :: Monad m => [E] -> [([HsPat],E->E)] -> E -> Ce m E