ref: 994a9aca7d24e493ba422fb4e3de626c5bc1b96d
parent: 1b0c99b7821ae56932c1e1f1ac9b910aaff51f9e
author: Lennart Augustsson <lennart@augustsson.net>
date: Fri Oct 13 07:15:24 EDT 2023
Parse class/instance.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-972
-((A :0 _856) ((A :1 ((B _902) _0)) ((A :2 (((S' _902) _0) I)) ((A :3 _826) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _855) ((C _74) _5))) ((A :7 (((C' _6) (_873 _71)) ((_74 _871) _70))) ((A :8 ((B ((S _902) _871)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_74 _188)) _10)) ((A :12 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_73 _9)) P)) ((A :15 ((B (B (_73 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 ((B (_73 _9)) (B (P _784)))) ((A :18 ((B (_73 _9)) (BK (P _784)))) ((A :19 ((_73 _9) ((S P) I))) ((A :20 ((B (_73 _9)) ((C (S' P)) I))) ((A :21 ((B Y) ((B (B (P (_14 _114)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _115)))))) ((A :22 ((B Y) ((B (B (P (_14 _784)))) ((B (C' B)) (B _13))))) ((A :23 _3) ((A :24 (T (_14 _784))) ((A :25 (_21 _75)) ((A :26 ((C C) _33)) ((A :27 (T _32)) ((A :28 ((P _33) _32)) ((A :29 _33) ((A :30 ((C ((C S') _28)) I)) ((A :31 ((C S) _28)) ((A :32 K) ((A :33 A) ((A :34 _831) ((A :35 _832) ((A :36 (((S' _27) (_823 #97)) ((C _823) #122))) ((A :37 (((S' _27) (_823 #65)) ((C _823) #90))) ((A :38 (((S' _26) _36) _37)) ((A :39 (((S' _27) (_823 #48)) ((C _823) #57))) ((A :40 (((S' _27) (_823 #32)) ((C _823) #126))) ((A :41 _820) ((A :42 _821) ((A :43 _823) ((A :44 _822) ((A :45 (((S' _26) ((C _41) #32)) (((S' _26) ((C _41) #9)) ((C _41) #10)))) ((A :46 ((S ((S (((S' _27) (_43 #65)) ((C _43) #90))) (_33 (((_783 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _81) (((C' _82) _35) (_35 #65))) (_35 #97))))) ((A :47 ((S ((S (((S' _27) (_43 #97)) ((C _43) #97))) (_33 (((_783 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _81) (((C' _82) _35) (_35 #97))) (_35 #65))))) ((A :48 _791) ((A :49 _792) ((A :50 _793) ((A :51 _794) ((A :52 (_49 %0.0)) ((A :53 _48) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _795) ((A :58 _796) ((A :59 _57) ((A :60 _58) ((A :61 _797) ((A :62 _798) ((A :63 _799) ((A :64 _800) ((A :65 _61) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _801) ((A :70 ((B BK) T)) ((A :71 (BK T)) ((A :72 P) ((A :73 I) ((A :74 B) ((A :75 I) ((A :76 K) ((A :77 C) ((A :78 _827) ((A :79 ((C ((C S') _188)) _189)) ((A :80 (((C' (S' (C' B))) B) I)) ((A :81 _785) ((A :82 _786) ((A :83 _787) ((A :84 _788) ((A :85 _789) ((A :86 _790) ((A :87 (_82 #0)) ((A :88 _808) ((A :89 _809) ((A :90 _810) ((A :91 _811) ((A :92 _812) ((A :93 _813) ((A :94 _88) ((A :95 (BK K)) ((A :96 ((B BK) ((B (B BK)) P))) ((A :97 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :98 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _26) (_91 #0))) (_88 #0)))) ((B (B ((C' P) (_86 #1)))) _81))) (C P))) _84)) _85)) ((A :99 _95) ((A :100 (((S' C) ((B (P _176)) (((C' (C' B)) (((C' C) _88) _176)) _177))) ((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') (_88 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_88 #1)))) ((B ((C' C) ((B ((C' S') (_88 #2))) (C _100)))) (C _100))))) (C _100))))) (C _100)))) (T K))) (T A)))) ((C _98) #4)))) ((A :101 (_107 _76)) ((A :102 ((_122 (_79 _101)) _99)) ((A :103 ((C (((C' B) ((P _114) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _104)))) (((S' (C' (C' B))) ((B (B (B _104))) (((S' (C' B)) ((B (B _104)) (((C' B) ((B _120) (T #0))) _103))) (((C' B) ((B _120) (T #1))) _103)))) (((C' B) ((B _120) (T #2))) _103)))) (((C' B) ((B _120) (T #3))) _103)))) ((B T) ((B (B P)) ((C' _81) (_83 #4)))))) ((A :104 ((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) _90)))) ((B ((C' B) _115)) _104)))))) ((B ((C' B) _115)) (C _104)))))))))) (((_783 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :105 ((_74 (_120 _188)) _103)) ((A :106 (((C' C) (((C' C) (C _100)) (_3 "Data.IntMap.!"))) I)) ((A :107 ((B ((C' B) T)) ((B (B Y)) (((C' (C' (S' (S' C)))) ((B ((S' B) ((B (S' P)) (C _96)))) ((B (B ((C' (
\ No newline at end of file
+978
+((A :0 _862) ((A :1 ((B _908) _0)) ((A :2 (((S' _908) _0) I)) ((A :3 _832) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _861) ((C _74) _5))) ((A :7 (((C' _6) (_879 _71)) ((_74 _877) _70))) ((A :8 ((B ((S _908) _877)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_74 _188)) _10)) ((A :12 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_73 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_73 _9)) P)) ((A :15 ((B (B (_73 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 ((B (_73 _9)) (B (P _790)))) ((A :18 ((B (_73 _9)) (BK (P _790)))) ((A :19 ((_73 _9) ((S P) I))) ((A :20 ((B (_73 _9)) ((C (S' P)) I))) ((A :21 ((B Y) ((B (B (P (_14 _114)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _115)))))) ((A :22 ((B Y) ((B (B (P (_14 _790)))) ((B (C' B)) (B _13))))) ((A :23 _3) ((A :24 (T (_14 _790))) ((A :25 (_21 _75)) ((A :26 ((C C) _33)) ((A :27 (T _32)) ((A :28 ((P _33) _32)) ((A :29 _33) ((A :30 ((C ((C S') _28)) I)) ((A :31 ((C S) _28)) ((A :32 K) ((A :33 A) ((A :34 _837) ((A :35 _838) ((A :36 (((S' _27) (_829 #97)) ((C _829) #122))) ((A :37 (((S' _27) (_829 #65)) ((C _829) #90))) ((A :38 (((S' _26) _36) _37)) ((A :39 (((S' _27) (_829 #48)) ((C _829) #57))) ((A :40 (((S' _27) (_829 #32)) ((C _829) #126))) ((A :41 _826) ((A :42 _827) ((A :43 _829) ((A :44 _828) ((A :45 (((S' _26) ((C _41) #32)) (((S' _26) ((C _41) #9)) ((C _41) #10)))) ((A :46 ((S ((S (((S' _27) (_43 #65)) ((C _43) #90))) (_33 (((_789 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _81) (((C' _82) _35) (_35 #65))) (_35 #97))))) ((A :47 ((S ((S (((S' _27) (_43 #97)) ((C _43) #97))) (_33 (((_789 "lib/Data/Char.hs") #3) #8)))) ((B _34) (((C' _81) (((C' _82) _35) (_35 #97))) (_35 #65))))) ((A :48 _797) ((A :49 _798) ((A :50 _799) ((A :51 _800) ((A :52 (_49 %0.0)) ((A :53 _48) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _801) ((A :58 _802) ((A :59 _57) ((A :60 _58) ((A :61 _803) ((A :62 _804) ((A :63 _805) ((A :64 _806) ((A :65 _61) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _807) ((A :70 ((B BK) T)) ((A :71 (BK T)) ((A :72 P) ((A :73 I) ((A :74 B) ((A :75 I) ((A :76 K) ((A :77 C) ((A :78 _833) ((A :79 ((C ((C S') _188)) _189)) ((A :80 (((C' (S' (C' B))) B) I)) ((A :81 _791) ((A :82 _792) ((A :83 _793) ((A :84 _794) ((A :85 _795) ((A :86 _796) ((A :87 (_82 #0)) ((A :88 _814) ((A :89 _815) ((A :90 _816) ((A :91 _817) ((A :92 _818) ((A :93 _819) ((A :94 _88) ((A :95 (BK K)) ((A :96 ((B BK) ((B (B BK)) P))) ((A :97 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :98 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _26) (_91 #0))) (_88 #0)))) ((B (B ((C' P) (_86 #1)))) _81))) (C P))) _84)) _85)) ((A :99 _95) ((A :100 (((S' C) ((B (P _176)) (((C' (C' B)) (((C' C) _88) _176)) _177))) ((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') (_88 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_88 #1)))) ((B ((C' C) ((B ((C' S') (_88 #2))) (C _100)))) (C _100))))) (C _100))))) (C _100)))) (T K))) (T A)))) ((C _98) #4)))) ((A :101 (_107 _76)) ((A :102 ((_122 (_79 _101)) _99)) ((A :103 ((C (((C' B) ((P _114) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _104)))) (((S' (C' (C' B))) ((B (B (B _104))) (((S' (C' B)) ((B (B _104)) (((C' B) ((B _120) (T #0))) _103))) (((C' B) ((B _120) (T #1))) _103)))) (((C' B) ((B _120) (T #2))) _103)))) (((C' B) ((B _120) (T #3))) _103)))) ((B T) ((B (B P)) ((C' _81) (_83 #4)))))) ((A :104 ((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) _90)))) ((B ((C' B) _115)) _104)))))) ((B ((C' B) _115)) (C _104)))))))))) (((_789 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :105 ((_74 (_120 _188)) _103)) ((A :106 (((C' C) (((C' C) (C _100)) (_3 "Data.IntMap.!"))) I)) ((A :107 ((B ((C' B) T)) ((B (B Y)) (((C' (C' (S' (S' C)))) ((B ((S' B) ((B (S' P)) (C _96)))) ((B (B ((C' (
\ No newline at end of file
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -5,6 +5,8 @@
import Data.Ordering_Type
infixr -1 ->
+infixr -2 =>
+infix 4 ~
data Any
data Char
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -48,6 +48,8 @@
Import _ -> []
ForImp ie i _ -> [(i, Lit $ LForImp ie)]
Infix _ _ -> []
+ Class _ _ _ -> [] -- XXX probably needs a default instance
+ Instance _ _ _ -> [] -- XXX probably needs instance record
oneAlt :: Expr -> EAlts
oneAlt e = EAlts [([], e)] []
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -15,8 +15,9 @@
EAlt,
ECaseArm,
EType, showEType,
+ EConstraint,
EPat, patVars, isPVar, isPConApp,
- EKind, kType,
+ EKind, kType, kConstraint,
IdKind(..), idKindIdent,
LHS,
Constr(..),
@@ -62,6 +63,8 @@
| Import ImportSpec
| ForImp String Ident EType
| Infix Fixity [Ident]
+ | Class (Maybe EConstraint) LHS [EBind]
+ | Instance (Maybe EConstraint) EType [EBind] -- no deriving yet
--Xderiving (Show, Eq)
data ImportSpec = ImportSpec Bool Ident (Maybe Ident) (Maybe (Bool, [ImportItem])) -- first Bool indicates 'qualified', second 'hiding'
@@ -191,6 +194,8 @@
-- * before desugaring: EApp, EVar, ETuple, EList
type EType = Expr
+type EConstraint = EType
+
data IdKind = IdKind Ident EKind
--Xderiving (Show, Eq)
@@ -202,6 +207,9 @@
kType :: EKind
kType = EVar (Ident noSLoc "Primitives.Type")
+kConstraint :: EKind
+kConstraint = EVar (Ident noSLoc "Primitives.Constraint")
+
tupleConstr :: SLoc -> Int -> Ident
tupleConstr loc n = mkIdentSLoc loc (replicate (n - 1) ',')
@@ -371,6 +379,10 @@
ForImp ie i t -> "foreign import ccall " ++ showString ie ++ " " ++ showIdent i ++ " :: " ++ showEType t
Infix (a, p) is -> "infix" ++ f a ++ " " ++ showInt p ++ " " ++ intercalate ", " (map showIdent is)
where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""
+ Class sup lhs bs -> "class " ++ ctx sup ++ showLHS lhs ++ showWhere bs
+ Instance ct ty bs -> "instance " ++ ctx ct ++ showEType ty ++ showWhere bs
+ where ctx Nothing = ""
+ ctx (Just t) = showEType t ++ " => "
showConstr :: Constr -> String
showConstr (Constr i ts) = unwords (showIdent i : map showEType ts)
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -115,9 +115,10 @@
satisfyM "LQIdent" is
keywords :: [String]
-keywords = ["case", "data", "do", "else", "forall", "foreign", "if", "import",
- "in", "infix", "infixl", "infixr",
- "let", "module", "newtype", "of", "primitive", "then", "type", "where"]
+keywords =
+ ["case", "class", "data", "do", "else", "forall", "foreign", "if", "import",
+ "in", "infix", "infixl", "infixr", "instance",
+ "let", "module", "newtype", "of", "primitive", "then", "type", "where"]
pSpec :: Char -> P ()
pSpec c = () <$ satisfy [c] is
@@ -253,14 +254,17 @@
<|< Type <$> (pKeyword "type" *> pLHS) <*> (pSymbol "=" *> pType)
<|< uncurry Fcn <$> pEqns
<|< Sign <$> (pLIdentSym <* pSymbol "::") <*> pType
- <|< Import <$> (pKeyword "import" *> pImportSpec)
+ <|< 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
+ <|< Instance <$> (pKeyword "instance" *> pContext) <*> pTypeApp <*> pWhere pClsBind
where
pAssoc = (AssocLeft <$ pKeyword "infixl") <|< (AssocRight <$ pKeyword "infixr") <|< (AssocNone <$ pKeyword "infix")
- dig (TInt _ i) | -1 <= i && i <= 9 = Just i
+ dig (TInt _ i) | -2 <= i && i <= 9 = Just i
dig _ = Nothing
pPrec = satisfyM "digit" dig
+ pContext = optional (pTypeApp <* pSymbol "=>")
pLHS :: P LHS
pLHS = (,) <$> pUIdentSym <*> emany pIdKind
@@ -303,7 +307,7 @@
pTypeOp = pOperators pTypeOper pTypeArg
pTypeOper :: P Ident
-pTypeOper = pOper <|< (mkIdent "->" <$ pSymbol "->")
+pTypeOper = pOper <|< (mkIdent "->" <$ pSymbol "->") <|< (mkIdent "=>" <$ pSymbol "=>")
pTypeArg :: P EType
pTypeArg = pTypeApp
@@ -403,7 +407,7 @@
pAlts :: P () -> P EAlts
pAlts sep = P.do
alts <- pAltsL sep
- bs <- pWhere
+ bs <- pWhere pBind
P.pure (EAlts alts bs)
pAltsL :: P () -> P [EAlt]
@@ -411,9 +415,9 @@
esome ((,) <$> (pSymbol "|" *> esepBy1 pStmt (pSpec ',')) <*> (sep *> pExpr))
<|< ((\ e -> [([], e)]) <$> (sep *> pExpr))
-pWhere :: P [EBind]
-pWhere =
- (pKeyword "where" *> pBlock pBind)
+pWhere :: P EBind -> P [EBind]
+pWhere pb =
+ (pKeyword "where" *> pBlock pb)
<|< P.pure []
-------------
@@ -517,8 +521,12 @@
pBind :: P EBind
pBind =
+ BPat <$> (pPatNotVar <* pSymbol "=") <*> pExpr
+ <|< pClsBind
+
+pClsBind :: P EBind
+pClsBind =
uncurry BFcn <$> pEqns
- <|< BPat <$> (pPatNotVar <* pSymbol "=") <*> pExpr
<|< BSign <$> (pLIdentSym <* pSymbol "::") <*> pType
-------------
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -329,6 +329,14 @@
kTypeTypeTypeS :: EType
kTypeTypeTypeS = kArrow kType $ kArrow kType kType
+-- (=>) :: Constraint -> Type -> Type
+kConstraintTypeTypeS :: EType
+kConstraintTypeTypeS = kArrow kConstraint $ kArrow kType kType
+
+-- (~) :: Type -> Type -> Constraint
+kTypeTypeConstraintS :: EType
+kTypeTypeConstraintS = kArrow kType (kArrow kType kConstraint)
+
builtinLoc :: SLoc
builtinLoc = SLoc "builtin" 0 0
@@ -343,6 +351,7 @@
-- The kinds are wired in (for now)
(mkIdentB "Primitives.Type", [entry "Primitives.Type" kTypeS]),
(mkIdentB "Type", [entry "Primitives.Type" kTypeS]),
+ (mkIdentB "Constraint", [entry "Primitives.Constraint" kTypeS]),
(mkIdentB "Primitives.->", [entry "Primitives.->" kTypeTypeTypeS]),
(mkIdentB "->", [entry "Primitives.->" kTypeTypeTypeS])
]
@@ -357,8 +366,11 @@
in (i, [entry (unIdent i) $ foldr kArrow kType (replicate n kType)])
in
[
- -- The function arrow is bothersome to define in Primtives, so keep it here.
+ -- The function arrow et al are bothersome to define in Primitives, so keep them here.
+ -- But the fixity is defined in Primitives.
(mkIdentB "->", [entry "Primitives.->" kTypeTypeTypeS]),
+ (mkIdentB "=>", [entry "Primitives.=>" kConstraintTypeTypeS]),
+ (mkIdentB "~", [entry "Primitives.~" kTypeTypeConstraintS]),
-- Primitives.hs uses the type [], and it's annoying to fix that.
(mkIdentB "Data.List.[]", [entry "Data.List.[]" kTypeTypeS])
] ++
--
⑨