ref: ac6c9473cdcc908c039a10281c703b7a073dceff
parent: 7ff283ebf5c2d4ce75e27bbc41b4d38d9983c7f4
parent: 56b5c80afe147b910093e3d2a8d8b002bec91ae9
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Mon Oct 16 10:27:45 EDT 2023
Merge branch 'master' into class
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-995
-((A :0 _879) ((A :1 ((B _925) _0)) ((A :2 (((S' _925) _0) I)) ((A :3 _849) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _878) ((C _75) _5))) ((A :7 (((C' _6) (_896 _72)) ((_75 _894) _71))) ((A :8 ((B ((S _925) _894)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_75 _190)) _10)) ((A :12 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_74 _9)) P)) ((A :15 ((B (B (_74 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_74 _9)) (B (P _807)))) ((A :19 ((B (_74 _9)) (BK (P _807)))) ((A :20 ((_74 _9) ((S P) I))) ((A :21 ((B (_74 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _115)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _116)))))) ((A :23 ((B Y) ((B (B (P (_14 _807)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _807))) ((A :26 (_22 _76)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 _854) ((A :36 _855) ((A :37 (((S' _28) (_846 #97)) ((C _846) #122))) ((A :38 (((S' _28) (_846 #65)) ((C _846) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_846 #48)) ((C _846) #57))) ((A :41 (((S' _28) (_846 #32)) ((C _846) #126))) ((A :42 _843) ((A :43 _844) ((A :44 _846) ((A :45 _845) ((A :46 (((S' _27) ((C _42) #32)) (((S' _27) ((C _42) #9)) ((C _42) #10)))) ((A :47 ((S ((S (((S' _28) (_44 #65)) ((C _44) #90))) (_34 (((_805 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _82) (((C' _83) _36) (_36 #65))) (_36 #97))))) ((A :48 ((S ((S (((S' _28) (_44 #97)) ((C _44) #97))) (_34 (((_805 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _82) (((C' _83) _36) (_36 #97))) (_36 #65))))) ((A :49 _814) ((A :50 _815) ((A :51 _816) ((A :52 _817) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _818) ((A :59 _819) ((A :60 _58) ((A :61 _59) ((A :62 _820) ((A :63 _821) ((A :64 _822) ((A :65 _823) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _824) ((A :71 ((B BK) T)) ((A :72 (BK T)) ((A :73 P) ((A :74 I) ((A :75 B) ((A :76 I) ((A :77 K) ((A :78 C) ((A :79 _850) ((A :80 ((C ((C S') _190)) _191)) ((A :81 (((C' (S' (C' B))) B) I)) ((A :82 _808) ((A :83 _809) ((A :84 _810) ((A :85 _811) ((A :86 _812) ((A :87 _813) ((A :88 (_83 #0)) ((A :89 _831) ((A :90 _832) ((A :91 _833) ((A :92 _834) ((A :93 _835) ((A :94 _836) ((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 _27) (_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)))))))))) (((_805 "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
\ No newline at end of file
+999
+((A :0 _883) ((A :1 ((B _929) _0)) ((A :2 (((S' _929) _0) I)) ((A :3 _853) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _882) ((C _75) _5))) ((A :7 (((C' _6) (_900 _72)) ((_75 _898) _71))) ((A :8 ((B ((S _929) _898)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_75 _190)) _10)) ((A :12 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_74 _9)) P)) ((A :15 ((B (B (_74 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_74 _9)) (B (P _811)))) ((A :19 ((B (_74 _9)) (BK (P _811)))) ((A :20 ((_74 _9) ((S P) I))) ((A :21 ((B (_74 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _115)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _116)))))) ((A :23 ((B Y) ((B (B (P (_14 _811)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _811))) ((A :26 (_22 _76)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 _858) ((A :36 _859) ((A :37 (((S' _28) (_850 #97)) ((C _850) #122))) ((A :38 (((S' _28) (_850 #65)) ((C _850) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_850 #48)) ((C _850) #57))) ((A :41 (((S' _28) (_850 #32)) ((C _850) #126))) ((A :42 _847) ((A :43 _848) ((A :44 _850) ((A :45 _849) ((A :46 (((S' _27) ((C _42) #32)) (((S' _27) ((C _42) #9)) ((C _42) #10)))) ((A :47 ((S ((S (((S' _28) (_44 #65)) ((C _44) #90))) (_34 (((_809 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _82) (((C' _83) _36) (_36 #65))) (_36 #97))))) ((A :48 ((S ((S (((S' _28) (_44 #97)) ((C _44) #97))) (_34 (((_809 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _82) (((C' _83) _36) (_36 #97))) (_36 #65))))) ((A :49 _818) ((A :50 _819) ((A :51 _820) ((A :52 _821) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _822) ((A :59 _823) ((A :60 _58) ((A :61 _59) ((A :62 _824) ((A :63 _825) ((A :64 _826) ((A :65 _827) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _828) ((A :71 ((B BK) T)) ((A :72 (BK T)) ((A :73 P) ((A :74 I) ((A :75 B) ((A :76 I) ((A :77 K) ((A :78 C) ((A :79 _854) ((A :80 ((C ((C S') _190)) _191)) ((A :81 (((C' (S' (C' B))) B) I)) ((A :82 _812) ((A :83 _813) ((A :84 _814) ((A :85 _815) ((A :86 _816) ((A :87 _817) ((A :88 (_83 #0)) ((A :89 _835) ((A :90 _836) ((A :91 _837) ((A :92 _838) ((A :93 _839) ((A :94 _840) ((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 _27) (_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)))))))))) (((_809 "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
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -36,12 +36,13 @@
let
f i = mkIdent ("$f" ++ showInt i)fs = [f i | (i, _) <- zip (enumFrom 0) cs]
- dsConstr i (Constr c ts) =
+ dsConstr i (Constr c ets) =
let
+ ts = either id (map snd) ets
xs = [mkIdent ("$x" ++ showInt j) | (j, _) <- zip (enumFrom 0) ts]in (qualIdent mn c, lams xs $ lams fs $ apps (Var (f i)) (map Var xs))
in zipWith dsConstr (enumFrom 0) cs
- Newtype _ c _ -> [ (qualIdent mn c, Lit (LPrim "I")) ]
+ Newtype _ (Constr c _) -> [ (qualIdent mn c, Lit (LPrim "I")) ]
Type _ _ -> []
Fcn f eqns -> [(f, dsEqns (getSLocIdent f) eqns)]
Sign _ _ -> []
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -20,7 +20,7 @@
EKind, kType, kConstraint,
IdKind(..), idKindIdent,
LHS,
- Constr(..),
+ Constr(..), ConstrField,
ConTyInfo,
Con(..), conIdent, conArity, eqCon, getSLocCon,
tupleConstr, untupleConstr, isTupleConstr,
@@ -56,7 +56,7 @@
data EDef
= Data LHS [Constr]
- | Newtype LHS Ident EType
+ | Newtype LHS Constr
| Type LHS EType
| Fcn Ident [Eqn]
| Sign Ident EType
@@ -186,9 +186,11 @@
type LHS = (Ident, [IdKind])
-data Constr = Constr Ident [EType]
+data Constr = Constr Ident (Either [EType] [ConstrField])
--Xderiving(Show, Eq)
+type ConstrField = (Ident, EType) -- record label and type
+
-- Expr restricted to
-- * after desugaring: EApp and EVar
-- * before desugaring: EApp, EVar, ETuple, EList
@@ -368,7 +370,7 @@
showEDef def =
case def of
Data lhs cs -> "data " ++ showLHS lhs ++ " = " ++ intercalate " | " (map showConstr cs)
- Newtype lhs c t -> "newtype " ++ showLHS lhs ++ " = " ++ showIdent c ++ " " ++ showEType t
+ Newtype lhs c -> "newtype " ++ showLHS lhs ++ " = " ++ showConstr c
Type lhs t -> "type " ++ showLHS lhs ++ " = " ++ showEType t
Fcn i eqns -> unlines (map (\ (Eqn ps alts) -> showIdent i ++ " " ++ unwords (map showEPat ps) ++ showAlts "=" alts) eqns)
Sign i t -> showIdent i ++ " :: " ++ showEType t
@@ -385,7 +387,9 @@
ctx ts = showEType (ETuple ts) ++ " => "
showConstr :: Constr -> String
-showConstr (Constr i ts) = unwords (showIdent i : map showEType ts)
+showConstr (Constr c (Left ts)) = unwords (showIdent c : map showEType ts)
+showConstr (Constr c (Right fs)) = unwords (showIdent c : "{" : map f fs ++ ["}"])+ where f (i, t) = showIdent i ++ " :: " ++ showEType t ++ ","
showLHS :: LHS -> String
showLHS lhs =
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -7,6 +7,7 @@
mkIdentSLoc,
isLower_, isIdentChar, isOperChar, isConIdent,
dummyIdent, isDummyIdent,
+ unQualIdent,
unQualString,
addIdentSuffix,
SLoc(..), noSLoc, isNoSLoc,
@@ -81,6 +82,9 @@
'.':r -> unQualString r
else
s
+
+unQualIdent :: Ident -> Ident
+unQualIdent (Ident l s) = Ident l (unQualString s)
isConIdent :: Ident -> Bool
isConIdent (Ident _ i) =
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -248,9 +248,9 @@
pDef :: P EDef
pDef =
- Data <$> (pKeyword "data" *> pLHS) <*> ((pSymbol "=" *> esepBy1 (Constr <$> pUIdentSym <*> emany pAType) (pSymbol "|"))
+ Data <$> (pKeyword "data" *> pLHS) <*> ((pSymbol "=" *> esepBy1 (Constr <$> pUIdentSym <*> pFields) (pSymbol "|"))
<|< P.pure [])
- <|< Newtype <$> (pKeyword "newtype" *> pLHS) <*> (pSymbol "=" *> pUIdent) <*> pAType
+ <|< Newtype <$> (pKeyword "newtype" *> pLHS) <*> (pSymbol "=" *> (Constr <$> pUIdentSym <*> pField))
<|< Type <$> (pKeyword "type" *> pLHS) <*> (pSymbol "=" *> pType)
<|< uncurry Fcn <$> pEqns
<|< Sign <$> (pLIdentSym <* pSymbol "::") <*> pType
@@ -266,6 +266,13 @@
pPrec = satisfyM "digit" dig
pContext = (pCtx <* pSymbol "=>") <|< P.pure []
pCtx = pParens (emany pType) <|< ((:[]) <$> pTypeApp)
+
+ pFields = Left <$> emany pAType <|<
+ Right <$> (pSpec '{' *> esepBy ((,) <$> (pLIdentSym <* pSymbol "::") <*> pType) (pSpec ',') <* pSpec '}')+ pField = P.do
+ fs <- pFields
+ guard $ either length length fs == 1
+ P.pure fs
pLHS :: P LHS
pLHS = (,) <$> pUIdentSym <*> emany pIdKind
--- 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
@@ -19,29 +19,44 @@
--Ximport GHC.Stack
--Ximport Debug.Trace
-data TModule a = TModule IdentModule [FixDef] [TypeExport] [SynDef] [ValueExport] a
+data TModule a = TModule
+ IdentModule -- module names
+ [FixDef] -- all fixities, exported or not
+ [TypeExport] -- exported types
+ [SynDef] -- all type synonyms, exported or not
+ [ValueExport] -- exported values (including from T(..))
+ a -- bindings
--Xderiving (Show)
-data TypeExport = TypeExport Ident Entry [ValueExport]
+data TypeExport = TypeExport
+ Ident -- unqualified name
+ Entry -- symbol table entry
+ [ValueExport] -- associated values, i.e., constructors, selectors, methods
--Xderiving (Show)
-data ValueExport = ValueExport Ident Entry
+data ValueExport = ValueExport
+ Ident -- unqualified name
+ Entry -- symbol table entry
--Xderiving (Show)
type FixDef = (Ident, Fixity)
type SynDef = (Ident, EType)
-data Entry = Entry Expr EType
+-- Symbol table entry for symbol i.
+data Entry = Entry
+ Expr -- convert (EVar i) to this expression; sometimes just (EVar i)
+ EType -- type/kind of identifier
--Xderiving(Show)
entryType :: Entry -> EType
entryType (Entry _ t) = t
-type ValueTable = M.Map [Entry]
-type TypeTable = M.Map [Entry]
-type KindTable = M.Map [Entry]
-type SynTable = M.Map EType
-type FixTable = M.Map Fixity
+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 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
type Sigma = EType
--type Tau = EType
@@ -53,22 +68,17 @@
-- 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 mn tds impossible)
+ thisMdl = (mn, mkTModule tds tcs)
impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ m mm _, tm) <- imps]
impMap = M.fromList [(i, m) | (i, m) <- thisMdl : impMdls]
- (texps, sexps, vexps) =
- unzip3 $ map (getTVExps impMap (typeTable tcs) (synTable tcs) (valueTable tcs)) exps
-{-- in TModule mn [] (concat texps) (concat sexps) (concat vexps) tds
(texps, vexps) =
unzip $ map (getTVExps impMap (typeTable tcs) (valueTable tcs)) exps
- (fexps, sexps) = unzip $ getFSExps impMap
--}
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
-- A hack to force evaluation of errors.
@@ -97,31 +107,23 @@
(imp, TModule mn fx ts' ss vs' a)
-- Type and value exports
-getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> SynTable -> ValueTable -> ExportItem ->
- ([TypeExport], [SynDef], [ValueExport])
-getTVExps impMap _ _ _ (ExpModule m) =
+getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> ValueTable -> ExportItem ->
+ ([TypeExport], [ValueExport])
+getTVExps impMap _ _ (ExpModule m) =
case M.lookup m impMap of
- Just (TModule _ _ te se ve _) -> (te, se, ve)
--- Just (TModule _ _ te _ ve _) -> (te, ve)
+ Just (TModule _ _ te _ ve _) -> (te, ve)
_ -> expErr m
-getTVExps _ tys _ vals (ExpTypeCon i) =
+getTVExps _ tys vals (ExpTypeCon i) =
let
e = expLookup i tys
qi = tyQIdent e
- in seq e ([TypeExport i e $ constrsOf qi (M.toList vals)], [], [])
-getTVExps _ tys syns _ (ExpType i) =
+ in ([TypeExport i e $ constrsOf qi (M.toList vals)], [])
+getTVExps _ tys _ (ExpType i) =
let
e = expLookup i tys
- qi = tyQIdent e
- se = case M.lookup qi syns of
- Nothing -> []
- Just ts -> [(qi, ts)]
- in seq e ([TypeExport i e []], se, [])
--- in ([TypeExport i e []], [])
-getTVExps _ _ _ vals (ExpValue i) =
- let
- e = (expLookup i vals)
- in seq e ([], [], [ValueExport i e])
+ in ([TypeExport i e []], [])
+getTVExps _ _ vals (ExpValue i) =
+ ([], [ValueExport i (expLookup i vals)])
-- Export all fixities and synonyms.
-- The synonyms might be needed, and the fixities are harmless
@@ -161,67 +163,82 @@
expErr :: forall a . Ident -> a
expErr i = errorMessage (getSLocIdent i) $ "export undefined " ++ showIdent i
-mkTModule :: forall a . IdentModule -> [EDef] -> a -> TModule a
-mkTModule mn tds a =
+-- 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 ts) =
- let
- e = ECon $ ConData ci (qualIdent mn ic)
- 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, length ts) | Constr c ts <- 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))))]
- tentry i vks kret = Entry (EVar (qualIdent mn i)) (lhsKind vks kret)
+ mn = moduleName 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 vks kType) (cons i vks cs) | Data (i, vks) cs <- tds ] ++
- [ TypeExport i (tentry i vks kType) (conn i vks c t) | Newtype (i, vks) c t <- tds ] ++
- [ TypeExport i (tentry i vks kType) [] | Type (i, vks) _ <- tds ] -- XXX kType is wrong
+ [ 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 a
+ 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 =
@@ -241,7 +258,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
@@ -248,50 +265,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
@@ -304,20 +324,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 +456,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)
@@ -538,8 +563,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
@@ -548,8 +573,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
tLookup :: --XHasCallStack =>
@@ -588,12 +613,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
- extValE i t (EVar $ qualIdent mn i)
+ 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
@@ -617,8 +654,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 =>
@@ -676,7 +713,7 @@
tcReset
case adef of
Data (i, vks) cs -> withVks vks kType $ \ vvks _ -> T.return $ Data (i, vvks) cs
- Newtype (i, vks) c t -> withVks vks kType $ \ vvks _ -> T.return $ Newtype (i, vvks) c t
+ Newtype (i, vks) c -> withVks vks kType $ \ vvks _ -> T.return $ Newtype (i, vvks) c
Type (i, vks) at ->
case at of
ESign t k -> withVks vks k $ \ vvks kr -> T.return $ Type (i, vvks) (ESign t kr)
@@ -703,10 +740,19 @@
-- Add symbol table entries (with kind) for all top level typeish definitions
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 (assocData c)
Type lhs t -> addLHSKind lhs (getTypeKind t)
Class _ lhs _ -> addLHSKind lhs kConstraint
_ -> T.return ()
@@ -718,7 +764,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
@@ -739,7 +785,7 @@
tcReset
case d of
Data lhs@(_, iks) cs -> withVars iks $ Data lhs <$> T.mapM tcConstr cs
- Newtype lhs@(_, iks) c t -> withVars iks $ Newtype lhs c <$> tCheckTypeT kType t
+ Newtype lhs@(_, iks) c -> withVars iks $ Newtype lhs <$> tcConstr c
Type lhs@(_, iks) t -> withVars iks $ Type lhs <$> tInferTypeT t
Sign i t -> Sign i <$> tCheckTypeT kType t
ForImp ie i t -> ForImp ie i <$> tCheckTypeT kType t
@@ -759,7 +805,9 @@
withExtVal i k $ withVars iks ta
tcConstr :: Constr -> T Constr
-tcConstr (Constr i ts) = Constr i <$> T.mapM (\ t -> tcTypeT (Check kType) t) ts
+tcConstr (Constr c ets) =
+ Constr c <$> either (\ x -> Left T.<$> T.mapM (\ t -> tcTypeT (Check kType) t) x)
+ (\ x -> Right T.<$> T.mapM (\ (i,t) -> (i,) <$> tcTypeT (Check kType) t) x) ets
expandClassInst :: EDef -> T [EDef]
expandClassInst d@(Class ctx lhs m) = (d:) <$> expandClass ctx lhs m
@@ -799,7 +847,7 @@
nSups = length sups
nArgs = nSups + nMeths
iCon = iDict -- dictionary constructor name
- dData = Data (iDict, vs) [Constr iCon $ supTys ++ methTys]
+ dData = Data (iDict, vs) [Constr iCon $ Left $ supTys ++ methTys]
ex = EVar (mkIdent "x")
tForall = EForall vs
@@ -873,23 +921,21 @@
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, length ts) | Constr c ts <- cs ]
+ cti = [ (qualIdent mn c, either length length ets) | Constr c ets <- cs ]
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
- addCon (Constr c ts) =
- extValE c (EForall vks $ foldr tArrow tret ts) (ECon $ ConData cti (qualIdent mn c))
+ addCon (Constr c ets) = T.do
+ let ts = either id (map snd) ets
+ 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
+ Newtype (i, vks) (Constr c fs) -> T.do
let
+ t = head $ either id (map snd) fs
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)
--
⑨