ref: 44e87cd4cb571edba8583ff38e27d00009447bfb
parent: a58a75d1d7ded8624731d24a0d603672df33b7a1
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Mon Aug 21 13:14:42 EDT 2023
Add a separate type for literals.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v2.2
-649
-(($A :0 ((_477 _431) ((($S' ($C ((($C' ($S' _477)) ($C _2)) (($B ($B (_477 _505))) ((($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' _478)) ((($C' $B) (($B _562) (($B _495) ((($C' _599) _8) 0)))) (($B (_562 _498)) (($B (_509 (($O 116) (($O 111) (($O 112) (($O 32) (($O 108) (($O 101) (($O 118) (($O 101) (($O 108) (($O 32) (($O 100) (($O 101) (($O 102) (($O 110) (($O 115) (($O 58) (($O 32) $K))))))))))))))))))) _459)))))))) ((($S' $B) (($B $B) (($B ($C' $B)) (($B ($B $B)) (($B ($B _478)) ((($C' $B) (($B _562) (($B _495) ((($C' _599) _8) 1)))) (_494 ($T (($B ($B (_562 _498))) ((($C' $B) _509) (($B (_509 (($O 32) (($O 61) (($O 32) $K))))) _225))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _478))) ((($C' $B) (($B $B) (($B _562) (($B _500) _11)))) (($B ($B (_509 _1))) (($B (($C' _509) _459)) (_509 (($O 10) $K))))))) (($B ($B (_477 _505))) ((($C' $B) (($B $B) (($B _562) (($B _495) ((($C' _599) _8) 0))))) (($B ($B (_562 _498))) (($B ($B (_509 (($O 102) (($O 105) (($O 110) (($O 97) (($O 108) (($O 32) (($O 112) (($O 97) (($O 115) (($O 115) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) $K))))))))))))))))))))))))) ((($C' ($C' _509)) (($B ($B (_472 6))) (($B ($B _459)) _593))) (($O 109) (($O 115) $K)))))))))) _3)))) _456))) (($B (($C' $C) (($B ($C _514)) _225))) (($C _527) (_542 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B ($B $K))) (($B ($B ($B ($B (_509 (($O 40) (($O 40) (($O 36) (($O 65) (($O 32) (($O 58) $K))))))))))) (($B ($B (($C' $B) (($B _509) _459)))) (($B ($B ($B (_509 (($O 32) $K))))) ((($C' $B) (($B ($C' _509)) ($B _225))) (($B (_509 (($O 41) (($O 32) $K)))) (($C _509) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _205)) $I))) (($B $K) $K))) $K)) $K))))) $T)) (($B (($S' _562) (($B _559) (($B (_562 _607)) (($B (_509 (($O 109) (($O 97) (($O 105) (($O 110) (($O 58) (($O 32) (($O 102) (($O 105) (($O 110) (($O 100) (($O 73) (($O 100) (($O 101) (($O 110) (($O 116) (($O 58) (($O 32) $K))))))))))))))))))) _293))))) ($C _449)))) (($B ($B _453)) (($B (($C' _511) (($B $T) (($B ($C $B)) (($B ($B ($B $K))) ((($C' ($C' ($C' $O))) ($B ($C $P))) $K)))))) (($C _527) (_542 0)))))) (($B (_562 _204)) (($B (_509 (($O 95) $K))) _459))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _526) (_513 (_470 (($O 45) (($O 118) $K)))))) ((_541 _470) (($O 45) (($O 114) $K))))) (($B (_507 (($O 46) $K))) (($B _561) (_512 ((_531 _584) (($O 45) (($O 105) $K)))))))) (($B (_562 _536)) ((($C' _509) (($B _561) (_512 ((_531 _584) (($O 45) (($O 111) $K)))))) (($O (($O 111) (($O 117) (($O 116) (($O 46) (($O 99) (($O 111) (($O 109) (($O 98) $K))))))))) $K))))) (($B (($S (($C ((($C' _595) _526) 1)) (_607 (($O 85) (($O 115) (($O 97) (($O 103) (($O 101) (($O 58) (($O 32) (($O 117) (($O 104) (($O 115) (($O 32) (($O 91) (($O 45) (($O 118) (($O 93) (($O 32) (($O 91) (($O 45) (($O 114) (($O 93) (($O 32) (($O 91) (($O 45) (($O 105) (($O 80) (($O 65) (($O 84) (($O 72) (($O 93) (($O 32) (($O 91) (($O 45) (($O 111) (($O 70) (($O 73) (($O 76) (($O 69) (($O 93) (($O 32) (($O 77) (($O 111) (($O 100) (($O 117) (($O 108) (($O 101) (($O 78) (($O 97) (($O 109) (($O 101) $K)))))))))))))))))))))))))))))))))))))))))))))))))))) _536)) (_513 ((_563 _604) ((_563 (_470 (($O 45) $K))) (_524 1)))))))) (($A :1 (($O 118) (($O 50) (($O 46) (($O 50) (($O 10) $K)))))) (($A :2 ((($S' ($S' _477)) _16) (($B ($B ($B (_477 _505)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _478) (($B (_562 _496)) (($B (_562 (_525 1000000))) _38)))))) (($B ($B ($B ($B (_477 _505))))) ((($C' $B) (($B ($C' $B)) (($B
\ No newline at end of file
+656
+(($A :0 ((_484 _438) ((($S' ($C ((($C' ($S' _484)) ($C _2)) (($B ($B (_484 _512))) ((($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' _485)) ((($C' $B) (($B _569) (($B _502) ((($C' _606) _8) 0)))) (($B (_569 _505)) (($B (_516 (($O 116) (($O 111) (($O 112) (($O 32) (($O 108) (($O 101) (($O 118) (($O 101) (($O 108) (($O 32) (($O 100) (($O 101) (($O 102) (($O 110) (($O 115) (($O 58) (($O 32) $K))))))))))))))))))) _466)))))))) ((($S' $B) (($B $B) (($B ($C' $B)) (($B ($B $B)) (($B ($B _485)) ((($C' $B) (($B _569) (($B _502) ((($C' _606) _8) 1)))) (_501 ($T (($B ($B (_569 _505))) ((($C' $B) _516) (($B (_516 (($O 32) (($O 61) (($O 32) $K))))) _229))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _485))) ((($C' $B) (($B $B) (($B _569) (($B _507) _11)))) (($B ($B (_516 _1))) (($B (($C' _516) _466)) (_516 (($O 10) $K))))))) (($B ($B (_484 _512))) ((($C' $B) (($B $B) (($B _569) (($B _502) ((($C' _606) _8) 0))))) (($B ($B (_569 _505))) (($B ($B (_516 (($O 102) (($O 105) (($O 110) (($O 97) (($O 108) (($O 32) (($O 112) (($O 97) (($O 115) (($O 115) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) (($O 32) $K))))))))))))))))))))))))) ((($C' ($C' _516)) (($B ($B (_479 6))) (($B ($B _466)) _600))) (($O 109) (($O 115) $K)))))))))) _3)))) _463))) (($B (($C' $C) (($B ($C _521)) _229))) (($C _534) (_549 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B ($B $K))) (($B ($B ($B ($B (_516 (($O 40) (($O 40) (($O 36) (($O 65) (($O 32) (($O 58) $K))))))))))) (($B ($B (($C' $B) (($B _516) _466)))) (($B ($B ($B (_516 (($O 32) $K))))) ((($C' $B) (($B ($C' _516)) ($B _229))) (($B (_516 (($O 41) (($O 32) $K)))) (($C _516) (($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' _569) (($B _566) (($B (_569 _614)) (($B (_516 (($O 109) (($O 97) (($O 105) (($O 110) (($O 58) (($O 32) (($O 102) (($O 105) (($O 110) (($O 100) (($O 73) (($O 100) (($O 101) (($O 110) (($O 116) (($O 58) (($O 32) $K))))))))))))))))))) _298))))) ($C _456)))) (($B ($B _460)) (($B (($C' _518) (($B $T) (($B ($C $B)) (($B ($B ($B $K))) ((($C' ($C' ($C' $O))) ($B ($C $P))) $K)))))) (($C _534) (_549 0)))))) (($B (_569 _205)) (($B (_516 (($O 95) $K))) _466))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _533) (_520 (_477 (($O 45) (($O 118) $K)))))) ((_548 _477) (($O 45) (($O 114) $K))))) (($B (_514 (($O 46) $K))) (($B _568) (_519 ((_538 _591) (($O 45) (($O 105) $K)))))))) (($B (_569 _543)) ((($C' _516) (($B _568) (_519 ((_538 _591) (($O 45) (($O 111) $K)))))) (($O (($O 111) (($O 117) (($O 116) (($O 46) (($O 99) (($O 111) (($O 109) (($O 98) $K))))))))) $K))))) (($B (($S (($C ((($C' _602) _533) 1)) (_614 (($O 85) (($O 115) (($O 97) (($O 103) (($O 101) (($O 58) (($O 32) (($O 117) (($O 104) (($O 115) (($O 32) (($O 91) (($O 45) (($O 118) (($O 93) (($O 32) (($O 91) (($O 45) (($O 114) (($O 93) (($O 32) (($O 91) (($O 45) (($O 105) (($O 80) (($O 65) (($O 84) (($O 72) (($O 93) (($O 32) (($O 91) (($O 45) (($O 111) (($O 70) (($O 73) (($O 76) (($O 69) (($O 93) (($O 32) (($O 77) (($O 111) (($O 100) (($O 117) (($O 108) (($O 101) (($O 78) (($O 97) (($O 109) (($O 101) $K)))))))))))))))))))))))))))))))))))))))))))))))))))) _543)) (_520 ((_570 _611) ((_570 (_477 (($O 45) $K))) (_531 1)))))))) (($A :1 (($O 118) (($O 50) (($O 46) (($O 50) (($O 10) $K)))))) (($A :2 ((($S' ($S' _484)) _16) (($B ($B ($B (_484 _512)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _485) (($B (_569 _503)) (($B (_569 (_532 1000000))) _38)))))) (($B ($B ($B ($B (_484 _512))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _485))) ((($
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -74,8 +74,9 @@
EVar i -> Var i
EApp f a -> App (dsExpr f) (dsExpr a)
ELam xs e -> dsLam xs e
- EInt i -> Int i
- EChar c -> Int (ord c)
+ ELit (LChar c) -> Lit (LInt (ord c))
+ ELit (LStr cs) -> dsExpr $ EList $ map (ELit . LChar) cs
+ ELit l -> Lit l
ECase e as -> dsCase e as
-- For now, just sequential bindings; each recursive
ELet ads e ->
@@ -87,11 +88,10 @@
de = dsExpr (ELet ds e)
def ir a =
case ir of
- (i, r) -> App (Lam i a) (App (Prim "Y") (Lam i r))
+ (i, r) -> App (Lam i a) (App (Lit (LPrim "Y")) (Lam i r))
in foldr def de dsd
EList es -> foldr (app2 cCons) cNil $ map dsExpr es
ETuple es -> Lam "$f" $ foldl App (Var "$f") $ map dsExpr es
- EStr cs -> dsExpr $ EList $ map EChar cs
EDo mn astmts ->
case astmts of
[] -> error "empty do"
@@ -118,7 +118,6 @@
if null stmts then error "do without final expression" else
dsExpr $ ELet ds (EDo mn stmts)
- EPrim s -> Prim s
ESectL e op ->
App (dsExpr (EVar op)) (dsExpr e)
ESectR op e ->
@@ -173,7 +172,7 @@
EList ps -> dsPat $ foldr (\ x xs -> EApp (EApp consCon x) xs) nilCon ps
ETuple ps -> dsPat $ foldl EApp (tupleCon (length ps)) ps
EAt i p -> EAt i (dsPat p)
- EInt _ -> ap
+ ELit _ -> ap
_ -> impossible
consCon :: EPat
@@ -200,7 +199,7 @@
dummyIdent = "_"
eError :: String -> Expr
-eError s = EApp (EPrim "error") (EStr s)
+eError s = EApp (ELit (LPrim "error")) (ELit $ LStr s)
lams :: [Ident] -> Exp -> Exp
lams xs e = foldr Lam e xs
@@ -313,7 +312,7 @@
S.return $ mkCase i narms ndflt
eMatchErr :: Exp
-eMatchErr = dsExpr $ EApp (EPrim "error") (EStr "no match")
+eMatchErr = dsExpr $ EApp (ELit (LPrim "error")) (ELit $ LStr "no match")
-- If the first expression isn't a variable, the use
-- a let binding and pass variable to f.
@@ -331,9 +330,8 @@
cheap ae =
case ae of
Var _ -> True
- Int _ -> True
- Prim _ -> True
- App (Prim _) _ -> True
+ Lit _ -> True
+ App (Lit _) _ -> True
_ -> False
-- Ugh, what a hack
@@ -357,7 +355,7 @@
-- A hack for Int pattern matching
if isInt name then
let
- cond = app2 eEqInt var (Int (readInt name))
+ cond = app2 eEqInt var (Lit (LInt (readInt name)))
in app2 cond dflt arhs
else
let
@@ -410,7 +408,7 @@
ECon c -> c
EAt _ p -> pConOf p
EApp p _ -> pConOf p
- EInt i -> let { n = showInt i } in Con [(n, 0)] n+ ELit (LInt i) -> let { n = showInt i } in Con [(n, 0)] n_ -> impossible
pArgs :: EPat -> [EPat]
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -9,7 +9,7 @@
) where
import Prelude
import Data.List
-import MicroHs.Parse --X(Ident, eqIdent)
+import MicroHs.Parse
--Ximport Compat
--import Debug.Trace
@@ -19,8 +19,7 @@
= Var Ident
| App Exp Exp
| Lam Ident Exp
- | Int Int
- | Prim PrimOp
+ | Lit Lit
--Xderiving (Show, Eq)
data MaybeApp = NotApp | IsApp Exp Exp
@@ -40,7 +39,7 @@
isPrim :: String -> Exp -> Bool
isPrim s ae =
case ae of
- Prim ss -> eqString s ss
+ Lit (LPrim ss) -> eqString s ss
_ -> False
isK :: Exp -> Bool
@@ -68,14 +67,26 @@
app3 f a1 a2 a3 = App (app2 f a1 a2) a3
cCons :: Exp
-cCons = Prim "O"
+cCons = Lit (LPrim "O")
cNil :: Exp
-cNil = Prim "K"
+cNil = Lit (LPrim "K")
cFlip :: Exp
-cFlip = Prim "C"
+cFlip = Lit (LPrim "C")
+cId :: Exp
+cId = Lit (LPrim "I")
+
+cConst :: Exp
+cConst = Lit (LPrim "K")
+
+cSpread :: Exp
+cSpread = Lit (LPrim "S")
+
+cP :: Exp
+cP = Lit (LPrim "P")
+
{-eqExp :: Exp -> Exp -> Bool
eqExp ae1 ae2 =
@@ -106,8 +117,7 @@
toStringP ae =
case ae of
Var x -> x
- Prim x -> '$':x
- Int i -> showInt i
+ Lit l -> showLit l
Lam x e -> "(\\" ++ x ++ " " ++ toStringP e ++ ")"
App f a -> "(" ++ toStringP f ++ " " ++ toStringP a ++ ")"@@ -124,18 +134,17 @@
abstract :: Ident -> Exp -> Exp
abstract x ae =
case ae of
- Var y -> if eqString x y then Prim "I" else cK (Var y)
+ Var y -> if eqString x y then cId else cK (Var y)
App f a -> cS (abstract x f) (abstract x a)
Lam y e -> abstract x $ abstract y e
- Prim _ -> cK ae
- Int _ -> cK ae
+ Lit _ -> cK ae
cK :: Exp -> Exp
-cK e = App (Prim "K") e
+cK e = App cConst e
cS :: Exp -> Exp -> Exp
cS a1 a2 =
- if isK a1 then Prim "I" else
+ if isK a1 then cId else
let
r = cS2 a1 a2
in
@@ -169,7 +178,7 @@
cS3 :: Exp -> Exp -> Exp
cS3 a1 a2 =
let
- r = app2 (Prim "S") a1 a2
+ r = app2 cSpread a1 a2
in
case getApp a1 of
NotApp -> r
@@ -207,7 +216,7 @@
if isB bc then
cCC e1 e2 e3
else if isC bc && isI e1 then
- app2 (Prim "P") e2 e3
+ app2 cP e2 e3
else
r
@@ -214,7 +223,7 @@
cC2 :: Exp -> Exp -> Exp
cC2 a1 a2 =
let
- r = app2 (Prim "C") a1 a2
+ r = app2 cFlip a1 a2
in
case getVar a1 of
Nothing -> r
@@ -238,7 +247,7 @@
NotApp -> r
IsApp cb ck ->
if isB cb && isK ck && isP a2 then
- Prim "O"
+ Lit (LPrim "O")
else
r
@@ -257,7 +266,7 @@
r
NotApp ->
if isC a1 && isC x1 && isI x2 then
- Prim "P"
+ cP
else
r
NotApp -> r
@@ -267,7 +276,7 @@
if isI a1 then
a2
else
- app2 (Prim "B") a1 a2
+ app2 (Lit (LPrim "B")) a1 a2
{-cB (App CB CK) CP = CO -- Cons
@@ -278,10 +287,10 @@
-}
cSS :: Exp -> Exp -> Exp -> Exp
-cSS e1 e2 e3 = app3 (Prim "S'") e1 e2 e3
+cSS e1 e2 e3 = app3 (Lit (LPrim "S'")) e1 e2 e3
cCC :: Exp -> Exp -> Exp -> Exp
-cCC e1 e2 e3 = app3 (Prim "C'") e1 e2 e3
+cCC e1 e2 e3 = app3 (Lit (LPrim "C'")) e1 e2 e3
-- This is a hack, it assumes things about the Prelude
flipOps :: [(PrimOp, PrimOp)]
@@ -307,11 +316,11 @@
aa = improveT a
in
if isK ff && isI aa then
- Prim "A"
+ Lit (LPrim "A")
-- else if isI ff then
-- aa
else if isC ff && isI aa then
- Prim "T"
+ Lit (LPrim "T")
else
let
def =
@@ -355,8 +364,7 @@
Var i -> i
App f a -> "(" ++ showExp f ++ " " ++ showExp a ++ ")"Lam i e -> "(\\" ++ i ++ ". " ++ showExp e ++ ")"
- Int i -> showInt i
- Prim p -> p
+ Lit l -> showLit l
substExp :: Ident -> Exp -> Exp -> Exp
substExp si se ae =
@@ -377,8 +385,7 @@
Lam j (substExp si se (substExp i (Var j) e))
else
Lam i (substExp si se e)
- Int _ -> ae
- Prim _ -> ae
+ Lit _ -> ae
freeVars :: Exp -> [Ident]
freeVars ae =
@@ -386,8 +393,7 @@
Var i -> [i]
App f a -> freeVars f ++ freeVars a
Lam i e -> deleteBy eqIdent i (freeVars e)
- Int _ -> []
- Prim _ -> []
+ Lit _ -> []
allVarsExp :: Exp -> [Ident]
allVarsExp ae =
@@ -395,8 +401,7 @@
Var i -> [i]
App f a -> allVarsExp f ++ allVarsExp a
Lam i e -> i : allVarsExp e
- Int _ -> []
- Prim _ -> []
+ Lit _ -> []
--------
-- Possible additions
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -10,6 +10,7 @@
ImportSpec(..),
EDef(..), showEDefs,
Expr(..), showExpr,
+ Lit(..), showLit,
EBind(..),
Eqn(..),
EStmt(..),
@@ -72,15 +73,12 @@
= EVar Ident
| EApp Expr Expr
| ELam [EPat] Expr
- | EInt Int
- | EChar Char
- | EStr String
+ | ELit Lit
| ECase Expr [ECaseArm]
| ELet [EBind] Expr
| ETuple [Expr]
| EList [Expr]
| EDo (Maybe Ident) [EStmt]
- | EPrim String
| ESectL Expr Ident
| ESectR Ident Expr
| EIf Expr Expr Expr
@@ -108,6 +106,9 @@
conArity :: Con -> Int
conArity (Con cs i) = fromMaybe undefined $ lookupBy eqIdent i cs
+data Lit = LInt Int | LChar Char | LStr String | LPrim String
+ --Xderiving (Show, Eq)
+
type ECaseArm = (EPat, Expr)
data EStmt = SBind EPat Expr | SThen Expr | SLet [EBind]
@@ -553,16 +554,20 @@
pAExprPT =
(EVar <$> pLIdent)
<|> (EVar <$> pUIdent)
- <|> (EInt <$> pInt)
- <|> (EChar <$> pChar)
- <|> (EStr <$> pString)
+ <|> (ELit <$> pLit)
<|> (eTuple <$> (pSym '(' *> esepBy1 pExprPT (pSym ',') <* pSym ')'))<|> (EList <$> (pSym '[' *> esepBy1 pExprPT (pSym ',') <* pSym ']'))
- <|> (EPrim <$> (pKeyword "primitive" *> pString))
+ <|> (ELit . LPrim <$> (pKeyword "primitive" *> pString))
<|> (ESectL <$> (pSym '(' *> pExprArg) <*> (pOper <* pSym ')')) <|> (ESectR <$> (pSym '(' *> pOper) <*> (pExprArg <* pSym ')'))<|> (ECompr <$> (pSym '[' *> pExprPT <* pSym '|') <*> (esepBy1 pStmt (pSym ',') <* pSym ']'))
+pLit :: P Lit
+pLit =
+ (LInt <$> pInt)
+ <|> (LChar <$> pChar)
+ <|> (LStr <$> pString)
+
eTuple :: [Expr] -> Expr
eTuple aes =
case aes of
@@ -594,9 +599,7 @@
pAPat =
(EVar <$> pLIdent)
<|> (EVar <$> pUIdent)
- <|> (EInt <$> pInt)
- <|> (EChar <$> pChar)
- <|> (EStr <$> pString)
+ <|> (ELit <$> pLit)
<|> (eTuple <$> (pSym '(' *> esepBy1 pPat (pSym ',') <* pSym ')'))<|> (EList <$> (pSym '[' *> esepBy1 pPat (pSym ',') <* pSym ']'))
<|> (EAt <$> (pLIdent <* pSymbol "@") <*> pAPat)
@@ -808,15 +811,12 @@
EVar v -> v
EApp f a -> "(" ++ showExpr f ++ " " ++ showExpr a ++ ")"ELam ps e -> "(\\" ++ unwords (map showExpr ps) ++ " -> " ++ showExpr e ++ ")"
- EInt i -> showInt i
- EChar c -> showChar c
- EStr s -> showString s
+ ELit i -> showLit i
ECase e as -> "case " ++ showExpr e ++ " of {\n" ++ unlines (map showCaseArm as) ++ "}"ELet bs e -> "let\n" ++ unlines (map showEBind bs) ++ "in " ++ showExpr e
ETuple es -> "(" ++ intercalate "," (map showExpr es) ++ ")"EList es -> showList showExpr es
EDo mn ss -> maybe "do" (\n -> n ++ ".do\n") mn ++ unlines (map showEStmt ss)
- EPrim p -> p
ESectL e i -> "(" ++ showExpr e ++ " " ++ i ++ ")" ESectR i e -> "(" ++ i ++ " " ++ showExpr e ++ ")"EIf e1 e2 e3 -> "if " ++ showExpr e1 ++ " then " ++ showExpr e2 ++ " else " ++ showExpr e3
@@ -826,6 +826,14 @@
EUVar i -> "a" ++ showInt i
ECon c -> conIdent c
+showLit :: Lit -> String
+showLit l =
+ case l of
+ LInt i -> showInt i
+ LChar c -> showChar c
+ LStr s -> showString s
+ LPrim s -> '$':s
+
showEStmt :: EStmt -> String
showEStmt as =
case as of
@@ -897,15 +905,12 @@
EVar i -> [i]
EApp e1 e2 -> allVarsExpr e1 ++ allVarsExpr e2
ELam ps e -> concatMap allVarsPat ps ++ allVarsExpr e
- EInt _ -> []
- EChar _ -> []
- EStr _ -> []
+ ELit _ -> []
ECase e as -> allVarsExpr e ++ concatMap (\ pa -> allVarsPat (fst pa) ++ allVarsExpr (snd pa)) as
ELet bs e -> concatMap allVarsBind bs ++ allVarsExpr e
ETuple es -> concatMap allVarsExpr es
EList es -> concatMap allVarsExpr es
EDo mi ss -> maybe [] (:[]) mi ++ concatMap allVarsStmt ss
- EPrim _ -> []
ESectL e i -> i : allVarsExpr e
ESectR i e -> i : allVarsExpr e
EIf e1 e2 e3 -> allVarsExpr e1 ++ allVarsExpr e2 ++ allVarsExpr e3
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -29,8 +29,8 @@
case ae of
Var n -> r n
App f a -> unsafeCoerce (trans r f) (trans r a)
- Int i -> unsafeCoerce i
- Prim p -> fromMaybe (error "primlookup") $ lookupBy eqString p primTable
+ Lit (LInt i) -> unsafeCoerce i
+ Lit (LPrim p) -> fromMaybe (error "primlookup") $ lookupBy eqString p primTable
_ -> error "trans: impossible"
-- Use linear search in this table.
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -643,7 +643,6 @@
tcExprR :: --XHasCallStack =>
Maybe EType -> Expr -> T (Typed Expr)
tcExprR mt ae =
- let { lit t = T.do { munify mt t; T.return (ae, t) } } incase ae of
EVar i ->
if isUnderscore i then
@@ -660,9 +659,7 @@
(ef, _) <- tcExpr (Just (tArrow ta tr)) f
T.return (EApp ef ea, tr)
ELam is e -> tcExprLam mt is e
- EInt _ -> lit (tCon "Primitives.Int")
- EChar _ -> lit (tCon "Primitives.Char")
- EStr _ -> lit (tApps "Data.List.[]" [tCon "Primitives.Char"])
+ ELit l -> tcLit mt l
ECase a arms -> T.do
(ea, ta) <- tcExpr Nothing a
(earms, tarms) <- unzip <$> T.mapM (tcArm mt ta) arms
@@ -722,9 +719,6 @@
tcExpr Nothing (ELet bs (EDo mmn ss))
T.return (EDo mn (SLet ebs : ys), tr)
- EPrim _ -> T.do
- t <- unMType mt -- pretend it is anything
- T.return (ae, t)
ESectL e i -> T.do
(EApp (EVar ii) ee, t) <- tcExpr mt (EApp (EVar i) e)
T.return (ESectL ee ii, t)
@@ -772,6 +766,17 @@
EBad _ -> impossible -- shouldn't happen
EUVar _ -> impossible -- shouldn't happen
ECon _ -> impossible
+
+tcLit :: Maybe EType -> Lit -> T (Typed Expr)
+tcLit mt l =
+ let { lit t = T.do { munify mt t; T.return (ELit l, t) } } in+ case l of
+ LInt _ -> lit (tCon "Primitives.Int")
+ LChar _ -> lit (tCon "Primitives.Char")
+ LStr _ -> lit (tApps "Data.List.[]" [tCon "Primitives.Char"])
+ LPrim _ -> T.do
+ t <- unMType mt -- pretend it is anything
+ T.return (ELit l, t)
unArrow :: Maybe EType -> T (EType, EType)
unArrow Nothing = T.do { a <- newUVar; r <- newUVar; T.return (a, r) }--
⑨