@@ -22,26 +22,37 @@ import Language.PureScript.Types
2222import Language.PureScript.Values
2323import Language.PureScript.CodeGen.JS.AST
2424
25+import qualified Data.Map as M
26+
27+import Control.Applicative
28+import Control.Monad.State
29+import Data.Maybe (fromMaybe)
30+
31+type MemberMap = M.Map (ModuleName, ProperName) [(String, Type)]
32+
2533desugarTypeClasses :: [Module] -> [Module]
26−desugarTypeClasses = map desugarModule
34+desugarTypeClasses = flip evalState M.empty . mapM desugarModule
35+
36+desugarModule :: Module -> State MemberMap Module
37+desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls
2738
28−desugarModule :: Module -> Module
29−desugarModule (Module name decls) = Module name $ concatMap desugarDecl decls
39+desugarDecl :: ModuleName -> Declaration -> State MemberMap [Declaration]
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]
3048
31−desugarDecl :: Declaration -> [Declaration]
32−desugarDecl (TypeClassDeclaration name arg members) =
33− typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
34−desugarDecl (TypeInstanceDeclaration deps name ty members) =
35− typeInstanceDictionaryDeclaration deps name ty members : map (typeInstanceDictionaryEntryDeclaration deps name ty) members
36−desugarDecl other = [other]
49+memberToNameAndType :: Declaration -> (String, Type)
50+memberToNameAndType (TypeDeclaration ident ty) = (identToString ident, ty)
51+memberToNameAndType _ = error "Invalid declaration in type class definition"
3752
3853typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration
3954typeClassDictionaryDeclaration name arg members =
4055 TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty))
41− where
42− memberToNameAndType :: Declaration -> (String, Type)
43− memberToNameAndType (TypeDeclaration ident ty) = (identToString ident, ty)
44− memberToNameAndType _ = error "Invalid declaration in type class definition"
4556
4657typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration
4758typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
@@ -61,18 +72,35 @@ typeInstanceDictionaryDeclaration deps name ty decls =
6172 (identToString ident, JSVar $ mkDictionaryEntryName name ty ident)
6273 memberToNameAndValue _ = error "Invalid declaration in type instance definition"
6374
64−typeInstanceDictionaryEntryDeclaration :: [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Declaration
65−typeInstanceDictionaryEntryDeclaration deps name ty (ValueDeclaration ident binders guard val) =
66− ValueDeclaration (mkDictionaryEntryName name ty ident) binders guard
67− (TypedValue val (ConstrainedType deps undefined))
68−typeInstanceDictionaryEntryDeclaration _ _ _ _ = error "Invalid declaration in type instance definition"
75+typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> State MemberMap Declaration
76+typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident binders grd val) = do
77+ m <- get
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
81+ return $ ValueDeclaration (mkDictionaryEntryName name ty ident) binders grd
82+ (TypedValue val (ConstrainedType deps valTy))
83+typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"
6984
7085identToString :: Ident -> String
7186identToString (Ident s) = s
72−identToString (Op _) = error "Unsupported type class instance name"
87+identToString (Op _) = error "TODO: Unsupported type class instance name"
88+
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
7392
7493mkDictionaryValueName :: Qualified ProperName -> Type -> Ident
75−mkDictionaryValueName _ _ = Ident "__dict"
94+mkDictionaryValueName cl ty = Ident $ "__" ++ qualifiedToString cl ++ "_" ++ typeToString ty
95+ where
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"
76104
77105mkDictionaryEntryName :: Qualified ProperName -> Type -> Ident -> Ident
78106mkDictionaryEntryName name ty ident = let Ident dictName = mkDictionaryValueName name ty