ref: 4fb86eb0b959aa27cdd2b5c3766ab3c7cdc59aaa
parent: 0964b4c7af767f850dd2a6d350b16e628457bcd8
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Mon Oct 16 15:40:00 EDT 2023
Handle class and instance tables.
--- a/Makefile
+++ b/Makefile
@@ -86,6 +86,7 @@
$(GHCC) -c src/MicroHs/IdentMap.hs
$(GHCC) -c src/MicroHs/Exp.hs
$(GHCC) -c src/MicroHs/TCMonad.hs
+ $(GHCC) -c src/MicroHs/State.hs
$(GHCC) -c src/MicroHs/TypeCheck.hs
$(GHCC) -c src/MicroHs/Desugar.hs
$(GHCC) -c src/MicroHs/StateIO.hs
--- a/MicroHs.cabal
+++ b/MicroHs.cabal
@@ -51,6 +51,7 @@
MicroHs.StateIO
MicroHs.IdentMap
MicroHs.Interactive
+ MicroHs.State
MicroHs.TCMonad
MicroHs.Translate
MicroHs.TypeCheck
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-997
-((A :0 _881) ((A :1 ((B _927) _0)) ((A :2 (((S' _927) _0) I)) ((A :3 _851) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _880) ((C _75) _5))) ((A :7 (((C' _6) (_898 _72)) ((_75 _896) _71))) ((A :8 ((B ((S _927) _896)) _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 _809)))) ((A :19 ((B (_74 _9)) (BK (P _809)))) ((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 _809)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _809))) ((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 _856) ((A :36 _857) ((A :37 (((S' _28) (_848 #97)) ((C _848) #122))) ((A :38 (((S' _28) (_848 #65)) ((C _848) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_848 #48)) ((C _848) #57))) ((A :41 (((S' _28) (_848 #32)) ((C _848) #126))) ((A :42 _845) ((A :43 _846) ((A :44 _848) ((A :45 _847) ((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 (((_807 "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 (((_807 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _82) (((C' _83) _36) (_36 #97))) (_36 #65))))) ((A :49 _816) ((A :50 _817) ((A :51 _818) ((A :52 _819) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _820) ((A :59 _821) ((A :60 _58) ((A :61 _59) ((A :62 _822) ((A :63 _823) ((A :64 _824) ((A :65 _825) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _826) ((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 _852) ((A :80 ((C ((C S') _190)) _191)) ((A :81 (((C' (S' (C' B))) B) I)) ((A :82 _810) ((A :83 _811) ((A :84 _812) ((A :85 _813) ((A :86 _814) ((A :87 _815) ((A :88 (_83 #0)) ((A :89 _833) ((A :90 _834) ((A :91 _835) ((A :92 _836) ((A :93 _837) ((A :94 _838) ((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)))))))))) (((_807 "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
--- /dev/null
+++ b/src/MicroHs/State.hs
@@ -1,0 +1,14 @@
+{-# OPTIONS_GHC -Wno-orphans -Wno-dodgy-imports -Wno-unused-imports #-}+module MicroHs.State(
+ State, runState,
+ fmap, (<$>), (<*>),
+ (>>=), (>>), return, fail,
+ get, put, gets,
+ mapM, mapM_,
+ sequence,
+ when,
+ ) where
+--Ximport Control.Monad hiding(ap)
+--Ximport Data.Functor.Identity
+--Ximport GHC.Stack
+import Control.Monad.State.Strict --Xhiding(ap)
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -11,6 +11,7 @@
import Data.List
import Data.Maybe
import qualified Data.IntMap as IM
+import qualified MicroHs.State as S
import MicroHs.TCMonad as T
import qualified MicroHs.IdentMap as M
import MicroHs.Ident
@@ -57,7 +58,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 ([Ident], [Ident]) -- super class selector names, instance names
+type ClassTable = M.Map (Int, [Ident]) -- # super classes, instance names
type Instances = [([IdKind], [EConstraint], EConstraint)]
type Constraints= [(Ident, EConstraint)]
@@ -294,6 +295,9 @@
moduleName :: TCState -> IdentModule
moduleName (TC mn _ _ _ _ _ _ _ _ _ _ _) = mn
+classTable :: TCState -> ClassTable
+classTable (TC _ _ _ _ _ _ _ _ _ ct _ _) = ct
+
tcMode :: TCState -> TCMode
tcMode (TC _ _ _ _ _ _ _ _ m _ _ _) = m
@@ -345,6 +349,16 @@
TC mn n fx tt st vt ast sub m cs is es <- get
put $ TC mn n fx tt st vt (M.insert i ids ast) sub m cs is es
+addClassTable :: Ident -> (Int, [Ident]) -> T ()
+addClassTable i x = T.do
+ TC mn n fx tt st vt ast sub m cs is es <- get
+ put $ TC mn n fx tt st vt ast sub m (M.insert i x cs) is es
+
+addInstance :: ([IdKind], [EConstraint], EConstraint) -> T ()
+addInstance inst = T.do
+ TC mn n fx tt st vt ast sub m cs is es <- get
+ put $ TC mn n fx tt st vt ast sub m cs (inst : is) es
+
-- XXX handle imports
initTC :: IdentModule -> FixTable -> TypeTable -> SynTable -> ValueTable -> AssocTable -> TCState
initTC mn fs ts ss vs as =
@@ -715,8 +729,9 @@
dsk <- T.mapM tcDefKind ds -- Check&rename kinds in all type definitions
T.mapM_ addTypeKind dsk -- Add the kind of each type to the environment
dst <- T.mapM tcDefType dsk -- Kind check all type expressions (except local signatures)
- dss <- T.mapM expandClassInst dst -- Expand all class & instance definitions
- T.return (concat dss)
+ dsc <- T.mapM expandClass dst -- Expand all class definitions
+ dsi <- T.mapM expandInst (concat dsc) -- Expand all instance definitions
+ T.return (concat dsi)
-- Make sure that the kind expressions are well formed.
tcDefKind :: EDef -> T EDef
@@ -820,10 +835,6 @@
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
-expandClassInst d@(Instance iks mc c m) = (d:) <$> expandInst iks mc c m
-expandClassInst d = T.return [d]
-- Expand a class defintion to
-- * a "data" type for the dictionary, with kind Constraint
@@ -858,10 +869,11 @@
-- in the desugaring pass.
-- Default methods are added as actual definitions.
-- The constructor and mathods are added to the symbol table in addValueType.
-expandClass :: [EConstraint] -> LHS -> [EBind] -> T [EDef]
-expandClass _sups (iCls, vs) ms = T.do
+expandClass :: EDef -> T [EDef]
+expandClass dcls@(Class ctx (iCls, vs) ms) = T.do
mn <- gets moduleName
let
+ methIds = [ i | (BSign i _) <- ms ]
meths = [ b | b@(BSign _ _) <- ms ]
mdflts = [ (i, eqns) | BFcn i eqns <- ms ]
tCtx = tApps (qualIdent mn iCls) (map (EVar . idKindIdent) vs)
@@ -873,7 +885,9 @@
noDflt = EApp (EVar (mkIdent "Prelude._noDefault")) (ELit noSLoc (LStr (unIdent iCls ++ "." ++ unIdent i)))
mkDflt _ = impossible
dDflts = concatMap mkDflt meths
- T.return dDflts
+ addClassTable (qualIdent mn iCls) (length ctx, methIds)
+ T.return $ dcls : dDflts
+expandClass d = T.return [d]
{-mn <- gets moduleName
supTys <- T.return sups -- T.mapM clsToDict sups
@@ -934,15 +948,35 @@
-- Where methodK is either from bs of the default method.
-- There's one magic dict$ for each superclass.
-- * Add instance to instance table
-expandInst :: [IdKind] -> [EConstraint] -> EType -> [EBind] -> T [EDef]
-expandInst vks _ctx cc bs = T.do
+expandInst :: EDef -> T [EDef]
+expandInst dinst@(Instance vks ctx cc bs) = T.do
let loc@(SLoc _ l c) = getSLocExpr cc
- iCon = getAppCon cc
+ iCls = getAppCon cc
iInst = mkIdentSLoc loc $ "inst$L" ++ showInt l ++ "C" ++ showInt c
sign = Sign iInst (eForall vks cc)
- bind = Fcn iInst [Eqn [] $ EAlts [([], foldl EApp (EVar iCon) meths)] bs]
- meths = []
- T.return [sign, bind]
+ (e, _) <- tLookupV iCls
+ ct <- gets classTable
+ let qiCls = getAppCon e
+ (nsup, mis) <-
+ case M.lookup qiCls ct of
+ Nothing -> tcError loc $ "not a class " ++ showIdent qiCls
+ Just x -> T.return x
+ let (bs', (_, ims)) =
+ let f (BFcn i eqns) = S.do
+ (n, xs) <- S.get
+ let mi = mkIdentSLoc (getSLocIdent i) ("meth$" ++ showInt n)+ S.put (n+1, (i, mi):xs)
+ S.return (BFcn mi eqns)
+ f b = S.return b
+ in S.runState (S.mapM f bs) (1, [])
+ meths = map meth mis
+ where meth i = EVar $ fromMaybe (mkDefaultMethodId i) $ lookupBy eqIdent i ims
+ sups = replicate nsup (EVar $ mkIdentSLoc loc "dict$")
+ args = sups ++ meths
+ let bind = Fcn iInst [Eqn [] $ EAlts [([], foldl EApp (EVar $ mkClassConstructor iCls) args)] bs']
+ addInstance (vks, ctx, cc)
+ T.return [dinst, sign, bind]
+expandInst d = T.return [d]
eForall :: [IdKind] -> EType -> EType
eForall [] t = t
--
⑨