ref: e817a361588850dd899f9fa30067a14469e116c9
parent: 30be00d866cac749277b60b67013771c3d737d84
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Fri Oct 20 19:58:21 EDT 2023
Export classes correctly.
--- a/Makefile
+++ b/Makefile
@@ -51,6 +51,7 @@
$(GHCB) -c ghc/Data/Double.hs
$(GHCB) -c src/PrimTable.hs
$(GHCC) -c lib/Control/Error.hs
+ $(GHCC) -c lib/Data/Eq.hs
$(GHCC) -c lib/Data/Bool.hs
$(GHCC) -c lib/Data/Int.hs
$(GHCC) -c lib/Data/Double.hs
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1092
-((A :0 _915) ((A :1 ((B _961) _0)) ((A :2 (((S' _961) _0) I)) ((A :3 _885) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _914) ((C _76) _5))) ((A :7 (((C' _6) (_932 _72)) ((_76 _930) _71))) ((A :8 ((B ((S _961) _930)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_76 _192)) _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 _843)))) ((A :19 ((B (_74 _9)) (BK (P _843)))) ((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 _843)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _843))) ((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 _890) ((A :36 _891) ((A :37 (((S' _28) (_882 #97)) ((C _882) #122))) ((A :38 (((S' _28) (_882 #65)) ((C _882) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_882 #48)) ((C _882) #57))) ((A :41 (((S' _28) (_882 #32)) ((C _882) #126))) ((A :42 _879) ((A :43 _880) ((A :44 _882) ((A :45 _881) ((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 (((_841 "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 (((_841 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #97))) (_36 #65))))) ((A :49 _850) ((A :50 _851) ((A :51 _852) ((A :52 _853) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _854) ((A :59 _855) ((A :60 _58) ((A :61 _59) ((A :62 _856) ((A :63 _857) ((A :64 _858) ((A :65 _859) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _860) ((A :71 ((B BK) T)) ((A :72 (BK T)) ((A :73 P) ((A :74 I) ((A :75 (S _887)) ((A :76 B) ((A :77 I) ((A :78 K) ((A :79 C) ((A :80 _886) ((A :81 ((C ((C S') _192)) _193)) ((A :82 (((C' (S' (C' B))) B) I)) ((A :83 _844) ((A :84 _845) ((A :85 _846) ((A :86 _847) ((A :87 _848) ((A :88 _849) ((A :89 (_84 #0)) ((A :90 _867) ((A :91 _868) ((A :92 _869) ((A :93 _870) ((A :94 _871) ((A :95 _872) ((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 _180)) (((C' (C' B)) (((C' C) _90) _180)) _181))) ((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)))))))))) (((_841 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :107 ((_76 (_122 _192)) _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
+1096
+((A :0 _919) ((A :1 ((B _965) _0)) ((A :2 (((S' _965) _0) I)) ((A :3 _889) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _918) ((C _81) _5))) ((A :7 (((C' _6) (_936 _72)) ((_81 _934) _71))) ((A :8 ((B ((S _965) _934)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_81 _196)) _10)) ((A :12 ((B (B (_79 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_79 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_79 _9)) P)) ((A :15 ((B (B (_79 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_79 _9)) (B (P _847)))) ((A :19 ((B (_79 _9)) (BK (P _847)))) ((A :20 ((_79 _9) ((S P) I))) ((A :21 ((B (_79 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _120)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _121)))))) ((A :23 ((B Y) ((B (B (P (_14 _847)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _847))) ((A :26 (_22 _82)) ((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 _894) ((A :36 _895) ((A :37 (((S' _28) (_886 #97)) ((C _886) #122))) ((A :38 (((S' _28) (_886 #65)) ((C _886) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_886 #48)) ((C _886) #57))) ((A :41 (((S' _28) (_886 #32)) ((C _886) #126))) ((A :42 _883) ((A :43 _884) ((A :44 _886) ((A :45 _885) ((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 (((_846 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _88) (((C' _89) _36) (_36 #65))) (_36 #97))))) ((A :48 ((S ((S (((S' _28) (_44 #97)) ((C _44) #97))) (_34 (((_846 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _88) (((C' _89) _36) (_36 #97))) (_36 #65))))) ((A :49 _854) ((A :50 _855) ((A :51 _856) ((A :52 _857) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _858) ((A :59 _859) ((A :60 _58) ((A :61 _59) ((A :62 _860) ((A :63 _861) ((A :64 _862) ((A :65 _863) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _864) ((A :71 ((B BK) T)) ((A :72 (BK T)) ((A :73 P) ((A :74 P) ((A :75 (T K)) ((A :76 (T A)) ((A :77 (K (noDefault "Eq.=="))) ((A :78 ((B (B (B _29))) _75)) ((A :79 I) ((A :80 (S _891)) ((A :81 B) ((A :82 I) ((A :83 K) ((A :84 C) ((A :85 _890) ((A :86 ((C ((C S') _196)) _197)) ((A :87 (((C' (S' (C' B))) B) I)) ((A :88 _848) ((A :89 _849) ((A :90 _850) ((A :91 _851) ((A :92 _852) ((A :93 _853) ((A :94 (_89 #0)) ((A :95 ((_74 _871) _872)) ((A :96 _873) ((A :97 _874) ((A :98 _875) ((A :99 _876) ((A :100 (_75 _95)) ((A :101 (BK K)) ((A :102 ((B BK) ((B (B BK)) P))) ((A :103 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :104 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_97 #0))) ((C (_75 _95)) #0)))) ((B (B ((C' P) (_93 #1)))) _88))) (C P))) _91)) _92)) ((A :105 _101) ((A :106 (((S' C) ((B (P _184)) (((C' (C' B)) (((C' C) (_75 _95)) _184)) _185))) ((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') ((C (_75 _95)) #0))))) ((B ((C' (C' C)) ((B (B ((S' S') ((C (_75 _95)) #1)))) ((B ((C' C) ((B ((C' S') ((C (_75 _95)) #2))) (C _106)))) (C _106))))) (C _106))))) (C _106)))) (T K))) (T A)))) ((C _104) #4)))) ((A :107 (_113 _83)) ((A :108 ((_128 (_86 _107)) _105)) ((A :109 ((C (((C' B) ((P _120) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _110)))) (((S' (C' (C' B))) ((B (B (B _110))) (((S' (C' B)) ((B (B _110)) (((C' B) ((B _126) (T #0))) _109))) (((C' B) ((B _126) (T #1))) _109)))) (((C' B) ((B _126) (T #2))) _109)))) (((C' B) ((B _126) (T #3))) _109)))) ((B T) ((B (B P)) ((C' _88) (_90 #4)))))) ((A :110 ((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) _96)))) ((B ((C' B) _121)) _110)))))) ((B ((C' B) _121)) (C _110)))))))))) (((_846 "lib/Data/IntMap.hs
\ No newline at end of file
--- /dev/null
+++ b/lib/Data/Eq.hs
@@ -1,0 +1,19 @@
+module Data.Eq(
+ module Data.Eq
+ ) where
+import Data.Bool
+
+infix 4 ==,/=
+
+class Eq a where
+ (==) :: a -> a -> Bool
+ (/=) :: a -> a -> Bool
+ x /= y = not (x == y)
+
+{-+instance Eq Int where
+ (==) = primIntEq
+
+instance Eq Char where
+ (==) = primCharEq
+-}
--- 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 insts vals ds ->
- TModule mn fxs tys syns insts vals $ checkDup $ concatMap (dsDef mn) ds
+ TModule mn fxs tys syns clss insts vals ds ->
+ TModule mn fxs tys syns clss insts vals $ checkDup $ concatMap (dsDef mn) ds
dsDef :: IdentModule -> EDef -> [LDef]
dsDef mn adef =
@@ -402,10 +402,10 @@
-- Could use Prim "==", but that misses out some optimizations
eEqInt :: Exp
-eEqInt = Var $ mkIdent "Data.Int.=="
+eEqInt = Var $ mkIdent "Primitives.primIntEQ"
eEqChar :: Exp
-eEqChar = Var $ mkIdent "Data.Char.eqChar"
+eEqChar = Var $ mkIdent "Primitives.primCharEQ"
eEqStr :: Exp
eEqStr = --Var $ mkIdent "Text.String.eqString"
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -96,6 +96,7 @@
("equal", primitive "equal"), ("compare", primitive "compare"), ("rnf", primitive "rnf"),+ ("noDefault", primitive "noDefault"), ("IO.>>=", primitive "IO.>>="), ("IO.>>", primitive "IO.>>"), ("IO.return", primitive "IO.return"),--- 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
+ [ClsDef] -- all classes
[InstDict] -- all instances
[ValueExport] -- exported values (including from T(..))
a -- bindings
@@ -45,7 +46,10 @@
type FixDef = (Ident, Fixity)
type SynDef = (Ident, EType)
+type ClsDef = (Ident, ClassInfo)
+type ClassInfo = ([IdKind], [EConstraint], [Ident]) -- class tyvars, superclasses, methods
+
-- Symbol table entry for symbol i.
data Entry = Entry
Expr -- convert (EVar i) to this expression; sometimes just (EVar i)
@@ -61,7 +65,7 @@
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 ClassTable = M.Map ([IdKind], [EConstraint], [Ident]) -- super classes, instance names
+type ClassTable = M.Map ClassInfo -- maps a class identifier to its associated information
type InstTable = M.Map [InstDict] -- indexed by class name
type Constraints= [(Ident, EConstraint)]
@@ -77,8 +81,8 @@
-- trace (show amdl) $
let
imps = map filterImports aimps
- (fs, ts, ss, is, vs, as) = mkTables imps
- in case tcRun (tcDefs defs) (initTC mn fs ts ss is vs as) of
+ (fs, ts, ss, cs, is, vs, as) = mkTables imps
+ in case tcRun (tcDefs defs) (initTC mn fs ts ss cs is vs as) of
(tds, tcs) ->
let
thisMdl = (mn, mkTModule tds tcs)
@@ -86,16 +90,19 @@
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 ]
- 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
+ fexps = [ fe | TModule _ fe _ _ _ _ _ _ <- M.elems impMap ]
+ sexps = [ se | TModule _ _ _ se _ _ _ _ <- M.elems impMap ]
+ cexps = [ ce | TModule _ _ _ _ ce _ _ _ <- M.elems impMap ]
+ iexps = [ ie | TModule _ _ _ _ _ ie _ _ <- M.elems impMap ]
+ in tModule mn (nubBy (eqIdent `on` fst) (concat fexps)) (concat texps) (concat sexps) (concat cexps) (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] -> [InstDict] -> [ValueExport] -> [EDef] ->
+tModule :: IdentModule -> [FixDef] -> [TypeExport] -> [SynDef] -> [ClsDef] -> [InstDict] -> [ValueExport] -> [EDef] ->
TModule [EDef]
-tModule mn fs ts ss is vs ds = seqL ts `seq` seqL vs `seq` TModule mn fs ts ss is vs ds
+tModule mn fs ts ss cs is vs ds =
+-- trace ("tmodule " ++ showIdent mn ++ ": " ++ show ts) $+ seqL ts `seq` seqL vs `seq` TModule mn fs ts ss cs is vs ds
where
seqL :: forall a . [a] -> ()
seqL [] = ()
@@ -103,7 +110,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 ins vs a) =
+filterImports (imp@(ImportSpec _ _ _ (Just (hide, is))), TModule mn fx ts ss cs ins vs a) =
let
keep x xs = elemBy eqIdent x xs `neBool` hide
ivs = [ i | ImpValue i <- is ]
@@ -114,7 +121,7 @@
filter (\ (TypeExport i _ _) -> keep i its) ts
in
--trace (show (ts, vs)) $
- (imp, TModule mn fx ts' ss ins vs' a)
+ (imp, TModule mn fx ts' ss cs ins vs' a)
-- Type and value exports
getTVExps :: forall a . M.Map (TModule a) -> TypeTable -> ValueTable -> AssocTable -> ExportItem ->
@@ -121,7 +128,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
@@ -179,6 +186,7 @@
tt = typeTable tcs
at = assocTable tcs
vt = valueTable tcs
+ ct = classTable tcs
it = instTable tcs
-- Find the Entry for a type.
@@ -196,6 +204,7 @@
tes =
[ TypeExport i (tentry i) (assoc i) | Data (i, _) _ <- tds ] ++
[ TypeExport i (tentry i) (assoc i) | Newtype (i, _) _ <- tds ] ++
+ [ TypeExport i (tentry i) (assoc i) | Class _ (i, _) _ <- tds ] ++
[ TypeExport i (tentry i) [] | Type (i, _) _ <- tds ]
-- All type synonym definitions.
@@ -204,9 +213,13 @@
-- 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
+
-- All instances
ies = concat $ M.elems it
- in TModule mn fes tes ses ies ves impossible
+ in TModule mn fes tes ses ces ies ves impossible
-- Find all value Entry for names associated with a type.
getAssocs :: ValueTable -> AssocTable -> Ident -> [ValueExport]
@@ -217,7 +230,7 @@
_ -> impossible
in map (\ qi -> ValueExport (unQualIdent qi) (val qi)) qis
-mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, InstTable, ValueTable, AssocTable)
+mkTables :: forall a . [(ImportSpec, TModule a)] -> (FixTable, TypeTable, SynTable, ClassTable, InstTable, ValueTable, AssocTable)
mkTables mdls =
let
qns (ImportSpec q _ mas _) mn i =
@@ -227,37 +240,42 @@
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
+ allClasses :: ClassTable
+ allClasses =
+ let
+ clss (_, TModule _ _ _ _ ces _ _ _) = ces
+ in M.fromList $ concatMap clss mdls
allInsts :: InstTable
allInsts =
let
- insts (_, TModule _ _ _ _ ies _ _) = map (\ ie -> (getInstCon ie, [ie])) ies
+ insts (_, TModule _ _ _ _ _ ies _ _) = map (\ ie -> (getInstCon ie, [ie])) ies
in M.fromListWith (unionBy eqInstDict) $ concatMap insts mdls
- in (allFixes, allTypes, allSyns, allInsts, allValues, allAssocs)
+ in (allFixes, allTypes, allSyns, allClasses, allInsts, allValues, allAssocs)
eqEntry :: Entry -> Entry -> Bool
eqEntry x y =
@@ -420,13 +438,13 @@
putInstTable is
T.return a
-initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> InstTable -> ValueTable -> AssocTable -> TCState
-initTC mn fs ts ss is vs as =
+initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> ClassTable -> InstTable -> ValueTable -> AssocTable -> TCState
+initTC mn fs ts ss cs 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 is []
+ in TC mn 1 fs xts ss xvs as IM.empty TCExpr cs is []
kTypeS :: EType
kTypeS = kType
@@ -863,14 +881,16 @@
assocData (Constr c (Left _)) = [c]
assocData (Constr c (Right its)) = c : map fst its
case adef of
- Data lhs@(i, _) cs -> T.do
+ Data lhs@(i, _) cs -> T.do
addLHSKind lhs kType
addAssoc i (nubBy eqIdent $ concatMap assocData cs)
- Newtype lhs@(i, _) c -> T.do
+ 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
+ Type lhs t -> addLHSKind lhs (getTypeKind t)
+ Class _ lhs@(i, _) ms -> T.do
+ addLHSKind lhs kConstraint
+ addAssoc i (mkClassConstructor i : [ m | BSign m _ <- ms ])
_ -> T.return ()
getTypeKind :: EType -> EKind
@@ -987,7 +1007,7 @@
def (Just eqns) = Fcn iDflt eqns
iDflt = mkDefaultMethodId methId
-- XXX This isn't right, "Prelude._nodefault" might not be in scope
- noDflt = EApp (EVar (mkIdent "Prelude._noDefault")) (ELit noSLoc (LStr (unIdent iCls ++ "." ++ unIdent methId)))
+ noDflt = EApp noDefaultE (ELit noSLoc (LStr (unIdent iCls ++ "." ++ unIdent methId)))
mkDflt _ = impossible
dDflts = concatMap mkDflt meths
addClassTable (qualIdent mn iCls) (vks, ctx, methIds)
@@ -994,6 +1014,9 @@
T.return $ dcls : dDflts
expandClass d = T.return [d]
+noDefaultE :: Expr
+noDefaultE = ELit noSLoc $ LPrim "noDefault"
+
-- Turn (unqualified) class and method names into a default method name
mkDefaultMethodId :: Ident -> Ident
mkDefaultMethodId meth = addIdentSuffix meth "$dflt"
@@ -1686,7 +1709,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
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -152,7 +152,7 @@
T_FADD, T_FSUB, T_FMUL, T_FDIV,
T_FEQ, T_FNE, T_FLT, T_FLE, T_FGT, T_FGE, T_FSHOW, T_FREAD,
T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE,
- T_ERROR, T_SEQ, T_EQUAL, T_COMPARE, T_RNF,
+ T_ERROR, T_NODEFAULT, T_SEQ, T_EQUAL, T_COMPARE, T_RNF,
T_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_GETCHAR, T_IO_PUTCHAR,
T_IO_SERIALIZE, T_IO_DESERIALIZE, T_IO_OPEN, T_IO_CLOSE, T_IO_ISNULLHANDLE,
T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_DROPARGS,
@@ -672,6 +672,7 @@
{ ">=", T_GE }, { "seq", T_SEQ }, { "error", T_ERROR },+ { "noDefault", T_NODEFAULT }, { "equal", T_EQUAL }, { "compare", T_COMPARE }, { "rnf", T_RNF },@@ -1402,6 +1403,7 @@
case T_UGT: fprintf(f, "u>"); break;
case T_UGE: fprintf(f, "u>="); break;
case T_ERROR: fprintf(f, "error"); break;
+ case T_NODEFAULT: fprintf(f, "noDefault"); break;
case T_EQUAL: fprintf(f, "equal"); break;
case T_COMPARE: fprintf(f, "compare"); break;
case T_RNF: fprintf(f, "rnf"); break;
@@ -1730,6 +1732,7 @@
double rd;
FILE *hdl;
char *msg;
+ char *emsg;
heapoffs_t l;
/* Reset stack pointer and return. */
@@ -1879,7 +1882,12 @@
case T_UGT: CMPU(>);
case T_UGE: CMPU(>=);
+ case T_NODEFAULT:
+ emsg = "no default for ";
+ goto err; /* XXX not right if the error is caught */
case T_ERROR:
+ emsg = "";
+ err:
if (cur_handler) {/* Pass the string to the handler */
CHKARG1;
@@ -1888,7 +1896,7 @@
} else {/* No handler, so just die. */
CHKARGEV1(msg = evalstring(x));
- fprintf(stderr, "error: %s\n", msg);
+ fprintf(stderr, "error: %s%s\n", emsg, msg);
free(msg);
exit(1);
}
--
⑨