9420ad3 · rowtype-yoga/purescript-native

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

Multi parameter type classes #125. Also fix #224.

commit9420ad3804e9ba460eced5154fc2a3043999dd76 authorPhil Freeman <paf31@cantab.net> dateFri 21 Feb 2014, 20:01 (13 years ago) parent906e209

17 files changed+128−75

compare with golang

unifiedsplit

docgen/Main.hs+5−5

@@ -99,14 +99,14 @@ renderDeclaration n (P.ExternDataDeclaration name kind) =

9999renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do

100100 let typeName = P.runProperName name ++ " " ++ intercalate " " args

101101 atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty

102−renderDeclaration n (P.TypeClassDeclaration name arg ds) = do

103− atIndent n $ "class " ++ P.runProperName name ++ " " ++ arg ++ " where"

102+renderDeclaration n (P.TypeClassDeclaration name args ds) = do

103+ atIndent n $ "class " ++ P.runProperName name ++ " " ++ intercalate " " args ++ " where"

104104 mapM_ (renderDeclaration (n + 2)) ds

105−renderDeclaration n (P.TypeInstanceDeclaration constraints name ty _) = do

105+renderDeclaration n (P.TypeInstanceDeclaration constraints name tys _) = do

106106 let constraintsText = case constraints of

107107 [] -> ""

108− cs -> "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ P.prettyPrintType ty' ++ ")") cs) ++ ") => "

109− atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ P.prettyPrintType ty

108+ cs -> "(" ++ intercalate "," (map (\(pn, tys') -> show pn ++ " (" ++ intercalate " " (map (("(" ++) . (++ ")") . P.prettyPrintType) tys') ++ ")") cs) ++ ") => "

109+ atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ intercalate " " (map (("(" ++) . (++ ")") . P.prettyPrintType) tys)

110110renderDeclaration _ _ = return ()

111111

112112getName :: P.Declaration -> String

examples/failing/MPTCs.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+class Foo a where

4+ f :: a -> a

6+instance Foo String String where

7+ f a = a

examples/failing/OverlappingVars.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+class OverlappingVars a where

4+ f :: a -> a

6+data Foo a b = Foo a b

8+instance OverlappingVars (Foo a a) where

9+ f a = a

10+

11+test = f (Foo "" 0)

12+

examples/passing/MPTCs.pursnew file+24

@@ -0,0 +1,24 @@

1+module Main where

3+import Prelude

4+import Data.Array

6+class NullaryTypeClass where

7+ greeting :: String

9+instance NullaryTypeClass where

10+ greeting = "Hello, World!"

11+

12+class Coerce a b where

13+ coerce :: a -> b

14+

15+instance Coerce a a where

16+ coerce a = a

17+

18+instance (Prelude.Show a) => Coerce a String where

19+ coerce = show

20+

21+instance (Coerce a b) => Coerce [a] [b] where

22+ coerce = map coerce

23+

24+main = Debug.Trace.print $ coerce [greeting] :: [String]

examples/passing/TypeClasses.purs+1−1

@@ -48,7 +48,7 @@ instance (Prelude.Show a) => Prelude.Show [a] where

4848

4949test6 = \_ -> show ["testing"]

5050

51−instance Prelude.Monad (->) r where

51+instance Prelude.Monad ((->) r) where

5252 return a r = a

5353 (>>=) f g r = g (f r) r

5454

src/Language/PureScript/CodeGen/Optimize.hs+2−2

@@ -321,7 +321,7 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

321321 Right (Ident effDictName) = mkDictionaryValueName

322322 effModule

323323 (Qualified (Just prelude) (ProperName "Monad"))

324− (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))

324+ [TypeConstructor (Qualified (Just effModule) (ProperName "Eff"))]

325325 -- Check if an expression represents the Monad Eff dictionary

326326 isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True

327327 isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True

@@ -470,5 +470,5 @@ inlineCommonOperators = applyAll

470470 Right (Ident dictName) = mkDictionaryValueName

471471 (ModuleName [ProperName "Prim"])

