40f03bf · rowtype-yoga/purescript-native

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

on golang help sign in

Merge branch '618'

40f03bfPhil Freeman12 years ago

docgen/Main.hs+11−3

compare with golang

unifiedsplit

@@ -141,7 +141,7 @@ renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =

141 atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty

142renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do

143 let

144− typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map P.TypeVar args)

144+ typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

145 typeName = prettyPrintType' typeApp

146 exported = filter (isDctorExported name exps . fst) ctors

147 atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")

@@ -151,13 +151,17 @@ renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do

151renderDeclaration n _ (P.ExternDataDeclaration name kind) =

152 atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind

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

154− let typeName = P.runProperName name ++ " " ++ unwords args

154+ let

155+ typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

156+ typeName = prettyPrintType' typeApp

155 atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty

157 atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty

156renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do

158renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do

157 let impliesText = case implies of

159 let impliesText = case implies of

158 [] -> ""

160 [] -> ""

159 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "

161 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "

162+ classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

163+ className = prettyPrintType' classApp

160− atIndent n $ "class " ++ impliesText ++ P.runProperName name ++ " " ++ unwords args ++ " where"

164+ atIndent n $ "class " ++ impliesText ++ className ++ " where"

161 mapM_ (renderDeclaration (n + 2) exps) ds

165 mapM_ (renderDeclaration (n + 2) exps) ds

162renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do

166renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do

163 let constraintsText = case constraints of

167 let constraintsText = case constraints of

@@ -168,6 +172,10 @@ renderDeclaration n exps (P.PositionedDeclaration _ d) =

168 renderDeclaration n exps d

172 renderDeclaration n exps d

169renderDeclaration _ _ _ = return ()

173renderDeclaration _ _ _ = return ()

170

174

175+toTypeVar :: (String, Maybe P.Kind) -> P.Type

176+toTypeVar (s, Nothing) = P.TypeVar s

177+toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k

178+

171prettyPrintType' :: P.Type -> String

179prettyPrintType' :: P.Type -> String

172prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim

180prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim

173 where

181 where

examples/passing/KindedType.pursnew file+31

@@ -0,0 +1,31 @@

1+module Main where

3+type Star2Star f = f :: * -> *

5+type Star t = t :: *

7+test1 :: Star2Star [] String

8+test1 = ["test"]

10+f :: Star (String -> String)

11+f s = s

12+

13+test2 = f "test"

14+

15+data Proxy (f :: * -> *) = Proxy

16+

17+test3 :: Proxy []

18+test3 = Proxy

19+

20+type Test (f :: * -> *) = f String

21+

22+test4 :: Test []

23+test4 = ["test"]

24+

25+class Clazz (a :: *) where

26+ def :: a

27+

28+instance clazzString :: Clazz String where

29+ def = "test"

30+

31+main = Debug.Trace.trace "Done"

src/Language/PureScript/CodeGen/Externs.hs+16−4

@@ -29,6 +29,8 @@ import Language.PureScript.TypeClassDictionaries

29import Language.PureScript.Declarations

30import Language.PureScript.Pretty

31import Language.PureScript.Names

32+import Language.PureScript.Kinds

33+import Language.PureScript.Types

32import Language.PureScript.Environment

34import Language.PureScript.Environment

34-- |

36-- |

@@ -64,12 +66,15 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

64 let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')

66 let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')

65 then "newtype"

67 then "newtype"

66 else "data"

68 else "data"

69+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)

67− tell [dtype ++ " " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]

70+ tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]

68 Just (_, TypeSynonym) ->

71 Just (_, TypeSynonym) ->

69 case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of

72 case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of

70 Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"

73 Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"

71 Just (args, synTy) ->

74 Just (args, synTy) ->

75+ let

76+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)

72− tell ["type " ++ show pn ++ " " ++ unwords args ++ " = " ++ prettyPrintType synTy]

77+ in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]

73 _ -> error "Invalid input in exportToPs"

78 _ -> error "Invalid input in exportToPs"

75 exportToPs (ValueRef ident) =

