ref: 6b5d407ba8afff518bc47c37240f2bcbd2dd93f9
parent: 5aab9dd1d0d0b4e371ecbf5d5ad025de00a3eab1
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Mon Oct 16 07:31:30 EDT 2023
Redo how constructors/selectors are associated with a type. There is now a table that descibes the association. This is only used to do the correct exports for T(..).
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-973
-((A :0 _857) ((A :1 ((B _903) _0)) ((A :2 (((S' _903) _0) I)) ((A :3 _827) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _856) ((C _74) _5))) ((A :7 (((C' _6) (_874 _71)) ((_74 _872) _70))) ((A :8 ((B ((S _903) _872)) _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 _785)))) ((A :18 ((B (_73 _9)) (BK (P _785)))) ((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 _785)))) ((B (C' B)) (B _13))))) ((A :23 _3) ((A :24 (T (_14 _785))) ((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 _832) ((A :35 _833) ((A :36 (((S' _27) (_824 #97)) ((C _824) #122))) ((A :37 (((S' _27) (_824 #65)) ((C _824) #90))) ((A :38 (((S' _26) _36) _37)) ((A :39 (((S' _27) (_824 #48)) ((C _824) #57))) ((A :40 (((S' _27) (_824 #32)) ((C _824) #126))) ((A :41 _821) ((A :42 _822) ((A :43 _824) ((A :44 _823) ((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 (((_784 "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 (((_784 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _81) (((C' _82) _35) (_35 #97))) (_35 #65))))) ((A :48 _792) ((A :49 _793) ((A :50 _794) ((A :51 _795) ((A :52 (_49 %0.0)) ((A :53 _48) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _796) ((A :58 _797) ((A :59 _57) ((A :60 _58) ((A :61 _798) ((A :62 _799) ((A :63 _800) ((A :64 _801) ((A :65 _61) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _802) ((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 _828) ((A :79 ((C ((C S') _189)) _190)) ((A :80 (((C' (S' (C' B))) B) I)) ((A :81 _786) ((A :82 _787) ((A :83 _788) ((A :84 _789) ((A :85 _790) ((A :86 _791) ((A :87 (_82 #0)) ((A :88 _809) ((A :89 _810) ((A :90 _811) ((A :91 _812) ((A :92 _813) ((A :93 _814) ((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)))))))))) (((_784 "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
+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
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -7,6 +7,7 @@
mkIdentSLoc,
isLower_, isIdentChar, isOperChar, isConIdent,
isDummyIdent,
+ unQualIdent,
unQualString,
SLoc(..), noSLoc, isNoSLoc,
showSLoc,
@@ -65,6 +66,9 @@
qualIdent :: Ident -> Ident -> Ident
qualIdent (Ident loc qi) (Ident _ i) = Ident loc (qi ++ "." ++ i)
+
+unQualIdent :: Ident -> Ident
+unQualIdent (Ident l s) = Ident l (unQualString s)
unQualString :: String -> String
unQualString s =
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -6,7 +6,7 @@
TModule(..), showTModule,
impossible,
) where
-import Prelude
+import Prelude --Xhiding(showList)
import Data.Char
import Data.List
import Data.Maybe
@@ -68,8 +68,8 @@
-- trace (show amdl) $
let
imps = map filterImports aimps
- (fs, ts, ss, vs) = mkTables imps
- in case tcRun (tcDefs defs) (initTC mn fs ts ss vs) of
+ (fs, ts, ss, vs, as) = mkTables imps
+ in case tcRun (tcDefs defs) (initTC mn fs ts ss vs as) of
(tds, tcs) ->
let
thisMdl = (mn, mkTModule tds tcs)
@@ -166,78 +166,82 @@
expErr :: forall a . Ident -> a
expErr i = errorMessage (getSLocIdent i) $ ": export undefined " ++ showIdent i
+-- Construct a dummy TModule for the currently compiled module.
+-- It has all the relevant export tables.
+-- The value&type export tables will later be filtered through the export list.
mkTModule :: forall a . [EDef] -> TCState -> TModule a
mkTModule tds tcs =
let
-
- con ci it vks (Constr ic ets) =
- let
- e = ECon $ ConData ci (qualIdent mn ic)
- ts = either id (map snd) ets
- in ValueExport ic $ Entry e (EForall vks (foldr tArrow (tApps (qualIdent mn it) (map tVarK vks)) ts))
- cons i vks cs =
- let
- ci = [ (qualIdent mn c, either length length ets) | Constr c ets <- cs ]
- in map (con ci i vks) cs
- conn it vks ic t =
- let
- e = ECon $ ConNew (qualIdent mn ic)
- in [ValueExport ic $ Entry e (EForall vks (tArrow t (tApps (qualIdent mn it) (map tVarK vks))))]
-
mn = moduleName tcs
- tt = typeTable tcs
+ tt = typeTable tcs
+ at = assocTable tcs
+ vt = valueTable tcs
+
+ -- Find the Entry for a type.
tentry i =
case M.lookup (qualIdent mn i) tt of
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
+
+ -- All top level values possible to export.
ves = [ ValueExport i (Entry (EVar (qualIdent mn i)) ts) | Sign i ts <- tds ]
+
+ -- All top level types possible to export.
tes =
- [ TypeExport i (tentry i) (cons i vks cs) | Data (i, vks) cs <- tds ] ++
- [ TypeExport i (tentry i) (conn i vks c t) | Newtype (i, vks) c t <- tds ] ++
--- [ TypeExport i (tentry i) (assoc i) | Data (i, _) _ <- tds ] ++
--- [ TypeExport i (tentry i) (assoc i) | Newtype (i, _) _ _ <- tds ] ++
+ [ TypeExport i (tentry i) (assoc i) | Data (i, _) _ <- tds ] ++
+ [ TypeExport i (tentry i) (assoc i) | Newtype (i, _) _ _ <- tds ] ++
[ TypeExport i (tentry i) [] | Type (i, _) _ <- tds ]
+ -- All type synonym definitions.
ses = [ (qualIdent mn i, EForall vs t) | Type (i, vs) t <- tds ]
+
+ -- All fixity declaration.
fes = [ (qualIdent mn i, fx) | Infix fx is <- tds, i <- is ]
in TModule mn fes tes ses ves impossible
-mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, ValueTable)
+mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, ValueTable, AssocTable)
mkTables mdls =
let
- qns aisp mn i =
- case aisp of
- ImportSpec q _ mas _ ->
- let
- m = fromMaybe mn mas
- in if q then [qualIdent m i] else [i, qualIdent m i]
+ qns (ImportSpec q _ mas _) mn i =
+ let
+ m = fromMaybe mn mas
+ in if q then [qualIdent m i] else [i, qualIdent m i]
allValues :: ValueTable
allValues =
let
- 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 ]
+ 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
allSyns =
let
- syns arg =
- case arg of
- (_, TModule _ _ _ ses _ _) -> [ (i, x) | (i, x) <- ses ]
+ syns (_, TModule _ _ _ ses _ _) = ses
in M.fromList (concatMap syns mdls)
allTypes :: TypeTable
allTypes =
let
- types arg =
- case arg of
- (is, TModule mn _ tes _ _ _) -> [ (v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
+ types (is, TModule mn _ tes _ _ _) = [ (v, [e]) | TypeExport i e _ <- tes, v <- qns is mn i ]
in M.fromListWith (unionBy eqEntry) $ concatMap types mdls
allFixes =
let
fixes (_, TModule _ fes _ _ _ _) = fes
in M.fromList (concatMap fixes mdls)
- in (allFixes, allTypes, allSyns, allValues)
+ allAssocs :: AssocTable
+ allAssocs =
+ let
+ assocs (ImportSpec _ _ mas _, TModule mn _ tes _ _ _) =
+ let
+ m = fromMaybe mn mas
+ in [ (qualIdent m i, [qualIdent m a | ValueExport a _ <- cs]) | TypeExport i _ cs <- tes ]
+ in M.fromList $ concatMap assocs mdls
+ in (allFixes, allTypes, allSyns, allValues, allAssocs)
eqEntry :: Entry -> Entry -> Bool
eqEntry x y =
@@ -257,7 +261,7 @@
type Typed a = (a, EType)
-data TCState = TC IdentModule Int FixTable TypeTable SynTable ValueTable (IM.IntMap EType) TCMode
+data TCState = TC IdentModule Int FixTable TypeTable SynTable ValueTable AssocTable (IM.IntMap EType) TCMode
--Xderiving (Show)
data TCMode = TCExpr | TCPat | TCType
@@ -264,50 +268,53 @@
--Xderiving (Show)
typeTable :: TCState -> TypeTable
-typeTable (TC _ _ _ tt _ _ _ _) = tt
+typeTable (TC _ _ _ tt _ _ _ _ _) = tt
valueTable :: TCState -> ValueTable
-valueTable (TC _ _ _ _ _ vt _ _) = vt
+valueTable (TC _ _ _ _ _ vt _ _ _) = vt
synTable :: TCState -> SynTable
-synTable (TC _ _ _ _ st _ _ _) = st
+synTable (TC _ _ _ _ st _ _ _ _) = st
fixTable :: TCState -> FixTable
-fixTable (TC _ _ ft _ _ _ _ _) = ft
+fixTable (TC _ _ ft _ _ _ _ _ _) = ft
+assocTable :: TCState -> AssocTable
+assocTable (TC _ _ _ _ _ _ ast _ _) = ast
+
uvarSubst :: TCState -> IM.IntMap EType
-uvarSubst (TC _ _ _ _ _ _ sub _) = sub
+uvarSubst (TC _ _ _ _ _ _ _ sub _) = sub
moduleName :: TCState -> IdentModule
-moduleName (TC mn _ _ _ _ _ _ _) = mn
+moduleName (TC mn _ _ _ _ _ _ _ _) = mn
tcMode :: TCState -> TCMode
-tcMode (TC _ _ _ _ _ _ _ m) = m
+tcMode (TC _ _ _ _ _ _ _ _ m) = m
putValueTable :: ValueTable -> T ()
putValueTable venv = T.do
- TC mn n fx tenv senv _ sub m <- get
- put (TC mn n fx tenv senv venv sub m)
+ TC mn n fx tenv senv _ ast sub m <- get
+ put (TC mn n fx tenv senv venv ast sub m)
putTypeTable :: TypeTable -> T ()
putTypeTable tenv = T.do
- TC mn n fx _ senv venv sub m <- get
- put (TC mn n fx tenv senv venv sub m)
+ TC mn n fx _ senv venv ast sub m <- get
+ put (TC mn n fx tenv senv venv ast sub m)
putSynTable :: SynTable -> T ()
putSynTable senv = T.do
- TC mn n fx tenv _ venv sub m <- get
- put (TC mn n fx tenv senv venv sub m)
+ TC mn n fx tenv _ venv ast sub m <- get
+ put (TC mn n fx tenv senv venv ast sub m)
putUvarSubst :: IM.IntMap EType -> T ()
putUvarSubst sub = T.do
- TC mn n fx tenv senv venv _ m <- get
- put (TC mn n fx tenv senv venv sub m)
+ TC mn n fx tenv senv venv ast _ m <- get
+ put (TC mn n fx tenv senv venv ast sub m)
putTCMode :: TCMode -> T ()
putTCMode m = T.do
- TC mn n fx tenv senv venv sub _ <- get
- put (TC mn n fx tenv senv venv sub m)
+ TC mn n fx tenv senv venv ast sub _ <- get
+ put (TC mn n fx tenv senv venv ast sub m)
withTCMode :: forall a . TCMode -> T a -> T a
withTCMode m ta = T.do
@@ -320,20 +327,25 @@
-- Use the type table as the value table, and the primKind table as the type table.
withTypeTable :: forall a . T a -> T a
withTypeTable ta = T.do
- TC mn n fx tt st vt sub m <- get
- put (TC mn n fx primKindTable M.empty tt sub m)
+ TC mn n fx tt st vt ast sub m <- get
+ put (TC mn n fx primKindTable M.empty tt ast sub m)
a <- ta
- TC mnr nr _ _ _ ttr subr mr <- get
- put (TC mnr nr fx ttr st vt subr mr)
+ TC mnr nr _ _ _ ttr astr subr mr <- get
+ put (TC mnr nr fx ttr st vt astr subr mr)
T.return a
-initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> ValueTable -> TCState
-initTC mn fs ts ss vs =
+addAssocTable :: Ident -> [Ident] -> T ()
+addAssocTable i is = T.do
+ TC mn n fx tt st vt ast sub m <- get
+ put $ TC mn n fx tt st vt (M.insert i is ast) sub m
+
+initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> ValueTable -> AssocTable -> TCState
+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
- in TC mn 1 fs xts ss xvs IM.empty TCExpr
+ in TC mn 1 fs xts ss xvs as IM.empty TCExpr
kTypeS :: EType
kTypeS = kType
@@ -431,8 +443,8 @@
setUVar :: TRef -> EType -> T ()
setUVar i t = T.do
- TC mn n fx tenv senv venv sub m <- get
- put (TC mn n fx tenv senv venv (IM.insert i t sub) m)
+ TC mn n fx tenv senv venv ast sub m <- get
+ put (TC mn n fx tenv senv venv ast (IM.insert i t sub) m)
getUVar :: Int -> T (Maybe EType)
getUVar i = gets (IM.lookup i . uvarSubst)
@@ -577,8 +589,8 @@
-- Reset type variable and unification map
tcReset :: T ()
tcReset = T.do
- TC mn _ fx tenv senv venv _ m <- get
- put (TC mn 0 fx tenv senv venv IM.empty m)
+ TC mn _ fx tenv senv venv ast _ m <- get
+ put (TC mn 0 fx tenv senv venv ast IM.empty m)
newUVar :: T EType
newUVar = EUVar <$> newUniq
@@ -587,8 +599,8 @@
newUniq :: T TRef
newUniq = T.do
- TC mn n fx tenv senv venv sub m <- get
- put (TC mn (n+1) fx tenv senv venv sub m)
+ TC mn n fx tenv senv venv ast sub m <- get
+ put (TC mn (n+1) fx tenv senv venv ast sub m)
T.return n
tLookupInst :: --XHasCallStack =>
@@ -626,15 +638,24 @@
venv <- gets valueTable
putValueTable (M.insert i [Entry e t] venv)
-extQVal :: --XHasCallStack =>
- Ident -> EType -> T ()
-extQVal i t = T.do
+-- Extend the symbol table with i = e :: t
+-- Add both qualified and unqualified versions of i.
+extValETop :: --XHasCallStack =>
+ Ident -> EType -> Expr -> T ()
+extValETop i t e = T.do
mn <- gets moduleName
- let qi = qualIdent mn i
- eqi = EVar qi
- extValE qi t eqi
- extValE i t eqi
+ extValE (qualIdent mn i) t e
+ extValE i t e
+-- Extend symbol table with i::t.
+-- The translation for i will be the qualified name.
+-- Add both qualified and unqualified versions of i.
+extValQTop :: --XHasCallStack =>
+ Ident -> EType -> T ()
+extValQTop i t = T.do
+ mn <- gets moduleName
+ extValETop i t (EVar (qualIdent mn i))
+
extVal :: --XHasCallStack =>
Ident -> EType -> T ()
extVal i t = extValE i t $ EVar i
@@ -658,8 +679,8 @@
extFix :: Ident -> Fixity -> T ()
extFix i fx = T.do
- TC mn n fenv tenv senv venv sub m <- get
- put $ TC mn n (M.insert i fx fenv) tenv senv venv sub m
+ TC mn n fenv tenv senv venv ast sub m <- get
+ put $ TC mn n (M.insert i fx fenv) tenv senv venv ast sub m
T.return ()
withExtVal :: forall a . --XHasCallStack =>
@@ -737,10 +758,19 @@
addTypeKind :: EDef -> T ()
addTypeKind adef = T.do
- tcReset
+ let
+ addAssoc i is = T.do
+ mn <- gets moduleName
+ addAssocTable (qualIdent mn i) (map (qualIdent mn) is)
+ assocData (Constr c (Left _)) = [c]
+ assocData (Constr c (Right its)) = c : map fst its
case adef of
- Data lhs _ -> addLHSKind lhs kType
- Newtype lhs _ _ -> addLHSKind lhs kType
+ Data lhs@(i, _) cs -> T.do
+ addLHSKind lhs kType
+ addAssoc i (nubBy eqIdent $ concatMap assocData cs)
+ Newtype lhs@(i, _) c _ -> T.do
+ addLHSKind lhs kType
+ addAssoc i [c]
Type lhs t -> addLHSKind lhs (getTypeKind t)
_ -> T.return ()
@@ -751,7 +781,7 @@
addLHSKind :: LHS -> EKind -> T ()
addLHSKind (i, vks) kret =
-- trace ("addLHSKind " ++ showIdent i ++ " :: " ++ showExpr (lhsKind vks kret)) $- extQVal i (lhsKind vks kret)
+ extValQTop i (lhsKind vks kret)
lhsKind :: [IdKind] -> EKind -> EKind
lhsKind vks kret = foldr (\ (IdKind _ k) -> kArrow k) kret vks
@@ -798,9 +828,7 @@
addValueType adef = T.do
mn <- gets moduleName
case adef of
- Sign i t -> T.do
- extQVal i t
- extVal (qualIdent mn i) t
+ Sign i t -> extValQTop i t
Data (i, vks) cs -> T.do
let
cti = [ (qualIdent mn c, either length length ets) | Constr c ets <- cs ]
@@ -807,15 +835,13 @@
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
addCon (Constr c ets) = T.do
let ts = either id (map snd) ets
- extValE c (EForall vks $ foldr tArrow tret ts) (ECon $ ConData cti (qualIdent mn c))
+ extValETop c (EForall vks $ foldr tArrow tret ts) (ECon $ ConData cti (qualIdent mn c))
T.mapM_ addCon cs
Newtype (i, vks) c t -> T.do
let
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
- extValE c (EForall vks $ tArrow t tret) (ECon $ ConNew (qualIdent mn c))
- ForImp _ i t -> T.do
- extQVal i t
- extVal (qualIdent mn i) t
+ extValETop c (EForall vks $ tArrow t tret) (ECon $ ConNew (qualIdent mn c))
+ ForImp _ i t -> extValQTop i t
_ -> T.return ()
unForall :: EType -> ([IdKind], EType)
--
⑨