472472 (Qualified (Just (ModuleName [ProperName "Prelude"])) (ProperName className))

473− ty

473+ [ty]

474474 isOpDict _ _ _ = False

src/Language/PureScript/Declarations.hs+2−2

@@ -112,11 +112,11 @@ data Declaration

112112 -- |

113113 -- A type class declaration (name, argument, member declarations)

114114 --

115− | TypeClassDeclaration ProperName String [Declaration]

115+ | TypeClassDeclaration ProperName [String] [Declaration]

116116 -- |

117117 -- A type instance declaration (dependencies, class name, instance type, member declarations)

118118 --

119− | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]

119+ | TypeInstanceDeclaration [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]

120120 deriving (Show, D.Data, D.Typeable)

121121

122122-- |

src/Language/PureScript/Parser/Common.hs+1

@@ -49,6 +49,7 @@ reservedPsNames = [ "data"

4949 , "true"

5050 , "false"

5151 , "in"

52+ , "where"

5253 ]

5354

5455-- |

src/Language/PureScript/Parser/Declarations.hs+4−4

@@ -97,21 +97,21 @@ parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

9797parseTypeClassDeclaration = do

9898 reserved "class"

9999 className <- indented *> properName

100− ident <- indented *> identifier

100+ idents <- indented *> P.many identifier

101101 indented *> reserved "where"

102102 members <- mark (P.many (same *> parseTypeDeclaration))

103− return $ TypeClassDeclaration className ident members

103+ return $ TypeClassDeclaration className idents members

104104

105105parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration

106106parseTypeInstanceDeclaration = do

107107 reserved "instance"

108108 deps <- P.optionMaybe $ do

109− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> parseType))

109+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))

110110 indented

111111 reservedOp "=>"

112112 return deps

113113 className <- indented *> parseQualified properName

114− ty <- indented *> parseType

114+ ty <- indented *> P.many parseTypeAtom

115115 indented *> reserved "where"

116116 members <- mark (P.many (same *> parseValueDeclaration))

117117 return $ TypeInstanceDeclaration (fromMaybe [] deps) className ty members

src/Language/PureScript/Parser/Types.hs+1−1

@@ -85,7 +85,7 @@ parseConstrainedType = do

8585 constraints <- parens . commaSep1 $ do

8686 className <- parseQualified properName

8787 indented

88− ty <- parseType

88+ ty <- P.many parseTypeAtom

8989 return (className, ty)

9090 _ <- lexeme $ P.string "=>"

9191 return constraints

src/Language/PureScript/Pretty/Types.hs+1−1

@@ -38,7 +38,7 @@ typeLiterals = mkPattern match

3838 match ty@(TypeConstructor ctor) = Just $ show ctor

3939 match (TUnknown (Unknown u)) = Just $ 'u' : show u

4040 match (Skolem s _) = Just $ 's' : show s

41− match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty

41+ match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ intercalate " " (map prettyPrintType ty') ++ ")") deps) ++ ") => " ++ prettyPrintType ty

4242 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

4343 match (ForAll ident ty _) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty

4444 match REmpty = Just "()"

src/Language/PureScript/Sugar/TypeClasses.hs+33−33

@@ -34,11 +34,11 @@ import Control.Monad.State

3434import Control.Arrow ((***))

3535

3636import Data.Maybe (fromMaybe)

37−import Data.List (nub)

37+import Data.List (intercalate, nub)

3838import Data.Generics (mkQ, everything)

3939import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs)

4040

41−type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])

41+type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])

4242

4343type Desugar = StateT MemberMap (Either String)

4444

@@ -91,10 +91,10 @@ desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl

9191-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }

9292--

9393desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]

94−desugarDecl mn d@(TypeClassDeclaration name arg members) = do

94+desugarDecl mn d@(TypeClassDeclaration name args members) = do

9595 let tys = map memberToNameAndType members

96− modify (M.insert (mn, name) (arg, tys))

97− return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members

96+ modify (M.insert (mn, name) (args, tys))

97+ return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor name args) members

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

