144dd6f · rowtype-yoga/purescript-native

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

Add support for user defined kinds (#2486)

* Add foreign import kind * Make ForeignKind.Lib visible to example tests * Rename to NamedKind, add kind traversal, update usedModules * More kind updates * Missing type declaration * Undo change to usedModules. * Use the name IdeDeclNamespace and IdeNSValue/etc * Add extern kind filter to binding groups * Replace Symbol with use of NamedKind * Add test for shadowing kind + update foreign kind test * Desugar kind in KindedType when desugaring names + pretty NamedKind * Add fail test for unifying custom kinds across modules * Move * and ! to Type and Effect, Remove ShadowPrimKind test * Add docs for kinds in Prim

commit144dd6f020167d2a21095e315afc5e60b3c2bc2f authorLiam Goodacre <goodacre.liam@gmail.com> dateWed 28 Dec 2016, 18:11 (10 years ago) parent766d7fe

46 files changed+560−129

compare with golang

unifiedsplit

examples/failing/DiffKindsSameName.pursnew file+15

@@ -0,0 +1,15 @@

1+-- @shouldFailWith KindsDoNotUnify

2+module DiffKindsSameName where

4+import DiffKindsSameName.LibA as LibA

5+import DiffKindsSameName.LibB as LibB

7+-- both `LibA` and `LibB` define a kind locally called `DemoKind`

8+-- `LibB` defines `DemoData :: LibB.DemoKind`

9+-- if we try to use `DemoData` in a place where `LibA.DemoKind` is expected, it should fail with `KindsDoNotUnify`

10+

11+data AProxy (m :: LibA.DemoKind) = AProxy

12+

13+bProxy :: AProxy LibB.DemoData

14+bProxy = AProxy

15+

examples/failing/DiffKindsSameName/LibA.pursnew file+4

@@ -0,0 +1,4 @@

1+module DiffKindsSameName.LibA where

3+foreign import kind DemoKind

examples/failing/DiffKindsSameName/LibB.pursnew file+6

@@ -0,0 +1,6 @@

1+module DiffKindsSameName.LibB where

3+foreign import kind DemoKind

5+foreign import data DemoData :: DemoKind

examples/passing/ForeignKind.pursnew file+10

@@ -0,0 +1,10 @@

1+module Main where

3+import Prelude

4+import ForeignKinds.Lib (kind Nat, Zero, Succ, N3, NatProxy, class AddNat, addNat, proxy1, proxy2)

5+import Control.Monad.Eff.Console (log)

7+proxy1Add2Is3 :: NatProxy N3

8+proxy1Add2Is3 = addNat proxy1 proxy2

10+main = log "Done"

examples/passing/ForeignKind/Lib.pursnew file+60

@@ -0,0 +1,60 @@

1+module ForeignKinds.Lib (kind Nat, Kinded, Zero, Succ, N0, N1, N2, N3, NatProxy(..), class AddNat, addNat, proxy1, proxy2) where

3+-- declaration

5+foreign import kind Nat

7+-- use in foreign data

9+foreign import data Zero :: Nat

10+foreign import data Succ :: Nat -> Nat

11+

12+-- use in data

13+

14+data NatProxy (t :: Nat) = NatProxy

15+

16+-- use in type sig

17+

18+succProxy :: forall n. NatProxy n -> NatProxy (Succ n)

19+succProxy _ = NatProxy

20+

21+-- use in alias

22+

23+type Kinded f = f :: Nat

24+

25+type KindedZero = Kinded Zero

26+

27+type N0 = Zero

28+type N1 = Succ N0

29+type N2 = Succ N1

30+type N3 = Succ N2

31+

32+-- use of alias

33+

34+proxy0 :: NatProxy N0

35+proxy0 = NatProxy

36+

37+proxy1 :: NatProxy N1

38+proxy1 = NatProxy

39+

40+proxy2 :: NatProxy N2

41+proxy2 = NatProxy

42+

43+proxy3 :: NatProxy N3

44+proxy3 = NatProxy

45+

46+-- use in class

47+

48+class AddNat (l :: Nat) (r :: Nat) (o :: Nat) | l -> r o

49+

50+instance addNatZero

51+ :: AddNat Zero r r

52+

53+instance addNatSucc

54+ :: AddNat l r o

55+ => AddNat (Succ l) r (Succ o)

56+

57+-- use of class

58+

59+addNat :: forall l r o. AddNat l r o => NatProxy l -> NatProxy r -> NatProxy o

60+addNat _ _ = NatProxy

psc-docs/Tags.hs+1

@@ -17,4 +17,5 @@ tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations

1717 names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]

1818 names (P.TypeClassDeclaration name _ _ _ _) = [P.runProperName name]

1919 names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name]

20+ names (P.ExternKindDeclaration name) = [P.runProperName name]

2021 names _ = []

purescript.cabal+2