80 exportToPs (ValueRef ident) =

@@ -82,8 +87,11 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

82 case Qualified (Just moduleName) className `M.lookup` typeClasses env of

87 case Qualified (Just moduleName) className `M.lookup` typeClasses env of

83 Nothing -> error $ show className ++ " has no type class definition in exportToPs"

88 Nothing -> error $ show className ++ " has no type class definition in exportToPs"

84 Just (args, members, implies) -> do

89 Just (args, members, implies) -> do

90+ let impliesString = if null implies

91+ then ""

85− let impliesString = if null implies then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "

92+ else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "

93+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)

86− tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]

94+ tell ["class " ++ impliesString ++ typeName ++ " where"]

87 forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->

95 forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->

88 tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]

96 tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]

@@ -95,6 +103,10 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

95 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "

103 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "

96 tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]

104 tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]

105

106+ toTypeVar :: (String, Maybe Kind) -> Type

107+ toTypeVar (s, Nothing) = TypeVar s

108+ toTypeVar (s, Just k) = KindedType (TypeVar s) k

109+

98 isValueExported :: Ident -> Bool

110 isValueExported :: Ident -> Bool

99 isValueExported ident = ValueRef ident `elem` exts

111 isValueExported ident = ValueRef ident `elem` exts

100

112

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

@@ -138,7 +138,7 @@ data Declaration

138 -- |

139 -- A data type declaration (data or newtype, name, arguments, data constructors)

140 --

141− = DataDeclaration DataDeclType ProperName [String] [(ProperName, [Type])]

141+ = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]

142 -- |

143 -- A minimal mutually recursive set of data type declarations

144 --

@@ -146,7 +146,7 @@ data Declaration

146 -- |

147 -- A type synonym declaration (name, arguments, type)

148 --

149− | TypeSynonymDeclaration ProperName [String] Type

149+ | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type

150 -- |

151 -- A type declaration for a value (name, ty)

152 --

@@ -183,7 +183,7 @@ data Declaration

183 -- |

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

185 --

186− | TypeClassDeclaration ProperName [String] [(Qualified ProperName, [Type])] [Declaration]

186+ | TypeClassDeclaration ProperName [(String, Maybe Kind)] [(Qualified ProperName, [Type])] [Declaration]

187 -- |

188 -- A type instance declaration (name, dependencies, class name, instance types, member

189 -- declarations)

src/Language/PureScript/Environment.hs+3−3

@@ -45,7 +45,7 @@ data Environment = Environment {

45 -- |

46 -- Type synonyms currently in scope

47 --

48− , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)

48+ , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)

49 -- |

50 -- Available type class dictionaries

51 --

@@ -53,7 +53,7 @@ data Environment = Environment {

53 -- |

54 -- Type classes

55 --

56− , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)], [(Qualified ProperName, [Type])])

56+ , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [(Qualified ProperName, [Type])])

57 } deriving (Show)

59-- |

@@ -124,7 +124,7 @@ data TypeKind

124 -- |

125 -- Data type

126 --

127− = DataType [String] [(ProperName, [Type])]

127+ = DataType [(String, Maybe Kind)] [(ProperName, [Type])]

128 -- |

129 -- Type synonym

130 --

src/Language/PureScript/Parser/Declarations.hs+10−3

@@ -13,6 +13,8 @@

13--

14-----------------------------------------------------------------------------