9999 desugared <- lift $ desugarCases members

100100 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared

@@ -106,50 +106,50 @@ memberToNameAndType :: Declaration -> (String, Type)

106106memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)

107107memberToNameAndType _ = error "Invalid declaration in type class definition"

108108

109−typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration

110−typeClassDictionaryDeclaration name arg members =

111− TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty))

109+typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration

110+typeClassDictionaryDeclaration name args members =

111+ TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty))

112112

113−typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration

114−typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =

113+typeClassMemberToDictionaryAccessor :: ProperName -> [String] -> Declaration -> Declaration

114+typeClassMemberToDictionaryAccessor name args (TypeDeclaration ident ty) =

115115 ExternDeclaration TypeClassAccessorImport ident

116116 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))

117− (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty) Nothing)

117+ (quantify (ConstrainedType [(Qualified Nothing name, map TypeVar args)] ty))

118118typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"

119119

120−typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration

121−typeInstanceDictionaryDeclaration mn deps name ty decls = do

120+typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

121+typeInstanceDictionaryDeclaration mn deps name tys decls = do

122122 m <- get

123− (arg, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right

123+ (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right

124124 $ M.lookup (qualify mn name) m

125− let memberTypes = map (id *** replaceTypeVars arg ty) instanceTys

126− entryName <- lift $ mkDictionaryValueName mn name ty

125+ let memberTypes = map (id *** (\instanceTy -> replaceAllTypeVars (zip args tys) instanceTy)) instanceTys

126+ entryName <- lift $ mkDictionaryValueName mn name tys

127127 memberNames <- mapM (memberToNameAndValue memberTypes) decls

128128 return $ ValueDeclaration entryName [] Nothing

129129 (TypedValue True

130130 (foldr Abs (ObjectLiteral memberNames) (map (\n -> Left . Ident $ '_' : show n) [1..max 1 (length deps)]))

131131 (quantify (if null deps then

132− function unit (TypeApp (TypeConstructor name) ty)

132+ function unit (foldl TypeApp (TypeConstructor name) tys)

133133 else

134− foldr function (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps)))

134+ foldr function (foldl TypeApp (TypeConstructor name) tys) (map (\(pn, tys) -> foldl TypeApp (TypeConstructor pn) tys) deps)))

135135 )

136136 where

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

138− memberToNameAndValue tys (ValueDeclaration ident _ _ _) = do

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

140− memberName <- mkDictionaryEntryName mn name ty ident

138+ memberToNameAndValue tys' (ValueDeclaration ident _ _ _) = do

139+ memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'

140+ memberName <- mkDictionaryEntryName mn name tys ident

141141 return (identToJs ident, TypedValue False

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

143143 (quantify memberType))

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

145145

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

147−typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do

146+typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration

147+typeInstanceDictionaryEntryDeclaration mn deps name tys (ValueDeclaration ident [] _ val) = do

148148 m <- get

149− valTy <- lift $ do (arg, members) <- lookupTypeClass m

149+ valTy <- lift $ do (args, members) <- lookupTypeClass m

150150 ty' <- lookupIdent members

151− return $ replaceTypeVars arg ty ty'

152− entryName <- mkDictionaryEntryName mn name ty ident

151+ return $ replaceAllTypeVars (zip args tys) ty'

152+ entryName <- mkDictionaryEntryName mn name tys ident

153153 return $ ValueDeclaration entryName [] Nothing

154154 (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))

155155 where

@@ -164,10 +164,10 @@ qualifiedToString _ (Qualified (Just mn) pn) = moduleNameToJs mn ++ "_" ++ runPr

164164-- |

165165-- Generate a name for a type class dictionary, based on the module name, class name and type name

166166--

167−mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Either String Ident

168−mkDictionaryValueName mn cl ty = do

169− tyStr <- typeToString mn ty

170− return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr

167+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> [Type] -> Either String Ident

168+mkDictionaryValueName mn cl tys = do

169+ tyStr <- mapM (typeToString mn) tys

