ref: 5041342c9ce33c1de26c42a162119f50c0f3671d
parent: 56b5c80afe147b910093e3d2a8d8b002bec91ae9
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Mon Oct 16 10:35:54 EDT 2023
Use AssocTable more
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-977
-((A :0 _861) ((A :1 ((B _907) _0)) ((A :2 (((S' _907) _0) I)) ((A :3 _831) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _860) ((C _74) _5))) ((A :7 (((C' _6) (_878 _71)) ((_74 _876) _70))) ((A :8 ((B ((S _907) _876)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_74 _189)) _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 _789)))) ((A :18 ((B (_73 _9)) (BK (P _789)))) ((A :19 ((_73 _9) ((S P) I))) ((A :20 ((B (_73 _9)) ((C (S' P)) I))) ((A :21 ((B Y) ((B (B (P (_14 _114)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _115)))))) ((A :22 ((B Y) ((B (B (P (_14 _789)))) ((B (C' B)) (B _13))))) ((A :23 _3) ((A :24 (T (_14 _789))) ((A :25 (_21 _75)) ((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 _836) ((A :35 _837) ((A :36 (((S' _27) (_828 #97)) ((C _828) #122))) ((A :37 (((S' _27) (_828 #65)) ((C _828) #90))) ((A :38 (((S' _26) _36) _37)) ((A :39 (((S' _27) (_828 #48)) ((C _828) #57))) ((A :40 (((S' _27) (_828 #32)) ((C _828) #126))) ((A :41 _825) ((A :42 _826) ((A :43 _828) ((A :44 _827) ((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 (((_788 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _81) (((C' _82) _35) (_35 #65))) (_35 #97))))) ((A :47 ((S ((S (((S' _27) (_43 #97)) ((C _43) #97))) (_33 (((_788 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _81) (((C' _82) _35) (_35 #97))) (_35 #65))))) ((A :48 _796) ((A :49 _797) ((A :50 _798) ((A :51 _799) ((A :52 (_49 %0.0)) ((A :53 _48) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _800) ((A :58 _801) ((A :59 _57) ((A :60 _58) ((A :61 _802) ((A :62 _803) ((A :63 _804) ((A :64 _805) ((A :65 _61) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _806) ((A :70 ((B BK) T)) ((A :71 (BK T)) ((A :72 P) ((A :73 I) ((A :74 B) ((A :75 I) ((A :76 K) ((A :77 C) ((A :78 _832) ((A :79 ((C ((C S') _189)) _190)) ((A :80 (((C' (S' (C' B))) B) I)) ((A :81 _790) ((A :82 _791) ((A :83 _792) ((A :84 _793) ((A :85 _794) ((A :86 _795) ((A :87 (_82 #0)) ((A :88 _813) ((A :89 _814) ((A :90 _815) ((A :91 _816) ((A :92 _817) ((A :93 _818) ((A :94 _88) ((A :95 (BK K)) ((A :96 ((B BK) ((B (B BK)) P))) ((A :97 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :98 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _26) (_91 #0))) (_88 #0)))) ((B (B ((C' P) (_86 #1)))) _81))) (C P))) _84)) _85)) ((A :99 _95) ((A :100 (((S' C) ((B (P _177)) (((C' (C' B)) (((C' C) _88) _177)) _178))) ((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') (_88 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_88 #1)))) ((B ((C' C) ((B ((C' S') (_88 #2))) (C _100)))) (C _100))))) (C _100))))) (C _100)))) (T K))) (T A)))) ((C _98) #4)))) ((A :101 (_107 _76)) ((A :102 ((_122 (_79 _101)) _99)) ((A :103 ((C (((C' B) ((P _114) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _104)))) (((S' (C' (C' B))) ((B (B (B _104))) (((S' (C' B)) ((B (B _104)) (((C' B) ((B _120) (T #0))) _103))) (((C' B) ((B _120) (T #1))) _103)))) (((C' B) ((B _120) (T #2))) _103)))) (((C' B) ((B _120) (T #3))) _103)))) ((B T) ((B (B P)) ((C' _81) (_83 #4)))))) ((A :104 ((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) _90)))) ((B ((C' B) _115)) _104)))))) ((B ((C' B) _115)) (C _104)))))))))) (((_788 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :105 ((_74 (_120 _189)) _103)) ((A :106 (((C' C) (((C' C) (C _100)) (_3 "Data.IntMap.!"))) I)) ((A :107 ((B ((C' B) T)) ((B (B Y)) (((C' (C' (S' (S' C)))) ((B ((S' B) ((B (S' P)) (C _96)))) ((B (B ((C' (S' C
\ No newline at end of file
+975
+((A :0 _859) ((A :1 ((B _905) _0)) ((A :2 (((S' _905) _0) I)) ((A :3 _829) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _858) ((C _74) _5))) ((A :7 (((C' _6) (_876 _71)) ((_74 _874) _70))) ((A :8 ((B ((S _905) _874)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_74 _189)) _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 _787)))) ((A :18 ((B (_73 _9)) (BK (P _787)))) ((A :19 ((_73 _9) ((S P) I))) ((A :20 ((B (_73 _9)) ((C (S' P)) I))) ((A :21 ((B Y) ((B (B (P (_14 _114)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _115)))))) ((A :22 ((B Y) ((B (B (P (_14 _787)))) ((B (C' B)) (B _13))))) ((A :23 _3) ((A :24 (T (_14 _787))) ((A :25 (_21 _75)) ((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 _834) ((A :35 _835) ((A :36 (((S' _27) (_826 #97)) ((C _826) #122))) ((A :37 (((S' _27) (_826 #65)) ((C _826) #90))) ((A :38 (((S' _26) _36) _37)) ((A :39 (((S' _27) (_826 #48)) ((C _826) #57))) ((A :40 (((S' _27) (_826 #32)) ((C _826) #126))) ((A :41 _823) ((A :42 _824) ((A :43 _826) ((A :44 _825) ((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 (((_786 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _81) (((C' _82) _35) (_35 #65))) (_35 #97))))) ((A :47 ((S ((S (((S' _27) (_43 #97)) ((C _43) #97))) (_33 (((_786 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _81) (((C' _82) _35) (_35 #97))) (_35 #65))))) ((A :48 _794) ((A :49 _795) ((A :50 _796) ((A :51 _797) ((A :52 (_49 %0.0)) ((A :53 _48) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _798) ((A :58 _799) ((A :59 _57) ((A :60 _58) ((A :61 _800) ((A :62 _801) ((A :63 _802) ((A :64 _803) ((A :65 _61) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _804) ((A :70 ((B BK) T)) ((A :71 (BK T)) ((A :72 P) ((A :73 I) ((A :74 B) ((A :75 I) ((A :76 K) ((A :77 C) ((A :78 _830) ((A :79 ((C ((C S') _189)) _190)) ((A :80 (((C' (S' (C' B))) B) I)) ((A :81 _788) ((A :82 _789) ((A :83 _790) ((A :84 _791) ((A :85 _792) ((A :86 _793) ((A :87 (_82 #0)) ((A :88 _811) ((A :89 _812) ((A :90 _813) ((A :91 _814) ((A :92 _815) ((A :93 _816) ((A :94 _88) ((A :95 (BK K)) ((A :96 ((B BK) ((B (B BK)) P))) ((A :97 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :98 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _26) (_91 #0))) (_88 #0)))) ((B (B ((C' P) (_86 #1)))) _81))) (C P))) _84)) _85)) ((A :99 _95) ((A :100 (((S' C) ((B (P _177)) (((C' (C' B)) (((C' C) _88) _177)) _178))) ((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') (_88 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_88 #1)))) ((B ((C' C) ((B ((C' S') (_88 #2))) (C _100)))) (C _100))))) (C _100))))) (C _100)))) (T K))) (T A)))) ((C _98) #4)))) ((A :101 (_107 _76)) ((A :102 ((_122 (_79 _101)) _99)) ((A :103 ((C (((C' B) ((P _114) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _104)))) (((S' (C' (C' B))) ((B (B (B _104))) (((S' (C' B)) ((B (B _104)) (((C' B) ((B _120) (T #0))) _103))) (((C' B) ((B _120) (T #1))) _103)))) (((C' B) ((B _120) (T #2))) _103)))) (((C' B) ((B _120) (T #3))) _103)))) ((B T) ((B (B P)) ((C' _81) (_83 #4)))))) ((A :104 ((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) _90)))) ((B ((C' B) _115)) _104)))))) ((B ((C' B) _115)) (C _104)))))))))) (((_786 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :105 ((_74 (_120 _189)) _103)) ((A :106 (((C' C) (((C' C) (C _100)) (_3 "Data.IntMap.!"))) I)) ((A :107 ((B ((C' B) T)) ((B (B Y)) (((C' (C' (S' (S' C)))) ((B ((S' B) ((B (S' P)) (C _96)))) ((B (B ((C' (S' C
\ No newline at end of file
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -76,7 +76,7 @@
impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ m mm _, tm) <- imps]
impMap = M.fromList [(i, m) | (i, m) <- thisMdl : impMdls]
(texps, vexps) =
- unzip $ map (getTVExps impMap (typeTable tcs) (valueTable tcs)) exps
+ unzip $ map (getTVExps impMap (typeTable tcs) (valueTable tcs) (assocTable tcs)) exps
fexps = [ fe | TModule _ fe _ _ _ _ <- M.elems impMap ]
sexps = [ se | TModule _ _ _ se _ _ <- M.elems impMap ]
in tModule mn (nubBy (eqIdent `on` fst) (concat fexps)) (concat texps) (concat sexps) (concat vexps) tds
@@ -107,22 +107,23 @@
(imp, TModule mn fx ts' ss vs' a)
-- Type and value exports
-getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> ValueTable -> ExportItem ->
+getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> ValueTable -> AssocTable -> ExportItem ->
([TypeExport], [ValueExport])
-getTVExps impMap _ _ (ExpModule m) =
+getTVExps impMap _ _ _ (ExpModule m) =
case M.lookup m impMap of
Just (TModule _ _ te _ ve _) -> (te, ve)
_ -> expErr m
-getTVExps _ tys vals (ExpTypeCon i) =
+getTVExps _ tys vals ast (ExpTypeCon i) =
let
e = expLookup i tys
qi = tyQIdent e
- in ([TypeExport i e $ constrsOf qi (M.toList vals)], [])
-getTVExps _ tys _ (ExpType i) =
+ ves = getAssocs vals ast qi
+ in ([TypeExport i e ves], [])
+getTVExps _ tys _ _ (ExpType i) =
let
e = expLookup i tys
in ([TypeExport i e []], [])
-getTVExps _ _ vals (ExpValue i) =
+getTVExps _ _ vals _ (ExpValue i) =
([], [ValueExport i (expLookup i vals)])
-- Export all fixities and synonyms.
@@ -141,22 +142,6 @@
tyQIdent (Entry (EVar qi) _) = qi
tyQIdent _ = error "tyQIdent"
-constrsOf :: Ident -> [(Ident, [Entry])] -> [ValueExport]
-constrsOf qi ies =
- [ ValueExport i e | (i, es) <- ies, e@(Entry (ECon _) t) <- es, eqIdent (retTyCon t) qi ]
-
-retTyCon :: EType -> Ident
-retTyCon (EForall _ t) = retTyCon t
-retTyCon t =
- case getArrow t of
- Nothing -> getAppCon t
- Just (_, a) -> retTyCon a
-
-getAppCon :: EType -> Ident
-getAppCon (EVar i) = i
-getAppCon (EApp f _) = getAppCon f
-getAppCon _ = error "getAppCon"
-
eVarI :: SLoc -> String -> Expr
eVarI loc = EVar . mkIdentSLoc loc
@@ -183,12 +168,7 @@
Just [e] -> e
_ -> impossible
-- Find all value Entry for names associated with a type.
- assoc i =
- let qis = fromMaybe [] $ M.lookup (qualIdent mn i) at
- val qi = case M.lookup qi vt of
- Just [e] -> e
- _ -> impossible
- in map (\ qi -> ValueExport (unQualIdent qi) (val qi)) qis
+ assoc i = getAssocs vt at (qualIdent mn i)
-- All top level values possible to export.
ves = [ ValueExport i (Entry (EVar (qualIdent mn i)) ts) | Sign i ts <- tds ]
@@ -205,6 +185,15 @@
-- All fixity declaration.
fes = [ (qualIdent mn i, fx) | Infix fx is <- tds, i <- is ]
in TModule mn fes tes ses ves impossible
+
+-- Find all value Entry for names associated with a type.
+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
+ in map (\ qi -> ValueExport (unQualIdent qi) (val qi)) qis
mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, ValueTable, AssocTable)
mkTables mdls =
--
⑨