144dd6f · rowtype-yoga/purescript-native

examples/failing/DiffKindsSameName.pursnew file+15

compare with golang

unifiedsplit

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

1+-- @shouldFailWith KindsDoNotUnify

2+module DiffKindsSameName where

3+

4+import DiffKindsSameName.LibA as LibA

5+import DiffKindsSameName.LibB as LibB

6+

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

2+

3+foreign import kind DemoKind

4+

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

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

1+module DiffKindsSameName.LibB where

2+

3+foreign import kind DemoKind

4+

5+foreign import data DemoData :: DemoKind

6+

examples/passing/ForeignKind.pursnew file+10

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

1+module Main where

2+

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)

6+

7+proxy1Add2Is3 :: NatProxy N3

8+proxy1Add2Is3 = addNat proxy1 proxy2

9+

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

2+

3+-- declaration

4+

5+foreign import kind Nat

6+

7+-- use in foreign data

8+

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

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

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

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

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

20 names _ = []

21 names _ = []

purescript.cabal+2

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

28 , examples/passing/ExplicitImportReExport/*.purs

29 , examples/passing/ExportExplicit/*.purs

30 , examples/passing/ExportExplicit2/*.purs

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

31 , examples/passing/Import/*.purs

32 , examples/passing/Import/*.purs

32 , examples/passing/ImportExplicit/*.purs

33 , examples/passing/ImportExplicit/*.purs

33 , examples/passing/ImportQualified/*.purs

34 , examples/passing/ImportQualified/*.purs

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

63 , examples/failing/ConflictingImports2/*.purs

64 , examples/failing/ConflictingImports2/*.purs

64 , examples/failing/ConflictingQualifiedImports/*.purs

65 , examples/failing/ConflictingQualifiedImports/*.purs

65 , examples/failing/ConflictingQualifiedImports2/*.purs

66 , examples/failing/ConflictingQualifiedImports2/*.purs

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

66 , examples/failing/DuplicateModule/*.purs

68 , examples/failing/DuplicateModule/*.purs

67 , examples/failing/ExportConflictClass/*.purs

69 , examples/failing/ExportConflictClass/*.purs

68 , examples/failing/ExportConflictCtor/*.purs

70 , examples/failing/ExportConflictCtor/*.purs

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

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

240 --

241 | ModuleRef ModuleName

242 -- |

243+ -- A named kind

244+ --

245+ | KindRef (ProperName 'KindName)

246+ -- |

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

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

244 -- elaboration in name desugaring.

248 -- elaboration in name desugaring.

245 --

249 --

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

258 (TypeClassRef name) == (TypeClassRef name') = name == name'

262 (TypeClassRef name) == (TypeClassRef name') = name == name'

259 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

263 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

260 (ModuleRef name) == (ModuleRef name') = name == name'

264 (ModuleRef name) == (ModuleRef name') = name == name'

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

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

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

262 (PositionedDeclarationRef _ _ r) == r' = r == r'

267 (PositionedDeclarationRef _ _ r) == r' = r == r'

263 r == (PositionedDeclarationRef _ _ r') = r == r'

268 r == (PositionedDeclarationRef _ _ r') = r == r'

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

286 orderOf (TypeRef _ _) = 2

292 orderOf (TypeRef _ _) = 2

287 orderOf (ValueRef _) = 3

293 orderOf (ValueRef _) = 3

288 orderOf (ValueOpRef _) = 4

294 orderOf (ValueOpRef _) = 4

289− orderOf _ = 5

295+ orderOf (KindRef _) = 5

296+ orderOf _ = 6

290

297

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

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

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

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

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

313getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r

320getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r

314getTypeClassRef _ = Nothing

321getTypeClassRef _ = Nothing

315

322

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

324+getKindRef (KindRef name) = Just name

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

326+getKindRef _ = Nothing

327+

316isModuleRef :: DeclarationRef -> Bool

328isModuleRef :: DeclarationRef -> Bool

317isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r

329isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r

318isModuleRef (ModuleRef _) = True

330isModuleRef (ModuleRef _) = True

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

381 --

393 --

382 | ExternDataDeclaration (ProperName 'TypeName) Kind

394 | ExternDataDeclaration (ProperName 'TypeName) Kind

383 -- |

395 -- |

396+ -- A foreign kind import (name)

397+ --

398+ | ExternKindDeclaration (ProperName 'KindName)

399+ -- |

384 -- A fixity declaration

400 -- A fixity declaration

385 --

401 --

386 | FixityDeclaration (Either ValueFixity TypeFixity)

402 | FixityDeclaration (Either ValueFixity TypeFixity)

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

469isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d

485isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d

470isExternDataDecl _ = False

486isExternDataDecl _ = False

471

487

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+

472-- |

496-- |

473-- Test if a declaration is a fixity declaration

497-- Test if a declaration is a fixity declaration

474--

498--

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

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

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

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

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

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

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

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

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

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

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

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

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

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

14import qualified Data.Set as S

15

16import Language.PureScript.AST.Binders

17−import Language.PureScript.AST.Literals

18import Language.PureScript.AST.Declarations

17import Language.PureScript.AST.Declarations

19−import Language.PureScript.Types

18+import Language.PureScript.AST.Literals

20−import Language.PureScript.Traversals

19+import Language.PureScript.Kinds

21import Language.PureScript.Names

20import Language.PureScript.Names

21+import Language.PureScript.Traversals

22+import Language.PureScript.Types

22

23

23everywhereOnValues

24everywhereOnValues

24 :: (Declaration -> Declaration)

25 :: (Declaration -> Declaration)

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

588 forValues (TypedValue _ _ ty) = f ty

589 forValues (TypedValue _ _ ty) = f ty

589 forValues _ = mempty

590 forValues _ = mempty

590

591

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+

591-- |

628-- |

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

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

593--

630--

src/Language/PureScript/Constants.hs+9

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

335pattern Fail :: Qualified (ProperName 'ClassName)

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

337

338+typ :: Text

339+typ = "Type"

340+

341+effect :: Text

342+effect = "Effect"

343+

344+symbol :: Text

345+symbol = "Symbol"

346+

338-- Code Generation

347-- Code Generation

339

348

340__superclass_ :: Text

349__superclass_ :: Text

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

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

110 typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs

111 types <- collect lookupTypeDeclaration impTypes expTypes

112 typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps

113+ kinds <- collect lookupKindDeclaration impKinds expKinds

113

114

114 (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

115 (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses

115

116

116 let filteredTypes = filterDataConstructors expCtors types

117 let filteredTypes = filterDataConstructors expCtors types

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

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

118

119

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

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

120

121

121 where

122 where

122

123

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

147 expTCs = P.exportedTypeClasses exports

148 expTCs = P.exportedTypeClasses exports

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

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

149

150

151+ expKinds = P.exportedKinds exports

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

153+

150-- |

154-- |

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

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

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

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

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

304 ("lookupTypeClassDeclaration: unexpected result: "

308 ("lookupTypeClassDeclaration: unexpected result: "

305 ++ (unlines . map show) other)

309 ++ (unlines . map show) other)

306

310

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+

307-- |

329-- |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

124 basicDeclaration title (ExternDataDeclaration kind')

125 basicDeclaration title (ExternDataDeclaration kind')

126+convertDeclaration (P.ExternKindDeclaration _) title =

127+ basicDeclaration title ExternKindDeclaration

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

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

126 basicDeclaration title (TypeSynonymDeclaration args ty)

129 basicDeclaration title (TypeSynonymDeclaration args ty)

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

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

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

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

5import Data.Text (Text)

6import qualified Data.Text as T

7import qualified Data.Map as Map

8+import qualified Data.Set as Set

8import Language.PureScript.Docs.Types

9import Language.PureScript.Docs.Types

9import qualified Language.PureScript as P

10import qualified Language.PureScript as P

10

11

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

25 , fail

26 , fail

26 , typeConcat

27 , typeConcat

27 , typeString

28 , typeString

29+ , kindType

30+ , kindEffect

31+ , kindSymbol

28 ]

32 ]

29 , modReExports = []

33 , modReExports = []

30 }

34 }

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

38 fromJust' (Just x) = x

42 fromJust' (Just x) = x

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

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

40

44

41−lookupPrimKind :: Text -> P.Kind

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

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

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

43−

59+

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

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

45primType title comments = Declaration

61primType title comments = Declaration

46 { declTitle = title

62 { declTitle = title

47 , declComments = Just comments

63 , declComments = Just comments

48 , declSourceSpan = Nothing

64 , declSourceSpan = Nothing

49 , declChildren = []

65 , declChildren = []

50− , declInfo = ExternDataDeclaration (lookupPrimKind title)

66+ , declInfo = ExternDataDeclaration (lookupPrimTypeKind title)

51 }

67 }

52

68

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

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

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

71 TypeClassDeclaration args superclasses fundeps

87 TypeClassDeclaration args superclasses fundeps

72 }

88 }

73

89

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+

74function :: Declaration

110function :: Declaration

75function = primType "Function" $ T.unlines

111function = primType "Function" $ T.unlines

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

112 [ "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{..} =

80 , ident $ adjustAliasName alias declTitle

81 ]

82

83+ ExternKindDeclaration ->

84+ [ keywordKind

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

86+ ]

87+

83 where

88 where

84 renderType' :: P.Type -> RenderedCode

89 renderType' :: P.Type -> RenderedCode

85 renderType' = renderTypeWithOptions opts

90 renderType' = renderTypeWithOptions opts

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

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

29 , keywordInstance

30 , keywordWhere

31 , keywordFixity

32+ , keywordKind

32 ) where

33 ) where

33

34

34import Prelude.Compat

35import Prelude.Compat

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

200keywordFixity P.Infixl = keyword "infixl"

201keywordFixity P.Infixl = keyword "infixl"

201keywordFixity P.Infixr = keyword "infixr"

202keywordFixity P.Infixr = keyword "infixr"

202keywordFixity P.Infix = keyword "infix"

203keywordFixity 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

132 -- operator's fixity.

133 --

134 | AliasDeclaration P.Fixity FixityAlias

135+

136+ -- |

137+ -- A kind declaration

138+ --

139+ | ExternKindDeclaration

135 deriving (Show, Eq, Ord)

140 deriving (Show, Eq, Ord)

136

141

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

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

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

161declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

166declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"

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

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

163declInfoToString (AliasDeclaration _ _) = "alias"

168declInfoToString (AliasDeclaration _ _) = "alias"

169+declInfoToString ExternKindDeclaration = "kind"

164

170

165isTypeClass :: Declaration -> Bool

171isTypeClass :: Declaration -> Bool

166isTypeClass Declaration{..} =

172isTypeClass Declaration{..} =

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

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

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

195 _ -> False

201 _ -> False

196

202

203+isKind :: Declaration -> Bool

204+isKind Declaration{..} =

205+ case declInfo of

206+ ExternKindDeclaration{} -> True

207+ _ -> False

208+

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

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

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

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

199filterChildren p decl =

211filterChildren p decl =

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

446 "alias" ->

458 "alias" ->

447 AliasDeclaration <$> key "fixity" asFixity

459 AliasDeclaration <$> key "fixity" asFixity

448 <*> key "alias" asFixityAlias

460 <*> key "alias" asFixityAlias

461+ "kind" ->

462+ pure ExternKindDeclaration

449 other ->

463 other ->

450 throwCustomError (InvalidDeclarationType other)

464 throwCustomError (InvalidDeclarationType other)

451

465

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

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

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

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

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

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

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

610+ ExternKindDeclaration -> []

596

611

597instance A.ToJSON ChildDeclarationInfo where

612instance A.ToJSON ChildDeclarationInfo where

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

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

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

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

36 -- ^ Available type class dictionaries

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

38 -- ^ Type classes

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

40+ -- ^ Kinds in scope

39 } deriving Show

41 } deriving Show

40

42

41-- | Information about a type class

43-- | Information about a type class

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

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

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

71--

73--

72initEnvironment :: Environment

74initEnvironment :: 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

74

76

75-- |

77-- |

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

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

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

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

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

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

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

211

213

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+

212-- |

229-- |

213-- Construct a type in the Prim module

230-- Construct a type in the Prim module

214--

231--

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

285function :: Type -> Type -> Type

302function :: Type -> Type -> Type

286function t1 = TypeApp (TypeApp tyFunction t1)

303function t1 = TypeApp (TypeApp tyFunction t1)

287

304

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+

288-- |

315-- |

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

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

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

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

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

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

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

294primTypes =

321primTypes =

295 M.fromList

322 M.fromList

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

308 ]

335 ]

309

336

310-- |

337-- |

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

316primClasses =

343primClasses =

317 M.fromList

344 M.fromList

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

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

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

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

320 ]

347 ]

321

348

322-- |

349-- |

src/Language/PureScript/Errors.hs+5

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

1030 nameType (DctorName _) = "data constructor"

1031 nameType (TyClassName _) = "type class"

1032 nameType (ModName _) = "module"

1033+ nameType (KiName _) = "kind"

1033

1034

1034 runName :: Qualified Name -> Text

1035 runName :: Qualified Name -> Text

1035 runName (Qualified mn (IdentName name)) =

1036 runName (Qualified mn (IdentName name)) =

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

1044 showQualified runProperName (Qualified mn name)

1045 showQualified runProperName (Qualified mn name)

1045 runName (Qualified mn (TyClassName name)) =

1046 runName (Qualified mn (TyClassName name)) =

1046 showQualified runProperName (Qualified mn name)

1047 showQualified runProperName (Qualified mn name)

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

1049+ showQualified runProperName (Qualified mn name)

1047 runName (Qualified Nothing (ModName name)) =

1050 runName (Qualified Nothing (ModName name)) =

1048 runModuleName name

1051 runModuleName name

1049 runName (Qualified _ ModName{}) =

1052 runName (Qualified _ ModName{}) =

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

1148 Just $ showIdent ident

1151 Just $ showIdent ident

1149prettyPrintRef (ModuleRef name) =

1152prettyPrintRef (ModuleRef name) =

1150 Just $ "module " <> runModuleName name

1153 Just $ "module " <> runModuleName name

1154+prettyPrintRef (KindRef pn) =

1155+ Just $ "kind " <> runProperName pn

1151prettyPrintRef (ReExportRef _ _) =

1156prettyPrintRef (ReExportRef _ _) =

1152 Nothing

1157 Nothing

1153prettyPrintRef (PositionedDeclarationRef _ _ ref) =

1158prettyPrintRef (PositionedDeclarationRef _ _ ref) =

src/Language/PureScript/Externs.hs+9

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

24import qualified Data.Text as T

25import Data.Version (showVersion)

26import qualified Data.Map as M

27+import qualified Data.Set as S

27

28

28import Language.PureScript.AST

29import Language.PureScript.AST

29import Language.PureScript.Crash

30import Language.PureScript.Crash

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

133 , edInstanceTypes :: [Type]

134 , edInstanceTypes :: [Type]

134 , edInstanceConstraints :: Maybe [Constraint]

135 , edInstanceConstraints :: Maybe [Constraint]

135 }

136 }

137+ -- | A kind declaration

138+ | EDKind

139+ { edKindName :: ProperName 'KindName

140+ }

136 deriving Show

141 deriving Show

137

142

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

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

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

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

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

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

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

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

152 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) }

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

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

149 where

155 where

150 dict :: NamedDict

156 dict :: NamedDict

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

220 , m2 <- M.elems m1

226 , m2 <- M.elems m1

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

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

222 ]

228 ]

229+ toExternsDeclaration (KindRef pn)

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

231+ = [ EDKind pn ]

223 toExternsDeclaration _ = []

232 toExternsDeclaration _ = []

224

233

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

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

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

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

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

95 IdeValue edValueName edValueType

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

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

97convertDecl P.EDInstance{} = Nothing

98convertDecl P.EDInstance{} = Nothing

98

99

99convertOperator :: P.ExternsFixity -> IdeDeclaration

100convertOperator :: P.ExternsFixity -> IdeDeclaration

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

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

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

138 IdeDeclTypeOperator op ->

139 IdeDeclTypeOperator op ->

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

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

141+ IdeDeclKind i ->

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

140 where

143 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

142 , annTypeAnnotation = Map.lookup x types

145 , annTypeAnnotation = Map.lookup x types

143 })

146 })

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

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

145− annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right 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

92 -- ^ The surrounding span

93 -> P.Declaration

94 -- ^ The declaration to extract spans from

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

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

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

96+ -- ^ Declarations and their source locations

97− -- value level one

98extractSpans ss d = case d of

97extractSpans ss d = case d of

99 P.PositionedDeclaration ss' _ d' ->

98 P.PositionedDeclaration ss' _ d' ->

100 extractSpans ss' d'

99 extractSpans ss' d'

101 P.ValueDeclaration i _ _ _ ->

100 P.ValueDeclaration i _ _ _ ->

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

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

103 P.TypeSynonymDeclaration name _ _ ->

102 P.TypeSynonymDeclaration name _ _ ->

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

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

105 P.TypeClassDeclaration name _ _ _ members ->

104 P.TypeClassDeclaration name _ _ _ members ->

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

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

107 P.DataDeclaration _ name _ ctors ->

106 P.DataDeclaration _ name _ ctors ->

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

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

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

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

110 P.ExternDeclaration ident _ ->

109 P.ExternDeclaration ident _ ->

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

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

112 P.ExternDataDeclaration name _ ->

111 P.ExternDataDeclaration name _ ->

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

113+ P.ExternKindDeclaration name ->

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

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

114 _ -> []

115 _ -> []

115 where

116 where

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

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

121 P.PositionedDeclaration ssP' _ dP' ->

122 P.PositionedDeclaration ssP' _ dP' ->

122 extractSpans' ssP' dP'

123 extractSpans' ssP' dP'

123 P.TypeDeclaration ident _ ->

124 P.TypeDeclaration ident _ ->

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

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

125 _ -> []

126 _ -> []

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

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

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

37 | IdeDeclValueOperator IdeValueOperator

38 | IdeDeclTypeOperator IdeTypeOperator

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

39 deriving (Show, Eq, Ord)

40 deriving (Show, Eq, Ord)

40

41

41data IdeValue = IdeValue

42data IdeValue = IdeValue

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

102

103

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

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

104

105

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

106+type DefinitionSites a = Map IdeDeclNamespace a

106type TypeAnnotations = Map P.Ident P.Type

107type TypeAnnotations = Map P.Ident P.Type

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

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

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

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

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

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

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

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

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

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

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

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

217identifierFromDeclarationRef _ = ""

219identifierFromDeclarationRef _ = ""

218

220

219data Success =

221data Success =

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

293 , "package" .= package

295 , "package" .= package

294 , "text" .= text

296 , "text" .= text

295 ]

297 ]

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

49 IdeDeclTypeClass name -> P.runProperName name

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

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

52+ IdeDeclKind name -> P.runProperName name

52

53

53discardAnn :: IdeDeclarationAnn -> IdeDeclaration

54discardAnn :: IdeDeclarationAnn -> IdeDeclaration

54discardAnn (IdeDeclarationAnn _ d) = d

55discardAnn (IdeDeclarationAnn _ d) = d

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

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

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

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

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

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

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

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

76

78

77 complModule = P.runModuleName m

79 complModule = P.runModuleName m

78

80

src/Language/PureScript/Interactive.hs+2

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

200 Just $ N.runIdent ident

201 showRef (P.ModuleRef name) =

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

203+ showRef (P.KindRef pn) =

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

203 showRef (P.ReExportRef _ _) =

205 showRef (P.ReExportRef _ _) =

204 Nothing

206 Nothing

205 showRef (P.PositionedDeclarationRef _ _ ref) =

207 showRef (P.PositionedDeclarationRef _ _ ref) =

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

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

114acceptable P.ExternDataDeclaration{} = True

115acceptable P.TypeClassDeclaration{} = True

116acceptable P.TypeInstanceDeclaration{} = True

117+acceptable P.ExternKindDeclaration{} = True

117acceptable _ = False

118acceptable _ = False

118

119

119parseReplQuery' :: String -> Either String ReplQuery

120parseReplQuery' :: String -> Either String ReplQuery

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

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

6

7import qualified Data.Aeson.TH as A

8

9+import Language.PureScript.Names

10+

9-- | The data type of kinds

11-- | The data type of kinds

10data Kind

12data Kind

11 -- | Unification variable of type Kind

13 -- | Unification variable of type Kind

12 = KUnknown Int

14 = KUnknown Int

13− -- | The kind of types

14− | Star

15− -- | The kind of effects

16− | Bang

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

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

18 | Row Kind

16 | Row Kind

19 -- | Function kinds

17 -- | Function kinds

20 | FunKind Kind Kind

18 | FunKind Kind Kind

21− -- | Type-level strings

19+ -- | A named kind

22− | Symbol

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

23 deriving (Show, Eq, Ord)

21 deriving (Show, Eq, Ord)

24

22

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

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

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

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

24 | DctorName (ProperName 'ConstructorName)

25 | TyClassName (ProperName 'ClassName)

26 | ModName ModuleName

27+ | KiName (ProperName 'KindName)

27 deriving (Eq, Show)

28 deriving (Eq, Show)

28

29

29getIdentName :: Name -> Maybe Ident

30getIdentName :: Name -> Maybe Ident

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

117-- |

118-- |

118-- The closed set of proper name types.

119-- The closed set of proper name types.

119--

120--

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

121+data ProperNameType

122+ = TypeName

123+ | ConstructorName

124+ | ClassName

125+ | KindName

126+ | Namespace

121

127

122-- |

128-- |

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

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

31typeName :: TokenParser (ProperName 'TypeName)

32typeName = ProperName <$> tyname

33

34+-- |

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

36+--

37+kindName :: TokenParser (ProperName 'KindName)

38+kindName = ProperName <$> kiname

39+

34-- |

40-- |

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

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

36--

42--

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

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

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

110

111parseExternDeclaration :: TokenParser Declaration

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

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

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

114+

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

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

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

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

115− <|> (do ident <- parseIdent

117+

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

119+

120+ parseExternTerm = ExternDeclaration <$> parseIdent

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

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

117− return $ ExternDeclaration ident ty))

118

122

119parseAssociativity :: TokenParser Associativity

123parseAssociativity :: TokenParser Associativity

120parseAssociativity =

124parseAssociativity =

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

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

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

168 <|> parseTypeRef

172 <|> parseTypeRef

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

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

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

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

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

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

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

172 where

177 where

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

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

5

6import Prelude.Compat

7

8+import Language.PureScript.Environment

8import Language.PureScript.Kinds

9import Language.PureScript.Kinds

9import Language.PureScript.Parser.Common

10import Language.PureScript.Parser.Common

10import Language.PureScript.Parser.Lexer

11import Language.PureScript.Parser.Lexer

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

13import qualified Text.Parsec.Expr as P

14import qualified Text.Parsec.Expr as P

14

15

15parseStar :: TokenParser Kind

16parseStar :: TokenParser Kind

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

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

17

18

18parseBang :: TokenParser Kind

19parseBang :: TokenParser Kind

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

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

20

21

21−parseSymbol :: TokenParser Kind

22+parseNamedKind :: TokenParser Kind

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

23+parseNamedKind = NamedKind <$> parseQualified kindName

23

24

24−parseTypeAtom :: TokenParser Kind

25+parseKindAtom :: TokenParser Kind

25−parseTypeAtom = indented *> P.choice

26+parseKindAtom = indented *> P.choice

26 [ parseStar

27 [ parseStar

27 , parseBang

28 , parseBang

28− , parseSymbol

29+ , parseNamedKind

29 , parens parseKind

30 , parens parseKind

30 ]

31 ]

32+

31-- |

33-- |

32-- Parse a kind

34-- Parse a kind

33--

35--

34parseKind :: TokenParser Kind

36parseKind :: TokenParser Kind

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

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

36 where

38 where

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

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

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

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

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

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

43 , lname'

44 , qualifier

45 , tyname

46+ , kiname

46 , dconsname

47 , dconsname

47 , uname

48 , uname

48 , uname'

49 , uname'

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

474 go (UName s) = Just s

475 go (UName s) = Just s

475 go _ = Nothing

476 go _ = Nothing

476

477

478+kiname :: TokenParser Text

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

480+ where

481+ go (UName s) = Just s

482+ go _ = Nothing

483+

477dconsname :: TokenParser Text

484dconsname :: TokenParser Text

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

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

479 where

486 where

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

549reservedPsNames = [ "data"

556reservedPsNames = [ "data"

550 , "newtype"

557 , "newtype"

551 , "type"

558 , "type"

559+ , "kind"

552 , "foreign"

560 , "foreign"

553 , "import"

561 , "import"

554 , "infixl"

562 , "infixl"

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

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

16

17import Language.PureScript.Crash

18import Language.PureScript.Kinds

19+import Language.PureScript.Names

19import Language.PureScript.Pretty.Common

20import Language.PureScript.Pretty.Common

20

21

21typeLiterals :: Pattern () Kind String

22typeLiterals :: Pattern () Kind String

22typeLiterals = mkPattern match

23typeLiterals = mkPattern match

23 where

24 where

24− match Star = Just "*"

25− match Bang = Just "!"

26− match Symbol = Just "Symbol"

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

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

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

28 match _ = Nothing

27 match _ = Nothing

29

28

30matchRow :: Pattern () Kind ((), Kind)

29matchRow :: Pattern () Kind ((), Kind)

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

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

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

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

75 return $ filter isImportDecl ds ++

76+ filter isExternKindDecl ds ++

76 filter isExternDataDecl ds ++

77 filter isExternDataDecl ds ++

77 dataBindingGroupDecls ++

78 dataBindingGroupDecls ++

78 filter isTypeClassDeclaration ds ++

79 filter isTypeClassDeclaration ds ++

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

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

25import Language.PureScript.Crash

26import Language.PureScript.Errors

27import Language.PureScript.Externs

28+import Language.PureScript.Kinds

28import Language.PureScript.Linter.Imports

29import Language.PureScript.Linter.Imports

29import Language.PureScript.Names

30import Language.PureScript.Names

30import Language.PureScript.Sugar.Names.Env

31import Language.PureScript.Sugar.Names.Env

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

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

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

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

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

100

101

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

103+ exportedKinds = exportedRefs getKindRef

104+

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

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

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

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

103 members <- findExportable m

107 members <- findExportable m

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

128 ++ go TypeClassRef exportedTypeClasses

132 ++ go TypeClassRef exportedTypeClasses

129 ++ go ValueRef exportedValues

133 ++ go ValueRef exportedValues

130 ++ go ValueOpRef exportedValueOps

134 ++ go ValueOpRef exportedValueOps

135+ ++ go KindRef exportedKinds

131 ++ maybe [] (filter isModuleRef) refs

136 ++ maybe [] (filter isModuleRef) refs

132 where

137 where

133

138

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

238 letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d

250 letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d

239 letBoundVariable _ = Nothing

251 letBoundVariable _ = Nothing

240

252

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+

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

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

242 updateTypesEverywhere pos = everywhereOnTypesM updateType

267 updateTypesEverywhere pos = everywhereOnTypesM updateType

243 where

268 where

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

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

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

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

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

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

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

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

248 updateType t = return t

274 updateType t = return t

249 updateInConstraint :: Constraint -> m Constraint

275 updateInConstraint :: Constraint -> m Constraint

250 updateInConstraint (Constraint name ts info) =

276 updateInConstraint (Constraint name ts info) =

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

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

252

278

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

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

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

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

255− Constraint

281+ Constraint

256− <$> updateClassName name pos

282+ <$> updateClassName name pos

257− <*> traverse (updateTypesEverywhere pos) ts

283+ <*> traverse (updateTypesEverywhere pos) ts

258 <*> pure info

284 <*> pure info

259

285

260 updateTypeName

286 updateTypeName

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

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

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

291 updateValueOpName = update (importedValueOps imports) ValOpName

317 updateValueOpName = update (importedValueOps imports) ValOpName

292

318

319+ updateKindName

320+ :: Qualified (ProperName 'KindName)

321+ -> Maybe SourceSpan

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

323+ updateKindName = update (importedKinds imports) KiName

324+

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

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

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

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

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

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

16 , exportTypeClass

17 , exportValue

18 , exportValueOp

19+ , exportKind

19 , getExports

20 , getExports

20 , checkImportConflicts

21 , checkImportConflicts

21 ) where

22 ) where

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

71data Imports = Imports

72data Imports = Imports

72 {

73 {

73 -- |

74 -- |

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

75 --

76 --

76 importedTypes :: ImportMap (ProperName 'TypeName)

77 importedTypes :: ImportMap (ProperName 'TypeName)

77 -- |

78 -- |

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

79 --

80 --

80 , importedTypeOps :: ImportMap (OpName 'TypeOpName)

81 , importedTypeOps :: ImportMap (OpName 'TypeOpName)

81 -- |

82 -- |

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

83 --

84 --

84 , importedDataConstructors :: ImportMap (ProperName 'ConstructorName)

85 , importedDataConstructors :: ImportMap (ProperName 'ConstructorName)

85 -- |

86 -- |

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

87 --

88 --

88 , importedTypeClasses :: ImportMap (ProperName 'ClassName)

89 , importedTypeClasses :: ImportMap (ProperName 'ClassName)

89 -- |

90 -- |

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

91 --

92 --

92 , importedValues :: ImportMap Ident

93 , importedValues :: ImportMap Ident

93 -- |

94 -- |

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

95 --

96 --

96 , importedValueOps :: ImportMap (OpName 'ValueOpName)

97 , importedValueOps :: ImportMap (OpName 'ValueOpName)

97 -- |

98 -- |

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

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

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

105 --

106 --

106 , importedQualModules :: S.Set ModuleName

107 , importedQualModules :: S.Set ModuleName

108+ -- |

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

110+ --

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

107 } deriving (Show)

112 } deriving (Show)

108

113

109nullImports :: Imports

114nullImports :: 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

111

116

112-- |

117-- |

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

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

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

117 nullImports

122 nullImports

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

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

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

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

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

120 }

126 }

121 where

127 where

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

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

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

155 -- from.

161 -- from.

156 --

162 --

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

163 , 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

158 } deriving (Show)

168 } deriving (Show)

159

169

160-- |

170-- |

161-- An empty 'Exports' value.

171-- An empty 'Exports' value.

162--

172--

163nullExports :: Exports

173nullExports :: 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

165

175

166-- |

176-- |

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

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

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

196 nullExports

206 nullExports

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

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

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

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

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

199 }

210 }

200 where

211 where

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

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

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

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

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

203

215

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

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

205primEnv :: Env

217primEnv :: Env

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

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

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

317 return $ exps { exportedValueOps = valueOps }

329 return $ exps { exportedValueOps = valueOps }

318

330

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+

319-- |

344-- |

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

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

321-- case an error is returned.

346-- case an error is returned.

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

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

19import Language.PureScript.Crash

20import Language.PureScript.Errors

21import Language.PureScript.Names

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

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

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

24

25-- |

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

51 exportTypeOp exps op mn

52 updateExports exps (ExternDeclaration name _) =

53 exportValue exps name mn

54+ updateExports exps (ExternKindDeclaration pn) =

55+ exportKind exps pn mn

54 updateExports exps (PositionedDeclaration pos _ d) =

56 updateExports exps (PositionedDeclaration pos _ d) =

55 rethrowWithPosition pos $ updateExports exps d

57 rethrowWithPosition pos $ updateExports exps d

56 updateExports exps _ = return exps

58 updateExports exps _ = return exps

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

61--

63--

62resolveExports

64resolveExports

63 :: forall m

65 :: forall m

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

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

65− => Env

67+ => Env

66− -> SourceSpan

68+ -> SourceSpan

67 -> ModuleName

69 -> ModuleName

68 -> Imports

70 -> Imports

69 -> Exports

71 -> Exports

70 -> [DeclarationRef]

72 -> [DeclarationRef]

71 -> m Exports

73 -> m Exports

72−resolveExports env ss mn imps exps refs =

74+resolveExports env ss mn imps exps refs =

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

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

74 filtered <- filterModule mn exps refs

76 filtered <- filterModule mn exps refs

75− exps' <- foldM elaborateModuleExports filtered refs

77+ exps' <- foldM elaborateModuleExports filtered refs

76− warnDuplicateRefs ss DuplicateExportRef refs

78+ warnDuplicateRefs ss DuplicateExportRef refs

77− return exps'

79+ return exps'

78−

80+

79 where

81 where

80

82

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

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

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

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

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

84 elaborateModuleExports :: Exports -> DeclarationRef -> m Exports

86 elaborateModuleExports :: Exports -> DeclarationRef -> m Exports

85 elaborateModuleExports result (PositionedDeclarationRef pos _ r) =

87 elaborateModuleExports result (PositionedDeclarationRef pos _ r) =

86− warnAndRethrowWithPosition pos $ elaborateModuleExports result r

88+ warnAndRethrowWithPosition pos $ elaborateModuleExports result r

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

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

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

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

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

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

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

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

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

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

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

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

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

93 return result

96 return result

94 { exportedTypes = types'

97 { exportedTypes = types'

95 , exportedTypeOps = typeOps'

98 , exportedTypeOps = typeOps'

96 , exportedTypeClasses = classes'

99 , exportedTypeClasses = classes'

97 , exportedValues = values'

100 , exportedValues = values'

98 , exportedValueOps = valueOps'

101 , exportedValueOps = valueOps'

102+ , exportedKinds = kinds'

99 }

103 }

100 elaborateModuleExports result (ModuleRef name) = do

104 elaborateModuleExports result (ModuleRef name) = do

101 let isPseudo = isPseudoModule name

105 let isPseudo = isPseudoModule name

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

115 elaborateModuleExports result _ = return result

121 elaborateModuleExports result _ = return result

116

122

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

123 -- 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 =

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

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

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

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

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

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

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

149

156

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

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

151 -- without qualification into an import scope.

158 -- without qualification into an import scope.

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

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

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

204 $ resolve exportedValueOps op

211 $ resolve exportedValueOps op

205

212

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+

206 resolve

221 resolve

207 :: Ord a

222 :: Ord a

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

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

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

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

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

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

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

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

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

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

240 return Exports

256 return Exports

241 { exportedTypes = types

257 { exportedTypes = types

242 , exportedTypeOps = typeOps

258 , exportedTypeOps = typeOps

243 , exportedTypeClasses = classes

259 , exportedTypeClasses = classes

244 , exportedValues = values

260 , exportedValues = values

245 , exportedValueOps = valueOps

261 , exportedValueOps = valueOps

262+ , exportedKinds = kinds

246 }

263 }

247

264

248 where

265 where

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

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

130 checkImportExists TyClassName (exportedTypeClasses exps) name

131 check (ModuleRef name) | isHiding =

132 throwError . errorMessage $ ImportHidingModule name

133+ check (KindRef name) = do

134+ checkImportExists KiName (exportedKinds exps) name

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

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

134

136

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

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

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

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

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

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

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

185 >>= 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))

184

187

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

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

186 importRef prov imp (PositionedDeclarationRef pos _ r) =

189 importRef prov imp (PositionedDeclarationRef pos _ r) =

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

205 importRef prov imp (TypeClassRef name) = do

208 importRef prov imp (TypeClassRef name) = do

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

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

207 return $ imp { importedTypeClasses = typeClasses' }

210 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' }

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

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

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

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

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

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

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

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

274 env <- getEnv

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

276 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

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

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

278 warnAndRethrow (addHint (ErrorInForeignImport name)) $ do

282 warnAndRethrow (addHint (ErrorInForeignImport name)) $ do

279 env <- getEnv

283 env <- getEnv

280 kind <- kindOf ty

284 kind <- kindOf ty

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

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

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

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

283 Just _ -> throwError . errorMessage $ RedefinedIdent name

287 Just _ -> throwError . errorMessage $ RedefinedIdent name

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

288 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

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

86 go (KUnknown u) k = solveKind u k

87 go k (KUnknown u) = solveKind u k

88− go Star Star = return ()

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

89− go Bang Bang = return ()

90− go Symbol Symbol = return ()

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

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

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

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

93 go k1' k3

91 go k1' k3

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

182solveTypes isData ts kargs tyCon = do

180solveTypes isData ts kargs tyCon = do

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

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

184 when isData $ do

182 when isData $ do

185− unifyKinds tyCon (foldr FunKind Star kargs)

183+ unifyKinds tyCon (foldr FunKind kindType kargs)

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

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

187 unless isData $

185 unless isData $

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

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

189 return tyCon

187 return tyCon

190

188

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

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

192starIfUnknown :: Kind -> Kind

190starIfUnknown :: Kind -> Kind

193−starIfUnknown (KUnknown _) = Star

191+starIfUnknown (KUnknown _) = kindType

194starIfUnknown (Row k) = Row (starIfUnknown k)

192starIfUnknown (Row k) = Row (starIfUnknown k)

195starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

193starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

196starIfUnknown k = k

194starIfUnknown k = k

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

211 k1 <- freshKind

209 k1 <- freshKind

212 Just moduleName <- checkCurrentModule <$> get

210 Just moduleName <- checkCurrentModule <$> get

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

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

214− unifyKinds k2 Star

212+ unifyKinds k2 kindType

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

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

216infer' (KindedType ty k) = do

214infer' (KindedType ty k) = do

217 (k', args) <- infer ty

215 (k', args) <- infer ty

218 unifyKinds k k'

216 unifyKinds k k'

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

224 k1 <- freshKind

222 k1 <- freshKind

225 Just moduleName <- checkCurrentModule <$> get

223 Just moduleName <- checkCurrentModule <$> get

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

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

227− unifyKinds k2 Star

225+ unifyKinds k2 kindType

228− return Star

226+ return kindType

229 go (KindedType ty k) = do

227 go (KindedType ty k) = do

230 k' <- go ty

228 k' <- go ty

231 unifyKinds k k'

229 unifyKinds k k'

232 return k'

230 return k'

233 go TypeWildcard{} = freshKind

231 go TypeWildcard{} = freshKind

234− go (TypeLevelString _) = return Symbol

232+ go (TypeLevelString _) = return kindSymbol

235 go (TypeVar v) = do

233 go (TypeVar v) = do

236 Just moduleName <- checkCurrentModule <$> get

234 Just moduleName <- checkCurrentModule <$> get

237 lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

235 lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

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

260 go (ConstrainedType deps ty) = do

258 go (ConstrainedType deps ty) = do

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

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

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

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

263− unifyKinds k Star

261+ unifyKinds k kindType

264 k <- go ty

262 k <- go ty

265− unifyKinds k Star

263+ unifyKinds k kindType

266− return Star

264+ return kindType

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

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

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

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

240 Type ->

241 Kind ->

242 m ()

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

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

244

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

246-- or TypeClassDictionary values.

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

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

74 addDtorImport i t mn is =

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

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

78 it "adds an implicit unqualified import" $

79 shouldBe

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

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

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

144 addImport imports import' = addExplicitImport' import' moduleName imports

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

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

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

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

18

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

20valueA = 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))

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

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

24dtorA2 = 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

6

7import qualified Language.PureScript as P

8import Language.PureScript.Ide.SourceFile

9+import Language.PureScript.Ide.Types

9import Test.Hspec

10import Test.Hspec

10

11

11span0, span1, span2 :: P.SourceSpan

12span0, span1, span2 :: P.SourceSpan

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

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

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

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

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

15

16

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

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

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

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

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

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

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

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

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

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

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

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

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

26foreign1 = 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")

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

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

28

30

29spec :: Spec

31spec :: Spec

30spec = do

32spec = do

31 describe "Extracting Spans" $ do

33 describe "Extracting Spans" $ do

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

48 describe "Type annotations" $ do

52 describe "Type annotations" $ do

49 it "extracts a type annotation" $

53 it "extracts a type annotation" $

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

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

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

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

24testModule :: Module

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

26 , 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))

28 , valueOperator Nothing

29 , ctorOperator Nothing

30 , typeOperator Nothing

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

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

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

50 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

3import Control.Monad

4import Data.List ((\\))

5import qualified Data.Map as Map

6+import qualified Data.Set as Set

6import qualified Language.PureScript as P

7import qualified Language.PureScript as P

7import qualified Language.PureScript.Docs as D

8import qualified Language.PureScript.Docs as D

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

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

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

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

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

14

15

15 putStrLn "Test that Prim is fully documented"

16 putStrLn "Test that Prim is fully documented"

17+ let actualPrimNames =

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

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

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

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

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

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

18

22

19− let undocumentedTypes = actualPrimTypes \\ documentedPrimTypes

23+ let undocumentedNames = actualPrimNames \\ documentedPrimNames

20− let extraTypes = documentedPrimTypes \\ actualPrimTypes

24+ let extraNames = documentedPrimNames \\ actualPrimNames

21

25

22− when (not (null undocumentedTypes)) $

26+ when (not (null undocumentedNames)) $

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

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

24

28

25− when (not (null extraTypes)) $

29+ when (not (null extraNames)) $

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

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