ref: 95c1eb3057853ccfb2a8c5e84b9098cc701c3ca3
parent: 8222d73799103f55611de1e17be73c8b7f34bbc6
parent: ea89588a4d8a13dcbdec4c505b5141f112bd16f9
author: Lennart Augustsson <lennart@augustsson.net>
date: Sat Oct 28 15:57:43 EDT 2023
Merge branch 'master' into class
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1131
-((A :0 _954) ((A :1 ((B _1000) _0)) ((A :2 (((S' _1000) _0) I)) ((A :3 _924) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _953) ((C _84) _5))) ((A :7 (((C' _6) (_971 _73)) ((_84 _969) _72))) ((A :8 ((B ((S _1000) _969)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_84 _210)) _10)) ((A :12 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_82 _9)) P)) ((A :15 ((B (B (_82 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_82 _9)) (B (P _882)))) ((A :19 ((B (_82 _9)) (BK (P _882)))) ((A :20 ((_82 _9) ((S P) I))) ((A :21 ((B (_82 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _122)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _123)))))) ((A :23 ((B Y) ((B (B (P (_14 _882)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _882))) ((A :26 (_22 _85)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 ((_76 _918) _919)) ((A :36 ((_76 _928) (_80 _36))) ((A :37 _929) ((A :38 _930) ((A :39 (((S' _28) (_921 #97)) ((C _921) #122))) ((A :40 (((S' _28) (_921 #65)) ((C _921) #90))) ((A :41 (((S' _27) _39) _40)) ((A :42 (((S' _28) (_921 #48)) ((C _921) #57))) ((A :43 (((S' _28) (_921 #32)) ((C _921) #126))) ((A :44 _918) ((A :45 _919) ((A :46 _921) ((A :47 _920) ((A :48 (((S' _27) ((C (_77 _35)) #32)) (((S' _27) ((C (_77 _35)) #9)) ((C (_77 _35)) #10)))) ((A :49 ((S ((S (((S' _28) (_46 #65)) ((C _46) #90))) (_34 (((_881 "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #65))) (_38 #97))))) ((A :50 ((S ((S (((S' _28) (_46 #97)) ((C _46) #97))) (_34 (((_881 "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #97))) (_38 #65))))) ((A :51 _889) ((A :52 _890) ((A :53 _891) ((A :54 _892) ((A :55 (_52 %0.0)) ((A :56 _51) ((A :57 _52) ((A :58 _53) ((A :59 _54) ((A :60 ((_76 _893) _894)) ((A :61 (_77 _60)) ((A :62 (_78 _60)) ((A :63 _895) ((A :64 _896) ((A :65 _897) ((A :66 _898) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _66) ((A :71 _899) ((A :72 ((B BK) T)) ((A :73 (BK T)) ((A :74 (((S' _76) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _77) (T K)))) (K _33)))) ((B ((C' B) (T (K _33)))) ((B _77) (T A))))) ((B _80) ((B _74) (((S' P) (T K)) (T A)))))) ((A :75 P) ((A :76 P) ((A :77 (T K)) ((A :78 (T A)) ((A :79 (K (noDefault "Eq.=="))) ((A :80 ((B (B (B _29))) _77)) ((A :81 ((_76 ((C ((C S') _29)) I)) (_80 _81))) ((A :82 I) ((A :83 (S _926)) ((A :84 B) ((A :85 I) ((A :86 K) ((A :87 C) ((A :88 _925) ((A :89 ((C ((C S') _210)) _211)) ((A :90 (((C' (S' (C' B))) B) I)) ((A :91 _883) ((A :92 _884) ((A :93 _885) ((A :94 _886) ((A :95 _887) ((A :96 _888) ((A :97 (_92 #0)) ((A :98 ((_76 _906) _907)) ((A :99 _908) ((A :100 _909) ((A :101 _910) ((A :102 _911) ((A :103 (BK K)) ((A :104 ((B BK) ((B (B BK)) P))) ((A :105 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :106 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_100 #0))) ((C (_77 _98)) #0)))) ((B (B ((C' P) (_96 #1)))) _91))) (C P))) _94)) _95)) ((A :107 _103) ((A :108 (((S' C) ((B (P _197)) (((C' (C' B)) (((C' C) (_77 _98)) _197)) _198))) ((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') ((C (_77 _98)) #0))))) ((B ((C' (C' C)) ((B (B ((S' S') ((C (_77 _98)) #1)))) ((B ((C' C) ((B ((C' S') ((C (_77 _98)) #2))) (C _108)))) (C _108))))) (C _108))))) (C _108)))) (T K))) (T A)))) ((C _106) #4)))) ((A :109 (_115 _86)) ((A :110 ((_131 (_89 _109)) _107)) ((A :111 ((C (((C' B) ((P _122) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _112)))) (((S' (C' (C' B))) ((B (B (B _112))) (((S' (C' B)) ((B (B _112)) (((C' B) ((B _129) (T #0))) _111))) (((C' B) ((B _129) (T #1))) _111)))) (((C' B) ((B _129) (T #2))) _111)))) (((C' B) ((B _129) (T #3))) _111)))) ((B T) ((B (B P)) ((C' _91) (_93 #4)))))) ((A :112 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C
\ No newline at end of file
+1132
+((A :0 _955) ((A :1 ((B _1001) _0)) ((A :2 (((S' _1001) _0) I)) ((A :3 _925) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _954) ((C _84) _5))) ((A :7 (((C' _6) (_972 _73)) ((_84 _970) _72))) ((A :8 ((B ((S _1001) _970)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_84 _210)) _10)) ((A :12 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_82 _9)) P)) ((A :15 ((B (B (_82 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_82 _9)) (B (P _883)))) ((A :19 ((B (_82 _9)) (BK (P _883)))) ((A :20 ((_82 _9) ((S P) I))) ((A :21 ((B (_82 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _122)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _123)))))) ((A :23 ((B Y) ((B (B (P (_14 _883)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _883))) ((A :26 (_22 _85)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 ((_76 _919) _920)) ((A :36 ((_76 _929) (_80 _36))) ((A :37 _930) ((A :38 _931) ((A :39 (((S' _28) (_922 #97)) ((C _922) #122))) ((A :40 (((S' _28) (_922 #65)) ((C _922) #90))) ((A :41 (((S' _27) _39) _40)) ((A :42 (((S' _28) (_922 #48)) ((C _922) #57))) ((A :43 (((S' _28) (_922 #32)) ((C _922) #126))) ((A :44 _919) ((A :45 _920) ((A :46 _922) ((A :47 _921) ((A :48 (((S' _27) ((C (_77 _35)) #32)) (((S' _27) ((C (_77 _35)) #9)) ((C (_77 _35)) #10)))) ((A :49 ((S ((S (((S' _28) (_46 #65)) ((C _46) #90))) (_34 (((_882 "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #65))) (_38 #97))))) ((A :50 ((S ((S (((S' _28) (_46 #97)) ((C _46) #97))) (_34 (((_882 "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #97))) (_38 #65))))) ((A :51 _890) ((A :52 _891) ((A :53 _892) ((A :54 _893) ((A :55 (_52 %0.0)) ((A :56 _51) ((A :57 _52) ((A :58 _53) ((A :59 _54) ((A :60 ((_76 _894) _895)) ((A :61 (_77 _60)) ((A :62 (_78 _60)) ((A :63 _896) ((A :64 _897) ((A :65 _898) ((A :66 _899) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _66) ((A :71 _900) ((A :72 ((B BK) T)) ((A :73 (BK T)) ((A :74 (((S' _76) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _77) (T K)))) (K _33)))) ((B ((C' B) (T (K _33)))) ((B _77) (T A))))) ((B _80) ((B _74) (((S' P) (T K)) (T A)))))) ((A :75 P) ((A :76 P) ((A :77 (T K)) ((A :78 (T A)) ((A :79 (K (noDefault "Eq.=="))) ((A :80 ((B (B (B _29))) _77)) ((A :81 ((_76 ((C ((C S') _29)) I)) (_80 _81))) ((A :82 I) ((A :83 (S _927)) ((A :84 B) ((A :85 I) ((A :86 K) ((A :87 C) ((A :88 _926) ((A :89 ((C ((C S') _210)) _211)) ((A :90 (((C' (S' (C' B))) B) I)) ((A :91 _884) ((A :92 _885) ((A :93 _886) ((A :94 _887) ((A :95 _888) ((A :96 _889) ((A :97 (_92 #0)) ((A :98 ((_76 _907) _908)) ((A :99 _909) ((A :100 _910) ((A :101 _911) ((A :102 _912) ((A :103 (BK K)) ((A :104 ((B BK) ((B (B BK)) P))) ((A :105 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :106 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_100 #0))) ((C (_77 _98)) #0)))) ((B (B ((C' P) (_96 #1)))) _91))) (C P))) _94)) _95)) ((A :107 _103) ((A :108 (((S' C) ((B (P _197)) (((C' (C' B)) (((C' C) (_77 _98)) _197)) _198))) ((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') ((C (_77 _98)) #0))))) ((B ((C' (C' C)) ((B (B ((S' S') ((C (_77 _98)) #1)))) ((B ((C' C) ((B ((C' S') ((C (_77 _98)) #2))) (C _108)))) (C _108))))) (C _108))))) (C _108)))) (T K))) (T A)))) ((C _106) #4)))) ((A :109 (_115 _86)) ((A :110 ((_131 (_89 _109)) _107)) ((A :111 ((C (((C' B) ((P _122) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _112)))) (((S' (C' (C' B))) ((B (B (B _112))) (((S' (C' B)) ((B (B _112)) (((C' B) ((B _129) (T #0))) _111))) (((C' B) ((B _129) (T #1))) _111)))) (((C' B) ((B _129) (T #2))) _111)))) (((C' B) ((B _129) (T #3))) _111)))) ((B T) ((B (B P)) ((C' _91) (_93 #4)))))) ((A :112 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -175,7 +175,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
@@ -193,7 +193,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 ->
@@ -221,15 +221,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, showEBinds,
@@ -83,7 +83,7 @@
= EVar Ident
| EApp Expr Expr
| EOper Expr [(Ident, Expr)]
- | ELam [EPat] Expr
+ | ELam [Eqn]
| ELit SLoc Lit
| ECase Expr [ECaseArm]
| ELet [EBind] Expr
@@ -102,6 +102,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
@@ -227,7 +230,7 @@
-- Create a tuple selector, component i (0 based) of n
mkTupleSel :: Int -> Int -> Expr
-mkTupleSel i n = ELam [ETuple [ EVar $ if k == i then x else dummyIdent | k <- [0 .. n - 1] ]] (EVar x)
+mkTupleSel i n = eLam [ETuple [ EVar $ if k == i then x else dummyIdent | k <- [0 .. n - 1] ]] (EVar x)
where x = mkIdent "$x"
---------------------------------
@@ -298,7 +301,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
@@ -393,7 +396,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
@@ -407,6 +410,9 @@
where ctx [] = empty
ctx ts = ppEType (ETuple ts) <+> text "=>"
+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)
@@ -444,7 +450,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
@@ -458,7 +458,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
@@ -1249,7 +1249,7 @@
u <- newUniq
let d = mkIdentSLoc (getSLocExpr e) ("adict$" ++ showInt u)e' <- withDict d ctx $ tCheckExpr t' e
- T.return $ ELam [EVar d] e'
+ T.return $ eLam [EVar d] e'
tCheckExpr t e = tCheck tcExpr t e
tGetRefType :: --XHasCallStack =>
@@ -1362,7 +1362,7 @@
instSigma loc (EApp f' a') rt mt
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
@@ -1391,7 +1391,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
@@ -1403,7 +1403,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
@@ -1546,12 +1546,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 <- tGetExpType 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 | trace ("tcEqns: " ++ showEBind (BFcn dummyIdent eqns) ++ " :: " ++ showEType t) False = undefined--
⑨