Skip to content

Commit e0d0502

Browse files
committed
More work on desugaring type classes into dictionaries
1 parent 0604bc1 commit e0d0502

File tree

4 files changed

+34
-4
lines changed

4 files changed

+34
-4
lines changed

src/Language/PureScript/Declarations.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,6 @@ data Declaration
4343
| ExternDataDeclaration ProperName Kind
4444
| FixityDeclaration Fixity String
4545
| ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
46-
| TypeClassDeclaration ProperName Ident [Declaration]
47-
| TypeInstanceDeclaration ProperName Type [Declaration]
46+
| TypeClassDeclaration ProperName String [Declaration]
47+
| TypeInstanceDeclaration (Qualified ProperName) Type [Declaration]
4848
deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/Parser/Declarations.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -100,15 +100,15 @@ parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
100100
parseTypeClassDeclaration = do
101101
reserved "class"
102102
className <- indented *> properName
103-
ident <- indented *> parseIdent
103+
ident <- indented *> identifier
104104
indented *> reserved "where"
105105
members <- mark (P.many (same *> parseTypeDeclaration))
106106
return $ TypeClassDeclaration className ident members
107107

108108
parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
109109
parseTypeInstanceDeclaration = do
110110
reserved "instance"
111-
className <- indented *> properName
111+
className <- indented *> parseQualified properName
112112
ty <- indented *> parseType
113113
indented *> reserved "where"
114114
members <- mark (P.many (same *> parseValueDeclaration))

src/Language/PureScript/Sugar/TypeClasses.hs

Lines changed: 29 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,9 @@ module Language.PureScript.Sugar.TypeClasses (
1717
) where
1818

1919
import Language.PureScript.Declarations
20+
import Language.PureScript.Names
21+
import Language.PureScript.Types
22+
import Language.PureScript.Values
2023

2124
desugarTypeClasses :: [Module] -> [Module]
2225
desugarTypeClasses = map desugarModule
@@ -25,4 +28,30 @@ desugarModule :: Module -> Module
2528
desugarModule (Module name decls) = Module name $ concatMap desugarDecl decls
2629

2730
desugarDecl :: Declaration -> [Declaration]
31+
desugarDecl (TypeClassDeclaration name arg members) = typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
32+
desugarDecl (TypeInstanceDeclaration name ty members) = []
2833
desugarDecl other = [other]
34+
35+
typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration
36+
typeClassDictionaryDeclaration name arg members = TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty))
37+
where
38+
memberToNameAndType :: Declaration -> (String, Type)
39+
memberToNameAndType (TypeDeclaration ident ty) = (show ident, ty)
40+
memberToNameAndType _ = error "Invalid declaration in type class definition"
41+
42+
typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration
43+
typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) = ExternDeclaration ident Nothing (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))
44+
typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
45+
46+
{-
47+
typeInstanceDictionaryDeclaration :: Qualified ProperName -> Type -> Declaration
48+
typeInstanceDictionaryDeclaration name ty decls =
49+
ValueDeclaration (mkDictionaryValueName name ty) [] Nothing (TypedValue (ObjectLiteral $ map memberToNameAndValue decls) (TypeApp (TypeConstructor name) ty))
50+
where
51+
memberToNameAndValue :: Declaration -> (String, Value)
52+
memberToNameAndValue (ValueDeclaration ident ty) = (show ident, ty)
53+
memberToNameAndValue _ = error "Invalid declaration in type class definition"
54+
55+
mkDictionaryValueName :: ProperName -> Type -> Ident
56+
mkDictionaryValueName _ _ = Ident "__dict"
57+
-}

src/Language/PureScript/Types.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ data Type
3333
| TypeApp Type Type
3434
| SaturatedTypeSynonym (Qualified ProperName) [Type]
3535
| ForAll String Type
36+
| ConstrainedType [(Qualified ProperName, Type)] Type
3637
| Skolem Int
3738
| REmpty
3839
| RCons String Type Type deriving (Show, Eq, Data, Typeable)

0 commit comments

Comments
 (0)