ref: 539549c81f58b7f6b42fa6f6cca2c4ca78620482
parent: d5bb0b9938efedc469af0359c91ca6782760d112
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Sat Oct 28 08:46:02 EDT 2023
Refactor symbol table to its own type.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1044
-((A :0 _928) ((A :1 ((B _974) _0)) ((A :2 (((S' _974) _0) I)) ((A :3 _898) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _927) ((C _75) _5))) ((A :7 (((C' _6) (_945 _71)) ((_75 _943) _70))) ((A :8 ((B ((S _974) _943)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_75 _190)) _10)) ((A :12 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_73 _9)) P)) ((A :15 ((B (B (_73 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 ((B (_73 _9)) (B (P _856)))) ((A :18 ((B (_73 _9)) (BK (P _856)))) ((A :19 ((_73 _9) ((S P) I))) ((A :20 ((B (_73 _9)) ((C (S' P)) I))) ((A :21 ((B Y) ((B (B (P (_14 _115)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _116)))))) ((A :22 ((B Y) ((B (B (P (_14 _856)))) ((B (C' B)) (B _13))))) ((A :23 _3) ((A :24 (T (_14 _856))) ((A :25 (_21 _76)) ((A :26 (R _33)) ((A :27 (T _32)) ((A :28 ((P _33) _32)) ((A :29 _33) ((A :30 ((C ((C S') _28)) I)) ((A :31 ((C S) _28)) ((A :32 K) ((A :33 A) ((A :34 _903) ((A :35 _904) ((A :36 (((S' _27) (_895 #97)) ((C _895) #122))) ((A :37 (((S' _27) (_895 #65)) ((C _895) #90))) ((A :38 (((S' _26) _36) _37)) ((A :39 (((S' _27) (_895 #48)) ((C _895) #57))) ((A :40 (((S' _27) (_895 #32)) ((C _895) #126))) ((A :41 _892) ((A :42 _893) ((A :43 _895) ((A :44 _894) ((A :45 (((S' _26) ((C _41) #32)) (((S' _26) ((C _41) #9)) ((C _41) #10)))) ((A :46 ((S ((S (((S' _27) (_43 #65)) ((C _43) #90))) (_33 (((_855 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _82) (((C' _83) _35) (_35 #65))) (_35 #97))))) ((A :47 ((S ((S (((S' _27) (_43 #97)) ((C _43) #97))) (_33 (((_855 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _82) (((C' _83) _35) (_35 #97))) (_35 #65))))) ((A :48 _863) ((A :49 _864) ((A :50 _865) ((A :51 _866) ((A :52 (_49 %0.0)) ((A :53 _48) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _867) ((A :58 _868) ((A :59 _57) ((A :60 _58) ((A :61 _869) ((A :62 _870) ((A :63 _871) ((A :64 _872) ((A :65 _61) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _873) ((A :70 ((B BK) T)) ((A :71 (BK T)) ((A :72 P) ((A :73 I) ((A :74 (S _900)) ((A :75 B) ((A :76 I) ((A :77 K) ((A :78 C) ((A :79 _899) ((A :80 ((C ((C S') _190)) _191)) ((A :81 (((C' (S' (C' B))) B) I)) ((A :82 _857) ((A :83 _858) ((A :84 _859) ((A :85 _860) ((A :86 _861) ((A :87 _862) ((A :88 (_83 #0)) ((A :89 _880) ((A :90 _881) ((A :91 _882) ((A :92 _883) ((A :93 _884) ((A :94 _885) ((A :95 _89) ((A :96 (BK K)) ((A :97 ((B BK) ((B (B BK)) P))) ((A :98 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :99 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _26) (_92 #0))) (_89 #0)))) ((B (B ((C' P) (_87 #1)))) _82))) (C P))) _85)) _86)) ((A :100 _96) ((A :101 (((S' C) ((B (P _178)) (((C' (C' B)) (((C' C) _89) _178)) _179))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') (_89 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_89 #1)))) ((B ((C' C) ((B ((C' S') (_89 #2))) (C _101)))) (C _101))))) (C _101))))) (C _101)))) (T K))) (T A)))) ((C _99) #4)))) ((A :102 (_108 _77)) ((A :103 ((_123 (_80 _102)) _100)) ((A :104 ((C (((C' B) ((P _115) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _105)))) (((S' (C' (C' B))) ((B (B (B _105))) (((S' (C' B)) ((B (B _105)) (((C' B) ((B _121) (T #0))) _104))) (((C' B) ((B _121) (T #1))) _104)))) (((C' B) ((B _121) (T #2))) _104)))) (((C' B) ((B _121) (T #3))) _104)))) ((B T) ((B (B P)) ((C' _82) (_84 #4)))))) ((A :105 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C') S) ((B (B (B (S B)))) ((B (B (B (B (B BK))))) ((B ((S' (C' B)) ((B B') B'))) ((B (B (B (B (B (S B)))))) ((B (B (B (B (B (B (B BK))))))) (((C' B) (B' (B' ((B (C' (C' (C' C)))) ((B ((C' B) (B' ((B C) _91)))) ((B ((C' B) _116)) _105)))))) ((B ((C' B) _116)) (C _105)))))))))) (((_855 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :106 ((_75 (_121 _190)) _104)) ((A :107 (((C' C) (((C' C) (C _101)) (_3 "Data.IntMap.!"))) I)) ((A :108 ((B ((C' B) T)) ((B (B Y)) (((C' (C' (S' (S' C)))) ((B ((S' B) ((B (S' P)) (C _97))
\ No newline at end of file
+1049
+((A :0 _933) ((A :1 ((B _979) _0)) ((A :2 (((S' _979) _0) I)) ((A :3 _903) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _932) ((C _75) _5))) ((A :7 (((C' _6) (_950 _71)) ((_75 _948) _70))) ((A :8 ((B ((S _979) _948)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_75 _190)) _10)) ((A :12 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_73 _9)) P)) ((A :15 ((B (B (_73 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 ((B (_73 _9)) (B (P _861)))) ((A :18 ((B (_73 _9)) (BK (P _861)))) ((A :19 ((_73 _9) ((S P) I))) ((A :20 ((B (_73 _9)) ((C (S' P)) I))) ((A :21 ((B Y) ((B (B (P (_14 _115)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _116)))))) ((A :22 ((B Y) ((B (B (P (_14 _861)))) ((B (C' B)) (B _13))))) ((A :23 _3) ((A :24 (T (_14 _861))) ((A :25 (_21 _76)) ((A :26 (R _33)) ((A :27 (T _32)) ((A :28 ((P _33) _32)) ((A :29 _33) ((A :30 ((C ((C S') _28)) I)) ((A :31 ((C S) _28)) ((A :32 K) ((A :33 A) ((A :34 _908) ((A :35 _909) ((A :36 (((S' _27) (_900 #97)) ((C _900) #122))) ((A :37 (((S' _27) (_900 #65)) ((C _900) #90))) ((A :38 (((S' _26) _36) _37)) ((A :39 (((S' _27) (_900 #48)) ((C _900) #57))) ((A :40 (((S' _27) (_900 #32)) ((C _900) #126))) ((A :41 _897) ((A :42 _898) ((A :43 _900) ((A :44 _899) ((A :45 (((S' _26) ((C _41) #32)) (((S' _26) ((C _41) #9)) ((C _41) #10)))) ((A :46 ((S ((S (((S' _27) (_43 #65)) ((C _43) #90))) (_33 (((_860 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _82) (((C' _83) _35) (_35 #65))) (_35 #97))))) ((A :47 ((S ((S (((S' _27) (_43 #97)) ((C _43) #97))) (_33 (((_860 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _82) (((C' _83) _35) (_35 #97))) (_35 #65))))) ((A :48 _868) ((A :49 _869) ((A :50 _870) ((A :51 _871) ((A :52 (_49 %0.0)) ((A :53 _48) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _872) ((A :58 _873) ((A :59 _57) ((A :60 _58) ((A :61 _874) ((A :62 _875) ((A :63 _876) ((A :64 _877) ((A :65 _61) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _878) ((A :70 ((B BK) T)) ((A :71 (BK T)) ((A :72 P) ((A :73 I) ((A :74 (S _905)) ((A :75 B) ((A :76 I) ((A :77 K) ((A :78 C) ((A :79 _904) ((A :80 ((C ((C S') _190)) _191)) ((A :81 (((C' (S' (C' B))) B) I)) ((A :82 _862) ((A :83 _863) ((A :84 _864) ((A :85 _865) ((A :86 _866) ((A :87 _867) ((A :88 (_83 #0)) ((A :89 _885) ((A :90 _886) ((A :91 _887) ((A :92 _888) ((A :93 _889) ((A :94 _890) ((A :95 _89) ((A :96 (BK K)) ((A :97 ((B BK) ((B (B BK)) P))) ((A :98 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :99 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _26) (_92 #0))) (_89 #0)))) ((B (B ((C' P) (_87 #1)))) _82))) (C P))) _85)) _86)) ((A :100 _96) ((A :101 (((S' C) ((B (P _178)) (((C' (C' B)) (((C' C) _89) _178)) _179))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') (_89 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_89 #1)))) ((B ((C' C) ((B ((C' S') (_89 #2))) (C _101)))) (C _101))))) (C _101))))) (C _101)))) (T K))) (T A)))) ((C _99) #4)))) ((A :102 (_108 _77)) ((A :103 ((_123 (_80 _102)) _100)) ((A :104 ((C (((C' B) ((P _115) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _105)))) (((S' (C' (C' B))) ((B (B (B _105))) (((S' (C' B)) ((B (B _105)) (((C' B) ((B _121) (T #0))) _104))) (((C' B) ((B _121) (T #1))) _104)))) (((C' B) ((B _121) (T #2))) _104)))) (((C' B) ((B _121) (T #3))) _104)))) ((B T) ((B (B P)) ((C' _82) (_84 #4)))))) ((A :105 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C') S) ((B (B (B (S B)))) ((B (B (B (B (B BK))))) ((B ((S' (C' B)) ((B B') B'))) ((B (B (B (B (B (S B)))))) ((B (B (B (B (B (B (B BK))))))) (((C' B) (B' (B' ((B (C' (C' (C' C)))) ((B ((C' B) (B' ((B C) _91)))) ((B ((C' B) _116)) _105)))))) ((B ((C' B) _116)) (C _105)))))))))) (((_860 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :106 ((_75 (_121 _190)) _104)) ((A :107 (((C' C) (((C' C) (C _101)) (_3 "Data.IntMap.!"))) I)) ((A :108 ((B ((C' B) T)) ((B (B Y)) (((C' (C' (S' (S' C)))) ((B ((S' B) ((B (S' P)) (C _97))
\ No newline at end of file
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -51,9 +51,9 @@
entryType :: Entry -> EType
entryType (Entry _ t) = t
-type ValueTable = M.Map [Entry] -- type of value identifiers, used during type checking values
-type TypeTable = M.Map [Entry] -- kind of type identifiers, used during kind checking types
-type KindTable = M.Map [Entry] -- sort of kind identifiers, used during sort checking kinds
+type ValueTable = SymTab Entry -- type of value identifiers, used during type checking values
+type TypeTable = SymTab Entry -- kind of type identifiers, used during kind checking types
+type KindTable = SymTab Entry -- sort of kind identifiers, used during sort checking kinds
type SynTable = M.Map EType -- body of type synonyms
type FixTable = M.Map Fixity -- precedence and associativity of operators
type AssocTable = M.Map [Ident] -- maps a type identifier to its associated construcors/selectors/methods
@@ -131,7 +131,7 @@
--getFSExps :: forall a . M.Map (TModule a) -> [([FixDef], [SynDef])]
--getFSExps impMap = [ (fe, se) | TModule _ fe _ se _ _ <- M.elems impMap ]
-expLookup :: Ident -> M.Map [Entry] -> Entry
+expLookup :: Ident -> SymTab Entry -> Entry
expLookup i m = either (errorMessage (getSLocIdent i)) id $ stLookup "export" i m
tyQIdent :: Entry -> Ident
@@ -160,9 +160,9 @@
-- Find the Entry for a type.
tentry i =
- case M.lookup (qualIdent mn i) tt of
- Just [e] -> e
- _ -> impossible
+ case stLookup "" (qualIdent mn i) tt of
+ Right e -> e
+ _ -> impossible
-- Find all value Entry for names associated with a type.
assoc i = getAssocs vt at (qualIdent mn i)
@@ -186,9 +186,9 @@
getAssocs :: ValueTable -> AssocTable -> Ident -> [ValueExport]
getAssocs vt at ai =
let qis = fromMaybe [] $ M.lookup ai at
- val qi = case M.lookup qi vt of
- Just [e] -> e
- _ -> impossible
+ val qi = case stLookup "" qi vt of
+ Right e -> e
+ _ -> impossible
in map (\ qi -> ValueExport (unQualIdent qi) (val qi)) qis
mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, ValueTable, AssocTable)
@@ -204,7 +204,7 @@
syms (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 ]
- in M.fromListWith (unionBy eqEntry) $ concatMap syms mdls
+ in stFromListWith (unionBy eqEntry) $ concatMap syms mdls
allSyns =
let
syns (_, TModule _ _ _ ses _ _) = ses
@@ -213,7 +213,7 @@
allTypes =
let
types (is, TModule mn _ tes _ _ _) = [ (v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
- in M.fromListWith (unionBy eqEntry) $ concatMap types mdls
+ in stFromListWith (unionBy eqEntry) $ concatMap types mdls
allFixes =
let
fixes (_, TModule _ fes _ _ _ _) = fes
@@ -328,8 +328,8 @@
initTC mn fs ts ss vs as =
-- trace ("initTC " ++ show (ts, vs)) $let
- xts = foldr (uncurry M.insert) ts primTypes
- xvs = foldr (uncurry M.insert) vs primValues
+ xts = foldr (uncurry stInsert) ts primTypes
+ xvs = foldr (uncurry stInsert) vs primValues
in TC mn 1 fs xts ss xvs as IM.empty TCExpr
kTypeS :: EType
@@ -351,7 +351,7 @@
primKindTable =
let
entry i = Entry (EVar (mkIdentB i))
- in M.fromList [
+ in stFromList [
-- The kinds are wired in (for now)
(mkIdentB "Primitives.Type", [entry "Primitives.Type" kTypeS]),
(mkIdentB "Type", [entry "Primitives.Type" kTypeS]),
@@ -604,14 +604,6 @@
Right (Entry e s) -> T.return (setSLocExpr (getSLocIdent i) e, s)
Left e -> tcError (getSLocIdent i) e
-stLookup :: String -> Ident -> M.Map [Entry] -> Either String Entry
-stLookup msg i env =
- case M.lookup i env of
- Just [e] -> Right e
- Just _ -> Left $ "ambiguous " ++ msg ++ ": " ++ showIdent i
- Nothing -> Left $ "undefined " ++ msg ++ ": " ++ showIdent i
- -- ++ "\n" ++ show env ;
-
tInst :: EType -> T EType
tInst as =
case as of
@@ -627,7 +619,7 @@
Ident -> EType -> Expr -> T ()
extValE i t e = T.do
venv <- gets valueTable
- putValueTable (M.insert i [Entry e t] venv)
+ putValueTable (stInsert i [Entry e t] venv)
-- Extend the symbol table with i = e :: t
-- Add both qualified and unqualified versions of i.
@@ -658,7 +650,7 @@
extTyp :: Ident -> EType -> T ()
extTyp i t = T.do
tenv <- gets typeTable
- putTypeTable (M.insert i [Entry (EVar i) t] tenv)
+ putTypeTable (stInsert i [Entry (EVar i) t] tenv)
extTyps :: [(Ident, EType)] -> T ()
extTyps = T.mapM_ (uncurry extTyp)
@@ -1389,7 +1381,7 @@
T.return (metaTvs tys')
getEnvTypes :: T [EType]
-getEnvTypes = gets (map entryType . concat . M.elems . valueTable)
+getEnvTypes = gets (map entryType . concat . stElems . valueTable)
{-quantify :: [MetaTv] -> Rho -> T Sigma
@@ -1521,3 +1513,28 @@
instSigma _ t1 (Infer r) = T.do
t1' <- tInst t1
tSetRefType r t1'
+
+---------------------
+
+data SymTab a = SymTab (M.Map [a]) -- [(Ident, a)]
+ --Xderiving(Show)
+
+stLookup :: forall a . String -> Ident -> SymTab a -> Either String a
+stLookup msg i (SymTab genv) =
+ case M.lookup i genv of
+ Just [e] -> Right e
+ Just _ -> Left $ "ambiguous " ++ msg ++ ": " ++ showIdent i
+ Nothing -> Left $ "undefined " ++ msg ++ ": " ++ showIdent i
+ -- ++ "\n" ++ show env ;
+
+stFromListWith :: forall a . ([a] -> [a] -> [a]) -> [(Ident, [a])] -> SymTab a
+stFromListWith comb ias = SymTab (M.fromListWith comb ias)
+
+stFromList :: forall a . [(Ident, [a])] -> SymTab a
+stFromList ias = SymTab (M.fromList ias)
+
+stElems :: forall a . SymTab a -> [[a]]
+stElems (SymTab genv) = M.elems genv
+
+stInsert :: forall a . Ident -> [a] -> SymTab a -> SymTab a
+stInsert i as (SymTab genv) = SymTab (M.insert i as genv)
--
⑨