16+{-# LANGUAGE TupleSections #-}

17+

16module Language.PureScript.Parser.Declarations (

18module Language.PureScript.Parser.Declarations (

17 parseDeclaration,

19 parseDeclaration,

18 parseModule,

20 parseModule,

@@ -28,6 +30,7 @@ import Data.Maybe (isJust, fromMaybe)

28import Control.Applicative

30import Control.Applicative

29import Control.Arrow ((+++))

31import Control.Arrow ((+++))

33+import Language.PureScript.Kinds

31import Language.PureScript.Parser.State

34import Language.PureScript.Parser.State

32import Language.PureScript.Parser.Common

35import Language.PureScript.Parser.Common

33import Language.PureScript.Declarations

36import Language.PureScript.Declarations

@@ -48,11 +51,15 @@ sourcePos = toSourcePos <$> P.getPosition

48 where

51 where

49 toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p)

52 toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p)

54+kindedIdent :: P.Parsec String ParseState (String, Maybe Kind)

55+kindedIdent = (, Nothing) <$> identifier

56+ <|> parens ((,) <$> identifier <*> (Just <$> (indented *> lexeme (P.string "::") *> indented *> parseKind)))

57+

51parseDataDeclaration :: P.Parsec String ParseState Declaration

58parseDataDeclaration :: P.Parsec String ParseState Declaration

52parseDataDeclaration = do

59parseDataDeclaration = do

53 dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)

60 dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)

54 name <- indented *> properName

61 name <- indented *> properName

55− tyArgs <- many (indented *> identifier)

62+ tyArgs <- many (indented *> kindedIdent)

56 ctors <- P.option [] $ do

63 ctors <- P.option [] $ do

57 _ <- lexeme $ indented *> P.char '='

64 _ <- lexeme $ indented *> P.char '='

58 sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe

65 sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe

@@ -66,7 +73,7 @@ parseTypeDeclaration =

66parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration

73parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration

67parseTypeSynonymDeclaration =

74parseTypeSynonymDeclaration =

68 TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)

75 TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)

69− <*> many (indented *> identifier)

76+ <*> many (indented *> kindedIdent)

70 <*> (lexeme (indented *> P.char '=') *> parsePolyType)

77 <*> (lexeme (indented *> P.char '=') *> parsePolyType)

72parseValueDeclaration :: P.Parsec String ParseState Declaration

79parseValueDeclaration :: P.Parsec String ParseState Declaration

@@ -163,7 +170,7 @@ parseTypeClassDeclaration = do

163 reservedOp "<="

170 reservedOp "<="

164 return implies

171 return implies

165 className <- indented *> properName

172 className <- indented *> properName

166− idents <- P.many (indented *> identifier)

173+ idents <- P.many (indented *> kindedIdent)

167 members <- P.option [] . P.try $ do

174 members <- P.option [] . P.try $ do

168 indented *> reserved "where"

175 indented *> reserved "where"

169 mark (P.many (same *> positioned parseTypeDeclaration))

176 mark (P.many (same *> positioned parseTypeDeclaration))

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

@@ -25,6 +25,7 @@ import Control.Monad (when, unless)

25import Language.PureScript.Types

26import Language.PureScript.Parser.State

27import Language.PureScript.Parser.Common

28+import Language.PureScript.Parser.Kinds

28import Language.PureScript.Environment

29import Language.PureScript.Environment

30import qualified Text.Parsec as P

31import qualified Text.Parsec as P

@@ -85,10 +86,12 @@ parseConstrainedType = do

85 return $ maybe ty (flip ConstrainedType ty) constraints

86 return $ maybe ty (flip ConstrainedType ty) constraints

87parseAnyType :: P.Parsec String ParseState Type

88parseAnyType :: P.Parsec String ParseState Type

88−parseAnyType = P.buildExpressionParser operators parseTypeAtom P.<?> "type"

89+parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"

89 where

90 where

90 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

91 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

91 , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]

92 , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]

93+ postfixTable = [ \t -> KindedType t <$> (P.try (lexeme (indented *> P.string "::")) *> parseKind)

94+ ]

93-- |

96-- |

94-- Parse a monotype

97-- Parse a monotype

src/Language/PureScript/Pretty/Types.hs+9

@@ -26,7 +26,9 @@ import Control.Arrow ((<+>))

26import Control.PatternArrows

28import Language.PureScript.Types

29+import Language.PureScript.Kinds

29import Language.PureScript.Pretty.Common

30import Language.PureScript.Pretty.Common

31+import Language.PureScript.Pretty.Kinds

30import Language.PureScript.Environment

32import Language.PureScript.Environment

32typeLiterals :: Pattern () Type String

34typeLiterals :: Pattern () Type String

@@ -71,6 +73,12 @@ appliedFunction = mkPattern match