@@ -28,6 +28,7 @@ extra-source-files: examples/passing/*.purs

2828 , examples/passing/ExplicitImportReExport/*.purs

2929 , examples/passing/ExportExplicit/*.purs

3030 , examples/passing/ExportExplicit2/*.purs

31+ , examples/passing/ForeignKind/*.purs

3132 , examples/passing/Import/*.purs

3233 , examples/passing/ImportExplicit/*.purs

3334 , examples/passing/ImportQualified/*.purs

@@ -63,6 +64,7 @@ extra-source-files: examples/passing/*.purs

6364 , examples/failing/ConflictingImports2/*.purs

6465 , examples/failing/ConflictingQualifiedImports/*.purs

6566 , examples/failing/ConflictingQualifiedImports2/*.purs

67+ , examples/failing/DiffKindsSameName/*.purs

6668 , examples/failing/DuplicateModule/*.purs

6769 , examples/failing/ExportConflictClass/*.purs

6870 , examples/failing/ExportConflictCtor/*.purs

src/Language/PureScript/AST/Declarations.hs+25−1

@@ -240,6 +240,10 @@ data DeclarationRef

240240 --

241241 | ModuleRef ModuleName

242242 -- |

243+ -- A named kind

244+ --

245+ | KindRef (ProperName 'KindName)

246+ -- |

243247 -- A value re-exported from another module. These will be inserted during

244248 -- elaboration in name desugaring.

245249 --

@@ -258,6 +262,7 @@ instance Eq DeclarationRef where

258262 (TypeClassRef name) == (TypeClassRef name') = name == name'

259263 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

260264 (ModuleRef name) == (ModuleRef name') = name == name'

265+ (KindRef name) == (KindRef name') = name == name'

261266 (ReExportRef mn ref) == (ReExportRef mn' ref') = mn == mn' && ref == ref'

262267 (PositionedDeclarationRef _ _ r) == r' = r == r'

263268 r == (PositionedDeclarationRef _ _ r') = r == r'

@@ -274,6 +279,7 @@ compDecRef (ValueOpRef name) (ValueOpRef name') = compare name name'

274279compDecRef (TypeClassRef name) (TypeClassRef name') = compare name name'

275280compDecRef (TypeInstanceRef ident) (TypeInstanceRef ident') = compare ident ident'

276281compDecRef (ModuleRef name) (ModuleRef name') = compare name name'

282+compDecRef (KindRef name) (KindRef name') = compare name name'

277283compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name'

278284compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref'

279285compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref'

@@ -286,7 +292,8 @@ compDecRef ref ref' = compare

286292 orderOf (TypeRef _ _) = 2

287293 orderOf (ValueRef _) = 3

288294 orderOf (ValueOpRef _) = 4

289− orderOf _ = 5

295+ orderOf (KindRef _) = 5

296+ orderOf _ = 6

290297

291298getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName])

292299getTypeRef (TypeRef name dctors) = Just (name, dctors)

@@ -313,6 +320,11 @@ getTypeClassRef (TypeClassRef name) = Just name

313320getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r

314321getTypeClassRef _ = Nothing

315322

323+getKindRef :: DeclarationRef -> Maybe (ProperName 'KindName)

324+getKindRef (KindRef name) = Just name

325+getKindRef (PositionedDeclarationRef _ _ r) = getKindRef r

326+getKindRef _ = Nothing

327+

316328isModuleRef :: DeclarationRef -> Bool

317329isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r

318330isModuleRef (ModuleRef _) = True

@@ -381,6 +393,10 @@ data Declaration

381393 --

382394 | ExternDataDeclaration (ProperName 'TypeName) Kind

383395 -- |

396+ -- A foreign kind import (name)

397+ --

398+ | ExternKindDeclaration (ProperName 'KindName)

399+ -- |

384400 -- A fixity declaration

385401 --

386402 | FixityDeclaration (Either ValueFixity TypeFixity)

@@ -469,6 +485,14 @@ isExternDataDecl ExternDataDeclaration{} = True

469485isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d

470486isExternDataDecl _ = False

471487

488+-- |

489+-- Test if a declaration is a foreign kind import

490+--

491+isExternKindDecl :: Declaration -> Bool

492+isExternKindDecl ExternKindDeclaration{} = True

493+isExternKindDecl (PositionedDeclaration _ _ d) = isExternKindDecl d

494+isExternKindDecl _ = False

495+

472496-- |

473497-- Test if a declaration is a fixity declaration

474498--

src/Language/PureScript/AST/Exported.hs+1

@@ -132,6 +132,7 @@ isExported (Just exps) decl = any (matches decl) exps

132132 matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'

133133 matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'

134134 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'

135+ matches (ExternKindDeclaration ident) (KindRef ident') = ident == ident'

135136 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

136137 matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef ident') = ident == ident'

137138 matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op'

src/Language/PureScript/AST/Traversals.hs+40−3

@@ -14,11 +14,12 @@ import Data.Maybe (mapMaybe)

1414import qualified Data.Set as S

1515

1616import Language.PureScript.AST.Binders

17−import Language.PureScript.AST.Literals

1817import Language.PureScript.AST.Declarations

19−import Language.PureScript.Types

20−import Language.PureScript.Traversals

18+import Language.PureScript.AST.Literals

19+import Language.PureScript.Kinds

2120import Language.PureScript.Names

21+import Language.PureScript.Traversals

22+import Language.PureScript.Types

2223

2324everywhereOnValues

2425 :: (Declaration -> Declaration)

@@ -588,6 +589,42 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con

588589 forValues (TypedValue _ _ ty) = f ty

589590 forValues _ = mempty

590591

592+accumKinds

593+ :: (Monoid r)

594+ => (Kind -> r)

595+ -> ( Declaration -> r

596+ , Expr -> r

597+ , Binder -> r

598+ , CaseAlternative -> r

599+ , DoNotationElement -> r

600+ )

601+accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

602+ where

603+ forDecls (DataDeclaration _ _ args dctors) =

604+ foldMap (foldMap f . snd) args `mappend`

605+ foldMap (foldMap forTypes . snd) dctors

606+ forDecls (TypeClassDeclaration _ args implies _ _) =

607+ foldMap (foldMap f . snd) args `mappend`

608+ foldMap (foldMap forTypes . constraintArgs) implies

609+ forDecls (TypeInstanceDeclaration _ cs _ tys _) =

610+ foldMap (foldMap forTypes . constraintArgs) cs `mappend`

611+ foldMap forTypes tys

612+ forDecls (TypeSynonymDeclaration _ args ty) =

613+ foldMap (foldMap f . snd) args `mappend`

614+ forTypes ty

615+ forDecls (TypeDeclaration _ ty) = forTypes ty

616+ forDecls (ExternDeclaration _ ty) = forTypes ty

617+ forDecls (ExternDataDeclaration _ kn) = f kn

618+ forDecls _ = mempty

619+

620+ forValues (TypeClassDictionary c _ _) = foldMap forTypes (constraintArgs c)

621+ forValues (DeferredDictionary _ tys) = foldMap forTypes tys

622+ forValues (TypedValue _ _ ty) = forTypes ty

623+ forValues _ = mempty

624+

625+ forTypes (KindedType _ k) = f k

626+ forTypes _ = mempty

627+

591628-- |

592629-- Map a function over type annotations appearing inside a value

593630--

src/Language/PureScript/Constants.hs+9

@@ -335,6 +335,15 @@ pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName

335335pattern Fail :: Qualified (ProperName 'ClassName)

336336pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail")

337337

338+typ :: Text

339+typ = "Type"

340+

341+effect :: Text

342+effect = "Effect"

343+

344+symbol :: Text

345+symbol = "Symbol"

346+

338347-- Code Generation

339348

340349__superclass_ :: Text

src/Language/PureScript/Docs/Convert/ReExports.hs+23−1

@@ -110,13 +110,14 @@ collectDeclarations imports exports = do

110110 typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

111111 types <- collect lookupTypeDeclaration impTypes expTypes

112112 typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps

113+ kinds <- collect lookupKindDeclaration impKinds expKinds

113114

114115 (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

115116

116117 let filteredTypes = filterDataConstructors expCtors types

117118 let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes

118119

119− pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps]))

120+ pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps, kinds]))

120121

121122 where

122123

@@ -147,6 +148,9 @@ collectDeclarations imports exports = do

147148 expTCs = P.exportedTypeClasses exports

148149 impTCs = concat (Map.elems (P.importedTypeClasses imports))

149150

151+ expKinds = P.exportedKinds exports

152+ impKinds = concat (Map.elems (P.importedKinds imports))

153+

150154-- |

151155-- Given a list of imported declarations (of a particular kind, ie. type, data,

152156-- class, value, etc), and the name of an exported declaration of the same

@@ -304,6 +308,24 @@ lookupTypeClassDeclaration importedFrom tyClass = do

304308 ("lookupTypeClassDeclaration: unexpected result: "

305309 ++ (unlines . map show) other)

306310

311+lookupKindDeclaration

312+ :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m)

313+ => P.ModuleName

314+ -> P.ProperName 'P.KindName

315+ -> m (P.ModuleName, [Declaration])

316+lookupKindDeclaration importedFrom kind = do

317+ decls <- lookupModuleDeclarations "lookupKindDeclaration" importedFrom

318+ let

319+ ds = filter (\d -> declTitle d == P.runProperName kind

320+ && isKind d)

321+ decls

322+ case ds of

323+ [d] ->

324+ pure (importedFrom, [d])

325+ other ->

326+ internalErrorInModule

327+ ("lookupKindDeclaration: unexpected result: " ++ show other)

328+

307329-- |

308330-- Get the full list of declarations for a particular module out of the

309331-- state, or raise an internal error if it is not there.

src/Language/PureScript/Docs/Convert/Single.hs+3

@@ -83,6 +83,7 @@ getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name)

8383getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)

8484getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)

8585getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)

86+getDeclarationTitle (P.ExternKindDeclaration name) = Just (P.runProperName name)

8687getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)

8788getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name)

8889getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)

@@ -122,6 +123,8 @@ convertDeclaration (P.DataDeclaration dtype _ args ctors) title =

122123 ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)

123124convertDeclaration (P.ExternDataDeclaration _ kind') title =

124125 basicDeclaration title (ExternDataDeclaration kind')

126+convertDeclaration (P.ExternKindDeclaration _) title =

127+ basicDeclaration title ExternKindDeclaration

125128convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =

126129 basicDeclaration title (TypeSynonymDeclaration args ty)

127130convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title =

src/Language/PureScript/Docs/Prim.hs+41−5

@@ -5,6 +5,7 @@ import Prelude.Compat hiding (fail)

55import Data.Text (Text)

66import qualified Data.Text as T

77import qualified Data.Map as Map

8+import qualified Data.Set as Set

89import Language.PureScript.Docs.Types

910import qualified Language.PureScript as P

1011

@@ -25,6 +26,9 @@ primDocsModule = Module

2526 , fail

2627 , typeConcat

2728 , typeString

29+ , kindType

30+ , kindEffect

31+ , kindSymbol

2832 ]

2933 , modReExports = []

3034 }

@@ -38,16 +42,28 @@ unsafeLookup m errorMsg name = go name

3842 fromJust' (Just x) = x

3943 fromJust' _ = P.internalError $ errorMsg ++ show name

4044

41−lookupPrimKind :: Text -> P.Kind

42−lookupPrimKind = fst . unsafeLookup P.primTypes "Docs.Prim: No such Prim type: "

43−

44−primType :: Text -> Text -> Declaration

45+primKind :: Text -> Text -> Declaration

46+primKind title comments =

47+ if Set.member (P.primName title) P.primKinds

48+ then Declaration

49+ { declTitle = title

50+ , declComments = Just comments

51+ , declSourceSpan = Nothing

52+ , declChildren = []

53+ , declInfo = ExternKindDeclaration

54+ }

55+ else P.internalError $ "Docs.Prim: No such Prim kind: " ++ T.unpack title

56+

57+lookupPrimTypeKind :: Text -> P.Kind

58+lookupPrimTypeKind = fst . unsafeLookup P.primTypes "Docs.Prim: No such Prim type: "

59+

60+primType :: Text -> Text -> Declaration

4561primType title comments = Declaration

4662 { declTitle = title

4763 , declComments = Just comments

4864 , declSourceSpan = Nothing

4965 , declChildren = []

50− , declInfo = ExternDataDeclaration (lookupPrimKind title)

66+ , declInfo = ExternDataDeclaration (lookupPrimTypeKind title)

5167 }

5268

5369-- | Lookup the TypeClassData of a Prim class. This function is specifically

@@ -71,6 +87,26 @@ primClass title comments = Declaration

7187 TypeClassDeclaration args superclasses fundeps

7288 }

7389

90+kindType :: Declaration

91+kindType = primKind "Type" $ T.unlines

92+ [ "`Type` (also known as `*`) is the kind of all proper types: those that"

93+ , "classify value-level terms."

94+ , "For example the type `Boolean` has kind `Type`; denoted by `Boolean :: Type`."

95+ ]

96+

97+kindEffect :: Declaration

98+kindEffect = primKind "Effect" $ T.unlines

99+ [ "`Effect` (also known as `!`) is the kind of all effect types."

100+ ]

101+

102+kindSymbol :: Declaration

103+kindSymbol = primKind "Symbol" $ T.unlines

104+ [ "`Symbol` is the kind of type-level strings."

105+ , ""

106+ , "Construct types of this kind using the same literal syntax as documented"

107+ , "for strings."

108+ ]

109+

74110function :: Declaration

75111function = primType "Function" $ T.unlines

76112 [ "A function, which takes values of the type specified by the first type"

src/Language/PureScript/Docs/Render.hs+5

@@ -80,6 +80,11 @@ renderDeclarationWithOptions opts Declaration{..} =

8080 , ident $ adjustAliasName alias declTitle

8181 ]

8282

83+ ExternKindDeclaration ->

84+ [ keywordKind

85+ , renderKind (P.NamedKind (notQualified declTitle))

86+ ]

87+

8388 where

8489 renderType' :: P.Type -> RenderedCode

8590 renderType' = renderTypeWithOptions opts

src/Language/PureScript/Docs/RenderedCode/Types.hs+4

@@ -29,6 +29,7 @@ module Language.PureScript.Docs.RenderedCode.Types

2929 , keywordInstance

3030 , keywordWhere

3131 , keywordFixity

32+ , keywordKind

3233 ) where

3334

3435import Prelude.Compat

@@ -200,3 +201,6 @@ keywordFixity :: P.Associativity -> RenderedCode

200201keywordFixity P.Infixl = keyword "infixl"

201202keywordFixity P.Infixr = keyword "infixr"

202203keywordFixity P.Infix = keyword "infix"

204+

205+keywordKind :: RenderedCode

206+keywordKind = keyword "kind"

src/Language/PureScript/Docs/Types.hs+15

@@ -132,6 +132,11 @@ data DeclarationInfo

132132 -- operator's fixity.

133133 --

134134 | AliasDeclaration P.Fixity FixityAlias

135+

136+ -- |

137+ -- A kind declaration

138+ --

139+ | ExternKindDeclaration

135140 deriving (Show, Eq, Ord)

136141

137142convertFundepsToStrings :: [(Text, Maybe P.Kind)] -> [P.FunctionalDependency] -> [([Text], [Text])]

@@ -161,6 +166,7 @@ declInfoToString (ExternDataDeclaration _) = "externData"

161166declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

162167declInfoToString (TypeClassDeclaration _ _ _) = "typeClass"

163168declInfoToString (AliasDeclaration _ _) = "alias"

169+declInfoToString ExternKindDeclaration = "kind"

164170

165171isTypeClass :: Declaration -> Bool

166172isTypeClass Declaration{..} =

@@ -194,6 +200,12 @@ isTypeAlias Declaration{..} =

194200 AliasDeclaration _ (P.Qualified _ d) -> isLeft d

195201 _ -> False

196202

203+isKind :: Declaration -> Bool

204+isKind Declaration{..} =

205+ case declInfo of

206+ ExternKindDeclaration{} -> True

207+ _ -> False

208+

197209-- | Discard any children which do not satisfy the given predicate.

198210filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration

199211filterChildren p decl =

@@ -446,6 +458,8 @@ asDeclarationInfo = do

446458 "alias" ->

447459 AliasDeclaration <$> key "fixity" asFixity

448460 <*> key "alias" asFixityAlias

461+ "kind" ->

462+ pure ExternKindDeclaration

449463 other ->

450464 throwCustomError (InvalidDeclarationType other)

451465

@@ -593,6 +607,7 @@ instance A.ToJSON DeclarationInfo where

593607 TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]

594608 TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps]

595609 AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias]

610+ ExternKindDeclaration -> []

596611

597612instance A.ToJSON ChildDeclarationInfo where

598613 toJSON info = A.object $ "declType" .= childDeclInfoToString info : props

src/Language/PureScript/Environment.hs+41−14

@@ -36,6 +36,8 @@ data Environment = Environment

3636 -- ^ Available type class dictionaries

3737 , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

3838 -- ^ Type classes

39+ , kinds :: S.Set (Qualified (ProperName 'KindName))

40+ -- ^ Kinds in scope

3941 } deriving Show

4042

4143-- | Information about a type class

@@ -70,7 +72,7 @@ data FunctionalDependency = FunctionalDependency

7072-- The initial environment with no values and only the default javascript types defined

7173--

7274initEnvironment :: Environment

73−initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses

75+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds

7476

7577-- |

7678-- A constructor for TypeClassData that computes which type class arguments are fully determined.

@@ -209,6 +211,21 @@ instance A.FromJSON DataDeclType where

209211primName :: Text -> Qualified (ProperName a)

210212primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

211213

214+primKind :: Text -> Kind

215+primKind = NamedKind . primName

216+

217+-- |

218+-- Kinds in prim

219+--

220+kindType :: Kind

221+kindType = primKind C.typ

222+

223+kindEffect :: Kind

224+kindEffect = primKind C.effect

225+

226+kindSymbol :: Kind

227+kindSymbol = primKind C.symbol

228+

212229-- |

213230-- Construct a type in the Prim module

214231--

@@ -285,6 +302,16 @@ isTypeOrApplied t1 t2 = t1 == t2

285302function :: Type -> Type -> Type

286303function t1 = TypeApp (TypeApp tyFunction t1)

287304

305+-- |

306+-- The primitive kinds

307+primKinds :: S.Set (Qualified (ProperName 'KindName))

308+primKinds =

309+ S.fromList

310+ [ primName C.typ

311+ , primName C.effect

312+ , primName C.symbol

313+ ]

314+

288315-- |

289316-- The primitive types in the external javascript environment with their

290317-- associated kinds. There are also pseudo `Fail` and `Partial` types

@@ -293,18 +320,18 @@ function t1 = TypeApp (TypeApp tyFunction t1)

293320primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

294321primTypes =

295322 M.fromList

296− [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))

297− , (primName "Array", (FunKind Star Star, ExternData))

298− , (primName "Record", (FunKind (Row Star) Star, ExternData))

299− , (primName "String", (Star, ExternData))

300− , (primName "Char", (Star, ExternData))

301− , (primName "Number", (Star, ExternData))

302− , (primName "Int", (Star, ExternData))

303− , (primName "Boolean", (Star, ExternData))

304− , (primName "Partial", (Star, ExternData))

305− , (primName "Fail", (FunKind Symbol Star, ExternData))

306− , (primName "TypeString", (FunKind Star Symbol, ExternData))

307− , (primName "TypeConcat", (FunKind Symbol (FunKind Symbol Symbol), ExternData))

323+ [ (primName "Function", (FunKind kindType (FunKind kindType kindType), ExternData))

324+ , (primName "Array", (FunKind kindType kindType, ExternData))

325+ , (primName "Record", (FunKind (Row kindType) kindType, ExternData))

326+ , (primName "String", (kindType, ExternData))

327+ , (primName "Char", (kindType, ExternData))

328+ , (primName "Number", (kindType, ExternData))

329+ , (primName "Int", (kindType, ExternData))

330+ , (primName "Boolean", (kindType, ExternData))

331+ , (primName "Partial", (kindType, ExternData))

332+ , (primName "Fail", (FunKind kindSymbol kindType, ExternData))

333+ , (primName "TypeString", (FunKind kindType kindSymbol, ExternData))

334+ , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))

308335 ]

309336

310337-- |

@@ -316,7 +343,7 @@ primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

316343primClasses =

317344 M.fromList

318345 [ (primName "Partial", (makeTypeClassData [] [] [] []))

319− , (primName "Fail", (makeTypeClassData [("message", Just Symbol)] [] [] []))

346+ , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))

320347 ]

321348

322349-- |

src/Language/PureScript/Errors.hs+5

@@ -1030,6 +1030,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

10301030 nameType (DctorName _) = "data constructor"

10311031 nameType (TyClassName _) = "type class"

10321032 nameType (ModName _) = "module"

1033+ nameType (KiName _) = "kind"

10331034

10341035 runName :: Qualified Name -> Text

10351036 runName (Qualified mn (IdentName name)) =

@@ -1044,6 +1045,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

10441045 showQualified runProperName (Qualified mn name)

10451046 runName (Qualified mn (TyClassName name)) =

10461047 showQualified runProperName (Qualified mn name)

1048+ runName (Qualified mn (KiName name)) =

1049+ showQualified runProperName (Qualified mn name)

10471050 runName (Qualified Nothing (ModName name)) =

10481051 runModuleName name

10491052 runName (Qualified _ ModName{}) =

@@ -1148,6 +1151,8 @@ prettyPrintRef (TypeInstanceRef ident) =

11481151 Just $ showIdent ident

11491152prettyPrintRef (ModuleRef name) =

11501153 Just $ "module " <> runModuleName name

1154+prettyPrintRef (KindRef pn) =

1155+ Just $ "kind " <> runProperName pn

11511156prettyPrintRef (ReExportRef _ _) =

11521157 Nothing

11531158prettyPrintRef (PositionedDeclarationRef _ _ ref) =

src/Language/PureScript/Externs.hs+9

@@ -24,6 +24,7 @@ import Data.Text (Text)

2424import qualified Data.Text as T

2525import Data.Version (showVersion)

2626import qualified Data.Map as M

27+import qualified Data.Set as S

2728

2829import Language.PureScript.AST

2930import Language.PureScript.Crash

@@ -133,6 +134,10 @@ data ExternsDeclaration =

133134 , edInstanceTypes :: [Type]

134135 , edInstanceConstraints :: Maybe [Constraint]

135136 }

137+ -- | A kind declaration

138+ | EDKind

139+ { edKindName :: ProperName 'KindName

140+ }

136141 deriving Show

137142

138143-- | Convert an externs file back into a module

@@ -145,6 +150,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar

145150 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }

146151 applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }

147152 applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) }

153+ applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) }

148154 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }

149155 where

150156 dict :: NamedDict

@@ -220,6 +226,9 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

220226 , m2 <- M.elems m1

221227 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)

222228 ]

229+ toExternsDeclaration (KindRef pn)

230+ | Qualified (Just mn) pn `S.member` kinds env

231+ = [ EDKind pn ]

223232 toExternsDeclaration _ = []

224233

225234$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport)

src/Language/PureScript/Ide/Externs.hs+7−3

@@ -94,6 +94,7 @@ convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $

9494convertDecl P.EDValue{..} = Just $ IdeDeclValue $

9595 IdeValue edValueName edValueType

9696convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName)

97+convertDecl P.EDKind{..} = Just (IdeDeclKind edKindName)

9798convertDecl P.EDInstance{} = Nothing

9899

99100convertOperator :: P.ExternsFixity -> IdeDeclaration

@@ -137,9 +138,12 @@ annotateModule (defs, types) (moduleName, decls) =

137138 annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op)

138139 IdeDeclTypeOperator op ->

139140 annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op)

141+ IdeDeclKind i ->

142+ annotateKind (i ^. properNameT) (IdeDeclKind i)

140143 where

141− annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (P.runIdent x)) defs

144+ annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs

142145 , annTypeAnnotation = Map.lookup x types

143146 })

144− annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs})

145− annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) defs})

147+ annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSValue x) defs})

148+ annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSType x) defs})

149+ annotateKind x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSKind x) defs})

src/Language/PureScript/Ide/SourceFile.hs+12−11

@@ -92,25 +92,26 @@ extractSpans

9292 -- ^ The surrounding span

9393 -> P.Declaration

9494 -- ^ The declaration to extract spans from

95− -> [(Either Text Text, P.SourceSpan)]

96− -- ^ A @Right@ corresponds to a type level declaration, and a @Left@ to a

97− -- value level one

95+ -> [(IdeDeclNamespace, P.SourceSpan)]

96+ -- ^ Declarations and their source locations

9897extractSpans ss d = case d of

9998 P.PositionedDeclaration ss' _ d' ->

10099 extractSpans ss' d'

101100 P.ValueDeclaration i _ _ _ ->

102− [(Left (P.runIdent i), ss)]

101+ [(IdeNSValue (P.runIdent i), ss)]

103102 P.TypeSynonymDeclaration name _ _ ->

104− [(Right (P.runProperName name), ss)]

103+ [(IdeNSType (P.runProperName name), ss)]

105104 P.TypeClassDeclaration name _ _ _ members ->

106− (Right (P.runProperName name), ss) : concatMap (extractSpans' ss) members

105+ (IdeNSType (P.runProperName name), ss) : concatMap (extractSpans' ss) members

107106 P.DataDeclaration _ name _ ctors ->

108− (Right (P.runProperName name), ss)

109− : map (\(cname, _) -> (Left (P.runProperName cname), ss)) ctors

107+ (IdeNSType (P.runProperName name), ss)

108+ : map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors

110109 P.ExternDeclaration ident _ ->

111− [(Left (P.runIdent ident), ss)]

110+ [(IdeNSValue (P.runIdent ident), ss)]

112111 P.ExternDataDeclaration name _ ->

113− [(Right (P.runProperName name), ss)]

112+ [(IdeNSType (P.runProperName name), ss)]

113+ P.ExternKindDeclaration name ->

114+ [(IdeNSKind (P.runProperName name), ss)]

114115 _ -> []

115116 where

116117 -- We need this special case to be able to also get the position info for

@@ -121,5 +122,5 @@ extractSpans ss d = case d of

121122 P.PositionedDeclaration ssP' _ dP' ->

122123 extractSpans' ssP' dP'

123124 P.TypeDeclaration ident _ ->

124− [(Left (P.runIdent ident), ssP)]

125+ [(IdeNSValue (P.runIdent ident), ssP)]

125126 _ -> []

src/Language/PureScript/Ide/Types.hs+12−1

@@ -36,6 +36,7 @@ data IdeDeclaration

3636 | IdeDeclTypeClass (P.ProperName 'P.ClassName)

3737 | IdeDeclValueOperator IdeValueOperator

3838 | IdeDeclTypeOperator IdeTypeOperator

39+ | IdeDeclKind (P.ProperName 'P.KindName)

3940 deriving (Show, Eq, Ord)

4041

4142data IdeValue = IdeValue

@@ -102,7 +103,7 @@ emptyAnn = Annotation Nothing Nothing Nothing

102103

103104type Module = (P.ModuleName, [IdeDeclarationAnn])

104105

105−type DefinitionSites a = Map (Either Text Text) a

106+type DefinitionSites a = Map IdeDeclNamespace a

106107type TypeAnnotations = Map P.Ident P.Type

107108newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotations))

108109 -- ^ SourceSpans for the definition sites of Values and Types aswell as type

@@ -214,6 +215,7 @@ identifierFromDeclarationRef :: P.DeclarationRef -> Text

214215identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name

215216identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident

216217identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name

218+identifierFromDeclarationRef (P.KindRef name) = P.runProperName name

217219identifierFromDeclarationRef _ = ""

218220

219221data Success =

@@ -293,3 +295,12 @@ instance ToJSON PursuitResponse where

293295 , "package" .= package

294296 , "text" .= text

295297 ]

298+

299+data IdeDeclNamespace =

300+ -- | An identifier in the value namespace

301+ IdeNSValue Text

302+ -- | An identifier in the type namespace

303+ | IdeNSType Text

304+ -- | An identifier in the kind namespace

305+ | IdeNSKind Text

306+ deriving (Show, Eq, Ord)

src/Language/PureScript/Ide/Util.hs+2

@@ -49,6 +49,7 @@ identifierFromIdeDeclaration d = case d of

4949 IdeDeclTypeClass name -> P.runProperName name

5050 IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName

5151 IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName

52+ IdeDeclKind name -> P.runProperName name

5253

5354discardAnn :: IdeDeclarationAnn -> IdeDeclaration

5455discardAnn (IdeDeclarationAnn _ d) = d

@@ -73,6 +74,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) =

7374 (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP)

7475 IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) ->

7576 (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind)

77+ IdeDeclKind k -> (P.runProperName k, "kind")

7678

7779 complModule = P.runModuleName m

7880

src/Language/PureScript/Interactive.hs+2

@@ -200,6 +200,8 @@ handleShowImportedModules = do

200200 Just $ N.runIdent ident

201201 showRef (P.ModuleRef name) =

202202 Just $ "module " <> N.runModuleName name

203+ showRef (P.KindRef pn) =

204+ Just $ "kind " <> N.runProperName pn

203205 showRef (P.ReExportRef _ _) =

204206 Nothing

205207 showRef (P.PositionedDeclarationRef _ _ ref) =

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

@@ -114,6 +114,7 @@ acceptable P.ExternDeclaration{} = True

114114acceptable P.ExternDataDeclaration{} = True

115115acceptable P.TypeClassDeclaration{} = True

116116acceptable P.TypeInstanceDeclaration{} = True

117+acceptable P.ExternKindDeclaration{} = True

117118acceptable _ = False

118119

119120parseReplQuery' :: String -> Either String ReplQuery

src/Language/PureScript/Kinds.hs+4−6

@@ -6,20 +6,18 @@ import Prelude.Compat

77import qualified Data.Aeson.TH as A

9+import Language.PureScript.Names

10+

911-- | The data type of kinds

1012data Kind

1113 -- | Unification variable of type Kind

1214 = KUnknown Int

13− -- | The kind of types

14− | Star

15− -- | The kind of effects

16− | Bang

1715 -- | Kinds for labelled, unordered rows without duplicates

1816 | Row Kind

1917 -- | Function kinds

2018 | FunKind Kind Kind

21− -- | Type-level strings

22− | Symbol

19+ -- | A named kind

20+ | NamedKind (Qualified (ProperName 'KindName))

2321 deriving (Show, Eq, Ord)

2422

2523$(A.deriveJSON A.defaultOptions ''Kind)

src/Language/PureScript/Names.hs+7−1

@@ -24,6 +24,7 @@ data Name

2424 | DctorName (ProperName 'ConstructorName)

2525 | TyClassName (ProperName 'ClassName)

2626 | ModName ModuleName

27+ | KiName (ProperName 'KindName)

2728 deriving (Eq, Show)

2829

2930getIdentName :: Name -> Maybe Ident

@@ -117,7 +118,12 @@ instance FromJSON (ProperName a) where

117118-- |

118119-- The closed set of proper name types.

119120--

120−data ProperNameType = TypeName | ConstructorName | ClassName | Namespace

121+data ProperNameType

122+ = TypeName

123+ | ConstructorName

124+ | ClassName

125+ | KindName

126+ | Namespace

121127

122128-- |

123129-- Coerces a ProperName from one ProperNameType to another. This should be used

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

@@ -31,6 +31,12 @@ properName = ProperName <$> uname

3131typeName :: TokenParser (ProperName 'TypeName)

3232typeName = ProperName <$> tyname

3333

34+-- |

35+-- Parse a proper name for a kind.

36+--

37+kindName :: TokenParser (ProperName 'KindName)

38+kindName = ProperName <$> kiname

39+

3440-- |

3541-- Parse a proper name for a data constructor.

3642--

src/Language/PureScript/Parser/Declarations.hs+11−6

@@ -109,12 +109,16 @@ parseValueDeclaration = do

109109 return $ maybe value (`Let` value) whereClause

110110

111111parseExternDeclaration :: TokenParser Declaration

112−parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *>

113− (ExternDataDeclaration <$> (reserved "data" *> indented *> typeName)

114− <*> (indented *> doubleColon *> parseKind)

115− <|> (do ident <- parseIdent

116− ty <- indented *> doubleColon *> noWildcards parsePolyType

117− return $ ExternDeclaration ident ty))

112+parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> parseExternAlt where

113+ parseExternAlt = parseExternData <|> parseExternKind <|> parseExternTerm

114+

115+ parseExternData = ExternDataDeclaration <$> (reserved "data" *> indented *> typeName)

116+ <*> (indented *> doubleColon *> parseKind)

117+

118+ parseExternKind = ExternKindDeclaration <$> (reserved "kind" *> indented *> kindName)

119+

120+ parseExternTerm = ExternDeclaration <$> parseIdent

121+ <*> (indented *> doubleColon *> noWildcards parsePolyType)

118122

119123parseAssociativity :: TokenParser Associativity

120124parseAssociativity =

@@ -167,6 +171,7 @@ parseDeclarationRef =

167171 <|> (ValueOpRef <$> parens parseOperator)

168172 <|> parseTypeRef

169173 <|> (TypeClassRef <$> (reserved "class" *> properName))

174+ <|> (KindRef <$> (reserved "kind" *> kindName))

170175 <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName))

171176 <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator))

172177 where

src/Language/PureScript/Parser/Kinds.hs+10−8

@@ -5,6 +5,7 @@ module Language.PureScript.Parser.Kinds (parseKind) where

66import Prelude.Compat

8+import Language.PureScript.Environment

89import Language.PureScript.Kinds

910import Language.PureScript.Parser.Common

1011import Language.PureScript.Parser.Lexer

@@ -13,26 +14,27 @@ import qualified Text.Parsec as P

1314import qualified Text.Parsec.Expr as P

1415

1516parseStar :: TokenParser Kind

16−parseStar = const Star <$> symbol' "*"

17+parseStar = const kindType <$> symbol' "*"

1718

1819parseBang :: TokenParser Kind

19−parseBang = const Bang <$> symbol' "!"

20+parseBang = const kindEffect <$> symbol' "!"

2021

21−parseSymbol :: TokenParser Kind

22−parseSymbol = const Symbol <$> uname' "Symbol"

22+parseNamedKind :: TokenParser Kind

23+parseNamedKind = NamedKind <$> parseQualified kindName

2324

24−parseTypeAtom :: TokenParser Kind

25−parseTypeAtom = indented *> P.choice

25+parseKindAtom :: TokenParser Kind

26+parseKindAtom = indented *> P.choice

2627 [ parseStar

2728 , parseBang

28− , parseSymbol

29+ , parseNamedKind

2930 , parens parseKind

3031 ]

32+

3133-- |

3234-- Parse a kind

3335--

3436parseKind :: TokenParser Kind

35−parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"

37+parseKind = P.buildExpressionParser operators parseKindAtom P.<?> "kind"

3638 where

3739 operators = [ [ P.Prefix (symbol' "#" >> return Row) ]

3840 , [ P.Infix (rarrow >> return FunKind) P.AssocRight ] ]

src/Language/PureScript/Parser/Lexer.hs+8

@@ -43,6 +43,7 @@ module Language.PureScript.Parser.Lexer

4343 , lname'

4444 , qualifier

4545 , tyname

46+ , kiname

4647 , dconsname

4748 , uname

4849 , uname'

@@ -474,6 +475,12 @@ tyname = token go P.<?> "type name"

474475 go (UName s) = Just s

475476 go _ = Nothing

476477

478+kiname :: TokenParser Text

479+kiname = token go P.<?> "kind name"

480+ where

481+ go (UName s) = Just s

482+ go _ = Nothing

483+

477484dconsname :: TokenParser Text

478485dconsname = token go P.<?> "data constructor name"

479486 where

@@ -549,6 +556,7 @@ reservedPsNames :: [Text]

549556reservedPsNames = [ "data"

550557 , "newtype"

551558 , "type"

559+ , "kind"

552560 , "foreign"

553561 , "import"

554562 , "infixl"

src/Language/PureScript/Pretty/Kinds.hs+2−3

@@ -16,15 +16,14 @@ import Data.Text (Text)

1616

1717import Language.PureScript.Crash

1818import Language.PureScript.Kinds

19+import Language.PureScript.Names

1920import Language.PureScript.Pretty.Common

2021

2122typeLiterals :: Pattern () Kind String

2223typeLiterals = mkPattern match

2324 where

24− match Star = Just "*"

25− match Bang = Just "!"

26− match Symbol = Just "Symbol"

2725 match (KUnknown u) = Just $ 'u' : show u

26+ match (NamedKind name) = Just $ T.unpack (showQualified runProperName name)

2827 match _ = Nothing

2928

3029matchRow :: Pattern () Kind ((), Kind)

src/Language/PureScript/Sugar/BindingGroups.hs+1

@@ -73,6 +73,7 @@ createBindingGroups moduleName = mapM f <=< handleDecls

7373 valueVerts = map (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values

7474 bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)

7575 return $ filter isImportDecl ds ++

76+ filter isExternKindDecl ds ++

7677 filter isExternDataDecl ds ++

7778 dataBindingGroupDecls ++

7879 filter isTypeClassDeclaration ds ++

src/Language/PureScript/Sugar/Names.hs+39−7

@@ -25,6 +25,7 @@ import Language.PureScript.AST

2525import Language.PureScript.Crash

2626import Language.PureScript.Errors

2727import Language.PureScript.Externs

28+import Language.PureScript.Kinds

2829import Language.PureScript.Linter.Imports

2930import Language.PureScript.Names

3031import Language.PureScript.Sugar.Names.Env

@@ -98,6 +99,9 @@ desugarImportsWithEnv externs modules = do

9899 exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ModuleName

99100 exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports

100101

102+ exportedKinds :: M.Map (ProperName 'KindName) ModuleName

103+ exportedKinds = exportedRefs getKindRef

104+

101105 updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)

102106 updateEnv (ms, env) m@(Module ss _ mn _ refs) = do

103107 members <- findExportable m

@@ -128,6 +132,7 @@ elaborateExports exps (Module ss coms mn decls refs) =

128132 ++ go TypeClassRef exportedTypeClasses

129133 ++ go ValueRef exportedValues

130134 ++ go ValueOpRef exportedValueOps

135+ ++ go KindRef exportedKinds

131136 ++ maybe [] (filter isModuleRef) refs

132137 where

133138

@@ -165,17 +170,24 @@ renameInModule imports (Module ss coms mn decls exps) =

165170 updateDecl (_, bound) d@(PositionedDeclaration pos _ _) =

166171 return ((Just pos, bound), d)

167172 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

168− (,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors)

173+ (,) (pos, bound) <$> (DataDeclaration dtype name <$> updateTypeArguments pos args

174+ <*> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors)

169175 updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =

170− (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)

176+ (,) (pos, bound) <$> (TypeSynonymDeclaration name <$> updateTypeArguments pos ps

177+ <*> updateTypesEverywhere pos ty)

171178 updateDecl (pos, bound) (TypeClassDeclaration className args implies deps ds) =

172− (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure deps <*> pure ds)

179+ (,) (pos, bound) <$> (TypeClassDeclaration className <$> updateTypeArguments pos args

180+ <*> updateConstraints pos implies

181+ <*> pure deps

182+ <*> pure ds)

173183 updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =

174184 (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds)

175185 updateDecl (pos, bound) (TypeDeclaration name ty) =

176186 (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

177187 updateDecl (pos, bound) (ExternDeclaration name ty) =

178188 (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)

189+ updateDecl (pos, bound) (ExternDataDeclaration name ki) =

190+ (,) (pos, bound) <$> (ExternDataDeclaration name <$> updateKindsEverywhere pos ki)

179191 updateDecl (pos, bound) (TypeFixityDeclaration fixity alias op) =

180192 (,) (pos, bound) <$> (TypeFixityDeclaration fixity <$> updateTypeName alias pos <*> pure op)

181193 updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Left alias)) op) =

@@ -238,6 +250,19 @@ renameInModule imports (Module ss coms mn decls exps) =

238250 letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d

239251 letBoundVariable _ = Nothing

240252

253+ updateKindsEverywhere :: Maybe SourceSpan -> Kind -> m Kind

254+ updateKindsEverywhere pos = everywhereOnKindsM updateKind

255+ where

256+ updateKind :: Kind -> m Kind

257+ updateKind (NamedKind name) = NamedKind <$> updateKindName name pos

258+ updateKind k = return k

259+

260+ updateTypeArguments

261+ :: (Traversable f, Traversable g)

262+ => Maybe SourceSpan

263+ -> f (a, g Kind) -> m (f (a, g Kind))

264+ updateTypeArguments pos = traverse (sndM (traverse (updateKindsEverywhere pos)))

265+

241266 updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type

242267 updateTypesEverywhere pos = everywhereOnTypesM updateType

243268 where

@@ -245,16 +270,17 @@ renameInModule imports (Module ss coms mn decls exps) =

245270 updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos

246271 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos

247272 updateType (ConstrainedType cs t) = ConstrainedType <$> traverse updateInConstraint cs <*> pure t

273+ updateType (KindedType t k) = KindedType t <$> updateKindsEverywhere pos k

248274 updateType t = return t

249275 updateInConstraint :: Constraint -> m Constraint

250276 updateInConstraint (Constraint name ts info) =

251277 Constraint <$> updateClassName name pos <*> pure ts <*> pure info

252278

253279 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]

254− updateConstraints pos = traverse $ \(Constraint name ts info) ->

255− Constraint

256− <$> updateClassName name pos

257− <*> traverse (updateTypesEverywhere pos) ts

280+ updateConstraints pos = traverse $ \(Constraint name ts info) ->

281+ Constraint

282+ <$> updateClassName name pos

283+ <*> traverse (updateTypesEverywhere pos) ts

258284 <*> pure info

259285

260286 updateTypeName

@@ -290,6 +316,12 @@ renameInModule imports (Module ss coms mn decls exps) =

290316 -> m (Qualified (OpName 'ValueOpName))

291317 updateValueOpName = update (importedValueOps imports) ValOpName

292318

319+ updateKindName

320+ :: Qualified (ProperName 'KindName)

321+ -> Maybe SourceSpan

322+ -> m (Qualified (ProperName 'KindName))

323+ updateKindName = update (importedKinds imports) KiName

324+

293325 -- Update names so unqualified references become qualified, and locally

294326 -- qualified references are replaced with their canoncial qualified names

295327 -- (e.g. M.Map -> Data.Map.Map).

src/Language/PureScript/Sugar/Names/Env.hs+33−8

@@ -16,6 +16,7 @@ module Language.PureScript.Sugar.Names.Env

1616 , exportTypeClass

1717 , exportValue

1818 , exportValueOp

19+ , exportKind

1920 , getExports

2021 , checkImportConflicts

2122 ) where

@@ -71,27 +72,27 @@ type ImportMap a = M.Map (Qualified a) [ImportRecord a]

7172data Imports = Imports

7273 {

7374 -- |

74− -- Local names for types within a module mapped to to their qualified names

75+ -- Local names for types within a module mapped to their qualified names

7576 --

7677 importedTypes :: ImportMap (ProperName 'TypeName)

7778 -- |

78− -- Local names for type operators within a module mapped to to their qualified names

79+ -- Local names for type operators within a module mapped to their qualified names

7980 --

8081 , importedTypeOps :: ImportMap (OpName 'TypeOpName)

8182 -- |

82− -- Local names for data constructors within a module mapped to to their qualified names

83+ -- Local names for data constructors within a module mapped to their qualified names

8384 --

8485 , importedDataConstructors :: ImportMap (ProperName 'ConstructorName)

8586 -- |

86− -- Local names for classes within a module mapped to to their qualified names

87+ -- Local names for classes within a module mapped to their qualified names

8788 --

8889 , importedTypeClasses :: ImportMap (ProperName 'ClassName)

8990 -- |

90− -- Local names for values within a module mapped to to their qualified names

91+ -- Local names for values within a module mapped to their qualified names

9192 --

9293 , importedValues :: ImportMap Ident

9394 -- |

94− -- Local names for value operators within a module mapped to to their qualified names

95+ -- Local names for value operators within a module mapped to their qualified names

9596 --

9697 , importedValueOps :: ImportMap (OpName 'ValueOpName)

9798 -- |

@@ -104,10 +105,14 @@ data Imports = Imports

104105 -- The "as" names of modules that have been imported qualified.

105106 --

106107 , importedQualModules :: S.Set ModuleName

108+ -- |

109+ -- Local names for kinds within a module mapped to their qualified names

110+ --

111+ , importedKinds :: ImportMap (ProperName 'KindName)

107112 } deriving (Show)

108113

109114nullImports :: Imports

110−nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty

115+nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty M.empty

111116

112117-- |

113118-- An 'Imports' value with imports for the `Prim` module.

@@ -117,6 +122,7 @@ primImports =

117122 nullImports

118123 { importedTypes = M.fromList $ mkEntries `concatMap` M.keys primTypes

119124 , importedTypeClasses = M.fromList $ mkEntries `concatMap` M.keys primClasses

125+ , importedKinds = M.fromList $ mkEntries `concatMap` S.toList primKinds

120126 }

121127 where

122128 mkEntries :: Qualified a -> [(Qualified a, [ImportRecord a])]

@@ -155,13 +161,17 @@ data Exports = Exports

155161 -- from.

156162 --

157163 , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName

164+ -- |

165+ -- The exported kinds along with the module they originally came from.

166+ --

167+ , exportedKinds :: M.Map (ProperName 'KindName) ModuleName

158168 } deriving (Show)

159169

160170-- |

161171-- An empty 'Exports' value.

162172--

163173nullExports :: Exports

164−nullExports = Exports M.empty M.empty M.empty M.empty M.empty

174+nullExports = Exports M.empty M.empty M.empty M.empty M.empty M.empty

165175

166176-- |

167177-- The imports and exports for a collection of modules. The 'SourceSpan' is used

@@ -196,10 +206,12 @@ primExports =

196206 nullExports

197207 { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes

198208 , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses

209+ , exportedKinds = M.fromList $ mkKindEntry `map` S.toList primKinds

199210 }

200211 where

201212 mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn))

202213 mkClassEntry (Qualified mn name) = (name, fromJust mn)

214+ mkKindEntry (Qualified mn name) = (name, fromJust mn)

203215

204216-- | Environment which only contains the Prim module.

205217primEnv :: Env

@@ -316,6 +328,19 @@ exportValueOp exps op mn = do

316328 valueOps <- addExport ValOpName op mn (exportedValueOps exps)

317329 return $ exps { exportedValueOps = valueOps }

318330

331+-- |

332+-- Safely adds a kind to some exports, returning an error if a conflict occurs.

333+--

334+exportKind

335+ :: MonadError MultipleErrors m

336+ => Exports

337+ -> ProperName 'KindName

338+ -> ModuleName

339+ -> m Exports

340+exportKind exps name mn = do

341+ kinds <- addExport KiName name mn (exportedKinds exps)

342+ return $ exps { exportedKinds = kinds }

343+

319344-- |

320345-- Adds an entry to a list of exports unless it is already present, in which

321346-- case an error is returned.

src/Language/PureScript/Sugar/Names/Exports.hs+28−11

@@ -19,7 +19,7 @@ import Language.PureScript.AST

1919import Language.PureScript.Crash

2020import Language.PureScript.Errors

2121import Language.PureScript.Names

22−import Language.PureScript.Sugar.Names.Env

22+import Language.PureScript.Sugar.Names.Env

2323import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs)

2424

2525-- |

@@ -51,6 +51,8 @@ findExportable (Module _ _ mn ds _) =

5151 exportTypeOp exps op mn

5252 updateExports exps (ExternDeclaration name _) =

5353 exportValue exps name mn

54+ updateExports exps (ExternKindDeclaration pn) =

55+ exportKind exps pn mn

5456 updateExports exps (PositionedDeclaration pos _ d) =

5557 rethrowWithPosition pos $ updateExports exps d

5658 updateExports exps _ = return exps

@@ -61,21 +63,21 @@ findExportable (Module _ _ mn ds _) =

6163--

6264resolveExports

6365 :: forall m

64− . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

65− => Env

66− -> SourceSpan

66+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)

67+ => Env

68+ -> SourceSpan

6769 -> ModuleName

6870 -> Imports

6971 -> Exports

7072 -> [DeclarationRef]

7173 -> m Exports

72−resolveExports env ss mn imps exps refs =

73− warnAndRethrow (addHint (ErrorInModule mn)) $ do

74+resolveExports env ss mn imps exps refs =

75+ warnAndRethrow (addHint (ErrorInModule mn)) $ do

7476 filtered <- filterModule mn exps refs

75− exps' <- foldM elaborateModuleExports filtered refs

76− warnDuplicateRefs ss DuplicateExportRef refs

77− return exps'

78−

77+ exps' <- foldM elaborateModuleExports filtered refs

78+ warnDuplicateRefs ss DuplicateExportRef refs

79+ return exps'

80+

7981 where

8082

8183 -- Takes the current module's imports, the accumulated list of exports, and a

@@ -83,19 +85,21 @@ resolveExports env ss mn imps exps refs =

8385 -- module, export anything from the imports that matches for that module.

8486 elaborateModuleExports :: Exports -> DeclarationRef -> m Exports

8587 elaborateModuleExports result (PositionedDeclarationRef pos _ r) =

86− warnAndRethrowWithPosition pos $ elaborateModuleExports result r

88+ warnAndRethrowWithPosition pos $ elaborateModuleExports result r

8789 elaborateModuleExports result (ModuleRef name) | name == mn = do

8890 let types' = exportedTypes result `M.union` exportedTypes exps

8991 let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps

9092 let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps

9193 let values' = exportedValues result `M.union` exportedValues exps

9294 let valueOps' = exportedValueOps result `M.union` exportedValueOps exps

95+ let kinds' = exportedKinds result `M.union` exportedKinds exps

9396 return result

9497 { exportedTypes = types'

9598 , exportedTypeOps = typeOps'

9699 , exportedTypeClasses = classes'

97100 , exportedValues = values'

98101 , exportedValueOps = valueOps'

102+ , exportedKinds = kinds'

99103 }

100104 elaborateModuleExports result (ModuleRef name) = do

101105 let isPseudo = isPseudoModule name

@@ -107,11 +111,13 @@ resolveExports env ss mn imps exps refs =

107111 reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps)

108112 reValues <- extract isPseudo name IdentName (importedValues imps)

109113 reValueOps <- extract isPseudo name ValOpName (importedValueOps imps)

114+ reKinds <- extract isPseudo name KiName (importedKinds imps)

110115 foldM (\exps' ((tctor, dctors), mn') -> exportType ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)

111116 >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps)

112117 >>= flip (foldM (uncurry . exportTypeClass ReExport)) (map resolveClass reClasses)

113118 >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues)

114119 >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps)

120+ >>= flip (foldM (uncurry . exportKind)) (map resolveKind reKinds)

115121 elaborateModuleExports result _ = return result

116122

117123 -- Extracts a list of values for a module based on a lookup table. If the

@@ -146,6 +152,7 @@ resolveExports env ss mn imps exps refs =

146152 || any (isQualifiedWith mn') (f (importedTypeClasses imps))

147153 || any (isQualifiedWith mn') (f (importedValues imps))

148154 || any (isQualifiedWith mn') (f (importedValueOps imps))

155+ || any (isQualifiedWith mn') (f (importedKinds imps))

149156

150157 -- Check whether a module name refers to a module that has been imported

151158 -- without qualification into an import scope.

@@ -203,6 +210,14 @@ resolveExports env ss mn imps exps refs =

203210 . fromMaybe (internalError "Missing value in resolveValueOp")

204211 $ resolve exportedValueOps op

205212

213+ -- Looks up an imported kind and re-qualifies it with the original

214+ -- module it came from.

215+ resolveKind :: Qualified (ProperName 'KindName) -> (ProperName 'KindName, ModuleName)

216+ resolveKind kind

217+ = splitQual

218+ . fromMaybe (internalError "Missing value in resolveKind")

219+ $ resolve exportedKinds kind

220+

206221 resolve

207222 :: Ord a

208223 => (Exports -> M.Map a ModuleName)

@@ -237,12 +252,14 @@ filterModule mn exps refs = do

237252 classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs

238253 values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs

239254 valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) M.empty refs

255+ kinds <- foldM (filterExport KiName getKindRef exportedKinds) M.empty refs

240256 return Exports

241257 { exportedTypes = types

242258 , exportedTypeOps = typeOps

243259 , exportedTypeClasses = classes

244260 , exportedValues = values

245261 , exportedValueOps = valueOps

262+ , exportedKinds = kinds

246263 }

247264

248265 where

src/Language/PureScript/Sugar/Names/Imports.hs+6

@@ -130,6 +130,8 @@ resolveImport importModule exps imps impQual = resolveByType

130130 checkImportExists TyClassName (exportedTypeClasses exps) name

131131 check (ModuleRef name) | isHiding =

132132 throwError . errorMessage $ ImportHidingModule name

133+ check (KindRef name) = do

134+ checkImportExists KiName (exportedKinds exps) name

133135 check r = internalError $ "Invalid argument to checkRefs: " ++ show r

134136

135137 -- Check that an explicitly imported item exists in the module it is being imported from

@@ -181,6 +183,7 @@ resolveImport importModule exps imps impQual = resolveByType

181183 >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (M.toList (exportedValues exps))

182184 >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (M.toList (exportedValueOps exps))

183185 >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (M.toList (exportedTypeClasses exps))

186+ >>= flip (foldM (\m (name, _) -> importer m (KindRef name))) (M.toList (exportedKinds exps))

184187

185188 importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports

186189 importRef prov imp (PositionedDeclarationRef pos _ r) =

@@ -205,6 +208,9 @@ resolveImport importModule exps imps impQual = resolveByType

205208 importRef prov imp (TypeClassRef name) = do

206209 let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov

207210 return $ imp { importedTypeClasses = typeClasses' }

211+ importRef prov imp (KindRef name) = do

212+ let kinds' = updateImports (importedKinds imp) (exportedKinds exps) id name prov

213+ return $ imp { importedKinds = kinds' }

208214 importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef"

209215 importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef"

210216 importRef _ _ ReExportRef{} = internalError "ReExportRef in importRef"

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

@@ -274,11 +274,15 @@ typeCheckAll moduleName _ = traverse go

274274 env <- getEnv

275275 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }

276276 return d

277+ go (d@(ExternKindDeclaration name)) = do

278+ env <- getEnv

279+ putEnv $ env { kinds = S.insert (Qualified (Just moduleName) name) (kinds env) }

280+ return d

277281 go (d@(ExternDeclaration name ty)) = do

278282 warnAndRethrow (addHint (ErrorInForeignImport name)) $ do

279283 env <- getEnv

280284 kind <- kindOf ty

281− guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star

285+ guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType

282286 case M.lookup (Qualified (Just moduleName) name) (names env) of

283287 Just _ -> throwError . errorMessage $ RedefinedIdent name

284288 Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, External, Defined) (names env) })

src/Language/PureScript/TypeChecker/Kinds.hs+13−15

@@ -85,9 +85,7 @@ unifyKinds k1 k2 = do

8585 go (KUnknown u1) (KUnknown u2) | u1 == u2 = return ()

8686 go (KUnknown u) k = solveKind u k

8787 go k (KUnknown u) = solveKind u k

88− go Star Star = return ()

89− go Bang Bang = return ()

90− go Symbol Symbol = return ()

88+ go (NamedKind k1') (NamedKind k2') | k1' == k2' = return ()

9189 go (Row k1') (Row k2') = go k1' k2'

9290 go (FunKind k1' k2') (FunKind k3 k4) = do

9391 go k1' k3

@@ -182,15 +180,15 @@ solveTypes

182180solveTypes isData ts kargs tyCon = do

183181 ks <- traverse (fmap fst . infer) ts

184182 when isData $ do

185− unifyKinds tyCon (foldr FunKind Star kargs)

186− forM_ ks $ \k -> unifyKinds k Star

183+ unifyKinds tyCon (foldr FunKind kindType kargs)

184+ forM_ ks $ \k -> unifyKinds k kindType

187185 unless isData $

188186 unifyKinds tyCon (foldr FunKind (head ks) kargs)

189187 return tyCon

190188

191−-- | Default all unknown kinds to the Star kind of types

189+-- | Default all unknown kinds to the kindType kind of types

192190starIfUnknown :: Kind -> Kind

193−starIfUnknown (KUnknown _) = Star

191+starIfUnknown (KUnknown _) = kindType

194192starIfUnknown (Row k) = Row (starIfUnknown k)

195193starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

196194starIfUnknown k = k

@@ -211,8 +209,8 @@ infer' (ForAll ident ty _) = do

211209 k1 <- freshKind

212210 Just moduleName <- checkCurrentModule <$> get

213211 (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty

214− unifyKinds k2 Star

215− return (Star, (ident, k1) : args)

212+ unifyKinds k2 kindType

213+ return (kindType, (ident, k1) : args)

216214infer' (KindedType ty k) = do

217215 (k', args) <- infer ty

218216 unifyKinds k k'

@@ -224,14 +222,14 @@ infer' other = (, []) <$> go other

224222 k1 <- freshKind

225223 Just moduleName <- checkCurrentModule <$> get

226224 k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty

227− unifyKinds k2 Star

228− return Star

225+ unifyKinds k2 kindType

226+ return kindType

229227 go (KindedType ty k) = do

230228 k' <- go ty

231229 unifyKinds k k'

232230 return k'

233231 go TypeWildcard{} = freshKind

234− go (TypeLevelString _) = return Symbol

232+ go (TypeLevelString _) = return kindSymbol

235233 go (TypeVar v) = do

236234 Just moduleName <- checkCurrentModule <$> get

237235 lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

@@ -260,8 +258,8 @@ infer' other = (, []) <$> go other

260258 go (ConstrainedType deps ty) = do

261259 forM_ deps $ \(Constraint className tys _) -> do

262260 k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

263− unifyKinds k Star

261+ unifyKinds k kindType

264262 k <- go ty

265− unifyKinds k Star

266− return Star

263+ unifyKinds k kindType

264+ return kindType

267265 go ty = internalError $ "Invalid argument to infer: " ++ show ty

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

@@ -240,7 +240,7 @@ checkTypeKind ::

240240 Type ->

241241 Kind ->

242242 m ()

243−checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star

243+checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType

244244

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

246246-- or TypeClassDictionary values.

tests/Language/PureScript/Ide/ImportsSpec.hs+2−2

@@ -74,7 +74,7 @@ spec = do

7474 addDtorImport i t mn is =

7575 prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is)

7676 addTypeImport i mn is =

77− prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.Star)) mn is)

77+ prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.kindType)) mn is)

7878 it "adds an implicit unqualified import" $

7979 shouldBe

8080 (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map"))

@@ -143,7 +143,7 @@ spec = do

143143 moduleName = (P.moduleNameFromString "Control.Monad")

144144 addImport imports import' = addExplicitImport' import' moduleName imports

145145 valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard))

146− typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.Star))

146+ typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.kindType))

147147 classImport name = (IdeDeclTypeClass (P.ProperName name))

148148 dtorImport name typeName = (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName name) (P.ProperName typeName) wildcard))

149149 -- expect any list of provided identifiers, when imported, to come out as specified

tests/Language/PureScript/Ide/ReexportsSpec.hs+1−1

@@ -18,7 +18,7 @@ d = IdeDeclarationAnn emptyAnn

1818

1919valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn

2020valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty))

21−typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.Star))

21+typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.kindType))

2222classA = d (IdeDeclTypeClass (P.ProperName "ClassA"))

2323dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty))

2424dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty))

tests/Language/PureScript/Ide/SourceFileSpec.hs+14−10

@@ -6,6 +6,7 @@ import Protolude

77import qualified Language.PureScript as P

88import Language.PureScript.Ide.SourceFile

9+import Language.PureScript.Ide.Types

910import Test.Hspec

1011

1112span0, span1, span2 :: P.SourceSpan

@@ -13,7 +14,7 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1)

1314span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2)

1415span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3)

1516

16−typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration

17+typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, foreign3, member1 :: P.Declaration

1718typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty

1819value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left [])

1920synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty

@@ -23,28 +24,31 @@ class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] []

2324data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] []

2425data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])]

2526foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty

26−foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.Star

27+foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.kindType

28+foreign3 = P.ExternKindDeclaration (P.ProperName "Foreign3")

2729member1 = P.TypeDeclaration (P.Ident "member1") P.REmpty

2830

2931spec :: Spec

3032spec = do

3133 describe "Extracting Spans" $ do

3234 it "extracts a span for a value declaration" $

33− extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(Left "value1", span1)]

35+ extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(IdeNSValue "value1", span1)]

3436 it "extracts a span for a type synonym declaration" $

35− extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(Right "Synonym1", span1)]

37+ extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(IdeNSType "Synonym1", span1)]

3638 it "extracts a span for a typeclass declaration" $

37− extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(Right "Class1", span1)]

39+ extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(IdeNSType "Class1", span1)]

3840 it "extracts spans for a typeclass declaration and its members" $

39− extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(Right "Class2", span1), (Left "member1", span2)]

41+ extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(IdeNSType "Class2", span1), (IdeNSValue "member1", span2)]

4042 it "extracts a span for a data declaration" $

41− extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(Right "Data1", span1)]

43+ extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNSType "Data1", span1)]

4244 it "extracts spans for a data declaration and its constructors" $

43− extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(Right "Data2", span1), (Left "Cons1", span1)]

45+ extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNSType "Data2", span1), (IdeNSValue "Cons1", span1)]

4446 it "extracts a span for a foreign declaration" $

45− extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(Left "foreign1", span1)]

47+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNSValue "foreign1", span1)]

4648 it "extracts a span for a data foreign declaration" $

47− extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(Right "Foreign2", span1)]

49+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(IdeNSType "Foreign2", span1)]

50+ it "extracts a span for a foreign kind declaration" $

51+ extractSpans span0 (P.PositionedDeclaration span1 [] foreign3) `shouldBe` [(IdeNSKind "Foreign3", span1)]

4852 describe "Type annotations" $ do

4953 it "extracts a type annotation" $

5054 extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)]

tests/Language/PureScript/Ide/StateSpec.hs+2−2

@@ -24,7 +24,7 @@ typeOperator =

2424testModule :: Module

2525testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty))

2626 , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty)))

27− , d (IdeDeclType (IdeType (P.ProperName "List") P.Star))

27+ , d (IdeDeclType (IdeType (P.ProperName "List") P.kindType))

2828 , valueOperator Nothing

2929 , ctorOperator Nothing

3030 , typeOperator Nothing

@@ -48,4 +48,4 @@ spec = describe "resolving operators" $ do

4848 it "resolves the type for a constructor operator" $

4949 resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty))

5050 it "resolves the kind for a type operator" $

51− resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.Star))

51+ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.kindType))

tests/TestPrimDocs.hs+12−8

@@ -3,6 +3,7 @@ module TestPrimDocs where

33import Control.Monad

44import Data.List ((\\))

55import qualified Data.Map as Map

6+import qualified Data.Set as Set

67import qualified Language.PureScript as P

78import qualified Language.PureScript.Docs as D

89import qualified Language.PureScript.Docs.AsMarkdown as D

@@ -13,14 +14,17 @@ main = do

1314 seq (D.runDocs (D.modulesAsMarkdown [D.primDocsModule])) (return ())

1415

1516 putStrLn "Test that Prim is fully documented"

16− let actualPrimTypes = map (P.runProperName . P.disqualify . fst) $ Map.toList P.primTypes

17− let documentedPrimTypes = map D.declTitle (D.modDeclarations D.primDocsModule)

17+ let actualPrimNames =

18+ -- note that prim type classes are listed in P.primTypes

19+ (map (P.runProperName . P.disqualify . fst) $ Map.toList P.primTypes) ++

20+ (map (P.runProperName . P.disqualify) $ Set.toList P.primKinds)

21+ let documentedPrimNames = map D.declTitle (D.modDeclarations D.primDocsModule)

1822

19− let undocumentedTypes = actualPrimTypes \\ documentedPrimTypes

20− let extraTypes = documentedPrimTypes \\ actualPrimTypes

23+ let undocumentedNames = actualPrimNames \\ documentedPrimNames

24+ let extraNames = documentedPrimNames \\ actualPrimNames

2125

22− when (not (null undocumentedTypes)) $

23− error $ "Undocumented Prim types: " ++ show undocumentedTypes

26+ when (not (null undocumentedNames)) $

27+ error $ "Undocumented Prim names: " ++ show undocumentedNames

2428

25− when (not (null extraTypes)) $

26− error $ "Extra Prim types: " ++ show undocumentedTypes

29+ when (not (null extraNames)) $

30+ error $ "Extra Prim names: " ++ show undocumentedNames