@@ -48,7 +48,8 @@ desugarDecl mn d@(TypeClassDeclaration name arg members) = do
48 return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
48 return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
49desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
49desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
50 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) members
50 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) members
51− return $ d : typeInstanceDictionaryDeclaration mn deps name ty members : entries
51+ dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty members
52+ return $ d : dictDecl : entries
52desugarDecl _ other = return [other]
53desugarDecl _ other = return [other]
54memberToNameAndType :: Declaration -> (String, Type)
55memberToNameAndType :: Declaration -> (String, Type)
@@ -66,19 +67,20 @@ typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
66 (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))
67 (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))
67typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
68typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
69−typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Declaration
70+typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration
70−typeInstanceDictionaryDeclaration mn deps name ty decls =
71+typeInstanceDictionaryDeclaration mn deps name ty decls = do
72+ entryName <- mkDictionaryValueName mn name ty
73+ memberNames <- mapM memberToNameAndValue decls
71− ExternDeclaration (mkDictionaryValueName mn name ty)
74+ return $ ExternDeclaration entryName
72− (Just (JSFunction (Just (mkDictionaryValueName mn name ty))
75+ (Just (JSFunction (Just entryName)
73 (map (\n -> Ident ('_' : show n)) [1..length deps])
76 (map (\n -> Ident ('_' : show n)) [1..length deps])
74− (JSBlock [JSReturn (JSObjectLiteral $ map memberToNameAndValue decls)])))
77+ (JSBlock [JSReturn (JSObjectLiteral memberNames)])))
75 (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))
78 (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))
77− memberToNameAndValue :: Declaration -> (String, JS)
80+ memberToNameAndValue :: Declaration -> Desugar (String, JS)
78− memberToNameAndValue (ValueDeclaration ident _ _ _) =
81+ memberToNameAndValue (ValueDeclaration ident _ _ _) = do
79− (identToString ident, let dict = JSVar $ mkDictionaryEntryName mn name ty ident
82+ memberName <- mkDictionaryEntryName mn name ty ident
80− in if null deps then dict
81− else JSApp dict (map (\n -> JSVar (Ident ('_' : show n))) [1..length deps]))
83+ return (identToString ident, JSApp (JSVar memberName) (map (\n -> JSVar (Ident ('_' : show n))) [1..length deps]))
82 memberToNameAndValue _ = error "Invalid declaration in type instance definition"
84 memberToNameAndValue _ = error "Invalid declaration in type instance definition"
84typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration
86typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration
@@ -88,7 +90,7 @@ typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident b
88 do (arg, members) <- M.lookup (qualify mn name) m
90 do (arg, members) <- M.lookup (qualify mn name) m
89 ty' <- lookup (identToString ident) members
91 ty' <- lookup (identToString ident) members
90 return $ replaceTypeVars arg ty ty'
92 return $ replaceTypeVars arg ty ty'
91− entryName = mkDictionaryEntryName mn name ty ident
93+ entryName <- mkDictionaryEntryName mn name ty ident
92 [ValueDeclaration _ _ _ val'] <- lift $ desugarCases [ValueDeclaration entryName binders grd val]
94 [ValueDeclaration _ _ _ val'] <- lift $ desugarCases [ValueDeclaration entryName binders grd val]
93 return $ ValueDeclaration entryName [] Nothing
95 return $ ValueDeclaration entryName [] Nothing
94 (TypedValue val' (quantify (if null deps then valTy else ConstrainedType deps valTy)))
96 (TypedValue val' (quantify (if null deps then valTy else ConstrainedType deps valTy)))
@@ -109,18 +111,21 @@ quantify ty' = foldr ForAll ty' tyVars
109 collect (TypeVar v) = [v]
111 collect (TypeVar v) = [v]
110 collect _ = []
112 collect _ = []
112−mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Ident
114+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Desugar Ident
113−mkDictionaryValueName mn cl ty = Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ typeToString ty
115+mkDictionaryValueName mn cl ty = do
116+ tyStr <- lift $ typeToString ty
117+ return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr
115− typeToString :: Type -> String
119+ typeToString :: Type -> Either String String
116− typeToString String = "string"
120+ typeToString String = return "string"
117− typeToString Number = "number"
121+ typeToString Number = return "number"
118− typeToString Boolean = "boolean"
122+ typeToString Boolean = return "boolean"
119− typeToString (Array (TypeVar _)) = "array"
123+ typeToString (Array (TypeVar _)) = return "array"
120− typeToString (TypeConstructor ty') = qualifiedToString mn ty'
124+ typeToString (TypeConstructor ty') = return $ qualifiedToString mn ty'
121 typeToString (TypeApp ty' (TypeVar _)) = typeToString ty'
125 typeToString (TypeApp ty' (TypeVar _)) = typeToString ty'
122− typeToString _ = error "TODO: Type class instance must be of the form T a1 ... an"
126+ typeToString _ = Left "Type class instance must be of the form T a1 ... an"
124−mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Ident
128+mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident
129+mkDictionaryEntryName mn name ty ident = do
125−mkDictionaryEntryName mn name ty ident = let Ident dictName = mkDictionaryValueName mn name ty
130+ Ident dictName <- mkDictionaryValueName mn name ty
126− in Ident $ dictName ++ "_" ++ identToString ident
131+ return $ Ident $ dictName ++ "_" ++ identToString ident