ref: 7a26d7ddf4fedc63aea0b0da9986485321f16809
parent: 9209004fb786c313a4112b524d23d0a3109fef44
author: Lennart Augustsson <lennart@augustsson.net>
date: Wed Aug 30 08:49:14 EDT 2023
Change StringMap to IdentMap
--- a/Makefile
+++ b/Makefile
@@ -60,7 +60,7 @@
$(GHCC) -c src/MicroHs/Expr.hs
$(GHCC) -c src/MicroHs/Lex.hs
$(GHCC) -c src/MicroHs/Parse.hs
- $(GHCC) -c src/MicroHs/StringMap.hs
+ $(GHCC) -c src/MicroHs/IdentMap.hs
$(GHCC) -c src/MicroHs/StringMapFast.hs
# $(GHCC) -c -package containers -package base src/MicroHs/StringMap.hs
$(GHCC) -c src/MicroHs/Exp.hs
--- a/TODO
+++ b/TODO
@@ -8,6 +8,7 @@
* Add location to Ident
- with file name
* Prettier printing of types
+ - unqualIdent
* Report location in type errors
* Special noMatch function with location
* Add overloading
@@ -17,5 +18,15 @@
* Add [x..y] syntax
* 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
+ - Use filename as the cache lookup key and SHA for validation
+* use 'data = primitive "Int"' for primitive types.
+* make an interactive version
+ - implement a simple readline
+ - implement catch (and maybe throw)
+ - make the runtime system catch ^C and stop execution
+* implement low level equality
+ - maybe?
+ - could be used instead of derived when all is derived
+* use pointer stack during GC instead of recursion.
+* add Double primitive type
+* implement Data.Integer
--- 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) (($B $P) _418)))) ($B _4))) $K))))))) (($B (($S' _630) (($B _627) (($B (_630 _677)) (($B (_575 "not found ")) _478))))) (($C' _360) _418))))) (($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 (
\ No newline at end of file
+(($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
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -10,7 +10,7 @@
--Ximport qualified CompatIO as IO
--Ximport System.IO(Handle)
-import qualified MicroHs.StringMap as M
+import qualified MicroHs.IdentMap as M
import MicroHs.StateIO as S
import MicroHs.Desugar
import MicroHs.Expr
@@ -72,7 +72,7 @@
compileModuleCached :: Flags -> IdentModule -> StateIO Cache (CModule, Time)
compileModuleCached flags nm = S.do
ch <- gets cache
- case M.lookup (unIdent nm) ch of
+ case M.lookup nm ch of
Nothing -> S.do
ws <- gets working
S.when (elemBy eqIdent nm ws) $
@@ -84,7 +84,7 @@
S.when (verbose flags > 0) $
liftIO $ putStrLn $ "importing done " ++ showIdent nm ++ ", " ++ showInt (tp + tt) ++ "ms (" ++ showInt tp ++ " + " ++ showInt tt ++ ")"c <- get
- put $ Cache (tail (working c)) (M.insert (unIdent nm) cm (cache c))
+ put $ Cache (tail (working c)) (M.insert nm cm (cache c))
S.return (cm, tp + tt + ts)
Just cm -> S.do
S.when (verbose flags > 0) $
--- /dev/null
+++ b/src/MicroHs/IdentMap.hs
@@ -1,0 +1,114 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+module MicroHs.IdentMap(
+ Map,
+ size,
+ empty, insert, lookup,
+ fromList, fromListWith,
+ toList, elems
+ ) where
+import Prelude --Xhiding(lookup)
+--Ximport Compat
+import MicroHs.Expr --X(Ident, eqIdent)
+
+{-+import qualified Data.Map as M
+import qualified GHC.Maybe
+
+type Map v = M.Map Ident v
+
+insert = M.insert
+
+fromListWith = M.fromListWith
+
+fromList = M.fromList
+
+--union = M.union
+
+lookup k m =
+ case M.lookup k m of
+ GHC.Maybe.Nothing -> Nothing
+ GHC.Maybe.Just v -> Just v
+
+empty = M.empty
+
+elems = M.elems
+-}
+
+-- This is a pretty bad implementation.
+data Map v = Map [(Ident, v)]
+ --Xderiving(Show)
+
+insert k v (Map kvs) = Map ((k, v):kvs)
+
+fromListWith un =
+ let
+ ins ikv akvs =
+ case akvs of
+ [] -> [ikv]
+ kv : kvs ->
+ case ikv of
+ (ik, iv) ->
+ case kv of
+ (k, v) ->
+ if eqIdent ik k then
+ (k, un iv v) : kvs
+ else
+ kv : ins ikv kvs
+ in
+ Map . foldr ins []
+
+fromList = Map
+
+{-+union akvs1 akvs2 =
+ case akvs1 of
+ Map kvs1 ->
+ case akvs2 of
+ Map kvs2 -> Map (kvs1 ++ kvs2)
+-}
+
+lookup ak (Map m) =
+ let
+ look akvs =
+ case akvs of
+ [] -> Nothing
+ kv : kvs ->
+ case kv of
+ (k, v) -> if eqIdent ak k then Just v else look kvs
+ in look m
+
+empty = Map []
+
+elems (Map kvs) = map snd kvs
+
+size (Map kvs) = length kvs
+
+toList (Map kvs) = kvs
+
+{-+import qualified Data.Map as M
+
+type Map v = M.Map Ident v
+
+insert = M.insertBy leIdent
+fromListWith = M.fromListByWith leIdent
+fromList = M.fromListBy leIdent
+--union = M.unionBy leIdent
+lookup = M.lookupBy leIdent
+empty = M.empty
+elems = M.elems
+toList = M.toList
+-}
+
+-------
+
+insert :: forall v . Ident -> v -> Map v -> Map v
+fromListWith :: forall v . (v -> v -> v) -> [(Ident, v)] -> Map v
+fromList :: forall v . [(Ident, v)] -> Map v
+--union :: forall v . Map v -> Map v -> Map v
+lookup :: forall v . Ident -> Map v -> Maybe v
+empty :: forall v . Map v
+elems :: forall v . Map v -> [v]
+size :: forall v . Map v -> Int
+toList :: forall v . Map v -> [(Ident, v)]
--- a/src/MicroHs/StringMap.hs
+++ /dev/null
@@ -1,113 +1,0 @@
--- Copyright 2023 Lennart Augustsson
--- See LICENSE file for full license.
-module MicroHs.StringMap(
- Map,
- size,
- empty, insert, lookup,
- fromList, fromListWith,
- toList, elems
- ) where
-import Prelude --Xhiding(lookup)
---Ximport Compat
-
-{--import qualified Data.Map as M
-import qualified GHC.Maybe
-
-type Map v = M.Map String v
-
-insert = M.insert
-
-fromListWith = M.fromListWith
-
-fromList = M.fromList
-
---union = M.union
-
-lookup k m =
- case M.lookup k m of
- GHC.Maybe.Nothing -> Nothing
- GHC.Maybe.Just v -> Just v
-
-empty = M.empty
-
-elems = M.elems
--}
-
--- This is a pretty bad implementation.
-data Map v = Map [(String, v)]
- --Xderiving(Show)
-
-insert k v (Map kvs) = Map ((k, v):kvs)
-
-fromListWith un =
- let
- ins ikv akvs =
- case akvs of
- [] -> [ikv]
- kv : kvs ->
- case ikv of
- (ik, iv) ->
- case kv of
- (k, v) ->
- if eqString ik k then
- (k, un iv v) : kvs
- else
- kv : ins ikv kvs
- in
- Map . foldr ins []
-
-fromList = Map
-
-{--union akvs1 akvs2 =
- case akvs1 of
- Map kvs1 ->
- case akvs2 of
- Map kvs2 -> Map (kvs1 ++ kvs2)
--}
-
-lookup ak (Map m) =
- let
- look akvs =
- case akvs of
- [] -> Nothing
- kv : kvs ->
- case kv of
- (k, v) -> if eqString ak k then Just v else look kvs
- in look m
-
-empty = Map []
-
-elems (Map kvs) = map snd kvs
-
-size (Map kvs) = length kvs
-
-toList (Map kvs) = kvs
-
-{--import qualified Data.Map as M
-
-type Map v = M.Map String v
-
-insert = M.insertBy leString
-fromListWith = M.fromListByWith leString
-fromList = M.fromListBy leString
---union = M.unionBy leString
-lookup = M.lookupBy leString
-empty = M.empty
-elems = M.elems
-toList = M.toList
--}
-
--------
-
-insert :: forall v . String -> v -> Map v -> Map v
-fromListWith :: forall v . (v -> v -> v) -> [(String, v)] -> Map v
-fromList :: forall v . [(String, v)] -> Map v
---union :: forall v . Map v -> Map v -> Map v
-lookup :: forall v . String -> Map v -> Maybe v
-empty :: forall v . Map v
-elems :: forall v . Map v -> [v]
-size :: forall v . Map v -> Int
-toList :: forall v . Map v -> [(String, v)]
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -5,7 +5,7 @@
) where
import Prelude
import Data.Maybe
-import qualified MicroHs.StringMap as M
+import qualified MicroHs.IdentMap as M
--Ximport GHC.Types
import Unsafe.Coerce
--Ximport Compat
@@ -20,9 +20,9 @@
translate (mainName, ds) =
let
--Xlook :: M.Map Any -> Ident -> Any
- look m n = fromMaybe (error $ "not found " ++ showIdent n) $ M.lookup (unIdent n) m
+ look m n = fromMaybe (error $ "not found " ++ showIdent n) $ M.lookup n m
--Xmp :: M.Map Any
- mp = M.fromList [(unIdent n, trans (look mp) d) | (n, d) <- ds ]
+ mp = M.fromList [(n, trans (look mp) d) | (n, d) <- ds ]
in unsafeCoerce $ look mp mainName
trans :: (Ident -> Any) -> Exp -> Any
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -9,7 +9,7 @@
import Data.Maybe
import qualified Data.IntMap as IM
import MicroHs.TCMonad as T
-import qualified MicroHs.StringMap as M
+import qualified MicroHs.IdentMap as M
import MicroHs.Expr
--Ximport Compat
--Ximport GHC.Stack
@@ -49,7 +49,7 @@
let
thisMdl = (mn, mkTModule mn tds impossible)
impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ m mm, tm) <- imps]
- impMap = M.fromList [(unIdent i, m) | (i, m) <- (thisMdl : impMdls)]
+ impMap = M.fromList [(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 (unIdent m) impMap of
+ case M.lookup 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 (unIdent qi) syns of
+ se = case M.lookup qi syns of
Nothing -> []
Just ts -> [(qi, ts)]
in ([TypeExport i e []], se, [])
@@ -78,7 +78,7 @@
expLookup :: Ident -> M.Map [Entry] -> Entry
expLookup i m =
- case M.lookup (unIdent i) m of
+ case M.lookup i m of
Just [e] -> e
Just _ -> error $ "export ambig " ++ showIdent i
Nothing -> expErr i
@@ -87,9 +87,9 @@
tyQIdent (Entry (EVar qi) _) = qi
tyQIdent _ = undefined
-constrsOf :: Ident -> [(String, [Entry])] -> [ValueExport]
+constrsOf :: Ident -> [(Ident, [Entry])] -> [ValueExport]
constrsOf qi ies =
- [ ValueExport (Ident i) e | (i, es) <- ies, e@(Entry (ECon _) (ETypeScheme _ t)) <- es, eqIdent (retTyCon t) qi ]
+ [ ValueExport i e | (i, es) <- ies, e@(Entry (ECon _) (ETypeScheme _ t)) <- es, eqIdent (retTyCon t) qi ]
retTyCon :: EType -> Ident
retTyCon t =
@@ -147,14 +147,14 @@
syms arg =
case arg of
(is, TModule mn tes _ ves _) ->
- [ (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 ]
+ [ (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 ]
in M.fromListWith (unionBy eqEntry) $ concatMap syms mdls
allSyns =
let
syns arg =
case arg of
- (_, TModule _ _ ses _ _) -> [ (unIdent i, x) | (i, x) <- ses ]
+ (_, TModule _ _ ses _ _) -> [ (i, x) | (i, x) <- ses ]
in M.fromList (concatMap syns mdls)
--XallTypes :: TypeTable
allTypes =
@@ -161,7 +161,7 @@
let
types arg =
case arg of
- (is, TModule mn tes _ _ _) -> [ (unIdent v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
+ (is, TModule mn tes _ _ _) -> [ (v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
in M.fromListWith (unionBy eqEntry) $ concatMap types mdls
in (allTypes, allSyns, allValues)
@@ -238,7 +238,7 @@
moduleOf :: Ident -> IdentModule
moduleOf = Ident . reverse . tail . dropWhile (neChar '.') . reverse . unIdent
-primTypes :: [(String, [Entry])]
+primTypes :: [(Ident, [Entry])]
primTypes =
let
entry i = Entry (EVar (Ident i))
@@ -245,25 +245,25 @@
tuple n =
let
i = tupleConstr n
- in (unIdent i, [entry (unIdent i) $ ETypeScheme [] $ foldr kArrow kType (replicate n kType)])
+ in (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
in
- [("IO", [entry "Primitives.IO" tt]),- ("->", [entry "Primitives.->" ttt]),- ("Int", [entry "Primitives.Int" t]),- ("Word", [entry "Primitives.Word" t]),- ("Char", [entry "Primitives.Char" t]),- ("Handle", [entry "Primitives.Handle" t]),- ("Any", [entry "Primitives.Any" t]),- ("String", [entry "Data.Char.String" t]),- ("[]", [entry "Data.List.[]" tt]),- ("()", [entry "Data.Tuple.()" t]),- ("Bool", [entry "Data.Bool_Type.Bool" t])] +++ [(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])] ++
map tuple (enumFromTo 2 10)
-primValues :: [(String, [Entry])]
+primValues :: [(Ident, [Entry])]
primValues =
let
tuple n =
@@ -272,7 +272,7 @@
vs = [Ident ("a" ++ showInt i) | i <- enumFromTo 1 n]ts = map tVar vs
r = tApps c ts
- in (unIdent c, [Entry (ECon $ ConData [(c, n)] c) $ ETypeScheme vs $ foldr tArrow r ts ])
+ in (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
@@ -346,7 +346,7 @@
syn (aa:ts) f
EVar i -> T.do
syns <- gets synTable
- case M.lookup (unIdent i) syns of
+ case M.lookup 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)
@@ -434,7 +434,7 @@
tLookup :: String -> Ident -> T (Expr, ETypeScheme)
tLookup msg i = T.do
env <- gets valueTable
- case M.lookup (unIdent i) env of
+ case M.lookup i env of
Nothing -> error $ "undefined, " ++ msg ++ ": " ++ showIdent i -- ++ "\n" ++ show env ;
Just aes ->
case aes of
@@ -460,7 +460,7 @@
Ident -> ETypeScheme -> Expr -> T ()
extValE i t e = T.do
venv <- gets valueTable
- putValueTable (M.insert (unIdent i) [Entry e t] venv)
+ putValueTable (M.insert i [Entry e t] venv)
extQVal :: --XHasCallStack =>
Ident -> ETypeScheme -> T ()
@@ -479,7 +479,7 @@
extTyp :: Ident -> ETypeScheme -> T ()
extTyp i t = T.do
tenv <- gets typeTable
- putTypeTable (M.insert (unIdent i) [Entry (EVar i) t] tenv)
+ putTypeTable (M.insert i [Entry (EVar i) t] tenv)
extTyps :: [(Ident, ETypeScheme)] -> T ()
extTyps = T.mapM_ (uncurry extTyp)
@@ -487,7 +487,7 @@
extSyn :: Ident -> ETypeScheme -> T ()
extSyn i t = T.do
senv <- gets synTable
- putSynTable (M.insert (unIdent i) t senv)
+ putSynTable (M.insert i t senv)
withExtVal :: forall a . --XHasCallStack =>
Ident -> ETypeScheme -> T a -> T a
--
⑨