ref: 40e35fd3527efb901c250b347a1a822b3ea98e45
parent: dd3e0fc5eeee93c5bcdc444624f855815082d5ce
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Wed Aug 23 16:32:31 EDT 2023
Add 'where' clauses
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.0
-670
-(($A :0 ((_497 _451) ((($S' ($C ((($C' ($S' _497)) ($C _2)) (($B ($B (_497 _525))) ((($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' _498)) ((($C' $B) (($B _583) (($B _515) ((($C' _620) _8) 0)))) (($B (_583 _518)) (($B (_529 "top level defns: ")) _479)))))))) ((($S' $B) (($B $B) (($B ($C' $B)) (($B ($B $B)) (($B ($B _498)) ((($C' $B) (($B _583) (($B _515) ((($C' _620) _8) 1)))) (_514 ($T (($B ($B (_583 _518))) ((($C' $B) _529) (($B (_529 " = ")) _236))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _498))) ((($C' $B) (($B $B) (($B _583) (($B _520) _11)))) (($B ($B (_529 _1))) (($B (($C' _529) _479)) (_529 (($O 10) $K))))))) (($B ($B (_497 _525))) ((($C' $B) (($B $B) (($B _583) (($B _515) ((($C' _620) _8) 0))))) (($B ($B (_583 _518))) (($B ($B (_529 "final pass "))) ((($C' ($C' _529)) (($B ($B (_492 6))) (($B ($B _479)) _614))) "ms")))))))) _3)))) _476))) (($B (($C' $C) (($B ($C _534)) _236))) (($C _547) (_563 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B ($B $K))) (($B ($B ($B ($B (_529 "(($A :"))))) (($B ($B (($C' $B) (($B _529) _479)))) (($B ($B ($B (_529 (($O 32) $K))))) ((($C' $B) (($B ($C' _529)) ($B _236))) (($B (_529 ") ")) (($C _529) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _213)) $I))) (($B $K) $K))) $K))))) $T)) (($B (($S' _583) (($B _580) (($B (_583 _628)) (($B (_529 "main: findIdent: ")) _306))))) ($C _469)))) (($B ($B _473)) (($B (($C' _531) (($B $T) (($B ($C $B)) (($B ($B ($B $K))) ((($C' ($C' ($C' $O))) ($B ($C $P))) $K)))))) (($C _547) (_563 0)))))) (($B (_583 _212)) (($B (_529 (($O 95) $K))) _479))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _546) (_533 (_490 "-v")))) ((_562 _490) "-r"))) (($B (_527 (($O 46) $K))) (($B _582) (_532 ((_551 _605) "-i")))))) (($B (_583 _557)) ((($C' _529) (($B _582) (_532 ((_551 _605) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _616) _546) 1)) (_628 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _557)) (_533 ((_584 _625) ((_584 (_490 (($O 45) $K))) (_544 1)))))))) (($A :1 "v3.0\10&") (($A :2 ((($S' ($S' _497)) _16) (($B ($B ($B (_497 _525)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _498) (($B (_583 _516)) (($B (_583 (_545 1000000))) _41)))))) (($B ($B ($B ($B (_497 _525))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _498))) ((($C' $B) (($B $B) (($B _583) (($B _515) ((($C' _620) _8) 0))))) (($B ($B (_583 _518))) (($B ($B (_529 "combinator conversion "))) ((($C' ($C' _529)) (($B ($B (_492 6))) (($B ($B _479)) _614))) "ms"))))))) (($B ($B _499)) (($B $P) (($C _308) "main"))))))) (_531 ($T ((($C' ($C' $O)) ((($C' $B) $P) _239)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_583 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _206))) (($C' ($C' _531)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _583) (($B _580) (($B (_583 _628)) (_529 "not found "))))) ($C _207))))) (($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) _238))) (($B (_583 (_580 (_628 "primlookup")))) (($C (_566 _490)) _5))))) (_628 "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
+680
+(($A :0 ((_507 _460) ((($S' ($C ((($C' ($S' _507)) ($C _2)) (($B ($B (_507 _535))) ((($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' _508)) ((($C' $B) (($B _593) (($B _525) ((($C' _630) _8) 0)))) (($B (_593 _528)) (($B (_539 "top level defns: ")) _489)))))))) ((($S' $B) (($B $B) (($B ($C' $B)) (($B ($B $B)) (($B ($B _508)) ((($C' $B) (($B _593) (($B _525) ((($C' _630) _8) 1)))) (_524 ($T (($B ($B (_593 _528))) ((($C' $B) _539) (($B (_539 " = ")) _239))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _508))) ((($C' $B) (($B $B) (($B _593) (($B _530) _11)))) (($B ($B (_539 _1))) (($B (($C' _539) _489)) (_539 (($O 10) $K))))))) (($B ($B (_507 _535))) ((($C' $B) (($B $B) (($B _593) (($B _525) ((($C' _630) _8) 0))))) (($B ($B (_593 _528))) (($B ($B (_539 "final pass "))) ((($C' ($C' _539)) (($B ($B (_502 6))) (($B ($B _489)) _624))) "ms")))))))) _3)))) _485))) (($B (($C' $C) (($B ($C _544)) _239))) (($C _557) (_573 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B ($B $K))) (($B ($B ($B ($B (_539 "(($A :"))))) (($B ($B (($C' $B) (($B _539) _489)))) (($B ($B ($B (_539 (($O 32) $K))))) ((($C' $B) (($B ($C' _539)) ($B _239))) (($B (_539 ") ")) (($C _539) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _216)) $I))) (($B $K) $K))) $K))))) $T)) (($B (($S' _593) (($B _590) (($B (_593 _638)) (($B (_539 "main: findIdent: ")) _310))))) ($C _478)))) (($B ($B _482)) (($B (($C' _541) (($B $T) (($B ($C $B)) (($B ($B ($B $K))) ((($C' ($C' ($C' $O))) ($B ($C $P))) $K)))))) (($C _557) (_573 0)))))) (($B (_593 _215)) (($B (_539 (($O 95) $K))) _489))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _556) (_543 (_500 "-v")))) ((_572 _500) "-r"))) (($B (_537 (($O 46) $K))) (($B _592) (_542 ((_561 _615) "-i")))))) (($B (_593 _567)) ((($C' _539) (($B _592) (_542 ((_561 _615) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _626) _556) 1)) (_638 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _567)) (_543 ((_594 _635) ((_594 (_500 (($O 45) $K))) (_554 1)))))))) (($A :1 "v3.0\10&") (($A :2 ((($S' ($S' _507)) _16) (($B ($B ($B (_507 _535)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _508) (($B (_593 _526)) (($B (_593 (_555 1000000))) _43)))))) (($B ($B ($B ($B (_507 _535))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _508))) ((($C' $B) (($B $B) (($B _593) (($B _525) ((($C' _630) _8) 0))))) (($B ($B (_593 _528))) (($B ($B (_539 "combinator conversion "))) ((($C' ($C' _539)) (($B ($B (_502 6))) (($B ($B _489)) _624))) "ms"))))))) (($B ($B _509)) (($B $P) (($C _312) "main"))))))) (_541 ($T ((($C' ($C' $O)) ((($C' $B) $P) _242)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_593 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _209))) (($C' ($C' _541)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _593) (($B _590) (($B (_593 _638)) (_539 "not found "))))) ($C _210))))) (($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) _241))) (($B (_593 (_590 (_638 "primlookup")))) (($C (_576 _500)) _5))))) (_638 "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,8 +46,8 @@
Sign _ _ -> []
Import _ -> []
-oneAlt :: Expr -> [EAlt]
-oneAlt e = [([], e)]
+oneAlt :: Expr -> EAlts
+oneAlt e = EAlts [([], e)] []
dsBind :: EBind -> [LDef]
dsBind abind =
@@ -71,21 +71,37 @@
in foldr Lam ex xs
_ -> impossible
-dsAlts :: [EAlt] -> (Exp -> Exp)
-dsAlts [] dflt = dflt
-dsAlts [([], e)] _ = dsExpr e -- fast special case
-dsAlts ((ss, rhs) : alts) dflt =
+dsAlts :: EAlts -> (Exp -> Exp)
+dsAlts (EAlts alts bs) = dsBinds bs . dsAltsL alts
+
+dsAltsL :: [EAlt] -> (Exp -> Exp)
+dsAltsL [] dflt = dflt
+dsAltsL [([], e)] _ = dsExpr e -- fast special case
+dsAltsL ((ss, rhs) : alts) dflt =
let
- erest = dsAlts alts dflt
+ erest = dsAltsL alts dflt
x = newVar (allVarsExp erest)
in eLet x erest (dsExpr $ dsAlt (EVar x) ss rhs)
dsAlt :: Expr -> [EStmt] -> Expr -> Expr
dsAlt _ [] rhs = rhs
-dsAlt dflt (SBind p e : ss) rhs = ECase e [(p, [(ss, rhs)]), (EVar dummyIdent, oneAlt dflt)]
+dsAlt dflt (SBind p e : ss) rhs = ECase e [(p, EAlts [(ss, rhs)] []), (EVar dummyIdent, oneAlt dflt)]
dsAlt dflt (SThen e : ss) rhs = EIf e (dsAlt dflt ss rhs) dflt
dsAlt dflt (SLet bs : ss) rhs = ELet bs (dsAlt dflt ss rhs)
+dsBinds :: [EBind] -> Exp -> Exp
+dsBinds ads ret =
+ case ads of
+ [] -> ret
+ d:ds ->
+ let
+ dsd = dsBind d
+ de = dsBinds ds ret
+ def ir a =
+ case ir of
+ (i, r) -> App (Lam i a) (App (Lit (LPrim "Y")) (Lam i r))
+ in foldr def de dsd
+
dsExpr :: Expr -> Exp
dsExpr aexpr =
case aexpr of
@@ -97,17 +113,7 @@
ELit l -> Lit l
ECase e as -> dsCase e as
-- For now, just sequential bindings; each recursive
- ELet ads e ->
- case ads of
- [] -> dsExpr e
- d:ds ->
- let
- dsd = dsBind d
- de = dsExpr (ELet ds e)
- def ir a =
- case ir of
- (i, r) -> App (Lam i a) (App (Lit (LPrim "Y")) (Lam i r))
- in foldr def de dsd
+ ELet ads e -> dsBinds ads (dsExpr e)
EList es -> foldr (app2 cCons) cNil $ map dsExpr es
ETuple es -> Lam "$f" $ foldl App (Var "$f") $ map dsExpr es
EDo mn astmts ->
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -14,6 +14,7 @@
EBind(..),
Eqn(..),
EStmt(..),
+ EAlts(..),
EAlt,
ECaseArm,
EType,
@@ -109,7 +110,7 @@
data Lit = LInt Int | LChar Char | LStr String | LPrim String
--Xderiving (Show, Eq)
-type ECaseArm = (EPat, [EAlt])
+type ECaseArm = (EPat, EAlts)
data EStmt = SBind EPat Expr | SThen Expr | SLet [EBind]
--Xderiving (Show, Eq)
@@ -118,9 +119,12 @@
--Xderiving (Show, Eq)
-- A single equation for a function
-data Eqn = Eqn [EPat] [EAlt]
+data Eqn = Eqn [EPat] EAlts
--Xderiving (Show, Eq)
+data EAlts = EAlts [EAlt] [EBind]
+ --Xderiving (Show, Eq)
+
type EAlt = ([EStmt], Expr)
type ConTyInfo = [(Ident, Int)] -- All constructors with their arities
@@ -593,11 +597,22 @@
pCaseArm :: P ECaseArm
pCaseArm = pair <$> pPat <*> pAlts (pSymbol "->")
-pAlts :: P () -> P [EAlt]
-pAlts sep =
+pAlts :: P () -> P EAlts
+pAlts sep = P.do
+ alts <- pAltsL sep
+ bs <- pWhere
+ P.pure (EAlts alts bs)
+
+pAltsL :: P () -> P [EAlt]
+pAltsL sep =
esome (pair <$> (pSym '|' *> esepBy1 pStmt (pSym ',')) <*> (sep *> pExpr))
<|< ((\ e -> [([], e)]) <$> (sep *> pExpr))
+pWhere :: P [EBind]
+pWhere =
+ (pKeyword "where" *> pBlock pBind)
+ <|< P.pure []
+
-- 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.
@@ -806,10 +821,17 @@
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)
+showAlts :: String -> EAlts -> String
+showAlts sep (EAlts alts bs) = showAltsL sep alts ++ showWhere bs
+showWhere :: [EBind] -> String
+showWhere [] = ""
+showWhere bs = "where\n" ++ unlines (map showEBind bs)
+
+showAltsL :: String -> [EAlt] -> String
+showAltsL sep [([], e)] = " " ++ sep ++ " " ++ showExpr e
+showAltsL sep alts = unlines (map (showAlt sep) alts)
+
showAlt :: String -> EAlt -> String
showAlt sep (ss, e) = " | " ++ concat (intersperse ", " (map showEStmt ss)) ++ " " ++ sep ++ " " ++ showExpr e
@@ -899,8 +921,11 @@
allVarsEqn :: Eqn -> [Ident]
allVarsEqn eqn =
case eqn of
- Eqn ps alts -> concatMap allVarsPat ps ++ concatMap allVarsAlt alts
+ Eqn ps alts -> concatMap allVarsPat ps ++ allVarsAlts alts
+allVarsAlts :: EAlts -> [Ident]
+allVarsAlts (EAlts alts bs) = concatMap allVarsAlt alts ++ concatMap allVarsBind bs
+
allVarsAlt :: EAlt -> [Ident]
allVarsAlt (ss, e) = concatMap allVarsStmt ss ++ allVarsExpr e
@@ -935,7 +960,7 @@
ECon c -> [conIdent c]
allVarsCaseArm :: ECaseArm -> [Ident]
-allVarsCaseArm (p, alts) = allVarsPat p ++ concatMap allVarsAlt alts
+allVarsCaseArm (p, alts) = allVarsPat p ++ allVarsAlts alts
allVarsStmt :: EStmt -> [Ident]
allVarsStmt astmt =
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -703,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, EAlts [(_, 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, EAlts [([], EDo mmn ss)] [])])))
T.return (EDo mn (SBind ep ea : ys), tr)
SThen a -> T.do
let
@@ -809,9 +809,13 @@
tcEqn t eqn =
case eqn of
Eqn ps alts -> tcPats t ps $ \ tt tps -> T.do
- aalts <- T.mapM (tcAlt tt) alts
+ aalts <- tcAlts tt alts
T.return (Eqn (map fst tps) aalts)
+tcAlts :: EType -> EAlts -> T EAlts
+tcAlts tt (EAlts alts bs) =
+ tcBinds bs $ \ bbs -> T.do { aalts <- T.mapM (tcAlt tt) alts; T.return (EAlts aalts bbs) }+
tcAlt :: EType -> EAlt -> T EAlt
tcAlt t (ss, rhs) = tcGuards ss $ \ sss -> T.do { (rrhs,_) <- tcExpr (Just t) rhs; T.return (sss, rrhs) }@@ -832,7 +836,7 @@
tcArm t tpat arm =
case arm of
(p, alts) -> tcPat tpat p $ \ pp -> T.do
- aalts <- T.mapM (tcAlt t) alts
+ aalts <- tcAlts t alts
T.return (pp, aalts)
tcPat ::forall a . EType -> EPat -> (EPat -> T a) -> T a
--
⑨