ref: fff0643c60f727c5eca1ec255e4bc7a22203fc25
parent: 16bec988daf9a4733c739ea44dd04df2081303cf
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Wed Nov 1 17:07:57 EDT 2023
Add parsing of fundeps.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1170
-((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _128) ((B _12) _1)) _235))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _234))) ((A :10 (((S' P) _2) (((C' _13) _1) _936))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _125) _12) _117))) ((A :20 (((S' B) _14) (((C' _128) _12) _118))) ((A :21 _1008) ((A :22 ((B _1050) _21)) ((A :23 (((S' _1050) _21) I)) ((A :24 _978) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1007) ((C _116) _26))) ((A :28 (((C' _27) ((_124 _1021) _106)) ((_116 (_34 _1023)) _105))) ((A :29 ((B ((S _1050) (_34 _1023))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _234)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _235)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _936)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _936))) ((A :46 ((C _43) _117)) ((A :47 ((B _119) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _119) _48)) ((A :50 T) ((A :51 ((_123 ((B (B (_114 _50))) ((B ((C' C) _54)) (B P)))) (_127 _51))) ((A :52 (((((_11 _51) ((B (_114 _50)) P)) (_38 _53)) ((B (B (_114 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_114 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_116 _264)) _54)) ((A :56 ((B (_114 _50)) (B (P _936)))) ((A :57 ((B (_114 _50)) (BK (P _936)))) ((A :58 ((_114 _50) ((S P) I))) ((A :59 ((B (_114 _50)) ((C (S' P)) I))) ((A :60 ((_109 ((C ((C S') _63)) I)) (_113 _60))) ((A :61 (R _68)) ((A :62 (T _67)) ((A :63 ((P _68) _67)) ((A :64 _68) ((A :65 ((C ((C S') _63)) I)) ((A :66 ((C S) _63)) ((A :67 K) ((A :68 A) ((A :69 ((_109 _972) _973)) ((A :70 ((((((((_243 _69) (_252 _70)) _974) _975) _976) _977) (_257 _70)) (_258 _70))) ((A :71 ((_109 _982) (_113 _71))) ((A :72 ((((((((_243 _71) _981) (((C' (C' (_110 _259))) _981) _261)) (((C' (C' (_111 _259))) _981) _263)) (((C' (C' (_110 _259))) _981) _263)) (((C' (C' (_111 _259))) _981) _263)) (_257 _72)) (_258 _72))) ((A :73 _983) ((A :74 _984) ((A :75 (((S' _62) (_975 #97)) ((C _975) #122))) ((A :76 (((S' _62) (_975 #65)) ((C _975) #90))) ((A :77 (((S' _61) _75) _76)) ((A :78 (((S' _62) (_975 #48)) ((C _975) #57))) ((A :79 (((S' _61) _77) _78)) ((A :80 (((S' _62) (_975 #32)) ((C _975) #126))) ((A :81 (((S' _61) ((C (_110 _69)) #32)) (((S' _61) ((C (_110 _69)) #9)) ((C (_110 _69)) #10)))) ((A :82 ((S ((S (((S' _62) (_975 #65)) ((C _975) #90))) (_68 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _73) (((C' _129) (((C' _130) _74) (_74 #65))) (_74 #97))))) ((A :83 ((S ((S (((S' _62) (_975 #97)) ((C _975) #97))) (_68 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _73) (((C' _129) (((C' _130) _74) (_74 #97))) (_74 #65))))) ((A :84 _943) ((A :85 _944) ((A :86 _945) ((A :87 _946) ((A :88 (_85 %0.0)) ((A :89 _84) ((A :90 _85) ((A :91 _86) ((A :92 _87) ((A :93 ((_109 _947) _948)) ((A :94 (_110 _93)) ((A :95 (_111 _93)) ((A :96 _949) ((A :97 _950) ((A :98 _951) ((A :99 _952) ((A :100 _96) ((A :101 _97) ((A :102 _98) ((A :103 _99) ((A :104 _953) ((A :105 ((B BK) T)) ((A :106 (BK T)) ((A :107 (((S' _109) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _110) (T K)))) (K _67)))) ((B ((C' B) (T (K _67)))) ((B _110) (T
\ No newline at end of file
+1171
+((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _128) ((B _12) _1)) _235))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _234))) ((A :10 (((S' P) _2) (((C' _13) _1) _937))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _125) _12) _117))) ((A :20 (((S' B) _14) (((C' _128) _12) _118))) ((A :21 _1009) ((A :22 ((B _1051) _21)) ((A :23 (((S' _1051) _21) I)) ((A :24 _979) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1008) ((C _116) _26))) ((A :28 (((C' _27) ((_124 _1022) _106)) ((_116 (_34 _1024)) _105))) ((A :29 ((B ((S _1051) (_34 _1024))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _234)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _235)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _937)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _937))) ((A :46 ((C _43) _117)) ((A :47 ((B _119) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _119) _48)) ((A :50 T) ((A :51 ((_123 ((B (B (_114 _50))) ((B ((C' C) _54)) (B P)))) (_127 _51))) ((A :52 (((((_11 _51) ((B (_114 _50)) P)) (_38 _53)) ((B (B (_114 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_114 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_116 _264)) _54)) ((A :56 ((B (_114 _50)) (B (P _937)))) ((A :57 ((B (_114 _50)) (BK (P _937)))) ((A :58 ((_114 _50) ((S P) I))) ((A :59 ((B (_114 _50)) ((C (S' P)) I))) ((A :60 ((_109 ((C ((C S') _63)) I)) (_113 _60))) ((A :61 (R _68)) ((A :62 (T _67)) ((A :63 ((P _68) _67)) ((A :64 _68) ((A :65 ((C ((C S') _63)) I)) ((A :66 ((C S) _63)) ((A :67 K) ((A :68 A) ((A :69 ((_109 _973) _974)) ((A :70 ((((((((_243 _69) (_252 _70)) _975) _976) _977) _978) (_257 _70)) (_258 _70))) ((A :71 ((_109 _983) (_113 _71))) ((A :72 ((((((((_243 _71) _982) (((C' (C' (_110 _259))) _982) _261)) (((C' (C' (_111 _259))) _982) _263)) (((C' (C' (_110 _259))) _982) _263)) (((C' (C' (_111 _259))) _982) _263)) (_257 _72)) (_258 _72))) ((A :73 _984) ((A :74 _985) ((A :75 (((S' _62) (_976 #97)) ((C _976) #122))) ((A :76 (((S' _62) (_976 #65)) ((C _976) #90))) ((A :77 (((S' _61) _75) _76)) ((A :78 (((S' _62) (_976 #48)) ((C _976) #57))) ((A :79 (((S' _61) _77) _78)) ((A :80 (((S' _62) (_976 #32)) ((C _976) #126))) ((A :81 (((S' _61) ((C (_110 _69)) #32)) (((S' _61) ((C (_110 _69)) #9)) ((C (_110 _69)) #10)))) ((A :82 ((S ((S (((S' _62) (_976 #65)) ((C _976) #90))) (_68 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _73) (((C' _129) (((C' _130) _74) (_74 #65))) (_74 #97))))) ((A :83 ((S ((S (((S' _62) (_976 #97)) ((C _976) #97))) (_68 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _73) (((C' _129) (((C' _130) _74) (_74 #97))) (_74 #65))))) ((A :84 _944) ((A :85 _945) ((A :86 _946) ((A :87 _947) ((A :88 (_85 %0.0)) ((A :89 _84) ((A :90 _85) ((A :91 _86) ((A :92 _87) ((A :93 ((_109 _948) _949)) ((A :94 (_110 _93)) ((A :95 (_111 _93)) ((A :96 _950) ((A :97 _951) ((A :98 _952) ((A :99 _953) ((A :100 _96) ((A :101 _97) ((A :102 _98) ((A :103 _99) ((A :104 _954) ((A :105 ((B BK) T)) ((A :106 (BK T)) ((A :107 (((S' _109) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _110) (T K)))) (K _67)))) ((B ((C' B) (T (K _67)))) ((B _110) (T
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -49,7 +49,7 @@
Import _ -> []
ForImp ie i _ -> [(i, Lit $ LForImp ie)]
Infix _ _ -> []
- Class ctx (c, _) bs ->
+ Class ctx (c, _) _ bs ->
let f = mkIdent "$f"
meths :: [Ident]
meths = [ qualIdent mn i | (BSign i _) <- bs ]
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -14,6 +14,7 @@
EAlts(..),
EAlt,
ECaseArm,
+ FunDep,
EType, showEType, eqEType,
EConstraint,
EPat, patVars, isPVar, isPConApp,
@@ -66,7 +67,7 @@
| Import ImportSpec
| ForImp String Ident EType
| Infix Fixity [Ident]
- | Class [EConstraint] LHS [EBind] -- XXX will probable need initial forall with FD
+ | Class [EConstraint] LHS [FunDep] [EBind] -- XXX will probable need initial forall with FD
| Instance [IdKind] [EConstraint] EConstraint [EBind] -- no deriving yet
--Xderiving (Show, Eq)
@@ -102,6 +103,8 @@
| EForall [IdKind] Expr -- only in types
--Xderiving (Show, Eq)
+type FunDep = ([Ident], [Ident])
+
eLam :: [EPat] -> Expr -> Expr
eLam ps e = ELam $ eEqns ps e
@@ -408,10 +411,15 @@
ForImp ie i t -> text ("foreign import ccall " ++ showString ie) <+> ppIdent i <+> text "::" <+> ppEType t Infix (a, p) is -> text ("infix" ++ f a) <+> text (showInt p) <+> hsep (punctuate (text ", ") (map ppIdent is))where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""
- Class sup lhs bs -> ppWhere (text "class" <+> ctx sup <+> ppLHS lhs) bs
+ 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
where ctx [] = empty
ctx ts = ppEType (ETuple ts) <+> text "=>"
+
+ppFunDeps :: [FunDep] -> Doc
+ppFunDeps [] = empty
+ppFunDeps fds =
+ text "|" <+> hsep (punctuate (text ",") (map (\ (is, os) -> hsep (map ppIdent is) <+> text "-" <+> hsep (map ppIdent os)) fds))
ppEqns :: Doc -> Doc -> [Eqn] -> Doc
ppEqns name sepr = vcat . map (\ (Eqn ps alts) -> sep [name <+> hsep (map ppEPat ps), ppAlts sepr alts])
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -260,7 +260,7 @@
<|< Import <$> (pKeyword "import" *> pImportSpec)
<|< ForImp <$> (pKeyword "foreign" *> pKeyword "import" *> pKeyword "ccall" *> pString) <*> pLIdent <*> (pSymbol "::" *> pType)
<|< Infix <$> ((,) <$> pAssoc <*> pPrec) <*> esepBy1 pTypeOper (pSpec ',')
- <|< Class <$> (pKeyword "class" *> pContext) <*> pLHS <*> pWhere pClsBind
+ <|< Class <$> (pKeyword "class" *> pContext) <*> pLHS <*> pFunDeps <*> pWhere pClsBind
<|< Instance <$> (pKeyword "instance" *> pForall) <*> pContext <*> pTypeApp <*> pWhere pClsBind
where
pAssoc = (AssocLeft <$ pKeyword "infixl") <|< (AssocRight <$ pKeyword "infixr") <|< (AssocNone <$ pKeyword "infix")
@@ -276,6 +276,8 @@
fs <- pFields
guard $ either length length fs == 1
P.pure fs
+ pFunDeps = (pSpec '|' *> esome pFunDep) <|< P.pure []
+ pFunDep = (,) <$> esome pLIdent <*> (pSymbol "->" *> esome pLIdent)
pLHS :: P LHS
pLHS = (,) <$> pTypeIdentSym <*> emany pIdKind
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -241,7 +241,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) (assoc i) | Class _ (i, _) _ _ <- tds ] ++
[ TypeExport i (tentry i) [] | Type (i, _) _ <- tds ]
-- All type synonym definitions.
@@ -949,7 +949,7 @@
addLHSKind lhs kType
addAssoc i (assocData c)
Type lhs t -> addLHSKind lhs (getTypeKind t)
- Class _ lhs@(i, _) ms -> T.do
+ Class _ lhs@(i, _) _ ms -> T.do
addLHSKind lhs kConstraint
addAssoc i [ m | BSign m _ <- ms ]
_ -> T.return ()
@@ -987,7 +987,7 @@
Type lhs@(_, iks) t -> withVars iks $ Type lhs <$> tInferTypeT t
Sign i t -> Sign i <$> tCheckTypeT kType t
ForImp ie i t -> ForImp ie i <$> tCheckTypeT kType t
- Class ctx lhs@(_, iks) ms -> withVars iks $ Class <$> tcCtx ctx T.<*> T.return lhs T.<*> T.mapM tcMethod ms
+ Class ctx lhs@(_, iks) fds ms -> withVars iks $ Class <$> tcCtx ctx T.<*> T.return lhs <*> mapM tcFD fds T.<*> T.mapM tcMethod ms
Instance iks ctx c m -> withVars iks $ Instance iks <$> tcCtx ctx T.<*> tCheckTypeT kConstraint c T.<*> T.return m
_ -> T.return d
where
@@ -994,6 +994,8 @@
tcCtx = T.mapM (tCheckTypeT kConstraint)
tcMethod (BSign i t) = BSign i <$> tcTypeT (Check kType) t
tcMethod m = T.return m
+ tcFD (is, os) = (,) <$> mapM tcV is <*> mapM tcV os
+ where tcV i = T.do { _ <- tLookup "fundep" i; T.return i }withVars :: forall a . [IdKind] -> T a -> T a
withVars aiks ta =
@@ -1056,8 +1058,9 @@
-- in the desugaring pass.
-- Default methods are added as actual definitions.
-- The constructor and methods are added to the symbol table in addValueType.
+-- XXX FunDep
expandClass :: EDef -> T [EDef]
-expandClass dcls@(Class ctx (iCls, vks) ms) = T.do
+expandClass dcls@(Class ctx (iCls, vks) _fds ms) = T.do
mn <- gets moduleName
let
meths = [ b | b@(BSign _ _) <- ms ]
@@ -1158,11 +1161,12 @@
tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)
extValETop c (EForall vks $ tArrow t tret) (ECon $ ConNew (qualIdent mn c))
ForImp _ i t -> extValQTop i t
- Class ctx (i, vks) ms -> addValueClass ctx i vks ms
+ Class ctx (i, vks) fds ms -> addValueClass ctx i vks fds ms
_ -> T.return ()
-addValueClass :: [EConstraint] -> Ident -> [IdKind] -> [EBind] -> T ()
-addValueClass ctx iCls vks ms = T.do
+-- XXX FunDep
+addValueClass :: [EConstraint] -> Ident -> [IdKind] -> [FunDep] -> [EBind] -> T ()
+addValueClass ctx iCls vks _fds ms = T.do
mn <- gets moduleName
let
meths = [ b | b@(BSign _ _) <- ms ]
--
⑨