@@ -15,8 +15,7 @@
1515-----------------------------------------------------------------------------
1616
1717module Language.PureScript.Sugar.TypeClasses (
18− desugarTypeClasses,
19− mkDictionaryEntryName
18+ desugarTypeClasses
2019) where
2120
2221import Language.PureScript.Declarations
@@ -65,10 +64,10 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
6564-- class Foo a where
6665-- foo :: a -> a
6766--
68−-- instance Foo String where
67+-- instance fooString :: Foo String where
6968-- foo s = s ++ s
7069--
71−-- instance (Foo a) => Foo [a] where
70+-- instance fooArray :: (Foo a) => Foo [a] where
7271-- foo = map foo
7372--
7473-- becomes
@@ -79,7 +78,8 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
7978-- \ return dict.foo;\
8079-- \}" :: forall a. (Foo a) => a -> a
8180--
82−-- __Test_Foo_string_foo = (\s -> s ++ s) :: String -> String
81+-- :: String -> String
82+-- fooString = (\s -> s ++ s)
8383--
8484-- __Test_Foo_string :: {} -> Foo String
8585-- __Test_Foo_string = { foo: __Test_Foo_string_foo :: String -> String (unchecked) }
@@ -97,9 +97,8 @@ desugarDecl mn d@(TypeClassDeclaration name args members) = do
9797 return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)
9898desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
9999 desugared <- lift $ desugarCases members
100− entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared
101100 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
102− return $ (Just $ TypeInstanceRef name, d : entries ++ [dictDecl])
101+ return $ (Just $ TypeInstanceRef name, [d, dictDecl])
103102desugarDecl mn (PositionedDeclaration pos d) = do
104103 (dr, ds) <- desugarDecl mn d
105104 return (dr, map (PositionedDeclaration pos) ds)
@@ -126,54 +125,39 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type
126125typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
127126typeInstanceDictionaryDeclaration name mn deps className tys decls = do
128127 m <- get
128+
129+ -- Lookup the type arguments and member types for the type class
129130 (args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right
130131 $ M.lookup (qualify mn className) m
132+
133+ -- Replace the type arguments with the appropriate types in the member types
131134 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
132− let entryName = Escaped (show name)
135+ -- Create values for the type instance members
133136 memberNames <- mapM (memberToNameAndValue memberTypes) decls
134− return $ ValueDeclaration entryName TypeInstanceDictionaryValue [] Nothing
135− (TypedValue True
136− (foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)])
137− (quantify (if null deps then
138− function unit (foldl TypeApp (TypeConstructor className) tys)
139− else
140− foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor className) tys) deps))
141− )
137+ -- Create the type of the dictionary
138+ -- The type is an object type, but depending on type instance dependencies, may be constrained.
139+ -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
140+ -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
141+ -- dependencies, we introduce an unnamed function parameter.
142+ let dictTy = TypeApp tyObject (rowFromList (memberTypes, REmpty))
143+ constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
144+ dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames) else ObjectLiteral memberNames
145+ return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
142146 where
143147 unit :: Type
144148 unit = TypeApp tyObject REmpty
145149
146150 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
147− memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do
148− memberType <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys'
149− memberName <- mkDictionaryEntryName name ident
150− return (identToJs ident, TypedValue False
151− (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
152− (quantify memberType))
151+ memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
152+ _ <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys'
153+ let memberValue = typeInstanceDictionaryEntryValue d
154+ return (identToJs ident, memberValue)
153155 memberToNameAndValue tys' (PositionedDeclaration pos d) = do
154156 (ident, val) <- memberToNameAndValue tys' d
155157 return (ident, PositionedValue pos val)
156158 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
157159
158−typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration
159−typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclaration ident _ [] _ val) = do
160− m <- get
161− valTy <- lift $ do (args, members) <- lookupTypeClass m
162− ty' <- lookupIdent members
163− return $ replaceAllTypeVars (zip args tys) ty'
164− entryName <- mkDictionaryEntryName name ident
165− return $ ValueDeclaration entryName TypeInstanceMember [] Nothing
166− (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))
167− where
168− lookupTypeClass m = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $ M.lookup (qualify mn className) m
169− lookupIdent members = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " does not have method " ++ show ident) Nothing) Right $ lookup (identToJs ident) members
170−typeInstanceDictionaryEntryDeclaration name mn deps className tys (PositionedDeclaration pos d) =
171− PositionedDeclaration pos <$> typeInstanceDictionaryEntryDeclaration name mn deps className tys d
172−typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"
173−
174−-- |
175−-- Generate a name for a type class dictionary member, based on the module name, class name, type name and
176−-- member name
177−--
178−mkDictionaryEntryName :: Ident -> Ident -> Desugar Ident
179−mkDictionaryEntryName dictName ident = return $ Escaped $ show dictName ++ "_" ++ identToJs ident
160+ typeInstanceDictionaryEntryValue :: Declaration -> Value
161+ typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
162+ typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
163+ typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"