[clean up code some
John Meacham <john@repetae.net>**20061212063742] hunk ./E/FromHs.hs 122
-simplifyHsPat (HsPNeg p)
-    | HsPLit (HsInt i) <- p' = HsPLit $ HsInt (negate i)
-    | HsPLit (HsFrac i) <- p' = HsPLit $ HsFrac (negate i)
-    | otherwise = HsPNeg p'
-    where p' = (simplifyHsPat p)
+simplifyHsPat HsPNeg {} = error "E.FromHs: HsPNeg exists"
hunk ./E/FromHs.hs 159
-
hunk ./E/FromHs.hs 311
+    ceFuncs  :: FuncNames E,
hunk ./E/FromHs.hs 351
+        ceFuncs = funcs,
hunk ./E/FromHs.hs 354
+    Identity funcs = fmapM (return . EVar . toTVr assumps) sFuncNames
hunk ./E/FromHs.hs 359
-    Identity funcs = fmapM (return . EVar . toTVr assumps) sFuncNames
hunk ./E/FromHs.hs 409
-        return . (:[]) =<< nameToEntryPoint dataTable (tv n) (toName Name.FfiExportName ecn) (Just ffi) =<< fmapM (return . toTVr assumps) sFuncNames
+        tn <- convertVar (toName Name.Val n)
+        return . (:[]) =<< nameToEntryPoint dataTable tn (toName Name.FfiExportName ecn) (Just ffi) =<< fmapM (return . toTVr assumps) sFuncNames
hunk ./E/FromHs.hs 428
-        return [(name,var,lamt $ lp  ps' lv)]
+        lps <- lp  ps' lv
+        return [(name,var,lamt lps )]
hunk ./E/FromHs.hs 468
-        return $ lp ps' e
+        lp ps' e
hunk ./E/FromHs.hs 495
-        let ty = cType n
+        ty <- convertTyp (toName Name.Val n)
hunk ./E/FromHs.hs 498
-        let ty = cType n
+        ty <- convertTyp (toName Name.Val n)
hunk ./E/FromHs.hs 504
+        ty <- convertTyp (toName Name.Val n)
hunk ./E/FromHs.hs 506
-            cl [] = return $ eNil (cType n)
+            cl [] = return $ eNil ty
hunk ./E/FromHs.hs 509
-        return (EVar (tv n))
+        t <- convertVar (toName Name.Val n)
+        return (EVar t)
hunk ./E/FromHs.hs 529
-        convertMatches funcs tv cType bs pg els
+        convertMatches bs pg els
hunk ./E/FromHs.hs 543
-    tv n = tvr { tvrType = removeNewtypes dataTable (tvrType tvr) } where
-        tvr = toTVr assumps (toName Name.Val n)
-    lp  [] e = e
-    lp  (HsPVar n:ps) e = eLam (tv n) $ lp  ps e
+    lp  [] e = return e
+    lp  (HsPVar n:ps) e = do
+        v <- convertVar (toName Name.Val n)
+        eLam v `liftM` lp ps e
hunk ./E/FromHs.hs 560
-    cType (n::HsName) = fst $ convertVal assumps (toName Name.Val n)
hunk ./E/FromHs.hs 573
+convertVar n = do
+    (t,_,_) <- convertValue n
+    return t
+convertTyp n = do
+    (_,t,_) <- convertValue n
+    return t
+
+
hunk ./E/FromHs.hs 611
-convertMatches funcs tv cType bs ms err = match bs ms err where
-    doNegate e = eAp (eAp (func_negate funcs) (getType e)) e
-    fromInt = func_fromInt funcs
-    fromInteger = func_fromInteger funcs
-    fromRational = func_fromRational funcs
-    match :: Monad m => [E] -> [([HsPat],E->E)] -> E -> Ce m E
-    match  [] ps err = f ps where
-        f (([],e):ps) = do
-            r <- f ps
-            return (e r)
-        f [] = return err
-        f _ = error "FromHs.convertMatches.match"
-    match _ [] err = return err
-    match (b:bs) ps err = f patternGroups err where
-        isJoinPoint (EAp (EVar x) _) | getProperty prop_JOINPOINT x = True
-        isJoinPoint _ = False
-        f  [] err = return err
-        f (ps:pss) err = do
-            err' <- f pss err
-            if isEVar err' || isEError err' || isJoinPoint err' then
-               g ps err'
-               else do
-                [ev] <- newVars [EPi tvr { tvrType = unboxedTyUnit } $ getType err']
-                let ev' = setProperties [prop_ONESHOT, prop_JOINPOINT] ev
-                nm <- g ps (EAp (EVar ev') unboxedUnit)
-                return $ eLetRec [(ev',ELam (setProperty prop_ONESHOT tvr { tvrType = unboxedTyUnit }) err')] nm
-        g ps err
-            | all (not . isStrictPat) patternHeads = match bs [(ps',eLetRec (toBinding p) . e)  | (p:ps',e) <- ps] err
-            | any (isHsPAsPat || isHsPNeg || isHsPIrrPat) patternHeads = g (map (procAs b) ps) err
-            | Just () <- mapM_ fromHsPLitInt patternHeads = do
-                let tb = getType b
-                [bv] <- newVars [tb]
-                let gps = [ (p,[ (ps,e) |  (_:ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF ((\ (x:_) -> x) . fst) ps]
-                    eq = EAp (func_equals funcs) tb
-                    f els (HsPLit (HsInt i),ps) = do
-                        --let ip = (EAp (EAp fromInt tb) (ELit (LitInt (fromIntegral i) tInt)))
-                        let ip | abs i > integer_cutoff  = (EAp (EAp fromInteger tb) (intConvert i))
-                               | otherwise =  (EAp (EAp fromInt tb) (intConvert i))
-                        m <- match bs ps err
-                        createIf (EAp (EAp eq (EVar bv)) ip) m els
-                    f els (HsPLit (HsFrac i),ps) = do
-                        --let ip = (EAp (EAp fromInt tb) (ELit (LitInt (fromIntegral i) tInt)))
-                        let ip = (EAp (EAp fromRational tb) (toE i))
-                        m <- match bs ps err
-                        createIf (EAp (EAp eq (EVar bv)) ip) m els
-                e <- foldlM f err gps
-                return $ eLetRec [(bv,b)] e
-            | all isHsPString patternHeads = do
-                let tb = getType b
-                [bv] <- newVars [tb]
-                (eqString,_,_) <- convertValue v_eqString
-                let gps = [ (p,[ (ps,e) |  (_:ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF ((\ (x:_) -> x) . fst) ps]
-                    eq = EAp (func_equals funcs) tb
-                    f els (HsPLit (HsString s),ps) = do
-                        m <- match bs ps err
-                        return $ ifzh (EAp (EAp (EVar eqString) (EVar bv)) (toE s)) m els
-                e <- foldlM f err gps
-                return $ eLetRec [(bv,b)] e
-            | all isHsPLit patternHeads = do
-                let gps = [ (p,[ (ps,e) |  (_:ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF ((\ (x:_) -> x) . fst) ps]
-                    f (HsPLit l,ps) = do
-                        m <- match bs ps err
-                        return (Alt  (litconvert l (getType b)) m)
-                as@(_:_) <- mapM f gps
-                [TVr { tvrIdent = vr }] <- newVars [Unknown]
-                dataTable <- asks ceDataTable
-                return $ unbox dataTable b vr $ \tvr -> eCase tvr as err
-                --return $ eCase b as err
-            | all (\c -> isHsPApp c || isHsPString c) patternHeads = do
-                dataTable <- getDataTable
-                let gps =  sortGroupUnderF (hsPPatName . (\ (x:_) -> x) . fst) (map ff ps)
-                    ff ((HsPLit (HsString ""):ps),b) = ((HsPApp (nameName $ dc_EmptyList) []):ps,b)
-                    ff ((HsPLit (HsString (c:cs)):ps),b) = ((HsPApp (nameName $ dc_Cons) [HsPLit (HsChar c),HsPLit (HsString cs)]):ps,b)
-                    ff x = x
-                    (Just patCons) = getConstructor (toName DataConstructor $ fst $ head gps) dataTable
-                    f (name,ps) = do
-                        let spats = hsPatPats $ (\ (x:_) -> x) $ fst ((\ (x:_) -> x) ps)
-                            nargs = length spats
-                        vs <- newVars (slotTypes dataTable (toName DataConstructor name) (getType b))
-                        vs' <- newVars (map (const Unknown) vs)
+convertMatches ::
+    Monad m
+    => [E]
+    -> [([HsPat],E->E)]
+    -> E
+    -> Ce m E
+convertMatches bs ms err = do
+    assumps <- asks ceAssumps
+    dataTable <- getDataTable
+    funcs <- asks ceFuncs
+    let tv n = tvr { tvrType = removeNewtypes dataTable (tvrType tvr) } where
+            tvr = toTVr assumps (toName Name.Val n)
+    let doNegate e = eAp (eAp (func_negate funcs) (getType e)) e
+        fromInt = func_fromInt funcs
+        fromInteger = func_fromInteger funcs
+        fromRational = func_fromRational funcs
+        match :: Monad m => [E] -> [([HsPat],E->E)] -> E -> Ce m E
+        match  [] ps err = f ps where
+            f (([],e):ps) = do
+                r <- f ps
+                return (e r)
+            f [] = return err
+            f _ = error "FromHs.convertMatches.match"
+        match _ [] err = return err
+        match (b:bs) ps err = f patternGroups err where
+            isJoinPoint (EAp (EVar x) _) | getProperty prop_JOINPOINT x = True
+            isJoinPoint _ = False
+            f  [] err = return err
+            f (ps:pss) err = do
+                err' <- f pss err
+                if isEVar err' || isEError err' || isJoinPoint err' then
+                   g ps err'
+                   else do
+                    [ev] <- newVars [EPi tvr { tvrType = unboxedTyUnit } $ getType err']
+                    let ev' = setProperties [prop_ONESHOT, prop_JOINPOINT] ev
+                    nm <- g ps (EAp (EVar ev') unboxedUnit)
+                    return $ eLetRec [(ev',ELam (setProperty prop_ONESHOT tvr { tvrType = unboxedTyUnit }) err')] nm
+            g ps err
+                | all (not . isStrictPat) patternHeads = match bs [(ps',eLetRec (toBinding p) . e)  | (p:ps',e) <- ps] err
+                | any (isHsPAsPat || isHsPIrrPat) patternHeads = g (map (procAs b) ps) err
+                | Just () <- mapM_ fromHsPLitInt patternHeads = do
+                    let tb = getType b
+                    [bv] <- newVars [tb]
+                    let gps = [ (p,[ (ps,e) |  (_:ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF ((\ (x:_) -> x) . fst) ps]
+                        eq = EAp (func_equals funcs) tb
+                        f els (HsPLit (HsInt i),ps) = do
+                            --let ip = (EAp (EAp fromInt tb) (ELit (LitInt (fromIntegral i) tInt)))
+                            let ip | abs i > integer_cutoff  = (EAp (EAp fromInteger tb) (intConvert i))
+                                   | otherwise =  (EAp (EAp fromInt tb) (intConvert i))
+                            m <- match bs ps err
+                            createIf (EAp (EAp eq (EVar bv)) ip) m els
+                        f els (HsPLit (HsFrac i),ps) = do
+                            --let ip = (EAp (EAp fromInt tb) (ELit (LitInt (fromIntegral i) tInt)))
+                            let ip = (EAp (EAp fromRational tb) (toE i))
+                            m <- match bs ps err
+                            createIf (EAp (EAp eq (EVar bv)) ip) m els
+                    e <- foldlM f err gps
+                    return $ eLetRec [(bv,b)] e
+                | all isHsPString patternHeads = do
+                    let tb = getType b
+                    [bv] <- newVars [tb]
+                    (eqString,_,_) <- convertValue v_eqString
+                    let gps = [ (p,[ (ps,e) |  (_:ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF ((\ (x:_) -> x) . fst) ps]
+                        eq = EAp (func_equals funcs) tb
+                        f els (HsPLit (HsString s),ps) = do
+                            m <- match bs ps err
+                            return $ ifzh (EAp (EAp (EVar eqString) (EVar bv)) (toE s)) m els
+                    e <- foldlM f err gps
+                    return $ eLetRec [(bv,b)] e
+                | all isHsPLit patternHeads = do
+                    let gps = [ (p,[ (ps,e) |  (_:ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF ((\ (x:_) -> x) . fst) ps]
+                        f (HsPLit l,ps) = do
+                            m <- match bs ps err
+                            return (Alt  (litconvert l (getType b)) m)
+                    as@(_:_) <- mapM f gps
+                    [TVr { tvrIdent = vr }] <- newVars [Unknown]
+                    dataTable <- asks ceDataTable
+                    return $ unbox dataTable b vr $ \tvr -> eCase tvr as err
+                    --return $ eCase b as err
+                | all (\c -> isHsPApp c || isHsPString c) patternHeads = do
+                    dataTable <- getDataTable
+                    let gps =  sortGroupUnderF (hsPPatName . (\ (x:_) -> x) . fst) (map ff ps)
+                        ff ((HsPLit (HsString ""):ps),b) = ((HsPApp (nameName $ dc_EmptyList) []):ps,b)
+                        ff ((HsPLit (HsString (c:cs)):ps),b) = ((HsPApp (nameName $ dc_Cons) [HsPLit (HsChar c),HsPLit (HsString cs)]):ps,b)
+                        ff x = x
+                        (Just patCons) = getConstructor (toName DataConstructor $ fst $ head gps) dataTable
+                        f (name,ps) = do
+                            let spats = hsPatPats $ (\ (x:_) -> x) $ fst ((\ (x:_) -> x) ps)
+                                nargs = length spats
+                            vs <- newVars (slotTypes dataTable (toName DataConstructor name) (getType b))
+                            vs' <- newVars (map (const Unknown) vs)
hunk ./E/FromHs.hs 703
-                        ps' <- mapM pp ps
-                        m <- match (map EVar vs ++ bs) ps' err
-                        return $ deconstructionExpression dataTable (toName DataConstructor name) (getType b) vs vs' m
-                        --return (Alt (LitCons (toName DataConstructor name) vs (getType b))  m)
-                    --pp :: Monad m =>  ([HsPat], E->E) -> m ([HsPat], E->E)
-                    pp (HsPApp n ps:rps,e)  = do
-                        return $ (ps ++ rps , e)
-                as@(_:_) <- mapM f gps
-                case conVirtual patCons of
-                    Nothing -> return $ eCase b as err
-                    Just sibs -> do
-                        let (Just Constructor { conChildren = Just [vCons] }) = getConstructor (conInhabits patCons) dataTable
-                        [z] <- newVars [tIntzh]
-                        let err' = if length sibs <= length as then Unknown else err
-                        return $ eCase b [Alt litCons { litName = vCons, litArgs = [z], litType = getType b } (eCase (EVar z) as err')] Unknown
-            | otherwise = error $ "Heterogenious list: " ++ show patternHeads
-            where
-            patternHeads = map ((\ (x:_) -> x) . fst) ps
-        patternGroups = groupUnder (isStrictPat . (\ (x:_) -> x) . fst) ps
-        procAs b (HsPNeg (HsPLit (HsInt i)):ps, ef) =  procAs b (HsPLit (HsInt (negate i)):ps,ef)
-        procAs b (HsPNeg p:ps, ef) =  (p:ps,ef)  -- TODO, negative patterns
-        procAs b (HsPAsPat n p:ps, ef) =  (p:ps,eLetRec [((tv n),b)] . ef)
-        procAs b (HsPIrrPat p:ps, ef) =  (p:ps, ef) -- TODO, irrefutable patterns
-        procAs _ x = x
-        toBinding (HsPVar v) = [(tv v,b)]
-        toBinding (HsPNeg (HsPVar v)) = [(tv v,doNegate b)]
-        toBinding (HsPIrrPat p) = toBinding p
-        toBinding (HsPAsPat n p) = (tv n,b):toBinding p
-        toBinding p = error $ "toBinding: " ++ show p
+                            ps' <- mapM pp ps
+                            m <- match (map EVar vs ++ bs) ps' err
+                            return $ deconstructionExpression dataTable (toName DataConstructor name) (getType b) vs vs' m
+                            --return (Alt (LitCons (toName DataConstructor name) vs (getType b))  m)
+                        --pp :: Monad m =>  ([HsPat], E->E) -> m ([HsPat], E->E)
+                        pp (HsPApp n ps:rps,e)  = do
+                            return $ (ps ++ rps , e)
+                    as@(_:_) <- mapM f gps
+                    case conVirtual patCons of
+                        Nothing -> return $ eCase b as err
+                        Just sibs -> do
+                            let (Just Constructor { conChildren = Just [vCons] }) = getConstructor (conInhabits patCons) dataTable
+                            [z] <- newVars [tIntzh]
+                            let err' = if length sibs <= length as then Unknown else err
+                            return $ eCase b [Alt litCons { litName = vCons, litArgs = [z], litType = getType b } (eCase (EVar z) as err')] Unknown
+                | otherwise = error $ "Heterogenious list: " ++ show patternHeads
+                where
+                patternHeads = map ((\ (x:_) -> x) . fst) ps
+            patternGroups = groupUnder (isStrictPat . (\ (x:_) -> x) . fst) ps
+            procAs b (HsPAsPat n p:ps, ef) =  (p:ps,eLetRec [((tv n),b)] . ef)
+            procAs b (HsPIrrPat p:ps, ef) =  (p:ps, ef) -- TODO, irrefutable patterns
+            procAs _ x = x
+            toBinding (HsPVar v) = [(tv v,b)]
+            toBinding (HsPIrrPat p) = toBinding p
+            toBinding (HsPAsPat n p) = (tv n,b):toBinding p
+            toBinding p = error $ "toBinding: " ++ show p
+    match bs ms err
hunk ./E/FromHs.hs 740
-isStrictPat (HsPNeg p) = isStrictPat p