More work on desugaring type classes into dictionaries

paf31 · paf31 · commit e0d0502b63e9 · 2014-01-12T12:27:53.000-08:00
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
@@ -43,6 +43,6 @@ data Declaration
   | ExternDataDeclaration ProperName Kind
   | FixityDeclaration Fixity String
   | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
-  | TypeClassDeclaration ProperName Ident [Declaration]
-  | TypeInstanceDeclaration ProperName Type [Declaration]
+  | TypeClassDeclaration ProperName String [Declaration]
+  | TypeInstanceDeclaration (Qualified ProperName) Type [Declaration]
   deriving (Show, D.Data, D.Typeable)
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
@@ -100,15 +100,15 @@ parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
 parseTypeClassDeclaration = do
   reserved "class"
   className <- indented *> properName
-  ident <- indented *> parseIdent
+  ident <- indented *> identifier
   indented *> reserved "where"
   members <- mark (P.many (same *> parseTypeDeclaration))
   return $ TypeClassDeclaration className ident members
 
 parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
 parseTypeInstanceDeclaration = do
   reserved "instance"
-  className <- indented *> properName
+  className <- indented *> parseQualified properName
   ty <- indented *> parseType
   indented *> reserved "where"
   members <- mark (P.many (same *> parseValueDeclaration))
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -17,6 +17,9 @@ module Language.PureScript.Sugar.TypeClasses (
 ) where
 
 import Language.PureScript.Declarations
+import Language.PureScript.Names
+import Language.PureScript.Types
+import Language.PureScript.Values
 
 desugarTypeClasses :: [Module] -> [Module]
 desugarTypeClasses = map desugarModule
@@ -25,4 +28,30 @@ desugarModule :: Module -> Module
 desugarModule (Module name decls) = Module name $ concatMap desugarDecl decls
 
 desugarDecl :: Declaration -> [Declaration]
+desugarDecl (TypeClassDeclaration name arg members) = typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
+desugarDecl (TypeInstanceDeclaration name ty members) = []
 desugarDecl other = [other]
+
+typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration
+typeClassDictionaryDeclaration name arg members = TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty))
+  where
+  memberToNameAndType :: Declaration -> (String, Type)
+  memberToNameAndType (TypeDeclaration ident ty) = (show ident, ty)
+  memberToNameAndType _ = error "Invalid declaration in type class definition"
+
+typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration
+typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) = ExternDeclaration ident Nothing (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))
+typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
+
+{-
+typeInstanceDictionaryDeclaration :: Qualified ProperName -> Type -> Declaration
+typeInstanceDictionaryDeclaration name ty decls =
+  ValueDeclaration (mkDictionaryValueName name ty) [] Nothing (TypedValue (ObjectLiteral $ map memberToNameAndValue decls) (TypeApp (TypeConstructor name) ty))
+  where
+  memberToNameAndValue :: Declaration -> (String, Value)
+  memberToNameAndValue (ValueDeclaration ident ty) = (show ident, ty)
+  memberToNameAndValue _ = error "Invalid declaration in type class definition"
+
+mkDictionaryValueName :: ProperName -> Type -> Ident
+mkDictionaryValueName _ _ = Ident "__dict"
+-}
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
@@ -33,6 +33,7 @@ data Type
   | TypeApp Type Type
   | SaturatedTypeSynonym (Qualified ProperName) [Type]
   | ForAll String Type
+  | ConstrainedType [(Qualified ProperName, Type)] Type
   | Skolem Int
   | REmpty
   | RCons String Type Type deriving (Show, Eq, Data, Typeable)
