ref: 41eca634788b43a01fa0b2690516fc38e7e86743
parent: 7a26d7ddf4fedc63aea0b0da9986485321f16809
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Wed Aug 30 11:00:39 EDT 2023
Avoid direct use of Ident constructor.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.2
-731
-(($A :0 ((_541 _495) ((($S' ($C ((($C' ($S' _541)) (($B ($C _2)) _417)) (($B ($B (_541 _569))) ((($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')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _542)) ((($C' $B) (($B _630) (($B _559) ((($C' _668) _8) 0)))) (($B (_630 _562)) (($B (_575 "top level defns: ")) _523)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _542)) ((($C' $B) (($B _630) (($B _559) ((($C' _668) _8) 1)))) (_558 ($T (($B ($B (_630 _562))) ((($C' $B) (($B _575) _478)) (($B (_575 " = ")) _389))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _542))) ((($C' $B) ($B' (($B _630) (($B _564) _11)))) (($B ($B (_575 _1))) (($B (($C' _575) _523)) (_575 (($O 10) $K))))))) (($B ($B (_541 _569))) ((($C' $B) ($B' (($B _630) (($B _559) ((($C' _668) _8) 0))))) (($B ($B (_630 _562))) (($B ($B (_575 "final pass "))) ((($C' ($C' _575)) (($B ($B (_536 6))) (($B ($B _523)) _662))) "ms")))))))) _3)))) _520))) (($B (($C' $C) (($B ($C _580)) _389))) (($C _593) (_610 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_575 "(($A :"))))) (($B ($B (($C' $B) (($B _575) _523)))) (($B ($B ($B (_575 (($O 32) $K))))) ((($C' $B) (($B ($C' _575)) ($B _389))) (($B (_575 ") ")) (($C _575) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _366)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _630) (($B _627) (($B (_630 _677)) (($B (_575 "main: findIdent: ")) _478))))) (($C' _513) _418)))) (($B ($B _517)) (($B (($C' _577) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _418))) $K)))))) (($C _593) (_610 0)))))) (($B (_630 _365)) (($B (_630 _417)) (($B (_575 (($O 95) $K))) _523)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _592) (_579 (_534 "-v")))) ((_609 _534) "-r"))) (($B (_573 (($O 46) $K))) (($B _629) (_578 ((_597 _653) "-i")))))) (($B (_630 _604)) ((($C' _575) (($B _629) (_578 ((_597 _653) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _664) _592) 1)) (_677 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _604)) (_579 ((_631 _673) ((_631 (_534 (($O 45) $K))) (_590 1)))))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _541)) _16) (($B ($B ($B (_541 _569)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _542) (($B (_630 _560)) (($B (_630 (_591 1000000))) _190)))))) (($B ($B ($B ($B (_541 _569))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _542))) ((($C' $B) ($B' (($B _630) (($B _559) ((($C' _668) _8) 0))))) (($B ($B (_630 _562))) (($B ($B (_575 "combinator conversion "))) ((($C' ($C' _575)) (($B ($B (_536 6))) (($B ($B _523)) _662))) "ms"))))))) (($B ($B _543)) (($B $P) (($C _420) (_417 "main")))))))) (_577 ($T ((($C' ($C' $O)) ((($C' $B) $P) _392)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_630 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _359))) (($C' ($C' _577)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _630) (($B _627) (($B (_630 _677)) (($B (_575 "not found ")) _478))))) ($C _360))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _391))) (($B (_630 (_627 (_677 "primlookup")))) (($C (_613 _534)) _5))))) (_677 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($O (($P (($O 73) $K)) $I)) (($O (($P (($O 83) $K)) $S)) (($O (($P (($O 84) $K)) $T)) (($O (($P (($O 89) $K)) $Y)) (($O (($P "B'") $B')) (($O (($P "BK") $BK)) (($O
\ No newline at end of file
+732
+(($A :0 ((_542 _496) ((($S' ($C ((($C' ($S' _542)) (($B ($C _2)) _418)) (($B ($B (_542 _570))) ((($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')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _543)) ((($C' $B) (($B _631) (($B _560) ((($C' _669) _8) 0)))) (($B (_631 _563)) (($B (_576 "top level defns: ")) _524)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _543)) ((($C' $B) (($B _631) (($B _560) ((($C' _669) _8) 1)))) (_559 ($T (($B ($B (_631 _563))) ((($C' $B) (($B _576) _479)) (($B (_576 " = ")) _389))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _543))) ((($C' $B) ($B' (($B _631) (($B _565) _11)))) (($B ($B (_576 _1))) (($B (($C' _576) _524)) (_576 (($O 10) $K))))))) (($B ($B (_542 _570))) ((($C' $B) ($B' (($B _631) (($B _560) ((($C' _669) _8) 0))))) (($B ($B (_631 _563))) (($B ($B (_576 "final pass "))) ((($C' ($C' _576)) (($B ($B (_537 6))) (($B ($B _524)) _663))) "ms")))))))) _3)))) _521))) (($B (($C' $C) (($B ($C _581)) _389))) (($C _594) (_611 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_576 "(($A :"))))) (($B ($B (($C' $B) (($B _576) _524)))) (($B ($B ($B (_576 (($O 32) $K))))) ((($C' $B) (($B ($C' _576)) ($B _389))) (($B (_576 ") ")) (($C _576) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _366)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _631) (($B _628) (($B (_631 _678)) (($B (_576 "main: findIdent: ")) _479))))) (($C' _514) _419)))) (($B ($B _518)) (($B (($C' _578) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _419))) $K)))))) (($C _594) (_611 0)))))) (($B (_631 _365)) (($B (_631 _418)) (($B (_576 (($O 95) $K))) _524)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _593) (_580 (_535 "-v")))) ((_610 _535) "-r"))) (($B (_574 (($O 46) $K))) (($B _630) (_579 ((_598 _654) "-i")))))) (($B (_631 _605)) ((($C' _576) (($B _630) (_579 ((_598 _654) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _665) _593) 1)) (_678 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _605)) (_580 ((_632 _674) ((_632 (_535 (($O 45) $K))) (_591 1)))))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _542)) _16) (($B ($B ($B (_542 _570)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _543) (($B (_631 _561)) (($B (_631 (_592 1000000))) _190)))))) (($B ($B ($B ($B (_542 _570))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _543))) ((($C' $B) ($B' (($B _631) (($B _560) ((($C' _669) _8) 0))))) (($B ($B (_631 _563))) (($B ($B (_576 "combinator conversion "))) ((($C' ($C' _576)) (($B ($B (_537 6))) (($B ($B _524)) _663))) "ms"))))))) (($B ($B _544)) (($B $P) (($C _421) (_418 "main")))))))) (_578 ($T ((($C' ($C' $O)) ((($C' $B) $P) _392)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_631 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _359))) (($C' ($C' _578)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _631) (($B _628) (($B (_631 _678)) (($B (_576 "not found ")) _479))))) ($C _360))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _391))) (($B (_631 (_628 (_678 "primlookup")))) (($C (_614 _535)) _5))))) (_678 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($O (($P (($O 73) $K)) $I)) (($O (($P (($O 83) $K)) $S)) (($O (($P (($O 84) $K)) $T)) (($O (($P (($O 89) $K)) $Y)) (($O (($P "B'") $B')) (($O (($P "BK") $BK)) (($O
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -32,11 +32,11 @@
case adef of
Data _ cs ->
let
- f i = Ident ("$f" ++ showInt i)+ f i = mkIdent ("$f" ++ showInt i)fs = [f i | (i, _) <- zip (enumFrom 0) cs]
dsConstr i (c, ts) =
let
- xs = [Ident ("$x" ++ showInt j) | (j, _) <- zip (enumFrom 0) ts]+ xs = [mkIdent ("$x" ++ showInt j) | (j, _) <- zip (enumFrom 0) ts]in (qual mn c, lams xs $ lams fs $ apps (Var (f i)) (map Var xs))
in zipWith dsConstr (enumFrom 0) cs
Newtype _ c _ -> [ (qual mn c, Lit (LPrim "I")) ]
@@ -64,7 +64,7 @@
case eqns of
Eqn aps _ : _ ->
let
- vs = allVarsBind $ BFcn (Ident "") eqns
+ vs = allVarsBind $ BFcn (mkIdent "") eqns
xs = take (length aps) $ newVars vs
ex = runS (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts alts, hasGuards alts) | Eqn ps alts <- eqns]
in foldr Lam ex xs
@@ -89,7 +89,7 @@
dsAlt :: Expr -> [EStmt] -> Expr -> Expr
dsAlt _ [] rhs = rhs
dsAlt dflt (SBind p e : ss) rhs = ECase e [(p, EAlts [(ss, rhs)] []), (EVar dummyIdent, oneAlt dflt)]
-dsAlt dflt (SThen (EVar i) : ss) rhs | eqIdent i (Ident "Data.Bool.otherwise") = dsAlt dflt ss rhs
+dsAlt dflt (SThen (EVar i) : ss) rhs | eqIdent i (mkIdent "Data.Bool.otherwise") = dsAlt dflt ss rhs
dsAlt dflt (SThen e : ss) rhs = EIf e (dsAlt dflt ss rhs) dflt
dsAlt dflt (SLet bs : ss) rhs = ELet bs (dsAlt dflt ss rhs)
@@ -119,7 +119,7 @@
-- For now, just sequential bindings; each recursive
ELet ads e -> dsBinds ads (dsExpr e)
EList es -> foldr (app2 cCons) cNil $ map dsExpr es
- ETuple es -> Lam (Ident "$f") $ foldl App (Var $ Ident "$f") $ map dsExpr es
+ ETuple es -> Lam (mkIdent "$f") $ foldl App (Var $ mkIdent "$f") $ map dsExpr es
EDo mn astmts ->
case astmts of
[] -> error "empty do"
@@ -129,12 +129,12 @@
if null stmts then error "do without final expression"
else
-- case p of
--- EVar v -> dsExpr $ EApp (EApp (EVar (mqual mn (Ident ">>="))) e) (ELam [v] $ EDo mn stmts)
+-- EVar v -> dsExpr $ EApp (EApp (EVar (mqual mn (mkIdent ">>="))) e) (ELam [v] $ EDo mn stmts)
-- _ ->
let
nv = newVar (allVarsExpr aexpr)
body = ECase (EVar nv) [(p, oneAlt $ EDo mn stmts), (EVar dummyIdent, oneAlt $ eError "dopat")]
- res = dsExpr $ EApp (EApp (EVar (mqual mn (Ident ">>="))) e) (ELam [EVar nv] body)
+ res = dsExpr $ EApp (EApp (EVar (mqual mn (mkIdent ">>="))) e) (ELam [EVar nv] body)
in res
SThen e ->
@@ -141,7 +141,7 @@
if null stmts then
dsExpr e
else
- dsExpr $ EApp (EApp (EVar (mqual mn (Ident ">>"))) e) (EDo mn stmts)
+ dsExpr $ EApp (EApp (EVar (mqual mn (mkIdent ">>"))) e) (EDo mn stmts)
SLet ds ->
if null stmts then error "do without final expression" else
dsExpr $ ELet ds (EDo mn stmts)
@@ -161,7 +161,7 @@
let
nv = newVar (allVarsExpr aexpr)
body = ECase (EVar nv) [(p, oneAlt $ ECompr e stmts), (EVar dummyIdent, oneAlt $ EList [])]
- in app2 (Var (Ident "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 (ECompr e stmts) (EList []))
SLet ds ->
@@ -174,8 +174,8 @@
in
if eqChar (head $ unIdent ci) ',' then
let
- xs = [Ident ("x" ++ showInt i) | i <- enumFromTo 1 (untupleConstr ci) ]- body = Lam (Ident "$f") $ foldl App (Var (Ident "$f")) $ map Var xs
+ xs = [mkIdent ("x" ++ showInt i) | i <- enumFromTo 1 (untupleConstr ci) ]+ body = Lam (mkIdent "$f") $ foldl App (Var (mkIdent "$f")) $ map Var xs
in foldr Lam body xs
else
Var (conIdent c)
@@ -211,15 +211,15 @@
consCon :: EPat
consCon =
let
- n = Ident "Data.List.[]"
- c = Ident "Data.List.:"
+ n = mkIdent "Data.List.[]"
+ c = mkIdent "Data.List.:"
in ECon $ ConData [(n, 0), (c, 2)] c
nilCon :: EPat
nilCon =
let
- n = Ident "Data.List.[]"
- c = Ident "Data.List.:"
+ n = mkIdent "Data.List.[]"
+ c = mkIdent "Data.List.:"
in ECon $ ConData [(n, 0), (c, 2)] n
tupleCon :: Int -> EPat
@@ -229,7 +229,7 @@
in ECon $ ConData [(c, n)] c
dummyIdent :: Ident
-dummyIdent = Ident "_"
+dummyIdent = mkIdent "_"
eError :: String -> Expr
eError s = EApp (ELit (LPrim "error")) (ELit $ LStr s)
@@ -241,7 +241,7 @@
apps f = foldl App f
newVars :: [Ident] -> [Ident]
-newVars is = deleteFirstsBy eqIdent [ Ident ("q" ++ showInt i) | i <- enumFrom 1 ] is+newVars is = deleteFirstsBy eqIdent [ mkIdent ("q" ++ showInt i) | i <- enumFrom 1 ] isnewVar :: [Ident] -> Ident
newVar = head . newVars
@@ -285,7 +285,7 @@
runS used ss mtrx =
--trace ("runS " ++ show (ss, mtrx)) $let
- supply = deleteFirstsBy eqIdent [ Ident ("x" ++ showInt i) | i <- enumFrom 1 ] used+ supply = deleteFirstsBy eqIdent [ mkIdent ("x" ++ showInt i) | i <- enumFrom 1 ] used-- ds :: [Exp] -> [Exp] -> M Exp
ds xs aes =
case aes of
@@ -369,13 +369,13 @@
-- Could use Prim "==", but that misses out some optimizations
eEqInt :: Exp
-eEqInt = Var $ Ident "Data.Int.=="
+eEqInt = Var $ mkIdent "Data.Int.=="
eEqChar :: Exp
-eEqChar = Var $ Ident "Data.Char.eqChar"
+eEqChar = Var $ mkIdent "Data.Char.eqChar"
eEqStr :: Exp
-eEqStr = Var $ Ident "Text.String.eqString"
+eEqStr = Var $ mkIdent "Text.String.eqString"
mkCase :: Exp -> [(SPat, Exp)] -> Exp -> Exp
mkCase var pes dflt =
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -318,15 +318,15 @@
-- This is a hack, it assumes things about the Prelude
flipOps :: [(Ident, Ident)]
flipOps =
- [(Ident "Data.Int.+", Ident "Data.Int.+")
- ,(Ident "Data.Int.-", Ident "Data.Int.subtract")
- ,(Ident "Data.Int.*", Ident "Data.Int.*")
- ,(Ident "Data.Int.==", Ident "Data.Int.==")
- ,(Ident "Data.Int./=", Ident "Data.Int./=")
- ,(Ident "Data.Int.<", Ident "Data.Int.>")
- ,(Ident "Data.Int.<=", Ident "Data.Int.>=")
- ,(Ident "Data.Int.>", Ident "Data.Int.<")
- ,(Ident "Data.Int.>=", Ident "Data.Int.<=")
+ [(mkIdent "Data.Int.+", mkIdent "Data.Int.+")
+ ,(mkIdent "Data.Int.-", mkIdent "Data.Int.subtract")
+ ,(mkIdent "Data.Int.*", mkIdent "Data.Int.*")
+ ,(mkIdent "Data.Int.==", mkIdent "Data.Int.==")
+ ,(mkIdent "Data.Int./=", mkIdent "Data.Int./=")
+ ,(mkIdent "Data.Int.<", mkIdent "Data.Int.>")
+ ,(mkIdent "Data.Int.<=", mkIdent "Data.Int.>=")
+ ,(mkIdent "Data.Int.>", mkIdent "Data.Int.<")
+ ,(mkIdent "Data.Int.>=", mkIdent "Data.Int.<=")
]
improveT :: Exp -> Exp
@@ -409,7 +409,7 @@
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 = Ident ("a" ++ showInt n) }, not (elemBy eqIdent v ase), not (elemBy eqIdent v fe) ]+ head [ v | n <- enumFrom 0, let { v = mkIdent ("a" ++ showInt n) }, not (elemBy eqIdent v ase), not (elemBy eqIdent v fe) ]in
--trace ("substExp " ++ unwords [si, i, j]) $Lam j (substExp si se (substExp i (Var j) e))
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -1,5 +1,5 @@
module MicroHs.Expr(
- Ident(..), unIdent, eqIdent, qual, showIdent,
+ Ident, mkIdent, unIdent, eqIdent, qual, showIdent,
IdentModule,
EModule(..),
ExportSpec(..),
@@ -45,6 +45,9 @@
newtype Ident = Ident String
--Xderiving (Show, Eq)
type IdentModule = Ident
+
+mkIdent :: String -> Ident
+mkIdent = Ident
unIdent :: Ident -> String
unIdent (Ident s) = s
--- a/src/MicroHs/IdentMap.hs
+++ b/src/MicroHs/IdentMap.hs
@@ -8,7 +8,6 @@
toList, elems
) where
import Prelude --Xhiding(lookup)
---Ximport Compat
import MicroHs.Expr --X(Ident, eqIdent)
{---- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -25,11 +25,11 @@
(elemBy eqString "-r" args)
("." : catMaybes (map (stripPrefixBy eqChar "-i") args))(head $ catMaybes (map (stripPrefixBy eqChar "-o") args) ++ ["out.comb"])
- cmdl <- compileTop flags (Ident mn)
+ cmdl <- compileTop flags (mkIdent mn)
t1 <- getTimeMilli
let
(mainName, ds) = cmdl
- ref i = Var $ Ident $ "_" ++ showInt i
+ ref i = Var $ mkIdent $ "_" ++ showInt i
defs = M.fromList [ (unIdent n, ref i) | ((n, _), i) <- zip ds (enumFrom 0) ]
findIdent n = fromMaybe (error $ "main: findIdent: " ++ showIdent n) $
M.lookup (unIdent n) defs
@@ -77,4 +77,4 @@
t2 <- getTimeMilli
when (verbose flags > 0) $
putStrLn $ "combinator conversion " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
- return (qual mn (Ident "main"), dsn)
+ return (qual mn (mkIdent "main"), dsn)
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -46,7 +46,7 @@
pUIdentA :: P Ident
pUIdentA = satisfyM "UIdent" is
where
- is (TIdent _ [] s) | isUpper (head s) = Just (Ident s)
+ is (TIdent _ [] s) | isUpper (head s) = Just (mkIdent s)
is _ = Nothing
pUIdent :: P Ident
@@ -59,9 +59,9 @@
pUIdentSpecial :: P Ident
pUIdentSpecial =
- (Ident . map (const ',') <$> (pSpec '(' *> some (pSpec ',') <* pSpec ')'))- <|> (Ident "()" <$ (pSpec '(' *> pSpec ')')) -- Allow () as a constructor name- <|> (Ident "[]" <$ (pSpec '[' *> pSpec ']')) -- Allow [] as a constructor name
+ (mkIdent . map (const ',') <$> (pSpec '(' *> some (pSpec ',') <* pSpec ')'))+ <|> (mkIdent "()" <$ (pSpec '(' *> pSpec ')')) -- Allow () as a constructor name+ <|> (mkIdent "[]" <$ (pSpec '[' *> pSpec ']')) -- Allow [] as a constructor name
pUQIdentA :: P Ident
pUQIdentA = satisfyM "UQIdent" is
@@ -77,7 +77,7 @@
pLIdent :: P Ident
pLIdent = satisfyM "LIdent" is
where
- is (TIdent _ [] s) | isLower_ (head s) && not (elemBy eqString s keywords) = Just (Ident s)
+ is (TIdent _ [] s) | isLower_ (head s) && not (elemBy eqString s keywords) = Just (mkIdent s)
is _ = Nothing
pLQIdent :: P Ident
@@ -114,7 +114,7 @@
pSymOper :: P Ident
pSymOper = satisfyM "SymOper" is
where
- is (TIdent _ [] s) | not (isAlpha_ (head s)) && not (elemBy eqString s reservedOps) = Just (Ident s)
+ is (TIdent _ [] s) | not (isAlpha_ (head s)) && not (elemBy eqString s reservedOps) = Just (mkIdent s)
is _ = Nothing
pUQSymOper :: P Ident
@@ -398,7 +398,7 @@
pQualDo :: P Ident
pQualDo = satisfyM "QualDo" is
where
- is (TIdent _ qs@(_:_) "do") = Just (Ident (intercalate "." qs))
+ is (TIdent _ qs@(_:_) "do") = Just (mkIdent (intercalate "." qs))
is _ = Nothing
pAExpr :: P Expr
@@ -472,8 +472,8 @@
pOpers :: [String] -> P Ident
pOpers ops = P.do
- op@(Ident s) <- pOper
- guard (elemBy eqString s ops)
+ op <- pOper
+ guard (elemBy eqString (unIdent op) ops)
pure op
-------------
@@ -490,7 +490,7 @@
isAlpha_ c = isLower_ c || isUpper c
qualName :: [String] -> String -> Ident
-qualName qs s = Ident (intercalate "." (qs ++ [s]))
+qualName qs s = mkIdent (intercalate "." (qs ++ [s]))
-------------
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -103,7 +103,7 @@
getAppCon _ = undefined
eVarI :: String -> Expr
-eVarI = EVar . Ident
+eVarI = EVar . mkIdent
expErr :: forall a . Ident -> a
expErr i = error $ "export: " ++ showIdent i
@@ -236,12 +236,12 @@
-- XXX moduleOf is not correct
moduleOf :: Ident -> IdentModule
-moduleOf = Ident . reverse . tail . dropWhile (neChar '.') . reverse . unIdent
+moduleOf = mkIdent . reverse . tail . dropWhile (neChar '.') . reverse . unIdent
primTypes :: [(Ident, [Entry])]
primTypes =
let
- entry i = Entry (EVar (Ident i))
+ entry i = Entry (EVar (mkIdent i))
tuple n =
let
i = tupleConstr n
@@ -250,17 +250,17 @@
tt = ETypeScheme [] $ kArrow kType kType
ttt = ETypeScheme [] $ kArrow kType $ kArrow kType kType
in
- [(Ident "IO", [entry "Primitives.IO" tt]),
- (Ident "->", [entry "Primitives.->" ttt]),
- (Ident "Int", [entry "Primitives.Int" t]),
- (Ident "Word", [entry "Primitives.Word" t]),
- (Ident "Char", [entry "Primitives.Char" t]),
- (Ident "Handle", [entry "Primitives.Handle" t]),
- (Ident "Any", [entry "Primitives.Any" t]),
- (Ident "String", [entry "Data.Char.String" t]),
- (Ident "[]", [entry "Data.List.[]" tt]),
- (Ident "()", [entry "Data.Tuple.()" t]),
- (Ident "Bool", [entry "Data.Bool_Type.Bool" t])] ++
+ [(mkIdent "IO", [entry "Primitives.IO" tt]),
+ (mkIdent "->", [entry "Primitives.->" ttt]),
+ (mkIdent "Int", [entry "Primitives.Int" t]),
+ (mkIdent "Word", [entry "Primitives.Word" t]),
+ (mkIdent "Char", [entry "Primitives.Char" t]),
+ (mkIdent "Handle", [entry "Primitives.Handle" t]),
+ (mkIdent "Any", [entry "Primitives.Any" t]),
+ (mkIdent "String", [entry "Data.Char.String" t]),
+ (mkIdent "[]", [entry "Data.List.[]" tt]),
+ (mkIdent "()", [entry "Data.Tuple.()" t]),
+ (mkIdent "Bool", [entry "Data.Bool_Type.Bool" t])] ++
map tuple (enumFromTo 2 10)
primValues :: [(Ident, [Entry])]
@@ -269,7 +269,7 @@
tuple n =
let
c = tupleConstr n
- vs = [Ident ("a" ++ showInt i) | i <- enumFromTo 1 n]+ vs = [mkIdent ("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 ])
@@ -299,8 +299,8 @@
kType = tConI "Type"
getArrow :: EType -> Maybe (EType, EType)
-getArrow (EApp (EApp (EVar (Ident n)) a) b) =
- if eqString n "->" || eqString n "Primitives.->" then Just (a, b) else Nothing
+getArrow (EApp (EApp (EVar n) a) b) =
+ if eqIdent n (mkIdent "->") || eqIdent n (mkIdent "Primitives.->") then Just (a, b) else Nothing
getArrow _ = Nothing
{-@@ -674,7 +674,7 @@
[] -> newUVar
t : _ -> T.return t
let
- tlist = tApps (Ident "Data.List.[]") [te]
+ tlist = tApps (mkIdent "Data.List.[]") [te]
munify mt tlist
T.return (EList ees, tlist)
EDo mmn ass -> T.do
@@ -686,7 +686,7 @@
SThen a -> T.do
(ea, ta) <- tcExpr mt a
let
- sbind = maybe (Ident ">>=") (\ mn -> qual mn (Ident ">>=")) mmn
+ sbind = maybe (mkIdent ">>=") (\ mn -> qual mn (mkIdent ">>=")) mmn
(EVar qi, _) <- tLookupInst "variable" sbind
let
mn = moduleOf qi
@@ -697,7 +697,7 @@
case as of
SBind p a -> T.do
let
- sbind = maybe (Ident ">>=") (\ mn -> qual mn (Ident ">>=")) mmn
+ sbind = maybe (mkIdent ">>=") (\ mn -> qual mn (mkIdent ">>=")) mmn
(EApp (EApp _ ea) (ELam _ (ECase _ ((ep, EAlts [(_, EDo mn ys)] _): _)))
, tr) <-
tcExpr Nothing (EApp (EApp (EVar sbind) a)
@@ -705,7 +705,7 @@
T.return (EDo mn (SBind ep ea : ys), tr)
SThen a -> T.do
let
- sthen = maybe (Ident ">>") (\ mn -> qual mn (Ident ">>") ) mmn
+ sthen = maybe (mkIdent ">>") (\ mn -> qual mn (mkIdent ">>") ) 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)
@@ -768,7 +768,7 @@
case l of
LInt _ -> lit (tConI "Primitives.Int")
LChar _ -> lit (tConI "Primitives.Char")
- LStr _ -> lit (tApps (Ident "Data.List.[]") [tConI "Primitives.Char"])
+ LStr _ -> lit (tApps (mkIdent "Data.List.[]") [tConI "Primitives.Char"])
LPrim _ -> T.do
t <- unMType mt -- pretend it is anything
T.return (ELit l, t)
@@ -890,10 +890,10 @@
_ -> impossible
listConstr :: Ident
-listConstr = Ident "[]"
+listConstr = mkIdent "[]"
tConI :: String -> EType
-tConI = tCon . Ident
+tConI = tCon . mkIdent
tList :: EType
tList = tConI "Data.List.[]"
--
⑨