4b08ade · rowtype-yoga/purescript-native

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

Initial work on #618.

commit4b08ade1be59054c33dd0522f542f65605638df0 authorPhil Freeman <paf31@cantab.net> dateSun 26 Oct 2014, 19:56 (12 years ago) parent8192284

11 files changed+124−29

compare with golang

unifiedsplit

docgen/Main.hs+11−3 examples/passing/KindedType.purs+31 src/Language/PureScript/Declarations.hs+3−3 src/Language/PureScript/Parser/Declarations.hs+10−3 src/Language/PureScript/Parser/Types.hs+4−1 src/Language/PureScript/Pretty/Types.hs+9 src/Language/PureScript/Sugar/TypeClasses.hs+6−5 src/Language/PureScript/TypeChecker.hs+9−9 src/Language/PureScript/TypeChecker/Kinds.hs+16−5 src/Language/PureScript/TypeChecker/Types.hs+12 src/Language/PureScript/Types.hs+13

docgen/Main.hs+11−3

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

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

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

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

145145 typeName = prettyPrintType' typeApp

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

147147 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

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

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

153153renderDeclaration 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

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

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

157159 let impliesText = case implies of

158160 [] -> ""

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

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

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

163+ className = prettyPrintType' classApp

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

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

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

163167 let constraintsText = case constraints of

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

168172 renderDeclaration n exps d

169173renderDeclaration _ _ _ = return ()

170174

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+

171179prettyPrintType' :: P.Type -> String

172180prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim

173181 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/Declarations.hs+3−3

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

138138 -- |

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

140140 --

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

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

142142 -- |

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

144144 --

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

146146 -- |

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

148148 --

149− | TypeSynonymDeclaration ProperName [String] Type

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

150150 -- |

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

152152 --

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

183183 -- |

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

185185 --

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

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

187187 -- |

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

189189 -- declarations)

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

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

1313--

1414-----------------------------------------------------------------------------

1515

16+{-# LANGUAGE TupleSections #-}

17+

1618module Language.PureScript.Parser.Declarations (

1719 parseDeclaration,

1820 parseModule,

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

2830import Control.Applicative

2931import Control.Arrow ((+++))

3032

33+import Language.PureScript.Kinds

3134import Language.PureScript.Parser.State

3235import Language.PureScript.Parser.Common

3336import Language.PureScript.Declarations

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

4851 where

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

5053

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

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

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

57+

5158parseDataDeclaration :: P.Parsec String ParseState Declaration

5259parseDataDeclaration = do

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

5461 name <- indented *> properName

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

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

5663 ctors <- P.option [] $ do

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

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

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

6673parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration

6774parseTypeSynonymDeclaration =

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

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

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

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

7178

7279parseValueDeclaration :: P.Parsec String ParseState Declaration

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

163170 reservedOp "<="

164171 return implies

165172 className <- indented *> properName

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

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

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

168175 indented *> reserved "where"

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

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

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

2525import Language.PureScript.Types

2626import Language.PureScript.Parser.State

2727import Language.PureScript.Parser.Common

28+import Language.PureScript.Parser.Kinds

2829import Language.PureScript.Environment

2930

3031import qualified Text.Parsec as P

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

8586 return $ maybe ty (flip ConstrainedType ty) constraints

8687

8788parseAnyType :: P.Parsec String ParseState Type

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

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

8990 where

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

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

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

94+ ]

9295

9396-- |

9497-- Parse a monotype

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

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

2626import Control.PatternArrows

2727

2828import Language.PureScript.Types

29+import Language.PureScript.Kinds

2930import Language.PureScript.Pretty.Common

31+import Language.PureScript.Pretty.Kinds

3032import Language.PureScript.Environment

3133

3234typeLiterals :: Pattern () Type String

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

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

7274 match _ = Nothing

7375

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

77+kinded = mkPattern match

78+ where

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

80+ match _ = Nothing

81+

7482insertPlaceholders :: Type -> Type

7583insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert

7684 where

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

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

97105 ]

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

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

99108 ]

100109

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

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

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

2121import Language.PureScript.Declarations

2222import Language.PureScript.Names

2323import Language.PureScript.Types

24+import Language.PureScript.Kinds

2425import Language.PureScript.Sugar.CaseDeclarations

2526import Language.PureScript.Environment

2627import Language.PureScript.Errors

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

197198memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

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

199200

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

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

201202typeClassDictionaryDeclaration name args implies members =

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

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

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

208209 mtys = members' ++ superclassTypes

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

210211

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

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

212213typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

213214 ValueDeclaration ident TypeClassAccessorImport [] Nothing $

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

216217typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

217218 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

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

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

240241 let instanceTys = map memberToNameAndType tyDecls

241242

242243 -- 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

244245 -- Create values for the type instance members

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

246247 -- Create the type of the dictionary

@@ -251,7 +252,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

251252 let superclasses =

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

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

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

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

255256 , let fieldName = mkSuperclassDictionaryName superclass index

256257 ]

257258

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

@@ -127,9 +127,9 @@ typeCheckAll mainModuleName moduleName exps = go

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

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

129129 when (dtype == Newtype) $ checkNewtype dctors

130− checkDuplicateTypeArguments args

130+ checkDuplicateTypeArguments $ map fst args

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

132− addDataType moduleName dtype name args dctors ctorKind

132+ addDataType moduleName dtype name (map fst args) dctors ctorKind

133133 ds <- go rest

134134 return $ d : ds

135135 where

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

