4b08ade · rowtype-yoga/purescript-native

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

2+

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

4+

5+type Star t = t :: *

6+

7+test1 :: Star2Star [] String

8+test1 = ["test"]

9+

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

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

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

13--

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

15

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

30

32

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)

50

53

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)

71

78

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

29

30

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

86

87

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

92

95

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

27

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

31

33

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

73

75

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

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

251 let superclasses =

252 let superclasses =

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

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

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

254 | (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

255 , let fieldName = mkSuperclassDictionaryName superclass index

256 , let fieldName = mkSuperclassDictionaryName superclass index

256 ]

257 ]

257

258

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

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

127 go (d@(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− addDataType moduleName dtype name args dctors ctorKind

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

133 ds <- go rest

134 return $ d : ds

135 where

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

143 let dataDecls = mapMaybe toDataDecl tys

144 (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− checkDuplicateTypeArguments args

146+ checkDuplicateTypeArguments $ map fst args

147− addDataType moduleName dtype name args dctors ctorKind

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

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

149− checkDuplicateTypeArguments args

149+ checkDuplicateTypeArguments $ map fst args

150− addTypeSynonym moduleName name args ty kind

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

151 ds <- go rest

152 return $ d : ds

153 where

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

159 toDataDecl _ = Nothing

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

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

162− checkDuplicateTypeArguments args

162+ checkDuplicateTypeArguments $ map fst args

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

164− addTypeSynonym moduleName name args ty kind

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

165 ds <- go rest

166 return $ d : ds

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

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

216 ds <- go rest

217 return $ d : ds

218 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

220 ds <- go rest

221 return $ d : ds

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

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

92

99

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+12

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

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

1004check' val ty | containsTypeSynonyms ty = do

1006check' val ty | containsTypeSynonyms ty = do

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

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

1006 check val ty'

1008 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

1007check' (PositionedValue pos val) ty =

1013check' (PositionedValue pos val) ty =

1008 rethrowWithPosition pos $ check val ty

1014 rethrowWithPosition pos $ check val ty

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

1015check' 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

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

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

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

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

1088 checkFunctionApplication fn ty arg ret

1094 checkFunctionApplication fn ty arg ret

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

1096+ checkFunctionApplication fn ty arg ret

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

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

1090 dicts <- getTypeClassDictionaries

1098 dicts <- getTypeClassDictionaries

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

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

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

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

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

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

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

1132 subsumes val ty1 ty2

1140 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

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

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

1134 dicts <- getTypeClassDictionaries

1146 dicts <- getTypeClassDictionaries

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

1147 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 ((<=<))

27

28import Language.PureScript.Names

29+import Language.PureScript.Kinds

29import Language.PureScript.Traversals

30import Language.PureScript.Traversals

30

31

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

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

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

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

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

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

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

150 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

145 go _ ty = ty

152 go _ ty = ty

146 genName orig inUse = try 0

153 genName orig inUse = try 0

147 where

154 where

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

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

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

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

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

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

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

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

180 go _ _ = []

188 go _ _ = []

181

189

182-- |

190-- |

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

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

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

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

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

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

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

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

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

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

217 go (PrettyPrintArray t) = f (PrettyPrintArray (go t))

226 go (PrettyPrintArray t) = f (PrettyPrintArray (go t))

218 go (PrettyPrintObject t) = f (PrettyPrintObject (go t))

227 go (PrettyPrintObject t) = f (PrettyPrintObject (go t))

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

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

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

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

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

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

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

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

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

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

231 go (PrettyPrintArray t) = PrettyPrintArray (go (f t))

241 go (PrettyPrintArray t) = PrettyPrintArray (go (f t))

232 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))

242 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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