ref: ffdae3f2147eb63c4577e785dbb04263bf43ac42
parent: dd2677450c4d6e1bb3a2554b5e89276dac685e63
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Sat Oct 14 07:16:05 EDT 2023
Expand class definition.
--- a/lib/Prelude.hs
+++ b/lib/Prelude.hs
@@ -14,6 +14,7 @@
module System.IO,
module Text.String,
_noMatch,
+ _noDefault,
) where
import Control.Error
import Data.Bool
@@ -33,3 +34,7 @@
_noMatch fn l c = error $ "no match at " ++
if null fn then "no location" else
showString fn ++ ": " ++ "line " ++ showInt l ++ ", col " ++ showInt c
+
+-- Called when the default method is missing
+_noDefault :: forall a . [Char] -> a
+_noDefault s = error ("no default for " ++ s)--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -256,9 +256,6 @@
c = tupleConstr loc n
in ECon $ ConData [(c, n)] c
-dummyIdent :: Ident
-dummyIdent = mkIdent "_"
-
lams :: [Ident] -> Exp -> Exp
lams xs e = foldr Lam e xs
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -6,8 +6,9 @@
mkIdent, mkIdentLoc, unIdent, eqIdent, leIdent, qualIdent, showIdent, getSLocIdent, setSLocIdent,
mkIdentSLoc,
isLower_, isIdentChar, isOperChar, isConIdent,
- isDummyIdent,
+ dummyIdent, isDummyIdent,
unQualString,
+ addIdentSuffix,
SLoc(..), noSLoc, isNoSLoc,
showSLoc,
compareIdent,
@@ -17,6 +18,7 @@
--Yimport Primitives(NFData(..))
import Data.Char
--Ximport Compat
+--Ximport GHC.Stack
type Line = Int
type Col = Int
@@ -66,7 +68,11 @@
qualIdent :: Ident -> Ident -> Ident
qualIdent (Ident loc qi) (Ident _ i) = Ident loc (qi ++ "." ++ i)
-unQualString :: String -> String
+addIdentSuffix :: Ident -> String -> Ident
+addIdentSuffix (Ident loc i) s = Ident loc (i ++ s)
+
+unQualString :: --XHasCallStack =>
+ String -> String
unQualString s =
case span isIdentChar s of
("", r) -> r@@ -88,6 +94,9 @@
isLower_ :: Char -> Bool
isLower_ c = isLower c || eqChar c '_'
+
+dummyIdent :: Ident
+dummyIdent = mkIdent "_"
isDummyIdent :: Ident -> Bool
isDummyIdent (Ident _ "_") = True
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -405,6 +405,9 @@
tArrow :: EType -> EType -> EType
tArrow a r = tApp (tApp (tConI builtinLoc "Primitives.->") a) r
+tImplies :: EType -> EType -> EType
+tImplies a r = tApp (tApp (tConI builtinLoc "Primitives.=>") a) r
+
kArrow :: EKind -> EKind -> EKind
kArrow = tArrow
@@ -649,6 +652,7 @@
tcDefs ds = T.do
T.mapM_ tcAddInfix ds
dst <- tcDefsType ds
+ traceM (showEDefs dst)
T.mapM_ addTypeSyn dst
tcDefsValue dst
@@ -662,7 +666,9 @@
tcDefsType ds = withTypeTable $ T.do
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
- T.mapM tcDefType dsk
+ 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)
-- Make sure that the kind expressions are well formed.
tcDefKind :: EDef -> T EDef
@@ -728,7 +734,6 @@
_ -> T.return ()
-- Do kind checking of all typeish definitions.
--- XXX check method signatures?
tcDefType :: EDef -> T EDef
tcDefType d = T.do
tcReset
@@ -756,6 +761,67 @@
tcConstr :: Constr -> T Constr
tcConstr (Constr i ts) = Constr i <$> T.mapM (\ t -> tcTypeT (Check kType) t) ts
+
+expandClassInst :: EDef -> T [EDef]
+expandClassInst d@(Class _ lhs m) = (d:) <$> expandClass lhs m
+expandClassInst d@(Instance vs mc _ m) = (d:) <$> expandInst vs mc m
+expandClassInst d = T.return [d]
+
+-- Expand a class defintion to
+-- * a type for the dictionary
+-- * method selectors
+-- * default methods
+-- E.g.
+-- class Eq a where
+-- (==) :: a -> a -> Bool
+-- (/=) :: a -> a -> a
+-- x /= y = not (x == y)
+-- expands to
+-- data Eq$Dict a = Eq (a -> a -> Bool) (a -> a -> Bool)
+-- (==) :: forall a . Eq$Dict a -> (a -> a -> Bool)
+-- (==) (Eq x _) = x
+-- (/=) :: forall a . Eq$Dict a -> (a -> a -> Bool)
+-- (/=) (Eq _ x) = x
+-- (==$dflt) :: forall a . (Eq a) => (a -> a -> Bool)
+-- (==$dflt) = _noDefault "Eq.=="
+-- (/=$dflt) :: forall a . (Eq a) => (a -> a -> Bool)
+-- (/=$dflt) x y = not (x == y)
+--
+expandClass :: LHS -> [EBind] -> T [EDef]
+expandClass (iCls, vs) ms = T.do
+ mn <- gets moduleName
+ let iDict = addIdentSuffix iCls "Dict" {-"$Dict"-}+ meths = [ b | b@(BSign _ _) <- ms ]
+ mdflts = [ (i, eqns) | BFcn i eqns <- ms ]
+ nMeths = length meths
+ iCon = iCls
+ dData = Data (iDict, vs) [Constr iCon $ map (\ (BSign _ t) -> t) meths]
+
+ ex = EVar (mkIdent "x")
+ tForall = EForall vs
+ tDict = tApps (qualIdent mn iDict) (map (EVar . idKindIdent) vs)
+ pat k n = foldl EApp (EVar iCon) [ if k == i then ex else EVar dummyIdent | i <- [1..n] ]
+ mkSel (BSign i t) k = [ Sign i $ tForall $ tArrow tDict t, Fcn i [Eqn [pat k nMeths] $ EAlts [([], ex)] []] ]
+ mkSel _ _ = impossible
+ dSels = concat $ zipWith mkSel meths [1..]
+
+ tCtx = tApps (qualIdent mn iCls) (map (EVar . idKindIdent) vs)
+ mkDflt (BSign i t) = [ Sign iDflt $ tForall $ tCtx `tImplies` t, def $ lookupBy eqIdent i mdflts ]
+ where def Nothing = Fcn iDflt [Eqn [] $ EAlts [([], noDflt)] []]
+ def (Just eqns) = Fcn iDflt eqns
+ iDflt = addIdentSuffix i "dflt" {-"$dflt"-}+ -- XXX This isn't right, "Prelude._nodefault" might not be in scope
+ noDflt = EApp (EVar (mkIdent "Prelude._noDefault")) (ELit noSLoc (LStr (unIdent iCls ++ "." ++ unIdent i)))
+ mkDflt _ = impossible
+ dDflts = concatMap mkDflt meths
+
+ -- XXX add iDict to symbol table
+ T.return $ [dData] ++ dSels ++ dDflts
+
+expandInst :: [IdKind] -> Maybe EConstraint -> [EBind] -> T [EDef]
+expandInst _ _ _ = T.return [] -- XXX
+
+---------------------
tcDefsValue :: [EDef] -> T [EDef]
tcDefsValue ds = T.do
--
⑨