71 match (PrettyPrintFunction arg ret) = Just (arg, ret)

73 match (PrettyPrintFunction arg ret) = Just (arg, ret)

72 match _ = Nothing

74 match _ = Nothing

76+kinded :: Pattern () Type (Kind, Type)

77+kinded = mkPattern match

78+ where

79+ match (KindedType t k) = Just (k, t)

80+ match _ = Nothing

81+

74insertPlaceholders :: Type -> Type

82insertPlaceholders :: Type -> Type

75insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert

83insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert

76 where

84 where

@@ -96,6 +104,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom

96 , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret

104 , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret

97 ]

105 ]

98 , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]

106 , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]

107+ , [ Wrap kinded $ \k ty -> ty ++ " :: " ++ prettyPrintKind k ]

99 ]

108 ]

100

109

101forall_ :: Pattern () Type ([String], Type)

110forall_ :: Pattern () Type ([String], Type)

src/Language/PureScript/Sugar/TypeClasses.hs+6−5

@@ -21,6 +21,7 @@ module Language.PureScript.Sugar.TypeClasses (

21import Language.PureScript.Declarations

22import Language.PureScript.Names

23import Language.PureScript.Types

24+import Language.PureScript.Kinds

24import Language.PureScript.Sugar.CaseDeclarations

25import Language.PureScript.Sugar.CaseDeclarations

25import Language.PureScript.Environment

26import Language.PureScript.Environment

26import Language.PureScript.Errors

27import Language.PureScript.Errors

@@ -197,7 +198,7 @@ memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

197memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

198memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

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

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

199

200

200−typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration

201+typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration

201typeClassDictionaryDeclaration name args implies members =

202typeClassDictionaryDeclaration name args implies members =

202 let superclassTypes = [ (fieldName, function unit tySynApp)

203 let superclassTypes = [ (fieldName, function unit tySynApp)

203 | (index, (superclass, tyArgs)) <- zip [0..] implies

204 | (index, (superclass, tyArgs)) <- zip [0..] implies

@@ -208,11 +209,11 @@ typeClassDictionaryDeclaration name args implies members =

208 mtys = members' ++ superclassTypes

209 mtys = members' ++ superclassTypes

209 in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))

210 in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))

210

211

211−typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration

212+typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration

212typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

213typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

213 ValueDeclaration ident TypeClassAccessorImport [] Nothing $

214 ValueDeclaration ident TypeClassAccessorImport [] Nothing $

214 TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $

215 TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $

215− moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))

216+ moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))

216typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

217typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

217 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

218 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

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

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

@@ -240,7 +241,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

240 let instanceTys = map memberToNameAndType tyDecls

241 let instanceTys = map memberToNameAndType tyDecls

241

242

242 -- Replace the type arguments with the appropriate types in the member types

243 -- Replace the type arguments with the appropriate types in the member types

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

244+ let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys

244 -- Create values for the type instance members

245 -- Create values for the type instance members

245 memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls

246 memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls

246 -- Create the type of the dictionary

247 -- Create the type of the dictionary

@@ -249,7 +250,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

249 let superclasses =

250 let superclasses =

250 [ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))

251 [ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))

251 | (index, (superclass, suTyArgs)) <- zip [0..] implies

252 | (index, (superclass, suTyArgs)) <- zip [0..] implies

252− , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs

253+ , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

253 , let fieldName = mkSuperclassDictionaryName superclass index

254 , let fieldName = mkSuperclassDictionaryName superclass index

254 ]

255 ]

255

256

src/Language/PureScript/TypeChecker.hs+30−16

@@ -42,13 +42,13 @@ import Language.PureScript.TypeClassDictionaries

42import Language.PureScript.Environment

43import Language.PureScript.Errors

45−addDataType :: ModuleName -> DataDeclType -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

45+addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check ()

46addDataType moduleName dtype name args dctors ctorKind = do

47 env <- getEnv

48 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

49 forM_ dctors $ \(dctor, tys) ->

