@@ -48,7 +48,8 @@ desugarDecl mn d@(TypeClassDeclaration name arg members) = do
4848 return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
4949desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
5050 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
5253desugarDecl _ other = return [other]
5354
5455memberToNameAndType :: Declaration -> (String, Type)
@@ -66,19 +67,20 @@ typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
6667 (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))
6768typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
6869
69−typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Declaration
70−typeInstanceDictionaryDeclaration mn deps name ty decls =
71− ExternDeclaration (mkDictionaryValueName mn name ty)
72− (Just (JSFunction (Just (mkDictionaryValueName mn name ty))
70+typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration
71+typeInstanceDictionaryDeclaration mn deps name ty decls = do
72+ entryName <- mkDictionaryValueName mn name ty
73+ memberNames <- mapM memberToNameAndValue decls
74+ return $ ExternDeclaration entryName
75+ (Just (JSFunction (Just entryName)
7376 (map (\n -> Ident ('_' : show n)) [1..length deps])
74− (JSBlock [JSReturn (JSObjectLiteral $ map memberToNameAndValue decls)])))
77+ (JSBlock [JSReturn (JSObjectLiteral memberNames)])))
7578 (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))
7679 where
77− memberToNameAndValue :: Declaration -> (String, JS)
78− memberToNameAndValue (ValueDeclaration ident _ _ _) =
79− (identToString ident, let dict = JSVar $ 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]))
80+ memberToNameAndValue :: Declaration -> Desugar (String, JS)
81+ memberToNameAndValue (ValueDeclaration ident _ _ _) = do
82+ memberName <- mkDictionaryEntryName mn name ty ident
83+ return (identToString ident, JSApp (JSVar memberName) (map (\n -> JSVar (Ident ('_' : show n))) [1..length deps]))
8284 memberToNameAndValue _ = error "Invalid declaration in type instance definition"
8385
8486typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration
@@ -88,7 +90,7 @@ typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident b
8890 do (arg, members) <- M.lookup (qualify mn name) m
8991 ty' <- lookup (identToString ident) members
9092 return $ replaceTypeVars arg ty ty'
91− entryName = mkDictionaryEntryName mn name ty ident
93+ entryName <- mkDictionaryEntryName mn name ty ident
9294 [ValueDeclaration _ _ _ val'] <- lift $ desugarCases [ValueDeclaration entryName binders grd val]
9395 return $ ValueDeclaration entryName [] Nothing
9496 (TypedValue val' (quantify (if null deps then valTy else ConstrainedType deps valTy)))
@@ -109,18 +111,21 @@ quantify ty' = foldr ForAll ty' tyVars
109111 collect (TypeVar v) = [v]
110112 collect _ = []
111113
112−mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Ident
113−mkDictionaryValueName mn cl ty = Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ typeToString ty
114+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Desugar Ident
115+mkDictionaryValueName mn cl ty = do
116+ tyStr <- lift $ typeToString ty
117+ return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr
114118 where
115− typeToString :: Type -> String
116− typeToString String = "string"
117− typeToString Number = "number"
118− typeToString Boolean = "boolean"
119− typeToString (Array (TypeVar _)) = "array"
120− typeToString (TypeConstructor ty') = qualifiedToString mn ty'
119+ typeToString :: Type -> Either String String
120+ typeToString String = return "string"
121+ typeToString Number = return "number"
122+ typeToString Boolean = return "boolean"
123+ typeToString (Array (TypeVar _)) = return "array"
124+ typeToString (TypeConstructor ty') = return $ qualifiedToString mn ty'
121125 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"
123127
124−mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Ident
125−mkDictionaryEntryName mn name ty ident = let Ident dictName = mkDictionaryValueName mn name ty
126− in Ident $ dictName ++ "_" ++ identToString ident
128+mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident
129+mkDictionaryEntryName mn name ty ident = do
130+ Ident dictName <- mkDictionaryValueName mn name ty
131+ return $ Ident $ dictName ++ "_" ++ identToString ident