170+ return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ intercalate "_" tyStr

171171

172172typeToString :: ModuleName -> Type -> Either String String

173173typeToString _ (TypeVar _) = return "var"

@@ -179,7 +179,7 @@ typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"

179179-- Generate a name for a type class dictionary member, based on the module name, class name, type name and

180180-- member name

181181--

182−mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident

183−mkDictionaryEntryName mn name ty ident = do

184− Ident dictName <- lift $ mkDictionaryValueName mn name ty

182+mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> [Type] -> Ident -> Desugar Ident

183+mkDictionaryEntryName mn name tys ident = do

184+ Ident dictName <- lift $ mkDictionaryValueName mn name tys

185185 return $ Escaped $ dictName ++ "_" ++ identToJs ident

src/Language/PureScript/TypeChecker.hs+5−5

@@ -247,12 +247,12 @@ typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration _ _ _) : rest) =

247247 env <- getEnv

248248 ds <- typeCheckAll mainModuleName moduleName rest

249249 return $ qualifyAllUnqualifiedNames moduleName env d : ds

250−typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do

250+typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className tys _) : rest) = do

251251 env <- getEnv

252− dictName <- Check . lift $ mkDictionaryValueName moduleName className ty

253− checkTypeClassInstance moduleName ty

254− forM_ deps $ checkTypeClassInstance moduleName . snd

252+ dictName <- Check . lift $ mkDictionaryValueName moduleName className tys

253+ mapM_ (checkTypeClassInstance moduleName) tys

254+ forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

255255 addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env

256− [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])

256+ [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular])

257257 ds <- typeCheckAll mainModuleName moduleName rest

258258 return $ qualifyAllUnqualifiedNames moduleName env d : ds

src/Language/PureScript/TypeChecker/Kinds.hs+4−1

@@ -29,6 +29,7 @@ import Language.PureScript.Names

2929import Language.PureScript.TypeChecker.Monad

3030import Language.PureScript.Pretty

3131

32+import Control.Monad (forM_)

3233import Control.Monad.State

3334import Control.Monad.Error

3435import Control.Monad.Reader

@@ -159,7 +160,9 @@ infer (RCons _ ty row) = do

159160 k2 =?= Row k1

160161 return $ Row k1

161162infer (ConstrainedType deps ty) = do

162− mapM_ (infer . snd) deps

163+ forM_ deps $ \(className, tys) -> do

164+ _ <- infer $ foldl TypeApp (TypeConstructor className) tys

165+ return ()

163166 k <- infer ty

164167 k =?= Star

165168 return Star

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

@@ -260,14 +260,14 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go)

260260-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

261261-- return a type class dictionary reference.

262262--

263−entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value

264−entails moduleName context goal@(className, ty) = do

263+entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value

264+entails moduleName context goal@(className, tys) = do

265265 env <- getEnv

266266 case go env goal of

267− [] -> throwError $ "No " ++ show className ++ " instance found for " ++ prettyPrintType ty

267+ [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)

268268 (dict : _) -> return dict

269269 where

270− go env (className', ty') =

270+ go env (className', tys') =

271271 [ mkDictionary (canonicalizeDictionary tcd) args

272272 | tcd <- context

273273 -- Choose type class dictionaries in scope in the current module

@@ -275,16 +275,16 @@ entails moduleName context goal@(className, ty) = do

275275 -- Make sure the type class name matches the one we are trying to satisfy

276276 , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)

277277 -- Make sure the type unifies with the type in the type instance definition

278− , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)

278+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)

279279 -- Solve any necessary subgoals

280280 , args <- solveSubgoals env subst (tcdDependencies tcd) ]

281281 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

282282 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

283283 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

284− solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, Type)] -> [Maybe [Value]]

284+ solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [Value]]

285285 solveSubgoals _ _ Nothing = return Nothing

286286 solveSubgoals env subst (Just subgoals) = do

287− dict <- mapM (go env) (map (id *** replaceAllTypeVars subst) subgoals)