50 rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $

51− addDataConstructor moduleName dtype name args dctor tys

51+ addDataConstructor moduleName dtype name (map fst args) dctor tys

53addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

54addDataConstructor moduleName dtype name args dctor tys = do

@@ -58,7 +58,7 @@ addDataConstructor moduleName dtype name args dctor tys = do

58 let polyType = mkForAll args dctorTy

59 putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }

61−addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()

61+addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()

62addTypeSynonym moduleName name args ty kind = do

63 env <- getEnv

64 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)

@@ -76,7 +76,7 @@ addValue moduleName name ty nameKind = do

76 env <- getEnv

77 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })

79−addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()

79+addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()

80addTypeClass moduleName pn args implies ds =

81 let members = map toPair ds in

82 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }

@@ -124,14 +124,15 @@ typeCheckAll mainModuleName moduleName exps = go

124 where

125 go :: [Declaration] -> Check [Declaration]

126 go [] = return []

127− go (d@(DataDeclaration dtype name args dctors) : rest) = do

127+ go (DataDeclaration dtype name args dctors : rest) = do

128 rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do

129 when (dtype == Newtype) $ checkNewtype dctors

130− checkDuplicateTypeArguments args

130+ checkDuplicateTypeArguments $ map fst args

131 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)

132+ let args' = args `withKinds` ctorKind

132− addDataType moduleName dtype name args dctors ctorKind

133+ addDataType moduleName dtype name args' dctors ctorKind

133 ds <- go rest

134 ds <- go rest

134− return $ d : ds

135+ return $ DataDeclaration dtype name args dctors : ds

135 where

136 where

136 checkNewtype :: [(ProperName, [Type])] -> Check ()

137 checkNewtype :: [(ProperName, [Type])] -> Check ()

137 checkNewtype [(_, [_])] = return ()

138 checkNewtype [(_, [_])] = return ()

@@ -143,11 +144,13 @@ typeCheckAll mainModuleName moduleName exps = go

143 let dataDecls = mapMaybe toDataDecl tys

144 let dataDecls = mapMaybe toDataDecl tys

144 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

145 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

145 forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do

146 forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do

146− checkDuplicateTypeArguments args

147+ checkDuplicateTypeArguments $ map fst args

148+ let args' = args `withKinds` ctorKind

147− addDataType moduleName dtype name args dctors ctorKind

149+ addDataType moduleName dtype name args' dctors ctorKind

148 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do

150 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do

149− checkDuplicateTypeArguments args

151+ checkDuplicateTypeArguments $ map fst args

152+ let args' = args `withKinds` kind

150− addTypeSynonym moduleName name args ty kind

153+ addTypeSynonym moduleName name args' ty kind

151 ds <- go rest

154 ds <- go rest

152 return $ d : ds

155 return $ d : ds

153 where

156 where

@@ -157,13 +160,14 @@ typeCheckAll mainModuleName moduleName exps = go

157 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)

160 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)

158 toDataDecl (PositionedDeclaration _ d') = toDataDecl d'

161 toDataDecl (PositionedDeclaration _ d') = toDataDecl d'

159 toDataDecl _ = Nothing

162 toDataDecl _ = Nothing

160− go (d@(TypeSynonymDeclaration name args ty) : rest) = do

163+ go (TypeSynonymDeclaration name args ty : rest) = do

161 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do

164 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do

162− checkDuplicateTypeArguments args

165+ checkDuplicateTypeArguments $ map fst args

163 kind <- kindsOf False moduleName name args [ty]

166 kind <- kindsOf False moduleName name args [ty]

167+ let args' = args `withKinds` kind

164− addTypeSynonym moduleName name args ty kind

168+ addTypeSynonym moduleName name args' ty kind

165 ds <- go rest

169 ds <- go rest

166− return $ d : ds

170+ return $ TypeSynonymDeclaration name args ty : ds

167 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

171 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

168 go (ValueDeclaration name nameKind [] Nothing val : rest) = do

172 go (ValueDeclaration name nameKind [] Nothing val : rest) = do

169 d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do

173 d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do

@@ -240,6 +244,16 @@ typeCheckAll mainModuleName moduleName exps = go

240 rethrowWithPosition pos $ do

244 rethrowWithPosition pos $ do

241 (d' : rest') <- go (d : rest)

245 (d' : rest') <- go (d : rest)

242 return (PositionedDeclaration pos d' : rest')

246 return (PositionedDeclaration pos d' : rest')

247+

248+ -- |

249+ -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

250+ -- extracted from the kind of the type constructor itself.

251+ --

252+ withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]

253+ withKinds [] _ = []

254+ withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k

255+ withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2

256+ withKinds _ _ = error "Invalid arguments to peelKinds"

243

257

244-- |

258-- |

245-- Type check an entire module and ensure all types and classes defined within the module that are

259-- Type check an entire module and ensure all types and classes defined within the module that are

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

@@ -80,20 +80,27 @@ kindOf _ ty =

80-- |

81-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors

82--

83−kindsOf :: Bool -> ModuleName -> ProperName -> [String] -> [Type] -> Check Kind

83+kindsOf :: Bool -> ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Type] -> Check Kind

84kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

85 tyCon <- fresh

86 kargs <- replicateM (length args) fresh

87+ rest <- zipWithM freshKindVar args kargs

87− let dict = (name, tyCon) : zipWith (\arg kind -> (arg, kind)) (map ProperName args) kargs

88+ let dict = (name, tyCon) : rest

88 bindLocalTypeVariables moduleName dict $

89 bindLocalTypeVariables moduleName dict $

89 solveTypes isData ts kargs tyCon

90 solveTypes isData ts kargs tyCon

90 where

91 where

91 tidyUp (k, sub) = starIfUnknown $ sub $? k

92 tidyUp (k, sub) = starIfUnknown $ sub $? k

93+

94+freshKindVar :: (String, Maybe Kind) -> Kind -> UnifyT Kind Check (ProperName, Kind)

95+freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)

96+freshKindVar (arg, Just kind') kind = do

97+ kind =?= kind'

98+ return (ProperName arg, kind')

93-- |

100-- |

94-- Simultaneously infer the kinds of several mutually recursive type constructors

101-- Simultaneously infer the kinds of several mutually recursive type constructors

95--

102--

96−kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])

103+kindsOfAll :: ModuleName -> [(ProperName, [(String, Maybe Kind)], Type)] -> [(ProperName, [(String, Maybe Kind)], [Type])] -> Check ([Kind], [Kind])

97kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

104kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

98 synVars <- replicateM (length syns) fresh

105 synVars <- replicateM (length syns) fresh

99 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars

106 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars

@@ -103,12 +110,12 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

103 bindLocalTypeVariables moduleName dict' $ do

110 bindLocalTypeVariables moduleName dict' $ do

104 data_ks <- zipWithM (\tyCon (_, args, ts) -> do

111 data_ks <- zipWithM (\tyCon (_, args, ts) -> do

105 kargs <- replicateM (length args) fresh

112 kargs <- replicateM (length args) fresh

106− let argDict = zip (map ProperName args) kargs

113+ argDict <- zipWithM freshKindVar args kargs

107 bindLocalTypeVariables moduleName argDict $

114 bindLocalTypeVariables moduleName argDict $

108 solveTypes True ts kargs tyCon) tyCons tys

115 solveTypes True ts kargs tyCon) tyCons tys

109 syn_ks <- zipWithM (\synVar (_, args, ty) -> do

116 syn_ks <- zipWithM (\synVar (_, args, ty) -> do

110 kargs <- replicateM (length args) fresh

117 kargs <- replicateM (length args) fresh

111− let argDict = zip (map ProperName args) kargs

118+ argDict <- zipWithM freshKindVar args kargs

112 bindLocalTypeVariables moduleName argDict $

119 bindLocalTypeVariables moduleName argDict $

113 solveTypes False [ty] kargs synVar) synVars syns

120 solveTypes False [ty] kargs synVar) synVars syns

114 return (syn_ks, data_ks)

121 return (syn_ks, data_ks)

