@@ -22,26 +22,37 @@ import Language.PureScript.Types
22import Language.PureScript.Values
22import Language.PureScript.Values
23import Language.PureScript.CodeGen.JS.AST
23import Language.PureScript.CodeGen.JS.AST
25+import qualified Data.Map as M
27+import Control.Applicative
28+import Control.Monad.State
29+import Data.Maybe (fromMaybe)
31+type MemberMap = M.Map (ModuleName, ProperName) [(String, Type)]
25desugarTypeClasses :: [Module] -> [Module]
33desugarTypeClasses :: [Module] -> [Module]
26−desugarTypeClasses = map desugarModule
34+desugarTypeClasses = flip evalState M.empty . mapM desugarModule
36+desugarModule :: Module -> State MemberMap Module
37+desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls
28−desugarModule :: Module -> Module
39+desugarDecl :: ModuleName -> Declaration -> State MemberMap [Declaration]
29−desugarModule (Module name decls) = Module name $ concatMap desugarDecl decls
40+desugarDecl mn (TypeClassDeclaration name arg members) = do
41+ let tys = map memberToNameAndType members
42+ modify (M.insert (mn, name) tys)
43+ return $ typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
44+desugarDecl mn (TypeInstanceDeclaration deps name ty members) = do
45+ entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) members
46+ return $ typeInstanceDictionaryDeclaration deps name ty members : entries
47+desugarDecl _ other = return [other]
31−desugarDecl :: Declaration -> [Declaration]
49+memberToNameAndType :: Declaration -> (String, Type)
32−desugarDecl (TypeClassDeclaration name arg members) =
50+memberToNameAndType (TypeDeclaration ident ty) = (identToString ident, ty)
33− typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
51+memberToNameAndType _ = error "Invalid declaration in type class definition"
34−desugarDecl (TypeInstanceDeclaration deps name ty members) =
35− typeInstanceDictionaryDeclaration deps name ty members : map (typeInstanceDictionaryEntryDeclaration deps name ty) members
36−desugarDecl other = [other]
38typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration
53typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration
39typeClassDictionaryDeclaration name arg members =
54typeClassDictionaryDeclaration name arg members =
40 TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty))
55 TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty))
42− memberToNameAndType :: Declaration -> (String, Type)
43− memberToNameAndType (TypeDeclaration ident ty) = (identToString ident, ty)
44− memberToNameAndType _ = error "Invalid declaration in type class definition"
46typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration
57typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration
47typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
58typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
@@ -61,18 +72,35 @@ typeInstanceDictionaryDeclaration deps name ty decls =
61 (identToString ident, JSVar $ mkDictionaryEntryName name ty ident)
72 (identToString ident, JSVar $ mkDictionaryEntryName name ty ident)
62 memberToNameAndValue _ = error "Invalid declaration in type instance definition"
73 memberToNameAndValue _ = error "Invalid declaration in type instance definition"
64−typeInstanceDictionaryEntryDeclaration :: [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Declaration
75+typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> State MemberMap Declaration
65−typeInstanceDictionaryEntryDeclaration deps name ty (ValueDeclaration ident binders guard val) =
76+typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident binders grd val) = do
78+ let valTy = fromMaybe (error "Type class instance dictionary member is missing in typeInstanceDictionaryEntryDeclaration") $ do
79+ members <- M.lookup (qualify mn name) m
80+ lookup (identToString ident) members
66− ValueDeclaration (mkDictionaryEntryName name ty ident) binders guard
81+ return $ ValueDeclaration (mkDictionaryEntryName name ty ident) binders grd
67− (TypedValue val (ConstrainedType deps undefined))
82+ (TypedValue val (ConstrainedType deps valTy))
68−typeInstanceDictionaryEntryDeclaration _ _ _ _ = error "Invalid declaration in type instance definition"
83+typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"
70identToString :: Ident -> String
85identToString :: Ident -> String
71identToString (Ident s) = s
86identToString (Ident s) = s
72−identToString (Op _) = error "Unsupported type class instance name"
87+identToString (Op _) = error "TODO: Unsupported type class instance name"
89+qualifiedToString :: Qualified ProperName -> String
90+qualifiedToString (Qualified Nothing _) = error "TODO: handle unqualified instances"
91+qualifiedToString (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn
74mkDictionaryValueName :: Qualified ProperName -> Type -> Ident
93mkDictionaryValueName :: Qualified ProperName -> Type -> Ident
75−mkDictionaryValueName _ _ = Ident "__dict"
94+mkDictionaryValueName cl ty = Ident $ "__" ++ qualifiedToString cl ++ "_" ++ typeToString ty
96+ typeToString :: Type -> String
97+ typeToString String = "string"
98+ typeToString Number = "number"
99+ typeToString Boolean = "boolean"
100+ typeToString (Array (TypeVar _)) = "array"
101+ typeToString (TypeConstructor ty') = qualifiedToString ty'
102+ typeToString (TypeApp ty' (TypeVar _)) = typeToString ty'
103+ typeToString _ = error "TODO: Type class instance must be of the form T a1 ... an"
77mkDictionaryEntryName :: Qualified ProperName -> Type -> Ident -> Ident
105mkDictionaryEntryName :: Qualified ProperName -> Type -> Ident -> Ident
78mkDictionaryEntryName name ty ident = let Ident dictName = mkDictionaryValueName name ty
106mkDictionaryEntryName name ty ident = let Ident dictName = mkDictionaryValueName name ty