4e2064b · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Simplify the type classes implementation

4e2064bPhil Freeman13 years ago

src/Language/PureScript/CodeGen/JS.hs+1

@@ -139,6 +139,7 @@ valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JS

139valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])

140valueToJs _ m _ (Var ident) = varToJs m ident

141valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

142+valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val

142valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

143valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

143valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

144valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

144

145

src/Language/PureScript/Environment.hs+1−5

@@ -102,11 +102,7 @@ data NameKind

102 -- |

103 -- A type class dictionary, generated during desugaring of type class declarations

104 --

105− | TypeInstanceDictionaryValue

105+ | TypeInstanceDictionaryValue deriving (Show, Eq, Data, Typeable)

106− -- |

107− -- A type instance member, generated during desugaring of type class declarations

108− --

109− | TypeInstanceMember deriving (Show, Eq, Data, Typeable)

110

106

111-- |

107-- |

112-- The kinds of a type

108-- The kinds of a type

src/Language/PureScript/Pretty/Values.hs+1

@@ -47,6 +47,7 @@ literals = mkPattern' match

47 match (ObjectLiteral ps) = fmap concat $ sequence

48 [ return "{\n"

49 , withIndent $ prettyPrintMany prettyPrintObjectProperty ps

50+ , return "\n"

50 , currentIndent

51 , currentIndent

51 , return "}"

52 , return "}"

52 ]

53 ]

src/Language/PureScript/Sugar/TypeClasses.hs+28−44

@@ -15,8 +15,7 @@

15-----------------------------------------------------------------------------

17module Language.PureScript.Sugar.TypeClasses (

18− desugarTypeClasses,

18+ desugarTypeClasses

19− mkDictionaryEntryName

20) where

19) where

22import Language.PureScript.Declarations

21import Language.PureScript.Declarations

@@ -65,10 +64,10 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

65-- class Foo a where

64-- class Foo a where

66-- foo :: a -> a

65-- foo :: a -> a

67--

66--

68−-- instance Foo String where

67+-- instance fooString :: Foo String where

69-- foo s = s ++ s

68-- foo s = s ++ s

70--

69--

71−-- instance (Foo a) => Foo [a] where

70+-- instance fooArray :: (Foo a) => Foo [a] where

72-- foo = map foo

71-- foo = map foo

73--

72--

74-- becomes

73-- becomes

@@ -79,7 +78,8 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

79-- \ return dict.foo;\

78-- \ return dict.foo;\

80-- \}" :: forall a. (Foo a) => a -> a

79-- \}" :: forall a. (Foo a) => a -> a

81--

80--

82−-- __Test_Foo_string_foo = (\s -> s ++ s) :: String -> String

81+-- :: String -> String

82+-- fooString = (\s -> s ++ s)

83--

84-- __Test_Foo_string :: {} -> Foo String

85-- __Test_Foo_string = { foo: __Test_Foo_string_foo :: String -> String (unchecked) }

@@ -97,9 +97,8 @@ desugarDecl mn d@(TypeClassDeclaration name args members) = do

97 return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)

98desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do

99 desugared <- lift $ desugarCases members

100− entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared

101 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

100 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

102− return $ (Just $ TypeInstanceRef name, d : entries ++ [dictDecl])

101+ return $ (Just $ TypeInstanceRef name, [d, dictDecl])

103desugarDecl mn (PositionedDeclaration pos d) = do

102desugarDecl mn (PositionedDeclaration pos d) = do

104 (dr, ds) <- desugarDecl mn d

103 (dr, ds) <- desugarDecl mn d

105 return (dr, map (PositionedDeclaration pos) ds)

104 return (dr, map (PositionedDeclaration pos) ds)

@@ -126,54 +125,39 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type

126typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

125typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

127typeInstanceDictionaryDeclaration name mn deps className tys decls = do

126typeInstanceDictionaryDeclaration name mn deps className tys decls = do

128 m <- get

127 m <- get

128+

129+ -- Lookup the type arguments and member types for the type class

129 (args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right

130 (args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right

130 $ M.lookup (qualify mn className) m

131 $ M.lookup (qualify mn className) m

132+

133+ -- Replace the type arguments with the appropriate types in the member types

131 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys

134 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys

132− let entryName = Escaped (show name)

135+ -- Create values for the type instance members

133 memberNames <- mapM (memberToNameAndValue memberTypes) decls

136 memberNames <- mapM (memberToNameAndValue memberTypes) decls

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

134− return $ ValueDeclaration entryName TypeInstanceDictionaryValue [] Nothing

145+ return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)

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− )

142 where

146 where

143 unit :: Type

147 unit :: Type

144 unit = TypeApp tyObject REmpty

148 unit = TypeApp tyObject REmpty

145

149

146 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)

150 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)

147− memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do

151+ memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do

148− memberType <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys'

152+ _ <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys'

149− memberName <- mkDictionaryEntryName name ident

153+ let memberValue = typeInstanceDictionaryEntryValue d

150− return (identToJs ident, TypedValue False

154+ return (identToJs ident, memberValue)

151− (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

152− (quantify memberType))

153 memberToNameAndValue tys' (PositionedDeclaration pos d) = do

155 memberToNameAndValue tys' (PositionedDeclaration pos d) = do

154 (ident, val) <- memberToNameAndValue tys' d

156 (ident, val) <- memberToNameAndValue tys' d

155 return (ident, PositionedValue pos val)

157 return (ident, PositionedValue pos val)

156 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

158 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

157

159

158−typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration

160+ typeInstanceDictionaryEntryValue :: Declaration -> Value

159−typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclaration ident _ [] _ val) = do

161+ typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val

160− m <- get

162+ typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)

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"

163+ typeInstanceDictionaryEntryValue _ = 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

src/Language/PureScript/TypeChecker/Types.hs+4−4

@@ -270,7 +270,7 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go)

270-- A simplified representation of expressions which are used to represent type

271-- class dictionaries at runtime, which can be compared for equality

272--

273−data DictionaryValue

273+data DictionaryValue

274 -- |

275 -- A dictionary which is brought into scope by a local constraint

276 --

@@ -296,8 +296,8 @@ entails env moduleName context = solve (nubBy ((==) `on` canonicalizeDictionary)

296 filterModule :: TypeClassDictionaryInScope -> Bool

297 filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True

298 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True

299− filterModule _ = False

299+ filterModule _ = False

300−

300+

301 solve context' goal@(className, tys) =

302 case go goal of

303 [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

@@ -336,7 +336,7 @@ entails env moduleName context = solve (nubBy ((==) `on` canonicalizeDictionary)

336 verifySubstitution subst = do

337 let grps = groupBy ((==) `on` fst) subst

338 guard (all (pairwise (unifiesWith env) . map snd) grps)

339− return $ map head grps

339+ return $ map head grps

340

341-- |

342-- Check all values in a list pairwise match a predicate