ref: b7c1f531cc5f0bf95cbcfae20ef735c015e21f79
parent: 11b52f88ed01ed74d2ea6035143f35ad973a02de
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Tue Feb 6 12:21:18 EST 2024
New list comprehension desugaring.
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -191,6 +191,8 @@
dsExpr aexpr =
case aexpr of
EVar i -> Var i
+ EApp (EApp (EVar app) (EListish (LCompr e stmts))) l | app == mkIdent "Data.List_Type.++" ->
+ dsExpr $ dsCompr' e stmts l
EApp f a -> App (dsExpr f) (dsExpr a)
ELam qs -> dsEqns (getSLoc aexpr) qs
ELit _ (LChar c) -> Lit (LInt (ord c))
@@ -202,7 +204,8 @@
ETuple es -> Lam (mkIdent "$f") $ foldl App (Var $ mkIdent "$f") $ map dsExpr es
EIf e1 e2 e3 -> encIf (dsExpr e1) (dsExpr e2) (dsExpr e3)
EListish (LList es) -> encList $ map dsExpr es
- EListish (LCompr e astmts) ->
+ EListish (LCompr e stmts) -> dsExpr $ dsCompr' e stmts (EListish (LList []))
+{-case astmts of
[] -> dsExpr (EListish (LList [e]))
stmt : stmts ->
@@ -216,6 +219,7 @@
dsExpr (EIf c (EListish (LCompr e stmts)) (EListish (LList [])))
SLet ds ->
dsExpr (ELet ds (EListish (LCompr e stmts)))
+-}
ECon c ->
let
ci = conIdent c
@@ -228,6 +232,28 @@
in foldr Lam body xs
Nothing -> Var (conIdent c)
_ -> impossible
+
+dsCompr' :: Expr -> [EStmt] -> Expr -> Expr
+dsCompr' e ss l =
+ let r = dsCompr e ss l
+ in -- trace ("dsCompr:\n" ++ show (EApp (EApp (EVar (mkIdent "Data.List_Type.++")) (EListish (LCompr e ss))) l) ++ "\n" ++ show r)+ r
+
+dsCompr :: Expr -> [EStmt] -> Expr -> Expr
+dsCompr e [] l = EApp (EApp consCon e) l
+dsCompr e (SThen c : ss) l = EIf c (dsCompr e ss l) l
+dsCompr e (SLet ds : ss) l = ELet ds (dsCompr e ss l)
+dsCompr e xss@(SBind p g : ss) l = ELet [hdef] (EApp eh g)
+ where
+ hdef = BFcn h [eqn1, eqn2, eqn3]
+ eqn1 = eEqn [nilCon] l
+ eqn2 = eEqn [EApp (EApp consCon p) vs] (dsCompr e ss (EApp eh vs))
+ eqn3 = eEqn [EApp (EApp consCon u) vs] (EApp eh vs)
+ u = EVar dummyIdent
+ h = head $ newVars "$h" allVs
+ eh = EVar h
+ vs = EVar $ head $ newVars "$vs" allVs
+ allVs = allVarsExpr (EListish (LCompr (ETuple [e,l]) xss)) -- all used identifiers
-- Use tuple encoding to make a tuple
mkTupleE :: [Exp] -> Exp
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -651,7 +651,6 @@
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
ETuple es -> parens $ hsep $ punctuate (text ",") (map ppExpr es)
- EListish (LList es) -> ppList ppExpr es
EDo mn ss -> maybe (text "do") (\ n -> ppIdent n <> text ".do") mn $$ nest 2 (vcat (map ppEStmt ss))
ESectL e i -> parens $ ppExpr e <+> ppIdent i
ESectR i e -> parens $ ppIdent i <+> ppExpr e
@@ -687,7 +686,12 @@
ppForall iks = text "forall" <+> hsep (map ppIdKind iks) <+> text "."
ppListish :: Listish -> Doc
-ppListish _ = text "<<Listish>>"
+ppListish (LList es) = ppList ppExpr es
+ppListish (LCompr e ss) = brackets $ ppExpr e <+> text "|" <+> hsep (punctuate (text ",") (map ppEStmt ss))
+ppListish (LFrom e1) = brackets $ ppExpr e1 <> text ".."
+ppListish (LFromTo e1 e2) = brackets $ ppExpr e1 <> text ".." <> ppExpr e2
+ppListish (LFromThen e1 e2) = brackets $ ppExpr e1 <> text "," <> ppExpr e2 <> text ".."
+ppListish (LFromThenTo e1 e2 e3) = brackets $ ppExpr e1 <> text "," <> ppExpr e2 <> text ".." <> ppExpr e3
ppCon :: Con -> Doc
ppCon (ConData _ s _) = ppIdent s
--- /dev/null
+++ b/tests/ListCompr.hs
@@ -1,0 +1,13 @@
+module ListCompr(main) where
+import Prelude
+default (Int)
+
+main :: IO ()
+main = do
+ print [ x | x <- [1..3] ]
+ print [ x | x <- [1..3], odd x ]
+ print [ x+1 | x <- [1..3] ]
+ print [ (x,y) | x <- [1..3], y <- [1,2] ]
+ print $ [ x | x <- [1..3] ] ++ [ x | x <- [1..4] ]
+ print [ [ x + y | y <- [1,2] ] | x <- [1..3] ]
+ print [ x+1 | x <- [ a+b | a <- [1,10,100], b <- [2,3] ], even x ]
--- /dev/null
+++ b/tests/ListCompr.ref
@@ -1,0 +1,7 @@
+[1,2,3]
+[1,3]
+[2,3,4]
+[(1,1),(1,2),(2,1),(2,2),(3,1),(3,2)]
+[1,2,3,1,2,3,4]
+[[2,3],[3,4],[4,5]]
+[5,13,103]
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -59,6 +59,7 @@
$(TMHS) Unicode && $(EVAL) > Unicode.out && diff Unicode.ref Unicode.out
$(TMHS) BindPat && $(EVAL) > BindPat.out && diff BindPat.ref BindPat.out
$(TMHS) Read && $(EVAL) > Read.out && diff Read.ref Read.out
+ $(TMHS) ListCompr && $(EVAL) > ListCompr.out && diff ListCompr.ref ListCompr.out
errtest:
sh errtester.sh < errmsg.test
--
⑨