ref: 46673fc845c588c477b815ce6e3fd2ca195493eb
parent: 6a67714e02cd9cd49377591c39f03bb1f06814f7
parent: 86b1b129b5c087b0833586855cdf82ab817a9bda
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Sun Oct 13 08:43:59 EDT 2024
Merge branch 'master' into mhs-builtin
--- a/TODO
+++ b/TODO
@@ -43,7 +43,6 @@
* Install a targets.conf?
* let...in... doesn't parse correctly in a do
* let needs {} in a do with {}-* missing import in Text.Read.Internal gmhs: expandDict: Data.Floating.Floating
* export list in -boot doesn't work
* Cannot derive Show for 'newtype Alt f a = Alt (f a)'
* Fundep bug mtl:Control/Monad/RWS/Class.hs
--- a/lib/Text/Read/Internal.hs
+++ b/lib/Text/Read/Internal.hs
@@ -54,7 +54,6 @@
import Data.Either
import Data.Eq
import Data.Float
-import Data.Floating
import Data.Fractional
import Data.Function
import Data.Maybe
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -107,7 +107,7 @@
((cm, syms, t), ch) <- runStateIO comp ach
when (verbosityGT flags 0) $
putStrLn $ "total import time " ++ padLeft 6 (show t) ++ "ms"
- return ((tModuleName cm, concatMap bindingsOf $ cachedModules ch), syms, ch)
+ return ((tModuleName cm, concatMap tBindingsOf $ cachedModules ch), syms, ch)
-- Compile a module with the given name.
-- If the module has already been compiled, return the cached result.
@@ -180,18 +180,20 @@
(impMdls, _, tImps) <- fmap unzip3 $ mapM (uncurry $ compileModuleCached flags) imported
t3 <- liftIO getTimeMilli
+ glob <- gets getCacheTables
let
- (tmdl, syms) = typeCheck impt (zip specs impMdls) mdl
+ (tmdl, glob', syms) = typeCheck glob impt (zip specs impMdls) mdl
+ modify $ setCacheTables glob'
when (verbosityGT flags 3) $
liftIO $ putStrLn $ "type checked:\n" ++ showTModule showEDefs tmdl ++ "-----\n"
let
dmdl = desugar flags tmdl
- () <- return $ rnfErr $ bindingsOf dmdl
+ () <- return $ rnfErr $ tBindingsOf dmdl
t4 <- liftIO getTimeMilli
let
- cmdl = setBindings [ (i, compileOpt e) | (i, e) <- bindingsOf dmdl ] dmdl
- () <- return $ rnfErr $ bindingsOf cmdl -- This makes execution slower, but speeds up GC
+ cmdl = setBindings dmdl [ (i, compileOpt e) | (i, e) <- tBindingsOf dmdl ]
+ () <- return $ rnfErr $ tBindingsOf cmdl -- This makes execution slower, but speeds up GC
-- () <- return $ rnfErr syms same for this, but worse total time
t5 <- liftIO getTimeMilli
--- a/src/MicroHs/CompileCache.hs
+++ b/src/MicroHs/CompileCache.hs
@@ -3,6 +3,7 @@
Cache, addWorking, getWorking, emptyCache, deleteFromCache, workToDone, addBoot, getBoots,
cachedModules, lookupCache, lookupCacheChksum, getImportDeps,
addPackage, getCompMdls, getPathPkgs, getPkgs,
+ getCacheTables, setCacheTables,
saveCache, loadCached,
) where
import Prelude(); import MHSPrelude
@@ -11,7 +12,7 @@
import MicroHs.Ident(showIdent)
import qualified MicroHs.IdentMap as M
import MicroHs.Package
-import MicroHs.TypeCheck(TModule, tModuleName)
+import MicroHs.TypeCheck(TModule, tModuleName, GlobTables, emptyGlobTables, mergeGlobTables)
import System.IO
import System.IO.Serialize
import System.IO.MD5(MD5CheckSum)
@@ -40,12 +41,20 @@
working :: [IdentModule], -- modules currently being processed (used to detected circular imports)
boots :: [IdentModule], -- modules where only the boot version has been compiled
cache :: M.Map CacheEntry, -- cached compiled modules
- pkgs :: [(FilePath, Package)] -- loaded packages
+ pkgs :: [(FilePath, Package)], -- loaded packages
+ tables :: GlobTables
}
-- deriving (Show)
+getCacheTables :: Cache -> GlobTables
+getCacheTables = tables
+
+setCacheTables :: GlobTables -> Cache -> Cache
+setCacheTables ct c = c{ tables = ct }+
emptyCache :: Cache
-emptyCache = Cache { working = [], boots = [], cache = M.empty, pkgs = [] }+emptyCache =
+ Cache { working = [], boots = [], cache = M.empty, pkgs = [], tables = emptyGlobTables }deleteFromCache :: IdentModule -> Cache -> Cache
deleteFromCache mn c = c{ cache = M.delete mn (cache c) }@@ -94,7 +103,11 @@
getPkgs = map snd . pkgs
addPackage :: FilePath -> Package -> Cache -> Cache
-addPackage f p c = c{ pkgs = (f, p) : pkgs c, cache = foldr ins (cache c) (pkgExported p ++ pkgOther p) }+addPackage f p c = c{+ pkgs = (f, p) : pkgs c,
+ cache = foldr ins (cache c) (pkgExported p ++ pkgOther p),
+ tables = mergeGlobTables (pkgTables p) (tables c)
+ }
where ins t = M.insert (tModuleName t) (PkgMdl t)
saveCache :: FilePath -> Cache -> IO ()
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -29,10 +29,8 @@
type LDef = (Ident, Exp)
desugar :: Flags -> TModule [EDef] -> TModule [LDef]
-desugar flags atm =
- case atm of
- TModule mn fxs tys syns clss insts vals ds ->
- TModule mn fxs tys syns clss insts vals $ map lazier $ checkDup $ concatMap (dsDef flags mn) ds
+desugar flags tm =
+ setBindings tm (map lazier $ checkDup $ concatMap (dsDef flags (tModuleName tm)) (tBindingsOf tm))
dsDef :: Flags -> IdentModule -> EDef -> [LDef]
dsDef flags mn adef =
--- a/src/MicroHs/IdentMap.hs
+++ b/src/MicroHs/IdentMap.hs
@@ -14,6 +14,7 @@
null,
size,
toList, elems, keys,
+ merge,
mapM,
) where
import Prelude(); import MHSPrelude hiding(lookup, mapM, null)
@@ -187,3 +188,8 @@
doubleR (Node ll _ lk lv (Node lrl _ lrk lrv lrr)) k v r = node (node ll lk lv lrl) lrk lrv (node lrr k v r)
doubleR (Node ll _ lk lv (One lrk lrv )) k v r = node (node ll lk lv Nil) lrk lrv (node Nil k v r)
doubleR _ _ _ _ = undefined
+
+-- Merge two maps. There is no guarantee which side "wins"
+merge :: Map a -> Map a -> Map a
+merge m1 m2 | size m1 <= size m2 = foldr (uncurry insert) m2 (toList m1)
+ | otherwise = merge m2 m1
--- a/src/MicroHs/Interactive.hs
+++ b/src/MicroHs/Interactive.hs
@@ -271,15 +271,11 @@
getTypeInCache :: Cache -> Ident -> EType
getTypeInCache cash i =
- case getCModule cash of
- TModule _ _ _ _ _ _ vals _ ->
- head $ [ t | ValueExport i' (Entry _ t) <- vals, i == i' ] ++ [undefined]
+ head $ [ t | ValueExport i' (Entry _ t) <- tValueExps (getCModule cash), i == i' ] ++ [undefined]
getKindInCache :: Cache -> Ident -> EType
getKindInCache cash i =
- case getCModule cash of
- TModule _ _ tys _ _ _ _ _ ->
- head $ [ k | TypeExport i' (Entry _ k) _ <- tys, i == i' ] ++ [undefined]
+ head $ [ k | TypeExport i' (Entry _ k) _ <- tTypeExps (getCModule cash), i == i' ] ++ [undefined]
-- This could be smarter:
-- ":a" should complete with commands
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -161,6 +161,7 @@
pkg = Package { pkgName = mkIdent name, pkgVersion = ver, pkgCompiler = mhsVersion
, pkgExported = exported, pkgOther = other
+ , pkgTables = getCacheTables cash
, pkgDepends = pkgDeps }
--print (map tModuleName $ pkgOther pkg)
t1 <- getTimeMilli
--- a/src/MicroHs/Package.hs
+++ b/src/MicroHs/Package.hs
@@ -6,7 +6,7 @@
import Data.Version
import MicroHs.Desugar(LDef)
import MicroHs.Ident(Ident)
-import MicroHs.TypeCheck(TModule)
+import MicroHs.TypeCheck(TModule, GlobTables)
--
-- Packages are organized as follows:
@@ -31,6 +31,7 @@
pkgCompiler :: String, -- compiler version that created the package
pkgExported :: [TModule [LDef]], -- exported modules
pkgOther :: [TModule [LDef]], -- non-exported modules
+ pkgTables :: GlobTables, -- global tables
pkgDepends :: [(IdentPackage, Version)] -- used packages
}
-- deriving (Show)
--- a/src/MicroHs/TCMonad.hs
+++ b/src/MicroHs/TCMonad.hs
@@ -82,7 +82,7 @@
-- All known type equalities, contains the transitive&commutative closure.
type TypeEqTable = [(EType, EType)]
-type ClassInfo = ([IdKind], [EConstraint], EKind, [Ident], [IFunDep]) -- class tyvars, superclasses, class kind, methods, fundeps
+data ClassInfo = ClassInfo [IdKind] [EConstraint] EKind [Ident] [IFunDep] -- class tyvars, superclasses, class kind, methods, fundeps
type IFunDep = ([Bool], [Bool]) -- the length of the lists is the number of type variables
-----------------------------------------------
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -4,11 +4,11 @@
{-# LANGUAGE FlexibleContexts #-}module MicroHs.TypeCheck(
typeCheck,
- TModule(..), showTModule, tModuleName,
+ TModule(..), showTModule,
+ GlobTables, emptyGlobTables, mergeGlobTables,
impossible, impossibleShow,
mkClassConstructor,
mkSuperSel,
- bindingsOf,
setBindings,
boolPrefix,
listPrefix,
@@ -114,28 +114,36 @@
----------------------
-type Symbols = (SymTab, SymTab)
+-- Certain data structures persist during the entire compilation
+-- session. The information is needed beyond the scope where it was defined.
+data GlobTables = GlobTables {+ gSynTable :: SynTable, -- type synonyms are needed for expansion
+ gClassTable :: ClassTable, -- classes are neede for superclass expansion
+ gInstInfo :: InstTable -- instances are implicitely global
+ }
-data TModule a = TModule
- IdentModule -- module names
- [FixDef] -- all fixities, exported or not
- [TypeExport] -- exported types
- [SynDef] -- all type synonyms, exported or not
- [ClsDef] -- all classes
- [InstDef] -- all instances
- [ValueExport] -- exported values (including from T(..))
- a -- bindings
--- deriving (Show)
+emptyGlobTables :: GlobTables
+emptyGlobTables = GlobTables { gSynTable = M.empty, gClassTable = M.empty, gInstInfo = M.empty }-tModuleName :: forall a . TModule a -> IdentModule
-tModuleName (TModule a _ _ _ _ _ _ _) = a
+mergeGlobTables :: GlobTables -> GlobTables -> GlobTables
+mergeGlobTables g1 g2 = GlobTables { gSynTable = M.merge (gSynTable g1) (gSynTable g2),+ gClassTable = M.merge (gClassTable g1) (gClassTable g2),
+ gInstInfo = M.merge (gInstInfo g1) (gInstInfo g2) }
-bindingsOf :: forall a . TModule a -> a
-bindingsOf (TModule _ _ _ _ _ _ _ a) = a
+type Symbols = (SymTab, SymTab)
-setBindings :: forall a . a -> TModule a -> TModule a
-setBindings a (TModule x1 x2 x3 x4 x5 x6 x7 _) = TModule x1 x2 x3 x4 x5 x6 x7 a
+data TModule a = TModule {+ tModuleName :: IdentModule, -- module names
+ tFixDefs :: [FixDef], -- all fixities, exported or not
+ tTypeExps :: [TypeExport], -- exported types
+ tValueExps :: [ValueExport], -- exported values (including from T(..))
+ tBindingsOf :: a -- bindings
+ }
+-- deriving (Show)
+setBindings :: TModule b -> a -> TModule a
+setBindings (TModule x y z w _) a = TModule x y z w a
+
data TypeExport = TypeExport
Ident -- unqualified name
Entry -- symbol table entry
@@ -152,42 +160,40 @@
--instance Show ValueExport where show (ValueExport i _) = showIdent i
type FixDef = (Ident, Fixity)
-type SynDef = (Ident, EType)
-type ClsDef = (Ident, ClassInfo)
-type InstDef= (Ident, InstInfo)
type Sigma = EType
---type Tau = EType
type Rho = EType
-typeCheck :: forall a . ImpType -> [(ImportSpec, TModule a)] -> EModule -> (TModule [EDef], Symbols)
-typeCheck impt aimps (EModule mn exps defs) =
+typeCheck :: forall a . GlobTables -> ImpType -> [(ImportSpec, TModule a)] -> EModule -> (TModule [EDef], GlobTables, Symbols)
+typeCheck globs impt aimps (EModule mn exps defs) =
-- trace (unlines $ map (showTModuleExps . snd) aimps) $
let
imps = map filterImports aimps
- (fs, ts, ss, cs, is, vs, as) = mkTables imps
- in case tcRun (tcDefs impt defs) (initTC mn fs ts ss cs is vs as) of
+ tc = mkTCState mn globs imps
+ in case tcRun (tcDefs impt defs) tc of
(tds, tcs) ->
let
thisMdl = (mn, mkTModule impt tds tcs)
impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ _ m mm _, tm) <- imps]
impMap = M.fromList [(i, m) | (i, m) <- thisMdl : impMdls]
- (texps, cexps, vexps) =
- unzip3 $ map (getTVExps impMap (typeTable tcs) (valueTable tcs) (assocTable tcs) (classTable tcs)) exps
- fexps = [ fe | TModule _ fe _ _ _ _ _ _ <- M.elems impMap ]
- sexps = M.toList (synTable tcs)
- iexps = M.toList (instTable tcs)
- in ( tModule mn (nubBy ((==) `on` fst) (concat fexps)) (concat texps) sexps (concat cexps) iexps (concat vexps) tds
+ (texps, vexps) =
+ unzip $ map (getTVExps impMap (typeTable tcs) (valueTable tcs) (assocTable tcs)) exps
+ fexps = map tFixDefs (M.elems impMap)
+ sexps = synTable tcs
+ iexps = instTable tcs
+ ctbl = classTable tcs
+ in ( tModule mn (nubBy ((==) `on` fst) (concat fexps)) (concat texps) {- sexps (concat cexps) iexps-} (concat vexps) tds+ , GlobTables { gSynTable = sexps, gClassTable = ctbl, gInstInfo = iexps }, (typeTable tcs, valueTable tcs)
)
-- A hack to force evaluation of errors.
-- This should be redone to all happen in the T monad.
-tModule :: IdentModule -> [FixDef] -> [TypeExport] -> [SynDef] -> [ClsDef] -> [InstDef] -> [ValueExport] -> [EDef] ->
+tModule :: IdentModule -> [FixDef] -> [TypeExport] -> [ValueExport] -> [EDef] ->
TModule [EDef]
-tModule mn fs ts ss cs is vs ds =
+tModule mn fs ts vs ds =
-- trace ("tmodule " ++ showIdent mn ++ ":\n" ++ show vs) $- tseq ts `seq` vseq vs `seq` TModule mn fs ts ss cs is vs ds
+ tseq ts `seq` vseq vs `seq` TModule mn fs ts vs ds
where
tseq [] = ()
tseq (TypeExport _ e _:xs) = e `seq` tseq xs
@@ -196,7 +202,7 @@
filterImports :: forall a . (ImportSpec, TModule a) -> (ImportSpec, TModule a)
filterImports it@(ImportSpec _ _ _ _ Nothing, _) = it
-filterImports (imp@(ImportSpec _ _ _ _ (Just (hide, is))), TModule mn fx ts ss cs ins vs a) =
+filterImports (imp@(ImportSpec _ _ _ _ (Just (hide, is))), TModule mn fx ts vs a) =
let
keep x xs = elem x xs /= hide
ivs = [ i | ImpValue i <- is ]
@@ -226,7 +232,7 @@
checkBad msg (ivs \\ allVs) .
checkBad msg (its \\ allTs))
--trace (show (ts, vs)) $
- (imp, TModule mn fx ts' ss cs ins vs' a)
+ (imp, TModule mn fx ts' vs' a)
checkBad :: forall a . String -> [Ident] -> a -> a
checkBad _ [] a = a
@@ -234,29 +240,26 @@
errorMessage (getSLoc i) $ msg ++ ": " ++ showIdent i
-- Type and value exports
-getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> ValueTable -> AssocTable -> ClassTable -> ExportItem ->
- ([TypeExport], [ClsDef], [ValueExport])
-getTVExps impMap _ _ _ _ (ExpModule m) =
+getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> ValueTable -> AssocTable -> ExportItem ->
+ ([TypeExport], [ValueExport])
+getTVExps impMap _ _ _ (ExpModule m) =
case M.lookup m impMap of
- Just (TModule _ _ te _ ce _ ve _) -> (te, ce, ve)
+ Just (TModule _ _ te ve _) -> (te, ve)
_ -> errorMessage (getSLoc m) $ "undefined module: " ++ showIdent m
-getTVExps _ tys vals ast cls (ExpTypeSome i is) = getTypeExp tys vals ast cls i (`elem` is)
-getTVExps _ tys vals ast cls (ExpTypeAll i ) = getTypeExp tys vals ast cls i (const True)
-getTVExps _ _ vals _ _ (ExpValue i) =
- ([], [], [ValueExport i (expLookup i vals)])
+getTVExps _ tys vals ast (ExpTypeSome i is) = getTypeExp tys vals ast i (`elem` is)
+getTVExps _ tys vals ast (ExpTypeAll i ) = getTypeExp tys vals ast i (const True)
+getTVExps _ _ vals _ (ExpValue i) =
+ ([], [ValueExport i (expLookup i vals)])
-- Export a type, filter exported values by p.
-getTypeExp :: TypeTable -> ValueTable -> AssocTable -> ClassTable -> Ident -> (Ident -> Bool) ->
- ([TypeExport], [ClsDef], [ValueExport])
-getTypeExp tys vals ast cls ti p =
+getTypeExp :: TypeTable -> ValueTable -> AssocTable -> Ident -> (Ident -> Bool) ->
+ ([TypeExport], [ValueExport])
+getTypeExp tys vals ast ti p =
let
e = expLookup ti tys
qi = tyQIdent e
ves = filter (\ (ValueExport i _) -> p i) $ getAssocs vals ast qi
- cl = case M.lookup qi cls of
- Just ci -> [(qi, ci)]
- Nothing -> []
- in ([TypeExport ti e ves], cl, [])
+ in ([TypeExport ti e ves], [])
expLookup :: Ident -> SymTab -> Entry
expLookup i m = either (errorMessage (getSLoc i)) id $ stLookup "export" i m
@@ -281,8 +284,8 @@
tt = typeTable tcs
at = assocTable tcs
vt = valueTable tcs
- ct = classTable tcs
- it = instTable tcs
+-- ct = classTable tcs
+-- it = instTable tcs
-- Find the Entry for a type.
tentry i =
@@ -306,12 +309,14 @@
[ TypeExport i (tentry i) (assoc i) | Class _ (i, _) _ _ <- tds ] ++
[ TypeExport i (tentry i) [] | Type (i, _) _ <- tds ]
+{--- All type synonym definitions.
ses = [ (qualIdent mn i, EForall True vs t) | Type (i, vs) t <- tds ]
-
+-}
-- All fixity declaration.
fes = [ (qualIdent mn i, fx) | Infix fx is <- tds, i <- is ]
+{--- All classes
-- XXX only export the locally defined classes
ces = M.toList ct
@@ -318,7 +323,8 @@
-- All instances
ies = M.toList it
- in TModule mn fes tes ses ces ies ves impossible
+-}
+ in TModule mn fes tes ves impossible
-- Find all value Entry for names associated with a type.
getAssocs :: (HasCallStack) => ValueTable -> AssocTable -> Ident -> [ValueExport]
@@ -329,22 +335,21 @@
_ -> impossible
in map (\ qi -> ValueExport (unQualIdent qi) (val qi)) qis
-mkTables :: forall a . [(ImportSpec, TModule a)] ->
- (FixTable, TypeTable, SynTable, ClassTable, InstTable, ValueTable, AssocTable)
-mkTables mdls =
+mkTCState :: IdentModule -> GlobTables -> [(ImportSpec, TModule a)] -> TCState
+mkTCState mdlName globs mdls =
let
allValues :: ValueTable
allValues =
let
- usyms (ImportSpec _ qual _ _ _, TModule _ _ tes _ _ _ ves _) =
+ usyms (ImportSpec _ qual _ _ _, TModule _ _ tes ves _) =
if qual then [] else
[ (i, [e]) | ValueExport i e <- ves, not (isInstId i) ] ++
[ (i, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs, not (isDefaultMethodId i) ]
- qsyms (ImportSpec _ _ _ mas _, TModule mn _ tes _ cls _ ves _) =
+ qsyms (ImportSpec _ _ _ mas _, TModule mn _ tes {-_ cls _-} ves _) =let m = fromMaybe mn mas in
[ (v, [e]) | ValueExport i e <- ves, let { v = qualIdent m i } ] ++ [ (v, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs, let { v = qualIdentD e m i } ] ++- [ (v, [Entry (EVar v) t]) | (i, (_, _, t, _, _)) <- cls, let { v = mkClassConstructor i } ]+ [ (v, [Entry (EVar v) t]) | (i, ClassInfo _ _ t _ _) <- M.toList (gClassTable globs), let { v = mkClassConstructor i } ]-- Default methods are always entered with their qualified original name.
qualIdentD (Entry e _) m i | not (isDefaultMethodId i) = qualIdent m i
| otherwise =
@@ -352,43 +357,40 @@
EVar qi -> qi
_ -> undefined
in stFromList (concatMap usyms mdls) (concatMap qsyms mdls)
- allSyns =
- let
- syns (_, TModule _ _ _ ses _ _ _ _) = ses
- in M.fromList (concatMap syns mdls)
allTypes :: TypeTable
allTypes =
let
- usyms (ImportSpec _ qual _ _ _, TModule _ _ tes _ _ _ _ _) =
+ usyms (ImportSpec _ qual _ _ _, TModule _ _ tes _ _) =
if qual then [] else [ (i, [e]) | TypeExport i e _ <- tes ]
- qsyms (ImportSpec _ _ _ mas _, TModule mn _ tes _ _ _ _ _) =
+ qsyms (ImportSpec _ _ _ mas _, TModule mn _ tes _ _) =
let m = fromMaybe mn mas in
[ (qualIdent m i, [e]) | TypeExport i e _ <- tes ]
in stFromList (concatMap usyms mdls) (concatMap qsyms mdls)
- allFixes =
- let
- fixes (_, TModule _ fes _ _ _ _ _ _) = fes
- in M.fromList (concatMap fixes mdls)
+
+ allFixes :: FixTable
+ allFixes = M.fromList (concatMap (tFixDefs . snd) mdls)
allAssocs :: AssocTable
allAssocs =
let
- assocs (ImportSpec _ _ _ mas _, TModule mn _ tes _ _ _ _ _) =
+ 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
- allClasses :: ClassTable
- allClasses =
- let
- clss (_, TModule _ _ _ _ ces _ _ _) = ces
- in --(\ m -> trace ("allClasses: " ++ showListS showIdentClassInfo (M.toList m)) m) $- M.fromList $ concatMap clss mdls
- allInsts :: InstTable
- allInsts =
- let
- insts (_, TModule _ _ _ _ _ ies _ _) = ies
- in M.fromListWith mergeInstInfo $ concatMap insts mdls
- in (allFixes, allTypes, allSyns, allClasses, allInsts, allValues, allAssocs)
+ in TC { moduleName = mdlName,+ unique = 1,
+ fixTable = addPrimFixs allFixes,
+ typeTable = foldr (uncurry stInsertGlbU) allTypes primTypes,
+ synTable = gSynTable globs,
+ valueTable = foldr (uncurry stInsertGlbU) allValues primValues,
+ assocTable = allAssocs,
+ uvarSubst = IM.empty,
+ tcMode = TCExpr,
+ classTable = gClassTable globs,
+ ctxTables = (gInstInfo globs, [], [], []),
+ constraints = [],
+ defaults = stdDefaults
+ }
mergeInstInfo :: InstInfo -> InstInfo -> InstInfo
mergeInstInfo (InstInfo m1 l1 fds) (InstInfo m2 l2 _) =
@@ -522,17 +524,6 @@
ads <- gets argDicts
putArgDicts ((i,c) : ads)
-initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> ClassTable -> InstTable -> ValueTable -> AssocTable -> TCState
-initTC mn fs ts ss cs is vs as =
--- trace ("**** initTC " ++ showIdent mn ++ ": " ++ showListS (showPairS showIdent showEType) (M.toList ss)) $- let
- xts = foldr (uncurry stInsertGlbU) ts primTypes
- xvs = foldr (uncurry stInsertGlbU) vs primValues
- in TC { moduleName = mn, unique = 1, fixTable = addPrimFixs fs, typeTable = xts,- synTable = ss, valueTable = xvs, assocTable = as, uvarSubst = IM.empty,
- tcMode = TCExpr, classTable = cs, ctxTables = (is,[],[],[]), constraints = [],
- defaults = stdDefaults }
-
stdDefaults :: [EType]
stdDefaults = [EVar identInteger, EVar identFloatW, EApp (EVar identList) (EVar identChar)]
@@ -1200,7 +1191,9 @@
dDflts = case impt of
ImpNormal -> concatMap mkDflt meths
ImpBoot -> []
- addClassTable (qualIdent mn iCls) (vks, ctx, EUVar 0, methIds, mkIFunDeps (map idKindIdent vks) fds) -- Initial entry, no type needed.
+ -- Add to the class table. XXX also in addValueClass???
+ addClassTable (qualIdent mn iCls)
+ (ClassInfo vks ctx (EUVar 0) methIds (mkIFunDeps (map idKindIdent vks) fds)) -- Initial entry, no type needed.
return $ dcls : dDflts
expandClass _ d = return [d]
@@ -1245,7 +1238,7 @@
-- (e, _) <- tLookupV iCls
ct <- gets classTable
-- let qiCls = getAppCon e
- (_, supers, _, mis, fds) <-
+ (ClassInfo _ supers _ mis fds) <-
case M.lookup qiCls ct of
Nothing -> tcError loc $ "not a class " ++ showIdent qiCls
Just x -> return x
@@ -1385,7 +1378,7 @@
-- tcTrace ("addValueClass " ++ showEType (ETuple ctx))mapM_ addMethod meths
-- Update class table, now with actual constructor type.
- addClassTable qiCls (vks, ctx, iConTy, methIds, mkIFunDeps (map idKindIdent vks) fds)
+ addClassTable qiCls (ClassInfo vks ctx iConTy methIds (mkIFunDeps (map idKindIdent vks) fds))
mkClassConstructor :: Ident -> Ident
mkClassConstructor i = addIdentSuffix i "$C"
@@ -2302,9 +2295,7 @@
tBool loc = tConI loc $ boolPrefix ++ "Bool"
showTModule :: forall a . (a -> String) -> TModule a -> String
-showTModule sh amdl =
- case amdl of
- TModule mn _ _ _ _ _ _ a -> "Tmodule " ++ showIdent mn ++ "\n" ++ sh a ++ "\n"
+showTModule sh amdl = "Tmodule " ++ showIdent (tModuleName amdl) ++ "\n" ++ sh (tBindingsOf amdl) ++ "\n"
-----------------------------------------------------
@@ -2481,7 +2472,7 @@
-- XXX it seems we can get here, e.g., Control.Monad.Fail without Applicative import
error ("expandDict: " ++ show iCls)return [(edict, vks, ctx, cc, [])]
- Just (iks, sups, _, _, fds) -> do
+ Just (ClassInfo iks sups _ _ fds) -> do
let
vs = map idKindIdent iks
sub = zip vs args
@@ -2567,7 +2558,7 @@
ct <- gets classTable
case M.lookup i ct of
Nothing -> return Nothing
- Just (_, supers, _, _, _) -> return $ Just $ map (fst . getApp) supers
+ Just (ClassInfo _ supers _ _ _) -> return $ Just $ map (fst . getApp) supers
checkDefaultTypes :: EType -> Constraints -> T Bool
checkDefaultTypes ty cs = do