@@ -50,6 +50,44 @@ desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
5050desugarModule :: Module -> Desugar Module
5151desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls
5252
53+-- |
54+-- Desugar type class and type class instance declarations
55+--
56+-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
57+-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
58+--
59+-- E.g. the following
60+--
61+-- module Test where
62+--
63+-- class Foo a where
64+-- foo :: a -> a
65+--
66+-- instance Foo String where
67+-- foo s = s ++ s
68+--
69+-- instance (Foo a) => Foo [a] where
70+-- foo = map foo
71+--
72+-- becomes
73+--
74+-- type Foo a = { foo :: a -> a }
75+--
76+-- foreign import foo "function foo(dict) {\
77+-- \ return dict.foo;\
78+-- \}" :: forall a. (Foo a) => a -> a
79+--
80+-- __Test_Foo_string_foo = (\s -> s ++ s) :: String -> String
81+--
82+-- __Test_Foo_string :: Foo String
83+-- __Test_Foo_string = { foo: __Test_Foo_string_foo :: String -> String (unchecked) }
84+--
85+-- __Test_Foo_array_foo :: forall a. (Foo a) => [a] -> [a]
86+-- __Test_Foo_array_foo _1 = map (foo _1)
87+--
88+-- __Test_Foo_array :: forall a. Foo a -> Foo [a]
89+-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }
90+--
5391desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]
5492desugarDecl mn d@(TypeClassDeclaration name arg members) = do
5593 let tys = map memberToNameAndType members
@@ -119,13 +157,6 @@ qualifiedToString :: ModuleName -> Qualified ProperName -> String
119157qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)
120158qualifiedToString _ (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn
121159
122−quantify :: Type -> Type
123−quantify ty' = foldr (\arg t -> ForAll arg t Nothing) ty' tyVars
124− where
125− tyVars = nub $ everything (++) (mkQ [] collect) ty'
126− collect (TypeVar v) = [v]
127− collect _ = []
128−
129160-- |
130161-- Generate a name for a type class dictionary, based on the module name, class name and type name
131162--