ref: fb418b077823bb00a7ad98af674dae5a83951e66
parent: a6ae2c8e86ad0a1d3e89b470ac3bd846ccc937a2
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Fri Oct 20 07:06:57 EDT 2023
Handle import/export of instances.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1085
-((A :0 _908) ((A :1 ((B _954) _0)) ((A :2 (((S' _954) _0) I)) ((A :3 _878) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _907) ((C _76) _5))) ((A :7 (((C' _6) (_925 _72)) ((_76 _923) _71))) ((A :8 ((B ((S _954) _923)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_76 _191)) _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 _836)))) ((A :19 ((B (_74 _9)) (BK (P _836)))) ((A :20 ((_74 _9) ((S P) I))) ((A :21 ((B (_74 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _116)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _117)))))) ((A :23 ((B Y) ((B (B (P (_14 _836)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _836))) ((A :26 (_22 _77)) ((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 _883) ((A :36 _884) ((A :37 (((S' _28) (_875 #97)) ((C _875) #122))) ((A :38 (((S' _28) (_875 #65)) ((C _875) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_875 #48)) ((C _875) #57))) ((A :41 (((S' _28) (_875 #32)) ((C _875) #126))) ((A :42 _872) ((A :43 _873) ((A :44 _875) ((A :45 _874) ((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 (((_834 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #65))) (_36 #97))))) ((A :48 ((S ((S (((S' _28) (_44 #97)) ((C _44) #97))) (_34 (((_834 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #97))) (_36 #65))))) ((A :49 _843) ((A :50 _844) ((A :51 _845) ((A :52 _846) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _847) ((A :59 _848) ((A :60 _58) ((A :61 _59) ((A :62 _849) ((A :63 _850) ((A :64 _851) ((A :65 _852) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _853) ((A :71 ((B BK) T)) ((A :72 (BK T)) ((A :73 P) ((A :74 I) ((A :75 (S _880)) ((A :76 B) ((A :77 I) ((A :78 K) ((A :79 C) ((A :80 _879) ((A :81 ((C ((C S') _191)) _192)) ((A :82 (((C' (S' (C' B))) B) I)) ((A :83 _837) ((A :84 _838) ((A :85 _839) ((A :86 _840) ((A :87 _841) ((A :88 _842) ((A :89 (_84 #0)) ((A :90 _860) ((A :91 _861) ((A :92 _862) ((A :93 _863) ((A :94 _864) ((A :95 _865) ((A :96 _90) ((A :97 (BK K)) ((A :98 ((B BK) ((B (B BK)) P))) ((A :99 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :100 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_93 #0))) (_90 #0)))) ((B (B ((C' P) (_88 #1)))) _83))) (C P))) _86)) _87)) ((A :101 _97) ((A :102 (((S' C) ((B (P _179)) (((C' (C' B)) (((C' C) _90) _179)) _180))) ((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') (_90 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_90 #1)))) ((B ((C' C) ((B ((C' S') (_90 #2))) (C _102)))) (C _102))))) (C _102))))) (C _102)))) (T K))) (T A)))) ((C _100) #4)))) ((A :103 (_109 _78)) ((A :104 ((_124 (_81 _103)) _101)) ((A :105 ((C (((C' B) ((P _116) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _106)))) (((S' (C' (C' B))) ((B (B (B _106))) (((S' (C' B)) ((B (B _106)) (((C' B) ((B _122) (T #0))) _105))) (((C' B) ((B _122) (T #1))) _105)))) (((C' B) ((B _122) (T #2))) _105)))) (((C' B) ((B _122) (T #3))) _105)))) ((B T) ((B (B P)) ((C' _83) (_85 #4)))))) ((A :106 ((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) _92)))) ((B ((C' B) _117)) _106)))))) ((B ((C' B) _117)) (C _106)))))))))) (((_834 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :107 ((_76 (_122 _191)) _105)) ((A :108 (((C' C) (((C' C) (C _102)) (_3 "Data.IntMap.!"))) I)) ((A :109 ((B (C' Y)) (((C' (C' (S' (S' C)))
\ No newline at end of file
+1089
+((A :0 _912) ((A :1 ((B _958) _0)) ((A :2 (((S' _958) _0) I)) ((A :3 _882) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _911) ((C _76) _5))) ((A :7 (((C' _6) (_929 _72)) ((_76 _927) _71))) ((A :8 ((B ((S _958) _927)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_76 _191)) _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 _840)))) ((A :19 ((B (_74 _9)) (BK (P _840)))) ((A :20 ((_74 _9) ((S P) I))) ((A :21 ((B (_74 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _116)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _117)))))) ((A :23 ((B Y) ((B (B (P (_14 _840)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _840))) ((A :26 (_22 _77)) ((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 _887) ((A :36 _888) ((A :37 (((S' _28) (_879 #97)) ((C _879) #122))) ((A :38 (((S' _28) (_879 #65)) ((C _879) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_879 #48)) ((C _879) #57))) ((A :41 (((S' _28) (_879 #32)) ((C _879) #126))) ((A :42 _876) ((A :43 _877) ((A :44 _879) ((A :45 _878) ((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 (((_838 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #65))) (_36 #97))))) ((A :48 ((S ((S (((S' _28) (_44 #97)) ((C _44) #97))) (_34 (((_838 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #97))) (_36 #65))))) ((A :49 _847) ((A :50 _848) ((A :51 _849) ((A :52 _850) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _851) ((A :59 _852) ((A :60 _58) ((A :61 _59) ((A :62 _853) ((A :63 _854) ((A :64 _855) ((A :65 _856) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _857) ((A :71 ((B BK) T)) ((A :72 (BK T)) ((A :73 P) ((A :74 I) ((A :75 (S _884)) ((A :76 B) ((A :77 I) ((A :78 K) ((A :79 C) ((A :80 _883) ((A :81 ((C ((C S') _191)) _192)) ((A :82 (((C' (S' (C' B))) B) I)) ((A :83 _841) ((A :84 _842) ((A :85 _843) ((A :86 _844) ((A :87 _845) ((A :88 _846) ((A :89 (_84 #0)) ((A :90 _864) ((A :91 _865) ((A :92 _866) ((A :93 _867) ((A :94 _868) ((A :95 _869) ((A :96 _90) ((A :97 (BK K)) ((A :98 ((B BK) ((B (B BK)) P))) ((A :99 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :100 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_93 #0))) (_90 #0)))) ((B (B ((C' P) (_88 #1)))) _83))) (C P))) _86)) _87)) ((A :101 _97) ((A :102 (((S' C) ((B (P _179)) (((C' (C' B)) (((C' C) _90) _179)) _180))) ((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') (_90 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_90 #1)))) ((B ((C' C) ((B ((C' S') (_90 #2))) (C _102)))) (C _102))))) (C _102))))) (C _102)))) (T K))) (T A)))) ((C _100) #4)))) ((A :103 (_109 _78)) ((A :104 ((_124 (_81 _103)) _101)) ((A :105 ((C (((C' B) ((P _116) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _106)))) (((S' (C' (C' B))) ((B (B (B _106))) (((S' (C' B)) ((B (B _106)) (((C' B) ((B _122) (T #0))) _105))) (((C' B) ((B _122) (T #1))) _105)))) (((C' B) ((B _122) (T #2))) _105)))) (((C' B) ((B _122) (T #3))) _105)))) ((B T) ((B (B P)) ((C' _83) (_85 #4)))))) ((A :106 ((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) _92)))) ((B ((C' B) _117)) _106)))))) ((B ((C' B) _117)) (C _106)))))))))) (((_838 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :107 ((_76 (_122 _191)) _105)) ((A :108 (((C' C) (((C' C) (C _102)) (_3 "Data.IntMap.!"))) I)) ((A :109 ((B (C' Y)) (((C' (C' (S' (S' C)))
\ No newline at end of file
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -81,7 +81,7 @@
compile flags nm ach = IO.do
((_, t), ch) <- runStateIO (compileModuleCached flags nm) ach
let
- defs (TModule _ _ _ _ _ ds) = ds
+ defs (TModule _ _ _ _ _ _ ds) = ds
IO.when (verbose flags > 0) $
putStrLn $ "total import time " ++ padLeft 6 (showInt t) ++ "ms"
IO.return (concatMap defs $ M.elems $ cache ch, ch)
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -26,8 +26,8 @@
desugar :: TModule [EDef] -> TModule [LDef]
desugar atm =
case atm of
- TModule mn fxs tys syns vals ds ->
- TModule mn fxs tys syns vals $ checkDup $ concatMap (dsDef mn) ds
+ TModule mn fxs tys syns insts vals ds ->
+ TModule mn fxs tys syns insts vals $ checkDup $ concatMap (dsDef mn) ds
dsDef :: IdentModule -> EDef -> [LDef]
dsDef mn adef =
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -27,6 +27,7 @@
[FixDef] -- all fixities, exported or not
[TypeExport] -- exported types
[SynDef] -- all type synonyms, exported or not
+ [InstDict] -- all instances
[ValueExport] -- exported values (including from T(..))
a -- bindings
--Xderiving (Show)
@@ -76,8 +77,8 @@
-- trace (show amdl) $
let
imps = map filterImports aimps
- (fs, ts, ss, vs, as) = mkTables imps
- in case tcRun (tcDefs defs) (initTC mn fs ts ss vs as) of
+ (fs, ts, ss, is, vs, as) = mkTables imps
+ in case tcRun (tcDefs defs) (initTC mn fs ts ss is vs as) of
(tds, tcs) ->
let
thisMdl = (mn, mkTModule tds tcs)
@@ -85,15 +86,16 @@
impMap = M.fromList [(i, m) | (i, m) <- thisMdl : impMdls]
(texps, vexps) =
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
+ fexps = [ fe | TModule _ fe _ _ _ _ _ <- M.elems impMap ]
+ sexps = [ se | TModule _ _ _ se _ _ _ <- M.elems impMap ]
+ iexps = [ ie | TModule _ _ _ _ ie _ _ <- M.elems impMap ]
+ in tModule mn (nubBy (eqIdent `on` fst) (concat fexps)) (concat texps) (concat sexps) (concat iexps) (concat vexps) tds
-- A hack to force evaluation of errors.
-- This should be redone to all happen in the T monad.
-tModule :: IdentModule -> [FixDef] -> [TypeExport] -> [SynDef] -> [ValueExport] -> [EDef] ->
+tModule :: IdentModule -> [FixDef] -> [TypeExport] -> [SynDef] -> [InstDict] -> [ValueExport] -> [EDef] ->
TModule [EDef]
-tModule mn fs ts ss vs ds = seqL ts `seq` seqL vs `seq` TModule mn fs ts ss vs ds
+tModule mn fs ts ss is vs ds = seqL ts `seq` seqL vs `seq` TModule mn fs ts ss is vs ds
where
seqL :: forall a . [a] -> ()
seqL [] = ()
@@ -101,7 +103,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 vs a) =
+filterImports (imp@(ImportSpec _ _ _ (Just (hide, is))), TModule mn fx ts ss ins vs a) =
let
keep x xs = elemBy eqIdent x xs `neBool` hide
ivs = [ i | ImpValue i <- is ]
@@ -112,7 +114,7 @@
filter (\ (TypeExport i _ _) -> keep i its) ts
in
--trace (show (ts, vs)) $
- (imp, TModule mn fx ts' ss vs' a)
+ (imp, TModule mn fx ts' ss ins vs' a)
-- Type and value exports
getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> ValueTable -> AssocTable -> ExportItem ->
@@ -119,7 +121,7 @@
([TypeExport], [ValueExport])
getTVExps impMap _ _ _ (ExpModule m) =
case M.lookup m impMap of
- Just (TModule _ _ te _ ve _) -> (te, ve)
+ Just (TModule _ _ te _ _ ve _) -> (te, ve)
_ -> expErr m
getTVExps _ tys vals ast (ExpTypeCon i) =
let
@@ -177,6 +179,7 @@
tt = typeTable tcs
at = assocTable tcs
vt = valueTable tcs
+ it = instTable tcs
-- Find the Entry for a type.
tentry i =
@@ -200,8 +203,11 @@
-- All fixity declaration.
fes = [ (qualIdent mn i, fx) | Infix fx is <- tds, i <- is ]
- in TModule mn fes tes ses ves impossible
+ -- All instances
+ ies = concat $ M.elems it
+ in TModule mn fes tes ses ies ves impossible
+
-- Find all value Entry for names associated with a type.
getAssocs :: ValueTable -> AssocTable -> Ident -> [ValueExport]
getAssocs vt at ai =
@@ -211,7 +217,7 @@
_ -> impossible
in map (\ qi -> ValueExport (unQualIdent qi) (val qi)) qis
-mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, ValueTable, AssocTable)
+mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, InstTable, ValueTable, AssocTable)
mkTables mdls =
let
qns (ImportSpec q _ mas _) mn i =
@@ -221,32 +227,37 @@
allValues :: ValueTable
allValues =
let
- syms (is, TModule mn _ tes _ ves _) =
+ 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 (_, TModule _ _ _ ses _ _) = ses
+ syns (_, TModule _ _ _ ses _ _ _) = ses
in M.fromList (concatMap syns mdls)
allTypes :: TypeTable
allTypes =
let
- types (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
+ fixes (_, TModule _ fes _ _ _ _ _) = fes
in M.fromList (concatMap fixes 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
- in (allFixes, allTypes, allSyns, allValues, allAssocs)
+ allInsts :: InstTable
+ allInsts =
+ let
+ insts (_, TModule _ _ _ _ ies _ _) = map (\ ie -> (getInstCon ie, [ie])) ies
+ in M.fromListWith (unionBy eqInstDict) $ concatMap insts mdls
+ in (allFixes, allTypes, allSyns, allInsts, allValues, allAssocs)
eqEntry :: Entry -> Entry -> Bool
eqEntry x y =
@@ -265,8 +276,8 @@
-- Approximate equality for dictionaries.
-- The important thing is to avoid exact duplicates in the instance table.
eqInstDict :: InstDict -> InstDict -> Bool
-eqInstDict (EVar i, _, _, _) (EVar i', _, _, _) | i == i' = True
-eqInstDict _ _ = False
+eqInstDict (EVar i, _, _, _) (EVar i', _, _, _) = eqIdent i i'
+eqInstDict _ _ = False
getInstCon :: InstDict -> Ident
getInstCon (_, _, _, t) = getAppCon t
@@ -320,8 +331,8 @@
tcMode :: TCState -> TCMode
tcMode (TC _ _ _ _ _ _ _ _ m _ _ _) = m
-instances :: TCState -> InstTable
-instances (TC _ _ _ _ _ _ _ _ _ _ is _) = is
+instTable :: TCState -> InstTable
+instTable (TC _ _ _ _ _ _ _ _ _ _ is _) = is
constraints :: TCState -> Constraints
constraints (TC _ _ _ _ _ _ _ _ _ _ _ e) = e
@@ -391,7 +402,7 @@
addInstTable :: [InstDict] -> T ()
addInstTable ics = T.do
- is <- gets instances
+ is <- gets instTable
putInstTable $ foldr (\ ic -> M.insertWith (unionBy eqInstDict) (getInstCon ic) [ic]) is ics
addConstraint :: String -> (Ident, EConstraint) -> T ()
@@ -402,7 +413,7 @@
withDict :: forall a . Ident -> EConstraint -> T a -> T a
withDict i c ta = T.do
- is <- gets instances
+ is <- gets instTable
ics <- expandDict (EVar i) c
addInstTable ics
a <- ta
@@ -409,14 +420,13 @@
putInstTable is
T.return a
--- XXX handle imports
-initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> ValueTable -> AssocTable -> TCState
-initTC mn fs ts ss vs as =
+initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> InstTable -> ValueTable -> AssocTable -> TCState
+initTC mn fs ts ss is 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 as IM.empty TCExpr M.empty M.empty []
+ in TC mn 1 fs xts ss xvs as IM.empty TCExpr M.empty is []
kTypeS :: EType
kTypeS = kType
@@ -1675,7 +1685,7 @@
showTModule :: forall a . (a -> String) -> TModule a -> String
showTModule sh amdl =
case amdl of
- TModule mn _ _ _ _ a -> "Tmodule " ++ showIdent mn ++ "\n" ++ sh a ++ "\n"
+ TModule mn _ _ _ _ _ a -> "Tmodule " ++ showIdent mn ++ "\n" ++ sh a ++ "\n"
{-showValueTable :: ValueTable -> String
@@ -1868,12 +1878,12 @@
if null cs then
T.return []
else T.do
- traceM "solveConstraints"
+-- traceM "solveConstraints"
cs' <- T.mapM (\ (i,t) -> T.do { t' <- derefUVar t; T.return (i,t') }) cs- traceM ("constraints:\n" ++ unlines (map (\ (i, t) -> showIdent i ++ " :: " ++ showExpr t) cs'))- it <- gets instances
+-- traceM ("constraints:\n" ++ unlines (map (\ (i, t) -> showIdent i ++ " :: " ++ showExpr t) cs'))+ it <- gets instTable
let instsOf c = fromMaybe [] $ M.lookup c it
- traceM ("instances:\n" ++ unlines (map (\ (i, _, _, t) -> showExpr i ++ " :: " ++ showExpr t) (concat $ M.elems it)))+-- traceM ("instances:\n" ++ unlines (map (\ (i, _, _, t) -> showExpr i ++ " :: " ++ showExpr t) (concat $ M.elems it)))let solve :: [(Ident, EType)] -> [(Ident, EType)] -> [(Ident, Expr)] -> T ([(Ident, EType)], [(Ident, Expr)])
solve [] uns sol = T.return (uns, sol)
solve (cns@(di, ct) : cnss) uns sol = T.do
@@ -1890,8 +1900,8 @@
_ -> tcError loc $ "Multiple constraint solutions for: " ++ showEType ct
(unsolved, solved) <- solve cs' [] []
putConstraints unsolved
- traceM ("solved:\n" ++ unlines [ showIdent i ++ " = " ++ showExpr e | (i, e) <- solved ])- traceM ("unsolved:\n" ++ unlines [ showIdent i ++ " :: " ++ showEType t | (i, t) <- unsolved ])+-- traceM ("solved:\n" ++ unlines [ showIdent i ++ " = " ++ showExpr e | (i, e) <- solved ])+-- traceM ("unsolved:\n" ++ unlines [ showIdent i ++ " :: " ++ showEType t | (i, t) <- unsolved ])T.return solved
-- Check that there are no unsolved constraints.
--
⑨