ref: ea89588a4d8a13dcbdec4c505b5141f112bd16f9
parent: 4bbe3fffdb2c3d2e1c74f44c8bc9c44df185b9f0
author: Lennart Augustsson <lennart@augustsson.net>
date: Sat Oct 28 15:53:37 EDT 2023
Make ELam have an [Eqn] argument instead.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1050
-((A :0 _934) ((A :1 ((B _980) _0)) ((A :2 (((S' _980) _0) I)) ((A :3 _904) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _933) ((C _75) _5))) ((A :7 (((C' _6) (_951 _71)) ((_75 _949) _70))) ((A :8 ((B ((S _980) _949)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_75 _190)) _10)) ((A :12 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_73 _9)) P)) ((A :15 ((B (B (_73 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 ((B (_73 _9)) (B (P _862)))) ((A :18 ((B (_73 _9)) (BK (P _862)))) ((A :19 ((_73 _9) ((S P) I))) ((A :20 ((B (_73 _9)) ((C (S' P)) I))) ((A :21 ((B Y) ((B (B (P (_14 _115)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _116)))))) ((A :22 ((B Y) ((B (B (P (_14 _862)))) ((B (C' B)) (B _13))))) ((A :23 _3) ((A :24 (T (_14 _862))) ((A :25 (_21 _76)) ((A :26 (R _33)) ((A :27 (T _32)) ((A :28 ((P _33) _32)) ((A :29 _33) ((A :30 ((C ((C S') _28)) I)) ((A :31 ((C S) _28)) ((A :32 K) ((A :33 A) ((A :34 _909) ((A :35 _910) ((A :36 (((S' _27) (_901 #97)) ((C _901) #122))) ((A :37 (((S' _27) (_901 #65)) ((C _901) #90))) ((A :38 (((S' _26) _36) _37)) ((A :39 (((S' _27) (_901 #48)) ((C _901) #57))) ((A :40 (((S' _27) (_901 #32)) ((C _901) #126))) ((A :41 _898) ((A :42 _899) ((A :43 _901) ((A :44 _900) ((A :45 (((S' _26) ((C _41) #32)) (((S' _26) ((C _41) #9)) ((C _41) #10)))) ((A :46 ((S ((S (((S' _27) (_43 #65)) ((C _43) #90))) (_33 (((_861 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _82) (((C' _83) _35) (_35 #65))) (_35 #97))))) ((A :47 ((S ((S (((S' _27) (_43 #97)) ((C _43) #97))) (_33 (((_861 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _82) (((C' _83) _35) (_35 #97))) (_35 #65))))) ((A :48 _869) ((A :49 _870) ((A :50 _871) ((A :51 _872) ((A :52 (_49 %0.0)) ((A :53 _48) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _873) ((A :58 _874) ((A :59 _57) ((A :60 _58) ((A :61 _875) ((A :62 _876) ((A :63 _877) ((A :64 _878) ((A :65 _61) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _879) ((A :70 ((B BK) T)) ((A :71 (BK T)) ((A :72 P) ((A :73 I) ((A :74 (S _906)) ((A :75 B) ((A :76 I) ((A :77 K) ((A :78 C) ((A :79 _905) ((A :80 ((C ((C S') _190)) _191)) ((A :81 (((C' (S' (C' B))) B) I)) ((A :82 _863) ((A :83 _864) ((A :84 _865) ((A :85 _866) ((A :86 _867) ((A :87 _868) ((A :88 (_83 #0)) ((A :89 _886) ((A :90 _887) ((A :91 _888) ((A :92 _889) ((A :93 _890) ((A :94 _891) ((A :95 _89) ((A :96 (BK K)) ((A :97 ((B BK) ((B (B BK)) P))) ((A :98 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :99 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _26) (_92 #0))) (_89 #0)))) ((B (B ((C' P) (_87 #1)))) _82))) (C P))) _85)) _86)) ((A :100 _96) ((A :101 (((S' C) ((B (P _178)) (((C' (C' B)) (((C' C) _89) _178)) _179))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') (_89 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_89 #1)))) ((B ((C' C) ((B ((C' S') (_89 #2))) (C _101)))) (C _101))))) (C _101))))) (C _101)))) (T K))) (T A)))) ((C _99) #4)))) ((A :102 (_108 _77)) ((A :103 ((_123 (_80 _102)) _100)) ((A :104 ((C (((C' B) ((P _115) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _105)))) (((S' (C' (C' B))) ((B (B (B _105))) (((S' (C' B)) ((B (B _105)) (((C' B) ((B _121) (T #0))) _104))) (((C' B) ((B _121) (T #1))) _104)))) (((C' B) ((B _121) (T #2))) _104)))) (((C' B) ((B _121) (T #3))) _104)))) ((B T) ((B (B P)) ((C' _82) (_84 #4)))))) ((A :105 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C') S) ((B (B (B (S B)))) ((B (B (B (B (B BK))))) ((B ((S' (C' B)) ((B B') B'))) ((B (B (B (B (B (S B)))))) ((B (B (B (B (B (B (B BK))))))) (((C' B) (B' (B' ((B (C' (C' (C' C)))) ((B ((C' B) (B' ((B C) _91)))) ((B ((C' B) _116)) _105)))))) ((B ((C' B) _116)) (C _105)))))))))) (((_861 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :106 ((_75 (_121 _190)) _104)) ((A :107 (((C' C) (((C' C) (C _101)) (_3 "Data.IntMap.!"))) I)) ((A :108 ((B ((C' B) T)) ((B (B Y)) (((C' (C' (S' (S' C)))) ((B ((S' B) ((B (S' P)) (C _97))
\ No newline at end of file
+1051
+((A :0 _935) ((A :1 ((B _981) _0)) ((A :2 (((S' _981) _0) I)) ((A :3 _905) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _934) ((C _75) _5))) ((A :7 (((C' _6) (_952 _71)) ((_75 _950) _70))) ((A :8 ((B ((S _981) _950)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_75 _190)) _10)) ((A :12 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_73 _9)) P)) ((A :15 ((B (B (_73 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 ((B (_73 _9)) (B (P _863)))) ((A :18 ((B (_73 _9)) (BK (P _863)))) ((A :19 ((_73 _9) ((S P) I))) ((A :20 ((B (_73 _9)) ((C (S' P)) I))) ((A :21 ((B Y) ((B (B (P (_14 _115)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _116)))))) ((A :22 ((B Y) ((B (B (P (_14 _863)))) ((B (C' B)) (B _13))))) ((A :23 _3) ((A :24 (T (_14 _863))) ((A :25 (_21 _76)) ((A :26 (R _33)) ((A :27 (T _32)) ((A :28 ((P _33) _32)) ((A :29 _33) ((A :30 ((C ((C S') _28)) I)) ((A :31 ((C S) _28)) ((A :32 K) ((A :33 A) ((A :34 _910) ((A :35 _911) ((A :36 (((S' _27) (_902 #97)) ((C _902) #122))) ((A :37 (((S' _27) (_902 #65)) ((C _902) #90))) ((A :38 (((S' _26) _36) _37)) ((A :39 (((S' _27) (_902 #48)) ((C _902) #57))) ((A :40 (((S' _27) (_902 #32)) ((C _902) #126))) ((A :41 _899) ((A :42 _900) ((A :43 _902) ((A :44 _901) ((A :45 (((S' _26) ((C _41) #32)) (((S' _26) ((C _41) #9)) ((C _41) #10)))) ((A :46 ((S ((S (((S' _27) (_43 #65)) ((C _43) #90))) (_33 (((_862 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _82) (((C' _83) _35) (_35 #65))) (_35 #97))))) ((A :47 ((S ((S (((S' _27) (_43 #97)) ((C _43) #97))) (_33 (((_862 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _82) (((C' _83) _35) (_35 #97))) (_35 #65))))) ((A :48 _870) ((A :49 _871) ((A :50 _872) ((A :51 _873) ((A :52 (_49 %0.0)) ((A :53 _48) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _874) ((A :58 _875) ((A :59 _57) ((A :60 _58) ((A :61 _876) ((A :62 _877) ((A :63 _878) ((A :64 _879) ((A :65 _61) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _880) ((A :70 ((B BK) T)) ((A :71 (BK T)) ((A :72 P) ((A :73 I) ((A :74 (S _907)) ((A :75 B) ((A :76 I) ((A :77 K) ((A :78 C) ((A :79 _906) ((A :80 ((C ((C S') _190)) _191)) ((A :81 (((C' (S' (C' B))) B) I)) ((A :82 _864) ((A :83 _865) ((A :84 _866) ((A :85 _867) ((A :86 _868) ((A :87 _869) ((A :88 (_83 #0)) ((A :89 _887) ((A :90 _888) ((A :91 _889) ((A :92 _890) ((A :93 _891) ((A :94 _892) ((A :95 _89) ((A :96 (BK K)) ((A :97 ((B BK) ((B (B BK)) P))) ((A :98 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :99 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _26) (_92 #0))) (_89 #0)))) ((B (B ((C' P) (_87 #1)))) _82))) (C P))) _85)) _86)) ((A :100 _96) ((A :101 (((S' C) ((B (P _178)) (((C' (C' B)) (((C' C) _89) _178)) _179))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') (_89 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_89 #1)))) ((B ((C' C) ((B ((C' S') (_89 #2))) (C _101)))) (C _101))))) (C _101))))) (C _101)))) (T K))) (T A)))) ((C _99) #4)))) ((A :102 (_108 _77)) ((A :103 ((_123 (_80 _102)) _100)) ((A :104 ((C (((C' B) ((P _115) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _105)))) (((S' (C' (C' B))) ((B (B (B _105))) (((S' (C' B)) ((B (B _105)) (((C' B) ((B _121) (T #0))) _104))) (((C' B) ((B _121) (T #1))) _104)))) (((C' B) ((B _121) (T #2))) _104)))) (((C' B) ((B _121) (T #3))) _104)))) ((B T) ((B (B P)) ((C' _82) (_84 #4)))))) ((A :105 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C') S) ((B (B (B (S B)))) ((B (B (B (B (B BK))))) ((B ((S' (C' B)) ((B B') B'))) ((B (B (B (B (B (S B)))))) ((B (B (B (B (B (B (B BK))))))) (((C' B) (B' (B' ((B (C' (C' (C' C)))) ((B ((C' B) (B' ((B C) _91)))) ((B ((C' B) _116)) _105)))))) ((B ((C' B) _116)) (C _105)))))))))) (((_862 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :106 ((_75 (_121 _190)) _104)) ((A :107 (((C' C) (((C' C) (C _101)) (_3 "Data.IntMap.!"))) I)) ((A :108 ((B ((C' B) T)) ((B (B Y)) (((C' (C' (S' (S' C)))) ((B ((S' B) ((B (S' P)) (C _97))
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -164,7 +164,7 @@
case aexpr of
EVar i -> Var i
EApp f a -> App (dsExpr f) (dsExpr a)
- ELam xs e -> dsLam (getSLocExpr aexpr) xs e
+ ELam qs -> dsEqns (getSLocExpr aexpr) qs
ELit _ (LChar c) -> Lit (LInt (ord c))
ELit _ l -> Lit l
ECase e as -> dsCase (getSLocExpr aexpr) e as
@@ -182,7 +182,7 @@
let
nv = newVar (allVarsExpr aexpr)
body = ECase (EVar nv) [(p, oneAlt $ EListish (LCompr e stmts)), (EVar dummyIdent, oneAlt $ EListish (LList []))]
- in app2 (Var (mkIdent "Data.List.concatMap")) (dsExpr (ELam [EVar nv] body)) (dsExpr b)
+ in app2 (Var (mkIdent "Data.List.concatMap")) (dsExpr (eLam [EVar nv] body)) (dsExpr b)
SThen c ->
dsExpr (EIf c (EListish (LCompr e stmts)) (EListish (LList [])))
SLet ds ->
@@ -210,15 +210,6 @@
let
xs = [mkIdent ("x" ++ showInt i) | i <- enumFromTo 1 n ]in App tup (foldr Lam (Var (xs !! m)) xs)
-
-dsLam :: SLoc -> [EPat] -> Expr -> Exp
-dsLam loc ps e =
- let
- vs = allVarsExpr (ELam ps e)
- xs = take (length ps) (newVars "l" vs)
- ps' = map dsPat ps
- ex = runS loc (vs ++ xs) (map Var xs) [(ps', dsAlts $ oneAlt e, any hasLit ps')]
- in foldr Lam ex xs
-- Handle special syntax for lists and tuples
dsPat :: --XHasCallStack =>
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -5,7 +5,7 @@
ImportSpec(..),
ImportItem(..),
EDef(..), showEDefs,
- Expr(..), showExpr,
+ Expr(..), eLam, showExpr,
Listish(..),
Lit(..), showLit, eqLit,
EBind(..), showEBind,
@@ -77,7 +77,7 @@
= EVar Ident
| EApp Expr Expr
| EOper Expr [(Ident, Expr)]
- | ELam [EPat] Expr
+ | ELam [Eqn]
| ELit SLoc Lit
| ECase Expr [ECaseArm]
| ELet [EBind] Expr
@@ -96,6 +96,9 @@
| EForall [IdKind] Expr -- only in types
--Xderiving (Show, Eq)
+eLam :: [EPat] -> Expr -> Expr
+eLam ps e = ELam [Eqn ps (EAlts [([], e)] [])]
+
data Con
= ConData ConTyInfo Ident
| ConNew Ident
@@ -270,7 +273,7 @@
EVar i -> [i]
EApp e1 e2 -> allVarsExpr e1 ++ allVarsExpr e2
EOper e1 ies -> allVarsExpr e1 ++ concatMap (\ (i,e2) -> i : allVarsExpr e2) ies
- ELam ps e -> concatMap allVarsPat ps ++ allVarsExpr e
+ ELam qs -> concatMap allVarsEqn qs
ELit _ _ -> []
ECase e as -> allVarsExpr e ++ concatMap allVarsCaseArm as
ELet bs e -> concatMap allVarsBind bs ++ allVarsExpr e
@@ -377,7 +380,7 @@
Data lhs cs -> text "data" <+> ppLHS lhs <+> text "=" <+> hsep (punctuate (text " |") (map ppConstr cs))
Newtype lhs c -> text "newtype" <+> ppLHS lhs <+> text "=" <+> ppConstr c
Type lhs t -> text "type" <+> ppLHS lhs <+> text "=" <+> ppEType t
- Fcn i eqns -> vcat (map (\ (Eqn ps alts) -> sep [ppIdent i <+> hsep (map ppEPat ps), ppAlts (text "=") alts]) eqns)
+ Fcn i eqns -> ppEqns (ppIdent i) (text "=") eqns
Sign i t -> ppIdent i <+> text "::" <+> ppEType t
Import (ImportSpec q m mm mis) -> text "import" <+> (if q then text "qualified" else empty) <+> ppIdent m <> text (maybe "" ((" as " ++) . unIdent) mm) <>case mis of
@@ -387,6 +390,9 @@
Infix (a, p) is -> text ("infix" ++ f a) <+> text (showInt p) <+> hsep (punctuate (text ", ") (map ppIdent is))where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""
+ppEqns :: Doc -> Doc -> [Eqn] -> Doc
+ppEqns name sepr = vcat . map (\ (Eqn ps alts) -> sep [name <+> hsep (map ppEPat ps), ppAlts sepr alts])
+
ppConstr :: Constr -> Doc
ppConstr (Constr c (Left ts)) = hsep (ppIdent c : map ppEType ts)
ppConstr (Constr c (Right fs)) = ppIdent c <> braces (hsep $ map f fs)
@@ -421,7 +427,7 @@
EVar v -> ppIdent v
EApp _ _ -> ppApp [] ae
EOper e ies -> ppExpr (foldl (\ e1 (i, e2) -> EApp (EApp (EVar i) e1) e2) e ies)
- ELam ps e -> parens $ text "\\" <> hsep (map ppExpr ps) <+> text "->" <+> ppExpr e
+ ELam qs -> parens $ text "\\" <> ppEqns empty (text "->") qs
ELit _ i -> text (showLit i)
ECase e as -> text "case" <+> ppExpr e <+> text "of" $$ nest 2 (vcat (map ppCaseArm as))
ELet bs e -> text "let" $$ nest 2 (vcat (map ppEBind bs)) $$ text "in" <+> ppExpr e
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -450,7 +450,7 @@
pure $ maybe r (ESign r) mt
pLam :: P Expr
-pLam = ELam <$> (pSymbol "\\" *> esome pAPat) <*> (pSymbol "->" *> pExpr)
+pLam = eLam <$> (pSymbol "\\" *> esome pAPat) <*> (pSymbol "->" *> pExpr)
pCase :: P Expr
pCase = ECase <$> (pKeyword "case" *> pExpr) <*> (pKeyword "of" *> pBlock pCaseArm)
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -997,7 +997,7 @@
T.return (EApp f' a')
EOper e ies -> T.do e' <- tcOper e ies; tcExpr mt e'
- ELam ps e -> tcExprLam mt ps e
+ ELam qs -> tcExprLam mt qs
ELit loc' l -> tcLit mt loc' l
ECase a arms -> T.do
(ea, ta) <- tInferExpr a
@@ -1026,7 +1026,7 @@
let
sbind = maybe (mkIdentSLoc loc ">>=") (\ mn -> qualIdent mn (mkIdentSLoc loc ">>=")) mmn
tcExpr mt (EApp (EApp (EVar sbind) a)
- (ELam [eVarI loc "$x"] (ECase (eVarI loc "$x") [(p, EAlts [([], EDo mmn ss)] [])])))
+ (eLam [eVarI loc "$x"] (ECase (eVarI loc "$x") [(p, EAlts [([], EDo mmn ss)] [])])))
SThen a -> T.do
let
sthen = maybe (mkIdentSLoc loc ">>") (\ mn -> qualIdent mn (mkIdentSLoc loc ">>") ) mmn
@@ -1038,7 +1038,7 @@
ESectL e i -> tcExpr mt (EApp (EVar i) e)
ESectR i e -> T.do
let x = eVarI loc "$x"
- tcExpr mt (ELam [x] (EApp (EApp (EVar i) x) e))
+ tcExpr mt (eLam [x] (EApp (EApp (EVar i) x) e))
EIf e1 e2 e3 -> T.do
e1' <- tCheckExpr (tBool (getSLocExpr e1)) e1
case mt of
@@ -1182,12 +1182,10 @@
(tp, tr) <- unArrow (getSLocExpr p) t
tCheckPat tp p $ \ pp -> tcPats tr ps $ \ tt pps -> ta tt (pp : pps)
-tcExprLam :: Expected -> [EPat] -> Expr -> T Expr
-tcExprLam mt aps expr = T.do
+tcExprLam :: Expected -> [Eqn] -> T Expr
+tcExprLam mt qs = T.do
t <- tGetExpTypeSet mt
- tcPats t aps $ \ tt ps -> T.do
- er <- tCheckExpr tt expr
- T.return (ELam ps er)
+ ELam <$> tcEqns t qs
tcEqns :: EType -> [Eqn] -> T [Eqn]
tcEqns t eqns = T.mapM (tcEqn t) eqns
--
⑨