287+ dict <- mapM (go env) (map (id *** map (replaceAllTypeVars subst)) subgoals)

288288 return $ Just dict

289289 -- Make a dictionary from subgoal dictionaries by applying the correct function

290290 mkDictionary :: Qualified Ident -> Maybe [Value] -> Value

@@ -301,6 +301,12 @@ entails moduleName context goal@(className, ty) = do

301301 canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

302302 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

303303 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

304+ -- Ensure that a substitution is valid

305+ verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]

306+ verifySubstitution subst = do

307+ let grps = groupBy ((==) `on` fst) subst

308+ guard (all ((==) 1 . length . nubBy ((==) `on` snd)) grps)

309+ return $ map head grps

304310

305311-- |

306312-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),

@@ -399,12 +405,6 @@ varIfUnknown ty =

399405 typeToVar t = t

400406 in mkForAll (sort . map (toName . runUnknown) $ unks) ty'

401407

402−-- |

403−-- Replace named type variables with types

404−--

405−replaceAllTypeVars :: [(String, Type)] -> Type -> Type

406−replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id

407−

408408-- |

409409-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns

410410-- or TypeClassDictionary values.

src/Language/PureScript/Types.hs+9−3

@@ -66,7 +66,7 @@ data Type

6666 -- |

6767 -- A type with a set of type class constraints

6868 --

69− | ConstrainedType [(Qualified ProperName, Type)] Type

69+ | ConstrainedType [(Qualified ProperName, [Type])] Type

7070 -- |

7171 -- A skolem constant

7272 --

@@ -177,7 +177,7 @@ replaceTypeVars = replaceTypeVars' []

177177 t' = replaceTypeVars' bs v (TypeVar v') t

178178 in ForAll v' (go (v' : bs) t') sco

179179 | otherwise = ForAll v (go (v : bs) t) sco

180− go bs (ConstrainedType cs t) = ConstrainedType (map (id *** go bs) cs) (go bs t)

180+ go bs (ConstrainedType cs t) = ConstrainedType (map (id *** map (go bs)) cs) (go bs t)

181181 go bs (RCons name t r) = RCons name (go bs t) (go bs r)

182182 go _ ty = ty

183183 genName orig inUse = try 0

@@ -185,6 +185,12 @@ replaceTypeVars = replaceTypeVars' []

185185 try n | (orig ++ show n) `elem` inUse = try (n + 1)

186186 | otherwise = orig ++ show n

187187

188+-- |

189+-- Replace named type variables with types

190+--

191+replaceAllTypeVars :: [(String, Type)] -> Type -> Type

192+replaceAllTypeVars = foldl (\f (name, ty) -> replaceTypeVars name ty . f) id

193+

188194-- |

189195-- Collect all type variables appearing in a type

190196--

@@ -206,7 +212,7 @@ freeTypeVariables = nub . go []

206212 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2

207213 go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts

208214 go bound (ForAll v t _) = go (v : bound) t

209− go bound (ConstrainedType cs t) = concatMap (go bound . snd) cs ++ go bound t

215+ go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t

210216 go bound (RCons _ t r) = go bound t ++ go bound r

211217 go _ _ = []

212218

src/Language/PureScript/Values.hs+4−4

@@ -112,7 +112,7 @@ data Value

112112 -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and

113113 -- instance type, and the type class dictionaries in scope.

114114 --

115− | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

115+ | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

116116

117117-- |

118118-- The type of a type class dictionary

@@ -141,13 +141,13 @@ data TypeClassDictionaryInScope

141141 --

142142 , tcdClassName :: Qualified ProperName

143143 -- |

144− -- The type to which this type class instance applies

144+ -- The types to which this type class instance applies

145145 --

146− , tcdInstanceType :: Type

146+ , tcdInstanceTypes :: [Type]

147147 -- |

148148 -- Type class dependencies which must be satisfied to construct this dictionary

149149 --

150− , tcdDependencies :: Maybe [(Qualified ProperName, Type)]

150+ , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]

151151 -- |

152152 -- The type of this dictionary

153153 --