9420ad3 · rowtype-yoga/purescript-native

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

on golang help sign in

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

9420ad3Phil Freeman13 years ago

docgen/Main.hs+5−5

compare with golang

unifiedsplit

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

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

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

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

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

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

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

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

104 mapM_ (renderDeclaration (n + 2)) ds

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

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

106 let constraintsText = case constraints of

107 [] -> ""

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

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

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

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

110renderDeclaration _ _ = return ()

111

112getName :: 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

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

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

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

52 return a r = a

53 (>>=) f g r = g (f r) r

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

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

321 Right (Ident effDictName) = mkDictionaryValueName

322 effModule

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

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

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

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

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

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

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

470 Right (Ident dictName) = mkDictionaryValueName

471 (ModuleName [ProperName "Prim"])

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

473− ty

473+ [ty]

474 isOpDict _ _ _ = False

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

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

112 -- |

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

114 --

115− | TypeClassDeclaration ProperName String [Declaration]

115+ | TypeClassDeclaration ProperName [String] [Declaration]

116 -- |

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

118 --

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

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

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

121

122-- |

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

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

49 , "true"

50 , "false"

51 , "in"

52+ , "where"

52 ]

53 ]

54-- |

55-- |

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

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

97parseTypeClassDeclaration = do

98 reserved "class"

99 className <- indented *> properName

100− ident <- indented *> identifier

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

101 indented *> reserved "where"

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

103− return $ TypeClassDeclaration className ident members

103+ return $ TypeClassDeclaration className idents members

104

105parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration

106parseTypeInstanceDeclaration = do

107 reserved "instance"

108 deps <- P.optionMaybe $ do

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

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

110 indented

111 reservedOp "=>"

112 return deps

113 className <- indented *> parseQualified properName

114− ty <- indented *> parseType

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

115 indented *> reserved "where"

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

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

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

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

85 constraints <- parens . commaSep1 $ do

86 className <- parseQualified properName

87 indented

88− ty <- parseType

88+ ty <- P.many parseTypeAtom

89 return (className, ty)

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

91 return constraints

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

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

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

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

40 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

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

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

44 match REmpty = Just "()"

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

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

34import Control.Arrow ((***))

36import Data.Maybe (fromMaybe)

37−import Data.List (nub)

37+import Data.List (intercalate, nub)

38import Data.Generics (mkQ, everything)

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

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

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

43type Desugar = StateT MemberMap (Either String)

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

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

92--

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

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

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

95 let tys = map memberToNameAndType members

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

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

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

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

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

99 desugared <- lift $ desugarCases members

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

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

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

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

108

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

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

110−typeClassDictionaryDeclaration name arg members =

110+typeClassDictionaryDeclaration name args members =

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

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

112

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

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

114−typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =

114+typeClassMemberToDictionaryAccessor name args (TypeDeclaration ident ty) =

115 ExternDeclaration TypeClassAccessorImport ident

116 (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))

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

119

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

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

121−typeInstanceDictionaryDeclaration mn deps name ty decls = do

121+typeInstanceDictionaryDeclaration mn deps name tys decls = do

122 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

124 $ M.lookup (qualify mn name) m

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

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

126− entryName <- lift $ mkDictionaryValueName mn name ty

126+ entryName <- lift $ mkDictionaryValueName mn name tys

127 memberNames <- mapM (memberToNameAndValue memberTypes) decls

128 return $ ValueDeclaration entryName [] Nothing

129 (TypedValue True

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

131 (quantify (if null deps then

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

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

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

135 )

136 where

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

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

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

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

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

140− memberName <- mkDictionaryEntryName mn name ty ident

140+ memberName <- mkDictionaryEntryName mn name tys ident

141 return (identToJs ident, TypedValue False

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

143 (quantify memberType))

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

145

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

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

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

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

148 m <- get

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

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

150 ty' <- lookupIdent members

151− return $ replaceTypeVars arg ty ty'

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

152− entryName <- mkDictionaryEntryName mn name ty ident

152+ entryName <- mkDictionaryEntryName mn name tys ident

153 return $ ValueDeclaration entryName [] Nothing

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

155 where

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

164-- |

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

166--

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

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

168−mkDictionaryValueName mn cl ty = do

168+mkDictionaryValueName mn cl tys = do

169− tyStr <- typeToString mn ty

169+ tyStr <- mapM (typeToString mn) tys

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

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

171

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

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

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

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

180-- member name

181--

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

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

183−mkDictionaryEntryName mn name ty ident = do

183+mkDictionaryEntryName mn name tys ident = do

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

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

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

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

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

247 env <- getEnv

248 ds <- typeCheckAll mainModuleName moduleName rest

249 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

251 env <- getEnv

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

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

253− checkTypeClassInstance moduleName ty

253+ mapM_ (checkTypeClassInstance moduleName) tys

254− forM_ deps $ checkTypeClassInstance moduleName . snd

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

255 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])

257 ds <- typeCheckAll mainModuleName moduleName rest

258 return $ qualifyAllUnqualifiedNames moduleName env d : ds

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

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

29import Language.PureScript.TypeChecker.Monad

30import Language.PureScript.Pretty

32+import Control.Monad (forM_)

32import Control.Monad.State

33import Control.Monad.State

33import Control.Monad.Error

34import Control.Monad.Error

34import Control.Monad.Reader

35import Control.Monad.Reader

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

159 k2 =?= Row k1

160 k2 =?= Row k1

160 return $ Row k1

161 return $ Row k1

161infer (ConstrainedType deps ty) = do

162infer (ConstrainedType deps ty) = do

162− mapM_ (infer . snd) deps

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

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

165+ return ()

163 k <- infer ty

166 k <- infer ty

164 k =?= Star

167 k =?= Star

165 return Star

168 return Star

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

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

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

261-- return a type class dictionary reference.

262--

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

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

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

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

265 env <- getEnv

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

268 (dict : _) -> return dict

269 where

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

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

271 [ mkDictionary (canonicalizeDictionary tcd) args

272 | tcd <- context

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

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

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

276 , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)

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

279 -- Solve any necessary subgoals

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

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

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

283 -- 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]]

285 solveSubgoals _ _ Nothing = return Nothing

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

288 return $ Just dict

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

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

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

301 canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

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

303 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

304

310

305-- |

311-- |

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

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

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

399 typeToVar t = t

405 typeToVar t = t

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

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

401

407

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−

408-- |

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

410-- or TypeClassDictionary values.

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

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

66 -- |

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

68 --

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

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

70 -- |

71 -- A skolem constant

72 --

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

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

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

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

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

182 go _ ty = ty

183 genName orig inUse = try 0

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

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

186 | otherwise = orig ++ show n

187

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+

188-- |

194-- |

189-- Collect all type variables appearing in a type

195-- Collect all type variables appearing in a type

190--

196--

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

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

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

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

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

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

214 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

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

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

211 go _ _ = []

217 go _ _ = []

212

218

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

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

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

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

114 --

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

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

116

117-- |

118-- The type of a type class dictionary

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

141 --

142 , tcdClassName :: Qualified ProperName

143 -- |

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

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

145 --

146− , tcdInstanceType :: Type

146+ , tcdInstanceTypes :: [Type]

147 -- |

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

149 --

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

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

151 -- |

152 -- The type of this dictionary

153 --