@@ -179,6 +186,10 @@ infer' (ConstrainedType deps ty) = do

179 k <- infer ty

186 k <- infer ty

180 k =?= Star

187 k =?= Star

181 return Star

188 return Star

189+infer' (KindedType ty k) = do

190+ k' <- infer ty

191+ k =?= k'

192+ return k'

182infer' _ = error "Invalid argument to infer"

193infer' _ = error "Invalid argument to infer"

183

194

184

195

src/Language/PureScript/TypeChecker/Types.hs+14−2

@@ -124,6 +124,8 @@ unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintT

124 t3 `unifyTypes` t5

125 t4 `unifyTypes` t6

126 unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()

127+ unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2

128+ unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2

127 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2

129 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2

128 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2

130 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2

129 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

131 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

@@ -342,7 +344,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

342 -- Make sure the types unify with the types in the superclass implication

344 -- Make sure the types unify with the types in the superclass implication

343 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs

345 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs

344 -- Finally, satisfy the subclass constraint

346 -- Finally, satisfy the subclass constraint

345− , args' <- maybeToList $ mapM (flip lookup subst) args

347+ , args' <- maybeToList $ mapM (flip lookup subst) (map fst args)

346 , suDict <- go True subclassName args' ]

348 , suDict <- go True subclassName args' ]

347

349

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

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

@@ -630,7 +632,7 @@ expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either St

630expandTypeSynonym' env name args =

632expandTypeSynonym' env name args =

631 case M.lookup name (typeSynonyms env) of

633 case M.lookup name (typeSynonyms env) of

632 Just (synArgs, body) -> do

634 Just (synArgs, body) -> do

633− let repl = replaceAllTypeVars (zip synArgs args) body

635+ let repl = replaceAllTypeVars (zip (map fst synArgs) args) body

634 replaceAllTypeSynonyms' env repl

636 replaceAllTypeSynonyms' env repl

635 Nothing -> error "Type synonym was not defined"

637 Nothing -> error "Type synonym was not defined"

636

638

@@ -1041,6 +1043,10 @@ check' (Let ds val) ty = do

1041check' val ty | containsTypeSynonyms ty = do

1043check' val ty | containsTypeSynonyms ty = do

1042 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty

1044 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty

1043 check val ty'

1045 check val ty'

1046+check' val kt@(KindedType ty kind) = do

1047+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

1048+ val' <- check' val ty

1049+ return $ TypedValue True val' kt

1044check' (PositionedValue pos val) ty =

1050check' (PositionedValue pos val) ty =

1045 rethrowWithPosition pos $ check val ty

1051 rethrowWithPosition pos $ check val ty

1046check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))

1052check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))

@@ -1123,6 +1129,8 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do

1123checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do

1129checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do

1124 ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

1130 ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

1125 checkFunctionApplication fn ty arg ret

1131 checkFunctionApplication fn ty arg ret

1132+checkFunctionApplication' fn (KindedType ty _) arg ret = do

1133+ checkFunctionApplication fn ty arg ret

1126checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

1134checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

1127 dicts <- getTypeClassDictionaries

1135 dicts <- getTypeClassDictionaries

1128 checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret

1136 checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret

@@ -1167,6 +1175,10 @@ subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do

1167subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do

1175subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do

1168 ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

1176 ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

1169 subsumes val ty1 ty2

1177 subsumes val ty1 ty2

1178+subsumes' val (KindedType ty1 _) ty2 = do

1179+ subsumes val ty1 ty2

1180+subsumes' val ty1 (KindedType ty2 _) = do

1181+ subsumes val ty1 ty2

1170subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

1182subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

1171 dicts <- getTypeClassDictionaries

1183 dicts <- getTypeClassDictionaries

1172 subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2

1184 subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2

src/Language/PureScript/Types.hs+13

@@ -26,6 +26,7 @@ import Control.Applicative

26import Control.Monad ((<=<))

28import Language.PureScript.Names

29+import Language.PureScript.Kinds

29import Language.PureScript.Traversals

