ref: f418323a763fc416fd80157ebe29c482c71928c0
parent: 3c4dcd0457a4908b9e5e5969d875ada0412aa34d
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Wed Aug 30 06:30:27 EDT 2023
Temp
--- a/TODO
+++ b/TODO
@@ -18,3 +18,4 @@
* Add the possibility to save a compiler cache in a file
- Add SHA checksumming to the C code
- Use SHA as the cache lookup key.
+* use 'data = primitive "Int"' for primitive types.
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -229,8 +229,11 @@
in ECon $ ConData [(c, n)] c
dummyIdent :: Ident
-dummyIdent = "_"
+dummyIdent = Ident "_"
+dummyEIdent :: EIdent
+dummyEIdent = "_"
+
eError :: String -> Expr
eError s = EApp (ELit (LPrim "error")) (ELit $ LStr s)
@@ -281,6 +284,18 @@
put (tail is)
S.return (head is)
+newEIdents :: Int -> M [EIdent]
+newEIdents n = S.do
+ is <- get
+ put (drop n is)
+ S.return (map unIdent (take n is))
+
+newEIdent :: M EIdent
+newEIdent = S.do
+ is <- get
+ put (tail is)
+ S.return (head is)
+
runS :: [Ident] -> [Exp] -> Matrix -> Exp
runS used ss mtrx =
--trace ("runS " ++ show (ss, mtrx)) $@@ -314,7 +329,7 @@
i:is -> S.do
let
(arms, darms, rarms) = splitArms aarms
- ndarms = map (\ (EVar x : ps, ed, g) -> (ps, substAlpha x i . ed, g) ) darms
+ ndarms = map (\ (EVar x : ps, ed, g) -> (ps, substAlpha (unIdent x) i . ed, g) ) darms
-- traceM ("split " ++ show (arms, darms, rarms))letBind (dsMatrix dflt iis rarms) $ \ drest ->
letBind (dsMatrix drest is ndarms) $ \ ndflt ->
@@ -329,17 +344,17 @@
let
(pat:_, _, _) : _ = grp
con = pConOf pat
- xs <- newIdents (conArity con)
+ xs <- newEIdents (conArity con)
let
one arg =
case arg of
(p : ps, e, g) ->
case p of
- EAt a pp -> one (pp:ps, substAlpha a i . e, g)
+ EAt a pp -> one (pp:ps, substAlpha (unIdent a) i . e, g)
_ -> (pArgs p ++ ps, e, g)
_ -> impossible
cexp <- dsMatrix ndflt (map Var xs ++ is) (map one grp)
- S.return (SPat con xs, cexp)
+ S.return (SPat con (map Ident xs), cexp)
-- traceM $ "grps " ++ show grps
narms <- S.mapM oneGroup grps
S.return $ mkCase i narms ndflt
@@ -355,7 +370,7 @@
if cheap e then
f e
else S.do
- x <- newIdent
+ x <- newEIdent
r <- f (Var x)
S.return $ eLet x e r
@@ -382,7 +397,7 @@
--trace ("mkCase " ++ show pes) $case pes of
[] -> dflt
- [(SPat (ConNew _) [x], arhs)] -> eLet x var arhs
+ [(SPat (ConNew _) [x], arhs)] -> eLet (unIdent x) var arhs
(SPat (ConLit l) _, arhs) : rpes ->
let
cond =
@@ -426,22 +441,22 @@
-- Change from x to y inside e.
-- XXX Doing it at runtime.
-substAlpha :: Ident -> Exp -> Exp -> Exp
+substAlpha :: EIdent -> Exp -> Exp -> Exp
substAlpha x y e =
- if eqIdent x dummyIdent then
+ if eqEIdent x dummyEIdent then
e
else
substExp x y e
-eLet :: Ident -> Exp -> Exp -> Exp
+eLet :: EIdent -> Exp -> Exp -> Exp
eLet i e b =
- if eqIdent i dummyIdent then
+ if eqEIdent i dummyEIdent then
b
else
case b of
- Var j | eqIdent i j -> e
+ Var j | eqEIdent i j -> e
_ ->
- case filter (eqIdent i) (freeVars b) of
+ case filter (eqEIdent i) (freeVars b) of
[] -> b -- no occurences, no need to bind
[_] -> substExp i e b -- single occurrence, substitute XXX coule be worse if under lambda
_ -> App (Lam i b) e -- just use a beta redex
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -5,6 +5,7 @@
substExp,
Exp(..), showExp, toStringP,
PrimOp,
+ EIdent, eqEIdent,
encodeString,
app2, cCons, cNil, cFlip,
allVarsExp, freeVars
@@ -18,10 +19,14 @@
type PrimOp = String
+type EIdent = String
+eqEIdent :: EIdent -> EIdent -> Bool
+eqEIdent = eqString
+
data Exp
- = Var Ident
+ = Var EIdent
| App Exp Exp
- | Lam Ident Exp
+ | Lam EIdent Exp
| Lit Lit
--Xderiving (Show, Eq)
@@ -33,7 +38,7 @@
App f a -> IsApp f a
_ -> NotApp
-getVar :: Exp -> Maybe Ident
+getVar :: Exp -> Maybe EIdent
getVar ae =
case ae of
Var v -> Just v
@@ -154,7 +159,7 @@
Lam x a -> abstract x a
_ -> ae
-abstract :: Ident -> Exp -> Exp
+abstract :: EIdent -> Exp -> Exp
abstract x ae =
case ae of
Var y -> if eqString x y then cId else cK (Var y)
@@ -396,20 +401,20 @@
Lam i e -> "(\\" ++ i ++ ". " ++ showExp e ++ ")"
Lit l -> showLit l
-substExp :: Ident -> Exp -> Exp -> Exp
+substExp :: EIdent -> Exp -> Exp -> Exp
substExp si se ae =
case ae of
- Var i -> if eqIdent i si then se else ae
+ Var i -> if eqEIdent i si then se else ae
App f a -> App (substExp si se f) (substExp si se a)
- Lam i e -> if eqIdent si i then
+ Lam i e -> if eqEIdent si i then
ae
- else if elemBy eqIdent i (freeVars se) then
+ else if elemBy eqEIdent i (freeVars se) then
let
fe = allVarsExp e
ase = allVarsExp se
j = --head $ deleteFirstsBy eqIdent ["a" ++ showInt n | n <- enumFrom 0] (freeVars se ++ freeVars e)
--head [ v | n <- enumFrom 0, let { v = "a" ++ showInt n }, not (elemBy eqIdent v fse), not (elemBy eqIdent v fe) ]- head [ v | n <- enumFrom 0, let { v = "a" ++ showInt n }, not (elemBy eqIdent v ase), not (elemBy eqIdent v fe) ]+ head [ v | n <- enumFrom 0, let { v = "a" ++ showInt n }, not (elemBy eqEIdent v ase), not (elemBy eqEIdent v fe) ]in
--trace ("substExp " ++ unwords [si, i, j]) $Lam j (substExp si se (substExp i (Var j) e))
@@ -417,15 +422,15 @@
Lam i (substExp si se e)
Lit _ -> ae
-freeVars :: Exp -> [Ident]
+freeVars :: Exp -> [EIdent]
freeVars ae =
case ae of
Var i -> [i]
App f a -> freeVars f ++ freeVars a
- Lam i e -> deleteBy eqIdent i (freeVars e)
+ Lam i e -> deleteBy eqEIdent i (freeVars e)
Lit _ -> []
-allVarsExp :: Exp -> [Ident]
+allVarsExp :: Exp -> [EIdent]
allVarsExp ae =
case ae of
Var i -> [i]
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -1,5 +1,5 @@
module MicroHs.Expr(
- Ident, eqIdent, qual, showIdent,
+ Ident(..), unIdent, eqIdent, qual, showIdent,
IdentModule,
EModule(..),
ExportSpec(..),
@@ -42,17 +42,24 @@
| ExpValue Ident
--Xderiving (Show, Eq)
-type Ident = String
+newtype Ident = Ident String
+ --Xderiving (Show, Eq)
type IdentModule = Ident
+unIdent :: Ident -> String
+unIdent (Ident s) = s
+
+eqIdent :: Ident -> Ident -> Bool
+eqIdent (Ident i) (Ident j) = eqString i j
+
qual :: Ident -> Ident -> Ident
-qual qi i = qi ++ "." ++ i
+qual (Ident qi) (Ident i) = Ident (qi ++ "." ++ i)
isConIdent :: Ident -> Bool
-isConIdent i =
+isConIdent (Ident i) =
let
c = head i
- in isUpper c || eqChar c ':' || eqChar c ',' || eqIdent i "[]"
+ in isUpper c || eqChar c ':' || eqChar c ',' || eqString i "[]"
data EDef
= Data LHS [Constr]
@@ -185,22 +192,16 @@
type EKind = EType
-eqIdent :: Ident -> Ident -> Bool
-eqIdent = eqString
-
{-leIdent :: Ident -> Ident -> Bool
leIdent = leString
-}
-showIdent :: Ident -> String
-showIdent i = i
-
tupleConstr :: Int -> Ident
-tupleConstr n = replicate (n - 1) ','
+tupleConstr n = Ident (replicate (n - 1) ',')
untupleConstr :: Ident -> Int
-untupleConstr s = length s + 1
+untupleConstr (Ident s) = length s + 1
---------------------------------
@@ -286,20 +287,23 @@
ExpValue i -> i
-}
+showIdent :: Ident -> String
+showIdent (Ident i) = i
+
showEDef :: EDef -> String
showEDef def =
case def of
Data lhs _ -> "data " ++ showLHS lhs ++ " = ..."
- Newtype lhs c t -> "newtype " ++ showLHS lhs ++ " = " ++ c ++ " " ++ showEType t
+ Newtype lhs c t -> "newtype " ++ showLHS lhs ++ " = " ++ showIdent c ++ " " ++ showEType t
Type lhs t -> "type " ++ showLHS lhs ++ " = " ++ showEType t
- Fcn i eqns -> unlines (map (\ (Eqn ps alts) -> i ++ " " ++ unwords (map showEPat ps) ++ showAlts "=" alts) eqns)
- Sign i t -> i ++ " :: " ++ showETypeScheme t
- Import (ImportSpec q m mm) -> "import " ++ (if q then "qualified " else "") ++ m ++ maybe "" (" as " ++) mm+ Fcn i eqns -> unlines (map (\ (Eqn ps alts) -> showIdent i ++ " " ++ unwords (map showEPat ps) ++ showAlts "=" alts) eqns)
+ Sign i t -> showIdent i ++ " :: " ++ showETypeScheme t
+ Import (ImportSpec q m mm) -> "import " ++ (if q then "qualified " else "") ++ showIdent m ++ maybe "" ((" as " ++) . unIdent) mmshowLHS :: LHS -> String
showLHS lhs =
case lhs of
- (f, vs) -> unwords (f : vs)
+ (f, vs) -> unwords (map unIdent (f : vs))
showEDefs :: [EDef] -> String
showEDefs ds = unlines (map showEDef ds)
@@ -321,12 +325,12 @@
showExpr :: Expr -> String
showExpr ae =
case ae of
---X EVar "Primitives.Char" -> "Char"
---X EVar "Primitives.->" -> "(->)"
---X EApp (EApp (EVar "Primitives.->") a) b -> "(" ++ showExpr a ++ " -> " ++ showExpr b ++ ")"---X EApp (EVar "Data.List.[]") a -> "[" ++ showExpr a ++ "]"
---X EApp (EApp (EVar ",") a) b -> showExpr (ETuple [a,b])
- EVar v -> v
+--X EVar (Ident "Primitives.Char") -> "Char"
+--X EVar (Ident "Primitives.->") -> "(->)"
+--X EApp (EApp (EVar (Ident "Primitives.->")) a) b -> "(" ++ showExpr a ++ " -> " ++ showExpr b ++ ")"+--X EApp (EVar (Ident "Data.List.[]")) a -> "[" ++ showExpr a ++ "]"
+--X EApp (EApp (EVar (Ident ",")) a) b -> showExpr (ETuple [a,b])
+ EVar v -> showIdent v
EApp f a -> "(" ++ showExpr f ++ " " ++ showExpr a ++ ")"ELam ps e -> "(\\" ++ unwords (map showExpr ps) ++ " -> " ++ showExpr e ++ ")"
ELit i -> showLit i
@@ -334,18 +338,18 @@
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)
- ESectL e i -> "(" ++ showExpr e ++ " " ++ i ++ ")"- ESectR i e -> "(" ++ i ++ " " ++ showExpr e ++ ")"+ EDo mn ss -> maybe "do" (\ n -> showIdent n ++ ".do\n") mn ++ unlines (map showEStmt ss)
+ ESectL e i -> "(" ++ showExpr e ++ " " ++ showIdent i ++ ")"+ ESectR i e -> "(" ++ showIdent i ++ " " ++ showExpr e ++ ")"EIf e1 e2 e3 -> "if " ++ showExpr e1 ++ " then " ++ showExpr e2 ++ " else " ++ showExpr e3
ECompr _ _ -> "ECompr"
- EAt i e -> i ++ "@" ++ showExpr e
+ EAt i e -> showIdent i ++ "@" ++ showExpr e
EUVar i -> "a" ++ showInt i
ECon c -> showCon c
showCon :: Con -> String
-showCon (ConData _ s) = s
-showCon (ConNew s) = s
+showCon (ConData _ s) = showIdent s
+showCon (ConNew s) = showIdent s
showCon (ConLit l) = showLit l
--showCon (ConTup n) = "(" ++ tupleConstr n ++ ")"@@ -387,5 +391,5 @@
ETypeScheme vs t ->
if null vs
then showEType t
- else unwords ("forall" : vs ++ [".", showEType t])+ else unwords ("forall" : map unIdent vs ++ [".", showEType t])--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -439,7 +439,7 @@
-------------
-pRightAssoc :: P String -> P Expr -> P Expr
+pRightAssoc :: P Ident -> P Expr -> P Expr
pRightAssoc pOp p = P.do
e1 <- p
let
@@ -450,7 +450,7 @@
pure $ appOp op e1 e2
rest <|< pure e1
-pNonAssoc :: P String -> P Expr -> P Expr
+pNonAssoc :: P Ident -> P Expr -> P Expr
pNonAssoc pOp p = P.do
e1 <- p
let
@@ -461,17 +461,17 @@
pure $ appOp op e1 e2
rest <|< pure e1
-pLeftAssoc :: P String -> P Expr -> P Expr
+pLeftAssoc :: P Ident -> P Expr -> P Expr
pLeftAssoc pOp p = P.do
e1 <- p
es <- emany (pair <$> pOp <*> p)
pure $ foldl (\ x (op, y) -> appOp op x y) e1 es
-pOpers :: [String] -> P String
+pOpers :: [String] -> P Ident
pOpers ops = P.do
op <- pOper
guard (elemBy eqString op ops)
- pure op
+ pure (Ident op)
-------------
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -49,7 +49,7 @@
let
thisMdl = (mn, mkTModule mn tds impossible)
impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ m mm, tm) <- imps]
- impMap = M.fromList (thisMdl : impMdls)
+ impMap = M.fromList [(unIdent i, m) | (i, m) <- (thisMdl : impMdls)]
(texps, sexps, vexps) =
unzip3 $ map (getExps impMap (typeTable tcs) (synTable tcs) (valueTable tcs)) exps
in TModule mn (concat texps) (concat sexps) (concat vexps) tds
@@ -57,7 +57,7 @@
getExps :: forall a . M.Map (TModule a) -> TypeTable -> SynTable -> ValueTable -> ExportSpec ->
([TypeExport], [SynDef], [ValueExport])
getExps impMap _ _ _ (ExpModule m) =
- case M.lookup m impMap of
+ case M.lookup (unIdent m) impMap of
Just (TModule _ te se ve _) -> (te, se, ve)
_ -> expErr m
getExps _ tys _ vals (ExpTypeCon i) =
@@ -69,7 +69,7 @@
let
e = expLookup i tys
qi = tyQIdent e
- se = case M.lookup qi syns of
+ se = case M.lookup (unIdent qi) syns of
Nothing -> []
Just ts -> [(qi, ts)]
in ([TypeExport i e []], se, [])
@@ -78,9 +78,9 @@
expLookup :: Ident -> M.Map [Entry] -> Entry
expLookup i m =
- case M.lookup i m of
+ case M.lookup (unIdent i) m of
Just [e] -> e
- Just _ -> error $ "export ambig " ++ i
+ Just _ -> error $ "export ambig " ++ showIdent i
Nothing -> expErr i
tyQIdent :: Entry -> Ident
@@ -87,9 +87,9 @@
tyQIdent (Entry (EVar qi) _) = qi
tyQIdent _ = undefined
-constrsOf :: Ident -> [(Ident, [Entry])] -> [ValueExport]
+constrsOf :: Ident -> [(String, [Entry])] -> [ValueExport]
constrsOf qi ies =
- [ ValueExport i e | (i, es) <- ies, e@(Entry (ECon _) (ETypeScheme _ t)) <- es, eqIdent (retTyCon t) qi ]
+ [ ValueExport (Ident i) e | (i, es) <- ies, e@(Entry (ECon _) (ETypeScheme _ t)) <- es, eqIdent (retTyCon t) qi ]
retTyCon :: EType -> Ident
retTyCon t =
@@ -102,8 +102,11 @@
getAppCon (EApp f _) = getAppCon f
getAppCon _ = undefined
+eVarI :: String -> Expr
+eVarI = EVar . Ident
+
expErr :: forall a . Ident -> a
-expErr i = error $ "export: " ++ i
+expErr i = error $ "export: " ++ showIdent i
mkTModule :: forall a . IdentModule -> [EDef] -> a -> TModule a
mkTModule mn tds a =
@@ -144,14 +147,14 @@
syms arg =
case arg of
(is, TModule mn tes _ ves _) ->
- [ (v, [e]) | ValueExport i e <- ves, v <- qns is mn i ] ++
- [ (v, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs, v <- qns is mn i ]
+ [ (unIdent v, [e]) | ValueExport i e <- ves, v <- qns is mn i ] ++
+ [ (unIdent v, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs, v <- qns is mn i ]
in M.fromListWith (unionBy eqEntry) $ concatMap syms mdls
allSyns =
let
syns arg =
case arg of
- (_, TModule _ _ ses _ _) -> ses
+ (_, TModule _ _ ses _ _) -> [ (unIdent i, x) | (i, x) <- ses ]
in M.fromList (concatMap syns mdls)
--XallTypes :: TypeTable
allTypes =
@@ -158,7 +161,7 @@
let
types arg =
case arg of
- (is, TModule mn tes _ _ _) -> [ (v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
+ (is, TModule mn tes _ _ _) -> [ (unIdent v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
in M.fromListWith (unionBy eqEntry) $ concatMap types mdls
in (allTypes, allSyns, allValues)
@@ -233,16 +236,16 @@
-- XXX moduleOf is not correct
moduleOf :: Ident -> IdentModule
-moduleOf = reverse . tail . dropWhile (neChar '.') . reverse
+moduleOf = Ident . reverse . tail . dropWhile (neChar '.') . reverse . unIdent
-primTypes :: [(Ident, [Entry])]
+primTypes :: [(String, [Entry])]
primTypes =
let
- entry i = Entry (EVar i)
+ entry i = Entry (EVar (Ident i))
tuple n =
let
i = tupleConstr n
- in (i, [entry i $ ETypeScheme [] $ foldr kArrow kType (replicate n kType)])
+ in (unIdent i, [entry (unIdent i) $ ETypeScheme [] $ foldr kArrow kType (replicate n kType)])
t = ETypeScheme [] kType
tt = ETypeScheme [] $ kArrow kType kType
ttt = ETypeScheme [] $ kArrow kType $ kArrow kType kType
@@ -260,16 +263,16 @@
("Bool", [entry "Data.Bool_Type.Bool" t])] ++map tuple (enumFromTo 2 10)
-primValues :: [(Ident, [Entry])]
+primValues :: [(String, [Entry])]
primValues =
let
tuple n =
let
c = tupleConstr n
- vs = ["a" ++ showInt i | i <- enumFromTo 1 n]
+ vs = [Ident ("a" ++ showInt i) | i <- enumFromTo 1 n]ts = map tVar vs
r = tApps c ts
- in (c, [Entry (ECon $ ConData [(c, n)] c) $ ETypeScheme vs $ foldr tArrow r ts ])
+ in (unIdent c, [Entry (ECon $ ConData [(c, n)] c) $ ETypeScheme vs $ foldr tArrow r ts ])
in map tuple (enumFromTo 2 10)
type T a = TC TCState a
@@ -287,17 +290,17 @@
tApps i ts = foldl tApp (tCon i) ts
tArrow :: EType -> EType -> EType
-tArrow a r = tApp (tApp (tCon "Primitives.->") a) r
+tArrow a r = tApp (tApp (tConI "Primitives.->") a) r
kArrow :: EKind -> EKind -> EKind
kArrow = tArrow
kType :: EKind
-kType = EVar "Type"
+kType = tConI "Type"
getArrow :: EType -> Maybe (EType, EType)
-getArrow (EApp (EApp (EVar n) a) b) =
- if eqIdent n "->" || eqIdent n "Primitives.->" then Just (a, b) else Nothing
+getArrow (EApp (EApp (EVar (Ident n)) a) b) =
+ if eqString n "->" || eqString n "Primitives.->" then Just (a, b) else Nothing
getArrow _ = Nothing
{-@@ -343,7 +346,7 @@
syn (aa:ts) f
EVar i -> T.do
syns <- gets synTable
- case M.lookup i syns of
+ case M.lookup (unIdent i) syns of
Nothing -> T.return $ foldl tApp t ts
Just (ETypeScheme vs tt) ->
if length vs /= length ts then error $ "bad syn app: " --X ++ show (i, vs, ts)
@@ -431,8 +434,8 @@
tLookup :: String -> Ident -> T (Expr, ETypeScheme)
tLookup msg i = T.do
env <- gets valueTable
- case M.lookup i env of
- Nothing -> error $ "undefined, " ++ msg ++ ": " ++ i -- ++ "\n" ++ show env ;
+ case M.lookup (unIdent i) env of
+ Nothing -> error $ "undefined, " ++ msg ++ ": " ++ showIdent i -- ++ "\n" ++ show env ;
Just aes ->
case aes of
[] -> impossible
@@ -457,7 +460,7 @@
Ident -> ETypeScheme -> Expr -> T ()
extValE i t e = T.do
venv <- gets valueTable
- putValueTable (M.insert i [Entry e t] venv)
+ putValueTable (M.insert (unIdent i) [Entry e t] venv)
extQVal :: --XHasCallStack =>
Ident -> ETypeScheme -> T ()
@@ -476,7 +479,7 @@
extTyp :: Ident -> ETypeScheme -> T ()
extTyp i t = T.do
tenv <- gets typeTable
- putTypeTable (M.insert i [Entry (EVar i) t] tenv)
+ putTypeTable (M.insert (unIdent i) [Entry (EVar i) t] tenv)
extTyps :: [(Ident, ETypeScheme)] -> T ()
extTyps = T.mapM_ (uncurry extTyp)
@@ -484,7 +487,7 @@
extSyn :: Ident -> ETypeScheme -> T ()
extSyn i t = T.do
senv <- gets synTable
- putSynTable (M.insert i t senv)
+ putSynTable (M.insert (unIdent i) t senv)
withExtVal :: forall a . --XHasCallStack =>
Ident -> ETypeScheme -> T a -> T a
@@ -671,7 +674,7 @@
[] -> newUVar
t : _ -> T.return t
let
- tlist = tApps "Data.List.[]" [te]
+ tlist = tApps (Ident "Data.List.[]") [te]
munify mt tlist
T.return (EList ees, tlist)
EDo mmn ass -> T.do
@@ -683,7 +686,7 @@
SThen a -> T.do
(ea, ta) <- tcExpr mt a
let
- sbind = maybe ">>=" (\ mn -> qual mn ">>=") mmn
+ sbind = maybe (Ident ">>=") (\ mn -> qual mn (Ident ">>=")) mmn
(EVar qi, _) <- tLookupInst "variable" sbind
let
mn = moduleOf qi
@@ -694,15 +697,15 @@
case as of
SBind p a -> T.do
let
- sbind = maybe ">>=" (\ mn -> qual mn ">>=") mmn
+ sbind = maybe (Ident ">>=") (\ mn -> qual mn (Ident ">>=")) mmn
(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, EAlts [([], EDo mmn ss)] [])])))
+ (ELam [eVarI "$x"] (ECase (eVarI "$x") [(p, EAlts [([], EDo mmn ss)] [])])))
T.return (EDo mn (SBind ep ea : ys), tr)
SThen a -> T.do
let
- sthen = maybe ">>" (\ mn -> qual mn ">>" ) mmn
+ sthen = maybe (Ident ">>") (\ mn -> qual mn (Ident ">>") ) mmn
(EApp (EApp _ ea) (EDo mn ys), tr) <-
tcExpr Nothing (EApp (EApp (EVar sthen) a) (EDo mmn ss))
T.return (EDo mn (SThen ea : ys), tr)
@@ -716,7 +719,7 @@
(EApp (EVar ii) ee, t) <- tcExpr mt (EApp (EVar i) e)
T.return (ESectL ee ii, t)
ESectR i e -> T.do
- (ELam _ (EApp (EApp var _) ee), t) <- tcExpr mt (ELam [EVar "$x"] (EApp (EApp (EVar i) (EVar "$x")) e))
+ (ELam _ (EApp (EApp var _) ee), t) <- tcExpr mt (ELam [eVarI "$x"] (EApp (EApp (EVar i) (eVarI "$x")) e))
T.return (ESectR (getIdent var) ee, t)
EIf e1 e2 e3 -> T.do
(ee1, _) <- tcExpr (Just tBool) e1
@@ -763,9 +766,9 @@
tcLit mt l =
let { lit t = T.do { munify mt t; T.return (ELit l, t) } } incase l of
- LInt _ -> lit (tCon "Primitives.Int")
- LChar _ -> lit (tCon "Primitives.Char")
- LStr _ -> lit (tApps "Data.List.[]" [tCon "Primitives.Char"])
+ LInt _ -> lit (tConI "Primitives.Int")
+ LChar _ -> lit (tConI "Primitives.Char")
+ LStr _ -> lit (tApps (Ident "Data.List.[]") [tConI "Primitives.Char"])
LPrim _ -> T.do
t <- unMType mt -- pretend it is anything
T.return (ELit l, t)
@@ -887,13 +890,16 @@
_ -> impossible
listConstr :: Ident
-listConstr = "[]"
+listConstr = Ident "[]"
+tConI :: String -> EType
+tConI = tCon . Ident
+
tList :: EType
-tList = tCon "Data.List.[]"
+tList = tConI "Data.List.[]"
tBool :: EType
-tBool = tCon "Data.Bool_Type.Bool"
+tBool = tConI "Data.Bool_Type.Bool"
impossible :: --XHasCallStack =>
forall a . a
@@ -902,7 +908,7 @@
showTModule :: forall a . (a -> String) -> TModule a -> String
showTModule sh amdl =
case amdl of
- TModule mn _ _ _ a -> "Tmodule " ++ mn ++ "\n" ++ sh a
+ TModule mn _ _ _ a -> "Tmodule " ++ showIdent mn ++ "\n" ++ sh a
isUnderscore :: Ident -> Bool
-isUnderscore = eqIdent "_"
+isUnderscore = eqString "_" . unIdent
--
⑨