ref: aaf08a832d505b171b1ee6378568871281149ece
parent: c733f47863a47eeb9d2ef9b591501e7d0b01a9ae
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Fri Nov 17 12:32:07 EST 2023
Start of refactoring for existential types.
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -39,9 +39,10 @@
let
f i = mkIdent ("$f" ++ show i)fs = [f i | (i, _) <- zip [0::Int ..] cs]
- dsConstr i (Constr c ets) =
+ dsConstr i (Constr _ ctx c ets) =
let
- ss = map fst $ either id (map snd) ets -- strict flags
+ ss = (if null ctx then [] else [False]) ++
+ map fst (either id (map snd) ets) -- strict flags
xs = [mkIdent ("$x" ++ show j) | (j, _) <- zip [0::Int ..] ss]strict (False:ys) (_:is) e = strict ys is e
strict (True:ys) (x:is) e = App (App (Lit (LPrim "seq")) (Var x)) (strict ys is e)
@@ -48,7 +49,7 @@
strict _ _ e = e
in (qualIdent mn c, lams xs $ strict ss xs $ lams fs $ apps (Var (f i)) (map Var xs))
in zipWith dsConstr [0::Int ..] cs
- Newtype _ (Constr c _) -> [ (qualIdent mn c, Lit (LPrim "I")) ]
+ Newtype _ (Constr _ _ c _) -> [ (qualIdent mn c, Lit (LPrim "I")) ]
Type _ _ -> []
Fcn f eqns -> [(f, dsEqns (getSLoc f) eqns)]
Sign _ _ -> []
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -200,7 +200,10 @@
type LHS = (Ident, [IdKind])
-data Constr = Constr Ident (Either [SType] [ConstrField])
+data Constr = Constr
+ [IdKind] [EConstraint] -- existentials: forall vs . ctx =>
+ Ident -- constructor name
+ (Either [SType] [ConstrField]) -- types or named fields
--Xderiving(Show)
type ConstrField = (Ident, SType) -- record label and type
@@ -490,12 +493,14 @@
ForImp ie i t -> text ("foreign import ccall " ++ show ie) <+> ppIdent i <+> text "::" <+> ppEType t Infix (a, p) is -> text ("infix" ++ f a) <+> text (show p) <+> hsep (punctuate (text ", ") (map ppIdent is))where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""
- Class sup lhs fds bs -> ppWhere (text "class" <+> ctx sup <+> ppLHS lhs <+> ppFunDeps fds) bs
- Instance vs ct ty bs -> ppWhere (text "instance" <+> ppForall vs <+> ctx ct <+> ppEType ty) bs
+ Class sup lhs fds bs -> ppWhere (text "class" <+> ppCtx sup <+> ppLHS lhs <+> ppFunDeps fds) bs
+ Instance vs ct ty bs -> ppWhere (text "instance" <+> ppForall vs <+> ppCtx ct <+> ppEType ty) bs
Default ts -> text "default" <+> parens (hsep (punctuate (text ", ") (map ppEType ts)))
- where ctx [] = empty
- ctx ts = ppEType (ETuple ts) <+> text "=>"
+ppCtx :: [EConstraint] -> Doc
+ppCtx [] = empty
+ppCtx ts = ppEType (ETuple ts) <+> text "=>"
+
ppFunDeps :: [FunDep] -> Doc
ppFunDeps [] = empty
ppFunDeps fds =
@@ -505,9 +510,10 @@
ppEqns name sepr = vcat . map (\ (Eqn ps alts) -> sep [name <+> hsep (map ppEPat ps), ppAlts sepr alts])
ppConstr :: Constr -> Doc
-ppConstr (Constr c (Left ts)) = hsep (ppIdent c : map ppSType ts)
-ppConstr (Constr c (Right fs)) = ppIdent c <> braces (hsep $ map f fs)
- where f (i, t) = ppIdent i <+> text "::" <+> ppSType t <> text ","
+ppConstr (Constr iks ct c cs) = ppForall iks <+> ppCtx ct <+> ppIdent c <+> ppCs cs
+ where ppCs (Left ts) = hsep (map ppSType ts)
+ ppCs (Right fs) = braces (hsep $ map f fs)
+ where f (i, t) = ppIdent i <+> text "::" <+> ppSType t <> text ","
ppSType :: SType -> Doc
ppSType (False, t) = ppEType t
@@ -576,7 +582,7 @@
ppApp as f = parens $ hsep (map ppExpr (f:as))
ppForall :: [IdKind] -> Doc
-ppForall [] = empty
+--ppForall [] = empty
ppForall iks = text "forall" <+> hsep (map ppIdKind iks) <+> text "."
ppListish :: Listish -> Doc
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -253,7 +253,7 @@
pDef =
Data <$> (pKeyword "data" *> pLHS) <*> ((pSymbol "=" *> esepBy1 pConstr (pSymbol "|"))
<|< pure [])
- <|< Newtype <$> (pKeyword "newtype" *> pLHS) <*> (pSymbol "=" *> (Constr <$> pUIdentSym <*> pField))
+ <|< Newtype <$> (pKeyword "newtype" *> pLHS) <*> (pSymbol "=" *> (Constr [] [] <$> pUIdentSym <*> pField))
<|< Type <$> (pKeyword "type" *> pLHS) <*> (pSymbol "=" *> pType)
<|< uncurry Fcn <$> pEqns
<|< Sign <$> (pLIdentSym <* pSymbol "::") <*> pType
@@ -268,23 +268,34 @@
dig (TInt _ ii) | -2 <= i && i <= 9 = Just i where i = _integerToInt ii
dig _ = Nothing
pPrec = satisfyM "digit" dig
- pContext = (pCtx <* pSymbol "=>") <|< pure []
- pCtx = pParens (emany pType) <|< ((:[]) <$> pTypeApp)
- pFields = Left <$> emany pSAType <|<
- Right <$> (pSpec '{' *> esepBy ((,) <$> (pLIdentSym <* pSymbol "::") <*> pSType) (pSpec ',') <* pSpec '}')+ pFunDeps = (pSpec '|' *> esome pFunDep) <|< pure []
+ pFunDep = (,) <$> esome pLIdent <*> (pSymbol "->" *> esome pLIdent)
pField = do
fs <- pFields
guard $ either length length fs == 1
pure fs
- pFunDeps = (pSpec '|' *> esome pFunDep) <|< pure []
- pFunDep = (,) <$> esome pLIdent <*> (pSymbol "->" *> esome pLIdent)
- pConstr :: P Constr
- pConstr = (Constr <$> pUIdentSym <*> pFields)
- <|< ((\ t1 c t2 -> Constr c (Left [t1, t2])) <$> pSAType <*> pUSymOper <*> pSAType)
- pSAType = (,) <$> pStrict <*> pAType
- pSType = (,) <$> pStrict <*> pType
- pStrict = (True <$ pSymbol "!") <|< pure False
+
+pContext :: P [EConstraint]
+pContext = (pCtx <* pSymbol "=>") <|< pure []
+ where
+ pCtx = pParens (emany pType) <|< ((:[]) <$> pTypeApp)
+
+pConstr :: P Constr
+pConstr = (Constr <$> pForall <*> pContext <*> pUIdentSym <*> pFields)
+ <|< ((\ vs ct t1 c t2 -> Constr vs ct c (Left [t1, t2])) <$>
+ pForall <*> pContext <*> pSAType <*> pUSymOper <*> pSAType)
+
+pFields :: P (Either [SType] [(Ident, SType)])
+pFields = Left <$> emany pSAType <|<
+ Right <$> (pSpec '{' *> esepBy ((,) <$> (pLIdentSym <* pSymbol "::") <*> pSType) (pSpec ',') <* pSpec '}')+
+pSAType :: P (Bool, EType)
+pSAType = (,) <$> pStrict <*> pAType
+pSType :: P (Bool, EType)
+pSType = (,) <$> pStrict <*> pType
+pStrict :: P Bool
+pStrict = (True <$ pSymbol "!") <|< pure False
pLHS :: P LHS
pLHS = (,) <$> pTypeIdentSym <*> emany pIdKind
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -980,8 +980,8 @@
addAssoc i is = do
mn <- gets moduleName
addAssocTable (qualIdent mn i) (map (qualIdent mn) is)
- assocData (Constr c (Left _)) = [c]
- assocData (Constr c (Right its)) = c : map fst its
+ assocData (Constr _ _ c (Left _)) = [c]
+ assocData (Constr _ _ c (Right its)) = c : map fst its
case adef of
Data lhs@(i, _) cs -> do
addLHSKind lhs kType
@@ -1047,9 +1047,9 @@
withExtVal i k $ withVars iks ta
tcConstr :: Constr -> T Constr
-tcConstr (Constr c ets) =
- Constr c <$> either (\ x -> Left <$> mapM (\ (s,t) -> (s,) <$> tcTypeT (Check kType) t) x)
- (\ x -> Right <$> mapM (\ (i,(s,t)) -> ((i,) . (s,)) <$> tcTypeT (Check kType) t) x) ets
+tcConstr (Constr _ _ c ets) =
+ Constr [] [] c <$> either (\ x -> Left <$> mapM (\ (s,t) -> (s,) <$> tcTypeT (Check kType) t) x)
+ (\ x -> Right <$> mapM (\ (i,(s,t)) -> ((i,) . (s,)) <$> tcTypeT (Check kType) t) x) ets
-- Expand a class defintion to
@@ -1191,13 +1191,13 @@
Sign i t -> extValQTop i t
Data (i, vks) cs -> do
let
- cti = [ (qualIdent mn c, either length length ets) | Constr c ets <- cs ]
+ cti = [ (qualIdent mn c, either length length ets) | Constr _ _ c ets <- cs ]
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
- addCon (Constr c ets) = do
+ addCon (Constr _ _ c ets) = do
let ts = either id (map snd) ets
extValETop c (EForall vks $ foldr (tArrow . snd) tret ts) (ECon $ ConData cti (qualIdent mn c))
mapM_ addCon cs
- Newtype (i, vks) (Constr c fs) -> do
+ Newtype (i, vks) (Constr _ _ c fs) -> do
let
t = snd $ head $ either id (map snd) fs
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
--
⑨