30import Language.PureScript.Traversals

31-- |

32-- |

@@ -78,6 +79,11 @@ data Type

78 --

79 --

79 | RCons String Type Type

80 | RCons String Type Type

80 -- |

81 -- |

82+ -- A type with a kind annotation

83+ --

84+ | KindedType Type Kind

85+ --

86+ -- |

81 -- A placeholder used in pretty printing

87 -- A placeholder used in pretty printing

82 --

88 --

83 | PrettyPrintFunction Type Type

89 | PrettyPrintFunction Type Type

@@ -153,6 +159,7 @@ replaceAllTypeVars = go []

153 usedVars = concatMap (usedTypeVariables . snd) m

159 usedVars = concatMap (usedTypeVariables . snd) m

154 go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t)

160 go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t)

155 go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)

161 go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)

162+ go bs m (KindedType t k) = KindedType (go bs m t) k

156 go _ _ ty = ty

163 go _ _ ty = ty

157

164

158 genName orig inUse = try 0

165 genName orig inUse = try 0

@@ -183,6 +190,7 @@ freeTypeVariables = nub . go []

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

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

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

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

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

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

193+ go bound (KindedType t _) = go bound t

186 go _ _ = []

194 go _ _ = []

187

195

188-- |

196-- |

@@ -219,6 +227,7 @@ everywhereOnTypes f = go

219 go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)

227 go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)

220 go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))

228 go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))

221 go (RCons name ty rest) = f (RCons name (go ty) (go rest))

229 go (RCons name ty rest) = f (RCons name (go ty) (go rest))

230+ go (KindedType ty k) = f (KindedType (go ty) k)

222 go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))

231 go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))

223 go (PrettyPrintArray t) = f (PrettyPrintArray (go t))

232 go (PrettyPrintArray t) = f (PrettyPrintArray (go t))

224 go (PrettyPrintObject t) = f (PrettyPrintObject (go t))

233 go (PrettyPrintObject t) = f (PrettyPrintObject (go t))

@@ -233,6 +242,7 @@ everywhereOnTypesTopDown f = go . f

233 go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco

242 go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco

234 go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))

243 go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))

235 go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))

244 go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))

245+ go (KindedType ty k) = KindedType (go (f ty)) k

236 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))

246 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))

237 go (PrettyPrintArray t) = PrettyPrintArray (go (f t))

247 go (PrettyPrintArray t) = PrettyPrintArray (go (f t))

238 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))

248 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))

@@ -247,6 +257,7 @@ everywhereOnTypesM f = go

247 go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f

257 go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f

248 go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f

258 go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f

249 go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f

259 go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f

260+ go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f

250 go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f

261 go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f

251 go (PrettyPrintArray t) = (PrettyPrintArray <$> go t) >>= f

262 go (PrettyPrintArray t) = (PrettyPrintArray <$> go t) >>= f

252 go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f

263 go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f

@@ -261,6 +272,7 @@ everywhereOnTypesTopDownM f = go <=< f

261 go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco

272 go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco

262 go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)

273 go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)

263 go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)

274 go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)

275+ go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k

264 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)

276 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)

265 go (PrettyPrintArray t) = PrettyPrintArray <$> (f t >>= go)

277 go (PrettyPrintArray t) = PrettyPrintArray <$> (f t >>= go)

266 go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)

278 go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)

@@ -275,6 +287,7 @@ everythingOnTypes (<>) f = go

275 go t@(ForAll _ ty _) = f t <> go ty

287 go t@(ForAll _ ty _) = f t <> go ty

276 go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty

288 go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty

277 go t@(RCons _ ty rest) = f t <> go ty <> go rest

289 go t@(RCons _ ty rest) = f t <> go ty <> go rest

290+ go t@(KindedType ty _) = f t <> go ty

278 go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2

291 go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2

279 go t@(PrettyPrintArray t1) = f t <> go t1

292 go t@(PrettyPrintArray t1) = f t <> go t1

280 go t@(PrettyPrintObject t1) = f t <> go t1

293 go t@(PrettyPrintObject t1) = f t <> go t1