143143 let dataDecls = mapMaybe toDataDecl tys

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

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

146− checkDuplicateTypeArguments args

147− addDataType moduleName dtype name args dctors ctorKind

146+ checkDuplicateTypeArguments $ map fst args

147+ addDataType moduleName dtype name (map fst args) dctors ctorKind

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

149− checkDuplicateTypeArguments args

150− addTypeSynonym moduleName name args ty kind

149+ checkDuplicateTypeArguments $ map fst args

150+ addTypeSynonym moduleName name (map fst args) ty kind

151151 ds <- go rest

152152 return $ d : ds

153153 where

@@ -159,9 +159,9 @@ typeCheckAll mainModuleName moduleName exps = go

159159 toDataDecl _ = Nothing

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

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

162− checkDuplicateTypeArguments args

162+ checkDuplicateTypeArguments $ map fst args

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

164− addTypeSynonym moduleName name args ty kind

164+ addTypeSynonym moduleName name (map fst args) ty kind

165165 ds <- go rest

166166 return $ d : ds

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

@@ -216,7 +216,7 @@ typeCheckAll mainModuleName moduleName exps = go

216216 ds <- go rest

217217 return $ d : ds

218218 go (d@(TypeClassDeclaration pn args implies tys) : rest) = do

219− addTypeClass moduleName pn args implies tys

219+ addTypeClass moduleName pn (map fst args) implies tys

220220 ds <- go rest

221221 return $ d : ds

222222 go (TypeInstanceDeclaration dictName deps className tys _ : rest) =

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

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

8080-- |

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

8282--

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

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

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

8585 tyCon <- fresh

8686 kargs <- replicateM (length args) fresh

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

87+ rest <- zipWithM freshKindVar args kargs

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

8889 bindLocalTypeVariables moduleName dict $

8990 solveTypes isData ts kargs tyCon

9091 where

9192 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')

9299

93100-- |

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

95102--

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

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

98105 synVars <- replicateM (length syns) fresh

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

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

103110 bindLocalTypeVariables moduleName dict' $ do

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

105112 kargs <- replicateM (length args) fresh

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

113+ argDict <- zipWithM freshKindVar args kargs

107114 bindLocalTypeVariables moduleName argDict $

108115 solveTypes True ts kargs tyCon) tyCons tys

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

110117 kargs <- replicateM (length args) fresh

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

118+ argDict <- zipWithM freshKindVar args kargs

112119 bindLocalTypeVariables moduleName argDict $

113120 solveTypes False [ty] kargs synVar) synVars syns

114121 return (syn_ks, data_ks)

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

179186 k <- infer ty

180187 k =?= Star

181188 return Star

189+infer' (KindedType ty k) = do

190+ k' <- infer ty

191+ k =?= k'

192+ return k'

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

183194

184195

src/Language/PureScript/TypeChecker/Types.hs+12

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

124124 t3 `unifyTypes` t5

125125 t4 `unifyTypes` t6

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

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

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

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

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

129131 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

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

10041006check' val ty | containsTypeSynonyms ty = do

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

10061008 check val ty'

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

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

1011+ val' <- check' val ty

1012+ return $ TypedValue True val' kt

10071013check' (PositionedValue pos val) ty =

10081014 rethrowWithPosition pos $ check val ty

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

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

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

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

10881094 checkFunctionApplication fn ty arg ret

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

1096+ checkFunctionApplication fn ty arg ret

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

10901098 dicts <- getTypeClassDictionaries

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

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

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

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

11321140 subsumes val ty1 ty2

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

1142+ subsumes val ty1 ty2

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

1144+ subsumes val ty1 ty2

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

11341146 dicts <- getTypeClassDictionaries

11351147 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

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

2727

2828import Language.PureScript.Names

29+import Language.PureScript.Kinds

2930import Language.PureScript.Traversals

3031

3132-- |

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

7879 --

7980 | RCons String Type Type

8081 -- |

82+ -- A type with a kind annotation

83+ --

84+ | KindedType Type Kind

85+ --

86+ -- |

8187 -- A placeholder used in pretty printing

8288 --

8389 | PrettyPrintFunction Type Type

@@ -142,6 +148,7 @@ replaceTypeVars = replaceTypeVars' []

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

143149 go bs (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs)) cs) (go bs t)

144150 go bs (RCons name' t r) = RCons name' (go bs t) (go bs r)

151+ go bs (KindedType t k) = KindedType (go bs t) k

145152 go _ ty = ty

146153 genName orig inUse = try 0

147154 where

@@ -177,6 +184,7 @@ freeTypeVariables = nub . go []

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

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

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

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

180188 go _ _ = []

181189

182190-- |

@@ -213,6 +221,7 @@ everywhereOnTypes f = go

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

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

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

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

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

217226 go (PrettyPrintArray t) = f (PrettyPrintArray (go t))

218227 go (PrettyPrintObject t) = f (PrettyPrintObject (go t))

@@ -227,6 +236,7 @@ everywhereOnTypesTopDown f = go . f

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

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

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

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

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

231241 go (PrettyPrintArray t) = PrettyPrintArray (go (f t))

232242 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))

@@ -241,6 +251,7 @@ everywhereOnTypesM f = go

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

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

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

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

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

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

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

@@ -255,6 +266,7 @@ everywhereOnTypesTopDownM f = go <=< f

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

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

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

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

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

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

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

@@ -269,6 +281,7 @@ everythingOnTypes (<>) f = go

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

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

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

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

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

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

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