ref: ea06c658eb27699cdc933c36d5fe4da50c0809b8
parent: a41e34ea12fb001d5cbcbb8f89c51527d9a48d42
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Wed Aug 23 09:42:04 EDT 2023
Prepare for guards.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.0
-657
-(($A :0 ((_485 _439) ((($S' ($C ((($C' ($S' _485)) ($C _2)) (($B ($B (_485 _513))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B ($B $B))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) (($B $B) (($B $B) (($B $C') (($B ($S' _486)) ((($C' $B) (($B _570) (($B _503) ((($C' _607) _8) 0)))) (($B (_570 _506)) (($B (_517 "top level defns: ")) _467)))))))) ((($S' $B) (($B $B) (($B ($C' $B)) (($B ($B $B)) (($B ($B _486)) ((($C' $B) (($B _570) (($B _503) ((($C' _607) _8) 1)))) (_502 ($T (($B ($B (_570 _506))) ((($C' $B) _517) (($B (_517 " = ")) _229))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _486))) ((($C' $B) (($B $B) (($B _570) (($B _508) _11)))) (($B ($B (_517 _1))) (($B (($C' _517) _467)) (_517 (($O 10) $K))))))) (($B ($B (_485 _513))) ((($C' $B) (($B $B) (($B _570) (($B _503) ((($C' _607) _8) 0))))) (($B ($B (_570 _506))) (($B ($B (_517 "final pass "))) ((($C' ($C' _517)) (($B ($B (_480 6))) (($B ($B _467)) _601))) "ms")))))))) _3)))) _464))) (($B (($C' $C) (($B ($C _522)) _229))) (($C _535) (_550 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B ($B $K))) (($B ($B ($B ($B (_517 "(($A :"))))) (($B ($B (($C' $B) (($B _517) _467)))) (($B ($B ($B (_517 (($O 32) $K))))) ((($C' $B) (($B ($C' _517)) ($B _229))) (($B (_517 ") ")) (($C _517) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _206)) $I))) (($B $K) $K))) $K))))) $T)) (($B (($S' _570) (($B _567) (($B (_570 _615)) (($B (_517 "main: findIdent: ")) _299))))) ($C _457)))) (($B ($B _461)) (($B (($C' _519) (($B $T) (($B ($C $B)) (($B ($B ($B $K))) ((($C' ($C' ($C' $O))) ($B ($C $P))) $K)))))) (($C _535) (_550 0)))))) (($B (_570 _205)) (($B (_517 (($O 95) $K))) _467))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _534) (_521 (_478 "-v")))) ((_549 _478) "-r"))) (($B (_515 (($O 46) $K))) (($B _569) (_520 ((_539 _592) "-i")))))) (($B (_570 _544)) ((($C' _517) (($B _569) (_520 ((_539 _592) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _603) _534) 1)) (_615 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _544)) (_521 ((_571 _612) ((_571 (_478 (($O 45) $K))) (_532 1)))))))) (($A :1 "v3.0\10&") (($A :2 ((($S' ($S' _485)) _16) (($B ($B ($B (_485 _513)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _486) (($B (_570 _504)) (($B (_570 (_533 1000000))) _38)))))) (($B ($B ($B ($B (_485 _513))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _486))) ((($C' $B) (($B $B) (($B _570) (($B _503) ((($C' _607) _8) 0))))) (($B ($B (_570 _506))) (($B ($B (_517 "combinator conversion "))) ((($C' ($C' _517)) (($B ($B (_480 6))) (($B ($B _467)) _601))) "ms"))))))) (($B ($B _487)) (($B $P) (($C _301) "main"))))))) (_519 ($T ((($C' ($C' $O)) ((($C' $B) $P) _232)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_570 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _199))) (($C' ($C' _519)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _570) (($B _567) (($B (_570 _615)) (_517 "not found "))))) ($C _200))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) (($B $K) $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _231))) (($B (_570 (_567 (_615 "primlookup")))) (($C (_553 _478)) _5))))) (_615 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($O (($P (($O 73) $K)) $I)) (($O (($P (($O 83) $K)) $S)) (($O (($P (($O 84) $K)) $T)) (($O (($P (($O 89) $K)) $Y)) (($O (($P "B'") $B')) (($O (($P (($O 43) $K)) $+)) (($O (($P (($O 45) $K)) $-))
\ No newline at end of file
+668
+(($A :0 ((_496 _450) ((($S' ($C ((($C' ($S' _496)) ($C _2)) (($B ($B (_496 _524))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B ($B $B))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) (($B $B) (($B $B) (($B $C') (($B ($S' _497)) ((($C' $B) (($B _581) (($B _514) ((($C' _618) _8) 0)))) (($B (_581 _517)) (($B (_528 "top level defns: ")) _478)))))))) ((($S' $B) (($B $B) (($B ($C' $B)) (($B ($B $B)) (($B ($B _497)) ((($C' $B) (($B _581) (($B _514) ((($C' _618) _8) 1)))) (_513 ($T (($B ($B (_581 _517))) ((($C' $B) _528) (($B (_528 " = ")) _235))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _497))) ((($C' $B) (($B $B) (($B _581) (($B _519) _11)))) (($B ($B (_528 _1))) (($B (($C' _528) _478)) (_528 (($O 10) $K))))))) (($B ($B (_496 _524))) ((($C' $B) (($B $B) (($B _581) (($B _514) ((($C' _618) _8) 0))))) (($B ($B (_581 _517))) (($B ($B (_528 "final pass "))) ((($C' ($C' _528)) (($B ($B (_491 6))) (($B ($B _478)) _612))) "ms")))))))) _3)))) _475))) (($B (($C' $C) (($B ($C _533)) _235))) (($C _546) (_561 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B ($B $K))) (($B ($B ($B ($B (_528 "(($A :"))))) (($B ($B (($C' $B) (($B _528) _478)))) (($B ($B ($B (_528 (($O 32) $K))))) ((($C' $B) (($B ($C' _528)) ($B _235))) (($B (_528 ") ")) (($C _528) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _212)) $I))) (($B $K) $K))) $K))))) $T)) (($B (($S' _581) (($B _578) (($B (_581 _626)) (($B (_528 "main: findIdent: ")) _305))))) ($C _468)))) (($B ($B _472)) (($B (($C' _530) (($B $T) (($B ($C $B)) (($B ($B ($B $K))) ((($C' ($C' ($C' $O))) ($B ($C $P))) $K)))))) (($C _546) (_561 0)))))) (($B (_581 _211)) (($B (_528 (($O 95) $K))) _478))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _545) (_532 (_489 "-v")))) ((_560 _489) "-r"))) (($B (_526 (($O 46) $K))) (($B _580) (_531 ((_550 _603) "-i")))))) (($B (_581 _555)) ((($C' _528) (($B _580) (_531 ((_550 _603) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _614) _545) 1)) (_626 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _555)) (_532 ((_582 _623) ((_582 (_489 (($O 45) $K))) (_543 1)))))))) (($A :1 "v3.0\10&") (($A :2 ((($S' ($S' _496)) _16) (($B ($B ($B (_496 _524)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _497) (($B (_581 _515)) (($B (_581 (_544 1000000))) _40)))))) (($B ($B ($B ($B (_496 _524))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _497))) ((($C' $B) (($B $B) (($B _581) (($B _514) ((($C' _618) _8) 0))))) (($B ($B (_581 _517))) (($B ($B (_528 "combinator conversion "))) ((($C' ($C' _528)) (($B ($B (_491 6))) (($B ($B _478)) _612))) "ms"))))))) (($B ($B _498)) (($B $P) (($C _307) "main"))))))) (_530 ($T ((($C' ($C' $O)) ((($C' $B) $P) _238)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_581 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _205))) (($C' ($C' _530)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _581) (($B _578) (($B (_581 _626)) (_528 "not found "))))) ($C _206))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) (($B $K) $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _237))) (($B (_581 (_578 (_626 "primlookup")))) (($C (_564 _489)) _5))))) (_626 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($O (($P (($O 73) $K)) $I)) (($O (($P (($O 83) $K)) $S)) (($O (($P (($O 84) $K)) $T)) (($O (($P (($O 89) $K)) $Y)) (($O (($P "B'") $B')) (($O (($P (($O 43) $K)) $+)) (($O (($P (($O 45) $K)) $-))
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -46,6 +46,9 @@
Sign _ _ -> []
Import _ -> []
+oneAlt :: Expr -> [EAlt]
+oneAlt e = [([], e)]
+
dsBind :: EBind -> [LDef]
dsBind abind =
case abind of
@@ -54,7 +57,7 @@
let
v = newVar (allVarsBind abind)
de = (v, dsExpr e)
- ds = [ (i, dsExpr (ECase (EVar v) [(p, EVar i)])) | i <- patVars p ]
+ ds = [ (i, dsExpr (ECase (EVar v) [(p, oneAlt $ EVar i)])) | i <- patVars p ]
in de : ds
dsEqns :: [Eqn] -> Exp
@@ -64,10 +67,14 @@
let
vs = allVarsBind $ BFcn "" eqns
xs = take (length aps) $ newVars vs
- ex = runS (vs ++ xs) (map Var xs) [(map dsPat ps, dsExpr e) | Eqn ps e <- eqns]
+ ex = runS (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts alts) | Eqn ps alts <- eqns]
in foldr Lam ex xs
_ -> impossible
+dsAlts :: [EAlt] -> (Exp -> Exp)
+dsAlts [([], e)] = \ _ -> dsExpr e
+dsAlts _ = undefined
+
dsExpr :: Expr -> Exp
dsExpr aexpr =
case aexpr of
@@ -105,7 +112,7 @@
-- _ ->
let
nv = newVar (allVarsExpr aexpr)
- body = ECase (EVar nv) [(p, EDo mn stmts), (EVar dummyIdent, eError "dopat")]
+ body = ECase (EVar nv) [(p, oneAlt $ EDo mn stmts), (EVar dummyIdent, oneAlt $ eError "dopat")]
res = dsExpr $ EApp (EApp (EVar (mqual mn ">>=")) e) (ELam [EVar nv] body)
in res
@@ -132,7 +139,7 @@
SBind p b ->
let
nv = newVar (allVarsExpr aexpr)
- body = ECase (EVar nv) [(p, ECompr e stmts), (EVar dummyIdent, EList [])]
+ body = ECase (EVar nv) [(p, oneAlt $ ECompr e stmts), (EVar dummyIdent, oneAlt $ EList [])]
in app2 (Var "Data.List.concatMap") (dsExpr (ELam [EVar nv] body)) (dsExpr b)
SThen c ->
dsExpr (EIf c (ECompr e stmts) (EList []))
@@ -151,7 +158,7 @@
let
vs = allVarsExpr (ELam ps e)
xs = take (length ps) (newVars vs)
- ex = runS (vs ++ xs) (map Var xs) [(map dsPat ps, dsExpr e)]
+ ex = runS (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts $ oneAlt e)]
in foldr Lam ex xs
mqual :: Maybe Ident -> Ident -> Ident
@@ -225,15 +232,14 @@
dsCase :: Expr -> [ECaseArm] -> Exp
dsCase ae as =
let
- r = runS (allVarsExpr (ECase ae as)) [dsExpr ae] [([dsPat p], dsExpr e) | (p, e) <- as]
+ r = runS (allVarsExpr (ECase ae as)) [dsExpr ae] [([dsPat p], dsAlts alts) | (p, alts) <- as]
in --trace (showExp r) $
r
-
type MState = [Ident] -- supply of unused variables.
type M a = State MState a
-type Arm = ([EPat], Exp)
+type Arm = ([EPat], Exp -> Exp)
type Matrix = [Arm]
newIdents :: Int -> M [Ident]
@@ -277,12 +283,11 @@
S.return dflt
else
case iis of
- [] -> S.return (snd (head aarms))
+ [] -> S.return $ (snd (head aarms)) dflt
i:is -> S.do
let
- -- XXX handle EAt
(arms, darms, rarms) = splitArms aarms
- ndarms = map (\ (EVar x : ps, ed) -> (ps, substAlpha x i ed) ) darms
+ ndarms = map (\ (EVar x : ps, ed) -> (ps, substAlpha x i . ed) ) darms
-- traceM ("split " ++ show (arms, darms, rarms))letBind (dsMatrix dflt iis rarms) $ \ drest ->
letBind (dsMatrix drest is ndarms) $ \ ndflt ->
@@ -301,7 +306,7 @@
case arg of
(p : ps, e) ->
case p of
- EAt a pp -> one (pp:ps, substAlpha a i e)
+ EAt a pp -> one (pp:ps, substAlpha a i . e)
_ -> (pArgs p ++ ps, e)
_ -> impossible
cexp <- dsMatrix ndflt (map Var xs ++ is) (map one grp)
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -14,6 +14,7 @@
EBind(..),
Eqn(..),
EStmt(..),
+ EAlt,
ECaseArm,
EType,
EPat, patVars, isPVar,
@@ -108,7 +109,7 @@
data Lit = LInt Int | LChar Char | LStr String | LPrim String
--Xderiving (Show, Eq)
-type ECaseArm = (EPat, Expr)
+type ECaseArm = (EPat, [EAlt])
data EStmt = SBind EPat Expr | SThen Expr | SLet [EBind]
--Xderiving (Show, Eq)
@@ -117,9 +118,11 @@
--Xderiving (Show, Eq)
-- A single equation for a function
-data Eqn = Eqn [EPat] Expr
+data Eqn = Eqn [EPat] [EAlt]
--Xderiving (Show, Eq)
+type EAlt = ([EStmt], Expr)
+
type ConTyInfo = [(Ident, Int)] -- All constructors with their arities
{-@@ -514,10 +517,9 @@
pEqn test = P.do
name <- pLIdent
pats <- emany pAPat
- pSymbol "="
+ alts <- pAlts (pSymbol "=")
guard (test name (length pats))
- rhs <- pExpr
- P.pure (name, Eqn pats rhs)
+ P.pure (name, Eqn pats alts)
pImportSpec :: P ImportSpec
pImportSpec =
@@ -589,8 +591,13 @@
pCase = ECase <$> (pKeyword "case" *> pExprPT) <*> (pKeywordW "of" *> pBlock pCaseArm)
pCaseArm :: P ECaseArm
-pCaseArm = pair <$> pPat <*> (pSymbol "->" *> pExpr)
+pCaseArm = pair <$> pPat <*> pAlts (pSymbol "->")
+pAlts :: P () -> P [EAlt]
+pAlts sep =
+ esome (pair <$> (pSym '|' *> esepBy1 pStmt (pSym ',')) <*> (sep *> pExpr))
+ <|< ((\ e -> [([], e)]) <$> (sep *> pExpr))
+
-- Sadly pattern and expression parsing cannot be joined because the
-- use of '->' in 'case' and lambda makes it weird.
-- Instead this is just a copy of some of the expression rules.
@@ -720,7 +727,7 @@
pBind :: P EBind
pBind =
uncurry BFcn <$> pEqns
- <|> BPat <$> (pPatNotVar <* pSymbol "=") <*> pExprPT
+ <|> BPat <$> (pPatNotVar <* pSym '=') <*> pExprPT
pQualDo :: P String
pQualDo = P.do
@@ -787,7 +794,7 @@
case def of
Data lhs _ -> "data " ++ showLHS lhs ++ " = ..."
Type lhs t -> "type " ++ showLHS lhs ++ " = " ++ showEType t
- Fcn i eqns -> unlines (map (\ (Eqn ps e) -> i ++ " " ++ unwords (map showEPat ps) ++ " = " ++ showExpr e) eqns)
+ Fcn i eqns -> unlines (map (\ (Eqn ps alts) -> i ++ " " ++ unwords (map showEPat ps) ++ showAlts "=" alts) eqns)
Sign i t -> i ++ " :: " ++ showETypeScheme t
Import (ImportSpec q m mm) -> "import " ++ (if q then "qualified " else "") ++ m ++ maybe "" (" as " ++) mm@@ -799,6 +806,13 @@
showEDefs :: [EDef] -> String
showEDefs ds = unlines (map showEDef ds)
+showAlts :: String -> [EAlt] -> String
+showAlts sep [([], e)] = " " ++ sep ++ " " ++ showExpr e
+showAlts sep alts = unlines (map (showAlt sep) alts)
+
+showAlt :: String -> EAlt -> String
+showAlt sep (ss, e) = " | " ++ concat (intersperse ", " (map showEStmt ss)) ++ " " ++ sep ++ " " ++ showExpr e
+
showExpr :: Expr -> String
showExpr ae =
case ae of
@@ -848,7 +862,7 @@
showCaseArm :: ECaseArm -> String
showCaseArm arm =
case arm of
- (p, e) -> showEPat p ++ " -> " ++ showExpr e
+ (p, alts) -> showEPat p ++ showAlts "->" alts
showEPat :: EPat -> String
showEPat = showExpr
@@ -885,8 +899,11 @@
allVarsEqn :: Eqn -> [Ident]
allVarsEqn eqn =
case eqn of
- Eqn ps e -> concatMap allVarsPat ps ++ allVarsExpr e
+ Eqn ps alts -> concatMap allVarsPat ps ++ concatMap allVarsAlt alts
+allVarsAlt :: EAlt -> [Ident]
+allVarsAlt (ss, e) = concatMap allVarsStmt ss ++ allVarsExpr e
+
{-allVarsLHS :: LHS -> [Ident]
allVarsLHS iis =
@@ -904,7 +921,7 @@
EApp e1 e2 -> allVarsExpr e1 ++ allVarsExpr e2
ELam ps e -> concatMap allVarsPat ps ++ allVarsExpr e
ELit _ -> []
- ECase e as -> allVarsExpr e ++ concatMap (\ pa -> allVarsPat (fst pa) ++ allVarsExpr (snd pa)) as
+ ECase e as -> allVarsExpr e ++ concatMap allVarsCaseArm as
ELet bs e -> concatMap allVarsBind bs ++ allVarsExpr e
ETuple es -> concatMap allVarsExpr es
EList es -> concatMap allVarsExpr es
@@ -916,6 +933,9 @@
EAt i e -> i : allVarsExpr e
EUVar _ -> []
ECon c -> [conIdent c]
+
+allVarsCaseArm :: ECaseArm -> [Ident]
+allVarsCaseArm (p, alts) = allVarsPat p ++ concatMap allVarsAlt alts
allVarsStmt :: EStmt -> [Ident]
allVarsStmt astmt =
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -618,11 +618,11 @@
case adef of
Fcn i eqns -> T.do
-- traceM $ "tcDefValue: " ++ showLHS (i, vs) ++ " = " ++ showExpr rhs
- (_, ETypeScheme tvs t) <- tLookup i
+ (_, ETypeScheme tvs tfn) <- tLookup i
let
vks = zip tvs (repeat (ETypeScheme [] kType))
mn <- gets moduleName
- teqns <- withExtTyps vks $ tcEqns t eqns
+ teqns <- withExtTyps vks $ tcEqns tfn eqns
--tcExpr (Just t) $ ELam (map EVar vs) rhs
T.return $ Fcn (qual mn i) teqns
-- (et, _) <- withExtTyps vks (tcExpr (Just t) (foldr eLam1 rhs vs))
@@ -662,8 +662,9 @@
ELit l -> tcLit mt l
ECase a arms -> T.do
(ea, ta) <- tcExpr Nothing a
- (earms, tarms) <- unzip <$> T.mapM (tcArm mt ta) arms
- T.return (ECase ea earms, head tarms)
+ tt <- unMType mt
+ earms <- T.mapM (tcArm tt ta) arms
+ T.return (ECase ea earms, tt)
ELet bs a -> tcBinds bs $ \ ebs -> T.do { (ea, ta) <- tcExpr mt a; T.return (ELet ebs ea, ta) }ETuple es -> T.do
let
@@ -702,10 +703,10 @@
SBind p a -> T.do
let
sbind = maybe ">>=" (\ mn -> qual mn ">>=") mmn
- (EApp (EApp _ ea) (ELam _ (ECase _ ((ep, EDo mn ys): _)))
+ (EApp (EApp _ ea) (ELam _ (ECase _ ((ep, [(_, EDo mn ys)]): _)))
, tr) <-
tcExpr Nothing (EApp (EApp (EVar sbind) a)
- (ELam [EVar "$x"] (ECase (EVar "$x") [(p, EDo mmn ss)])))
+ (ELam [EVar "$x"] (ECase (EVar "$x") [(p, [([], EDo mmn ss)])])))
T.return (EDo mn (SBind ep ea : ys), tr)
SThen a -> T.do
let
@@ -744,7 +745,7 @@
SBind p a -> T.do
v <- newUVar
(ea, _) <- tcExpr (Just $ tApp tList v) a
- tcPat (Just v) p $ \ ep ->
+ tcPat v p $ \ ep ->
doStmts (SBind ep ea : rss) ss
SThen a -> T.do
(ea, _) <- tcExpr (Just tBool) a
@@ -788,16 +789,18 @@
unify t (tArrow a r)
T.return (a, r)
+tcPats :: forall a . EType -> [EPat] -> (EType -> [Typed EPat] -> T a) -> T a
+tcPats t [] ta = ta t []
+tcPats t (p:ps) ta = T.do
+ (tp, tr) <- unArrow (Just t)
+ tcPat tp p $ \ pp -> tcPats tr ps $ \ tt pps -> ta tt ((pp, tp) : pps)
+
tcExprLam :: Maybe EType -> [EPat] -> Expr -> T (Typed Expr)
-tcExprLam mt aps expr =
- case aps of
- [] -> T.do
- (er, tr) <- tcExpr mt expr
- T.return (ELam [] er, tr)
- p:ps -> T.do
- (ta, r) <- unArrow mt
- ((pr, ELam psr er), tr) <- tcArm (Just r) ta (p, ELam ps expr)
- T.return (ELam (pr:psr) er, tArrow ta tr)
+tcExprLam mt aps expr = T.do
+ t <- unMType mt
+ tcPats t aps $ \ tt pts -> T.do
+ (er, tr) <- tcExpr (Just tt) expr
+ T.return (ELam (map fst pts) er, foldr tArrow tr (map snd pts))
tcEqns :: EType -> [Eqn] -> T [Eqn]
tcEqns t eqns = T.mapM (tcEqn t) eqns
@@ -805,23 +808,39 @@
tcEqn :: EType -> Eqn -> T Eqn
tcEqn t eqn =
case eqn of
- Eqn ps rhs -> T.do
- (ELam aps arhs, _) <- tcExprLam (Just t) ps rhs
- T.return (Eqn aps arhs)
+ Eqn ps alts -> tcPats t ps $ \ tt tps -> T.do
+ aalts <- T.mapM (tcAlt tt) alts
+ T.return (Eqn (map fst tps) aalts)
-tcArm :: Maybe EType -> EType -> ECaseArm -> T (Typed ECaseArm)
-tcArm mt t arm =
+tcAlt :: EType -> EAlt -> T EAlt
+tcAlt t (ss, rhs) = tcGuards ss $ \ sss -> T.do { (rrhs,_) <- tcExpr (Just t) rhs; T.return (sss, rrhs) }+
+tcGuards :: forall a . [EStmt] -> ([EStmt] -> T a) -> T a
+tcGuards [] ta = ta []
+tcGuards (s:ss) ta = tcGuard s $ \ rs -> tcGuards ss $ \ rss -> ta (rs:rss)
+
+tcGuard :: forall a . EStmt -> (EStmt -> T a) -> T a
+tcGuard (SBind p e) ta = T.do
+ (ee, tt) <- tcExpr Nothing e
+ tcPat tt p $ \ pp -> ta (SBind pp ee)
+tcGuard (SThen e) ta = T.do
+ (ee, _) <- tcExpr (Just tBool) e
+ ta (SThen ee)
+tcGuard (SLet bs) ta = tcBinds bs $ \ bbs -> ta (SLet bbs)
+
+tcArm :: EType -> EType -> ECaseArm -> T ECaseArm
+tcArm t tpat arm =
case arm of
- (p, a) -> T.do
- (pp, (ea, ta)) <- tcPat (Just t) p $ \ pp -> pair pp <$> tcExpr mt a
- T.return ((pp, ea), ta)
+ (p, alts) -> tcPat tpat p $ \ pp -> T.do
+ aalts <- T.mapM (tcAlt t) alts
+ T.return (pp, aalts)
-tcPat ::forall a . Maybe EType -> EPat -> (EPat -> T a) -> T a
-tcPat mt ap ta = T.do
+tcPat ::forall a . EType -> EPat -> (EPat -> T a) -> T a
+tcPat t ap ta = T.do
-- traceM $ "tcPat: " ++ show ap
env <- T.mapM (\ v -> (pair v . ETypeScheme []) <$> newUVar) $ filter (not . isUnderscore) $ patVars ap
withExtVals env $ T.do
- (pp, _) <- tcExpr mt ap
+ (pp, _) <- tcExpr (Just t) ap
() <- checkArity 0 pp
ta pp
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -6,9 +6,6 @@
#include <string.h>
#include <inttypes.h>
#include <locale.h>
-#if !defined(_MSC_VER)
-#include <sys/time.h>
-#endif
#include <ctype.h>
#if defined(__MINGW32__)
@@ -47,11 +44,15 @@
}
#else /* defined(_MSC_VER) */
+
+#include <sys/time.h>
+
#define FFSL(ret, arg) ((ret) = ffsl(arg))
#define PCOMMA "'"
#endif /* !defined(_MSC_VER) */
+#define GCRED 0
#define FASTTAGS 1
#define UNIONPTR 1
@@ -457,7 +458,7 @@
red_k++;
goto top;
}
- if (GETTAG(n) == T_AP && GETTAG(FUN(n)) == I) {+ if (GETTAG(n) == T_AP && GETTAG(FUN(n)) == T_I) {/* Do the I x --> x reduction */
NODEPTR x = ARG(n);
SETTAG(n, T_IND);
--
⑨