Skip to content

Commit 6cc8a7f

Browse files
klntskyklntsky
committed
Add KindApp
1 parent 2892933 commit 6cc8a7f

File tree

7 files changed

+309
-269
lines changed

7 files changed

+309
-269
lines changed

‎src/Docs/Search/App/SearchResults.purs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -545,6 +545,9 @@ renderType = case _ of
545545
, renderType t2
546546
]
547547

548+
KindApp t1 t2 ->
549+
HH.span_ [ renderType t1, space, renderType t2 ]
550+
548551
ty@(ForAll _ _ _) ->
549552
renderForAll ty
550553

‎src/Docs/Search/TypeDecoder.purs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -98,6 +98,8 @@ data Type
9898
| TypeOp QualifiedName
9999
-- | A type application
100100
| TypeApp Type Type
101+
-- | Explicit kind application
102+
| KindApp Type Type
101103
-- | Forall quantifier
102104
| ForAll String (Maybe Type) Type
103105
-- | A type withset of type class constraints
@@ -139,6 +141,9 @@ instance decodeJsonType :: DecodeJson Type where
139141
"TypeApp" ->
140142
decodeContents (decodeTuple TypeApp (const err)) (Left err) json
141143
where err = mkJsonError' "TypeApp" json
144+
"KindApp" ->
145+
decodeContents (decodeTuple KindApp (const err)) (Left err) json
146+
where err = mkJsonError' "KindApp" json
142147
"ForAll" ->
143148
decodeContents
144149
(decodeTriple
@@ -180,6 +185,7 @@ instance encodeJsonType :: EncodeJson Type where
180185
TypeConstructor val -> tagged "TypeConstructor" (encodeJson val)
181186
TypeOp val -> tagged "TypeOp" (encodeJson val)
182187
TypeApp t1 t2 -> tagged "TypeApp" (encodeTuple t1 t2)
188+
KindApp t1 t2 -> tagged "KindApp" (encodeTuple t1 t2)
183189
ForAll str Nothing ty -> tagged "ForAll" (encodeTriple str ty emptySkolemScope)
184190
ForAll str (Just k) ty -> tagged "ForAll" (encodeQuadriple str k ty emptySkolemScope)
185191
ConstrainedType c t -> tagged "ConstrainedType" (encodeTuple c t)

‎src/Docs/Search/TypePrinter.purs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,9 @@ showType = case _ of
3737
TypeApp t1 t2 ->
3838
showType t1 <> " " <> showType t2
3939

40+
KindApp t1 t2 ->
41+
showType t1 <> " " <> showType t2
42+
4043
ty@(ForAll _ _ _) ->
4144
showForAll ty
4245

‎src/Docs/Search/TypeQuery.purs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -297,6 +297,9 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
297297
go acc ({ q, t: REmpty } : rest) =
298298
go (QueryMismatch q : acc) rest
299299

300+
go acc ({ q, t: t@(KindApp _ _) } : rest) =
301+
go (TypeMismatch t : acc) rest
302+
300303

301304
-- | Sum various penalties.
302305
penalty :: TypeQuery -> Type -> Int
@@ -411,6 +414,7 @@ typeSize = go 0 <<< List.singleton
411414
go (n + 1) rest
412415
go n (TypeOp _ : rest) =
413416
go (n + 1) rest
417+
go n (KindApp t1 t2 : res) = go n (t1 : t2 : res)
414418
go n (TypeApp (TypeApp (TypeConstructor
415419
(QualifiedName { moduleNameParts: [ "Prim" ]
416420
, name: Identifier "Function" })) t1) t2 : rest) =

‎src/Docs/Search/TypeShape.purs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -115,6 +115,9 @@ shapeOfType ty = List.reverse $ go (pure ty) Nil
115115
TypeApp child1 child2 ->
116116
go (child1 : child2 : rest) (PApp : acc)
117117

118+
KindApp child1 child2 ->
119+
go (child1 : child2 : rest) (PApp : acc)
120+
118121
forallType@(ForAll _ _ _) ->
119122
go (foralls.ty : rest) (PForAll (List.length foralls.binders) : acc)
120123
where foralls = joinForAlls forallType

‎test/Main.purs‎

Lines changed: 3 additions & 269 deletions
Original file line numberDiff line numberDiff line change
@@ -2,291 +2,25 @@ module Test.Main where
22

33
import Prelude
44

5-
import Data.Argonaut.Core (Json)
6-
import Data.Argonaut.Decode (decodeJson)
7-
import Data.Argonaut.Parser (jsonParser)
8-
import Data.Either (Either(..))
9-
import Data.Maybe (Maybe(..))
10-
import Docs.Search.TypeDecoder (Constraint(..), FunDep(..), FunDeps(..), QualifiedName(..), Type(..))
11-
import Docs.Search.Types (Identifier(..))
125
import Effect (Effect)
13-
import Partial.Unsafe (unsafePartial)
146
import Test.Declarations as Declarations
15-
import Test.Extra (assertRight)
167
import Test.IndexBuilder as IndexBuilder
178
import Test.ModuleIndex as ModuleIndex
189
import Test.TypeQuery as TypeQuery
10+
import Test.TypeJson as TypeJson
1911
import Test.UI as UI
20-
import Test.Unit (TestSuite, suite, test)
12+
import Test.Unit (TestSuite)
2113
import Test.Unit.Main (runTest)
2214

2315
main :: Effect Unit
2416
main = do
2517
runTest mainTest
2618
UI.main
2719

28-
mkJson :: String -> Json
29-
mkJson str =
30-
unsafePartial $ case jsonParser str of
31-
Right r -> r
32-
3320
mainTest :: TestSuite
3421
mainTest = do
3522
TypeQuery.tests
23+
TypeJson.tests
3624
IndexBuilder.tests
3725
Declarations.tests
3826
ModuleIndex.tests
39-
suite "FunDeps decoder" do
40-
test "FunDeps" do
41-
let
42-
funDeps = mkJson """
43-
[
44-
[
45-
[
46-
"lhs",
47-
"rhs"
48-
],
49-
[
50-
"output"
51-
]
52-
]
53-
]
54-
"""
55-
assertRight (decodeJson funDeps)
56-
(FunDeps [ FunDep { lhs: [ "lhs", "rhs" ]
57-
, rhs: [ "output"]
58-
}
59-
])
60-
61-
suite "Constraint decoder" do
62-
test "Constraint" do
63-
let constraint = mkJson """
64-
{
65-
"constraintAnn": [],
66-
"constraintClass": [
67-
[
68-
"Prim"
69-
],
70-
"Partial"
71-
],
72-
"constraintArgs": [],
73-
"constraintData": null
74-
}
75-
"""
76-
assertRight (decodeJson constraint)
77-
(Constraint { constraintClass: qualified ["Prim"] "Partial"
78-
, constraintArgs: []
79-
})
80-
81-
suite "Type decoder" do
82-
test "TypeVar" do
83-
let typeVar = mkJson """
84-
{
85-
"annotation": [],
86-
"tag": "TypeVar",
87-
"contents": "m"
88-
}
89-
"""
90-
91-
assertRight (decodeJson typeVar)
92-
(TypeVar "m")
93-
94-
test "TypeApp" do
95-
let typeApp1 = mkJson """
96-
{
97-
"annotation": [],
98-
"tag": "TypeApp",
99-
"contents": [
100-
{
101-
"annotation": [],
102-
"tag": "TypeConstructor",
103-
"contents": [
104-
[
105-
"Control",
106-
"Monad",
107-
"ST",
108-
"Internal"
109-
],
110-
"ST"
111-
]
112-
},
113-
{
114-
"annotation": [],
115-
"tag": "TypeVar",
116-
"contents": "h"
117-
}
118-
]
119-
}
120-
"""
121-
122-
assertRight (decodeJson typeApp1) $
123-
TypeApp
124-
(TypeConstructor (qualified [ "Control"
125-
, "Monad"
126-
, "ST"
127-
, "Internal"
128-
]
129-
"ST"
130-
))
131-
(TypeVar "h")
132-
133-
test "TypeOp" do
134-
let typeOp = mkJson """
135-
{
136-
"annotation": [],
137-
"tag": "TypeOp",
138-
"contents": [
139-
[
140-
"Data",
141-
"NaturalTransformation"
142-
],
143-
"~>"
144-
]
145-
}
146-
"""
147-
assertRight (decodeJson typeOp) $
148-
TypeOp $ qualified [ "Data", "NaturalTransformation" ] "~>"
149-
150-
test "BinaryNoParens" do
151-
let binaryNoParens = mkJson """
152-
{
153-
"annotation": [],
154-
"tag": "BinaryNoParensType",
155-
"contents": [
156-
{
157-
"annotation": [],
158-
"tag": "TypeOp",
159-
"contents": [
160-
[
161-
"Data",
162-
"NaturalTransformation"
163-
],
164-
"~>"
165-
]
166-
},
167-
{
168-
"annotation": [],
169-
"tag": "TypeVar",
170-
"contents": "m"
171-
},
172-
{
173-
"annotation": [],
174-
"tag": "TypeVar",
175-
"contents": "n"
176-
}
177-
]
178-
}
179-
"""
180-
181-
assertRight (decodeJson binaryNoParens) $
182-
BinaryNoParensType
183-
(TypeOp $ qualified ["Data", "NaturalTransformation"] "~>")
184-
(TypeVar "m")
185-
(TypeVar "n")
186-
187-
test "ParensInType" do
188-
let parensInType = mkJson """
189-
{
190-
"annotation": [],
191-
"tag": "ParensInType",
192-
"contents": {
193-
"annotation": [],
194-
"tag": "TypeApp",
195-
"contents": [
196-
{
197-
"annotation": [],
198-
"tag": "TypeConstructor",
199-
"contents": [
200-
[
201-
"Data",
202-
"Maybe"
203-
],
204-
"Maybe"
205-
]
206-
},
207-
{
208-
"annotation": [],
209-
"tag": "TypeConstructor",
210-
"contents": [
211-
[
212-
"Prim"
213-
],
214-
"String"
215-
]
216-
}
217-
]
218-
}
219-
}
220-
"""
221-
222-
assertRight (decodeJson parensInType) $
223-
ParensInType $
224-
TypeApp
225-
(TypeConstructor (qualified [ "Data", "Maybe" ] "Maybe"))
226-
(TypeConstructor (qualified [ "Prim" ] "String"))
227-
test "RCons" do
228-
229-
let rcons = mkJson """
230-
{
231-
"annotation": [],
232-
"tag": "RCons",
233-
"contents": [
234-
"tail",
235-
{
236-
"annotation": [],
237-
"tag": "TypeApp",
238-
"contents": [
239-
{
240-
"annotation": [],
241-
"tag": "TypeConstructor",
242-
"contents": [
243-
[
244-
"Data",
245-
"Symbol"
246-
],
247-
"SProxy"
248-
]
249-
},
250-
{
251-
"annotation": [],
252-
"tag": "TypeVar",
253-
"contents": "t"
254-
}
255-
]
256-
},
257-
{
258-
"annotation": [],
259-
"tag": "REmpty"
260-
}
261-
]
262-
}
263-
"""
264-
265-
assertRight (decodeJson rcons) $
266-
RCons
267-
(Identifier "tail")
268-
(TypeApp (TypeConstructor $ qualified [ "Data", "Symbol" ] "SProxy")
269-
(TypeVar "t"))
270-
REmpty
271-
272-
test "ForAll #1" do
273-
let forallJson = mkJson """
274-
{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},null]}
275-
"""
276-
assertRight (decodeJson forallJson) $
277-
ForAll "a" Nothing (TypeApp (TypeApp (TypeConstructor $ qualified ["Prim"] "Function")
278-
(TypeConstructor $ qualified ["Prim"] "String"))
279-
(TypeVar "a"))
280-
281-
suite "jsons" do
282-
283-
test "jsons #1" do
284-
let json = mkJson """
285-
{"annotation":[],"tag":"ForAll","contents":["o",{"annotation":[],"tag":"ForAll","contents":["r",{"annotation":[],"tag":"ForAll","contents":["l",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Type","Data","Boolean"],"And"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"l"},{"annotation":[],"tag":"TypeVar","contents":"r"},{"annotation":[],"tag":"TypeVar","contents":"o"}],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"annotation":[],"tag":"TypeVar","contents":"l"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"annotation":[],"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}
286-
"""
287-
288-
assertRight (decodeJson json) $ (ForAll "o" Nothing (ForAll "r" Nothing (ForAll "l" Nothing (ConstrainedType (Constraint { constraintArgs: [(TypeVar "l"),(TypeVar "r"),(TypeVar "o")], constraintClass: (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: Identifier "And" }) }) (TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: Identifier "Function" })) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: Identifier "BProxy" })) (TypeVar "l"))) (TypeApp (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Prim"], name: Identifier "Function" })) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: Identifier "BProxy" })) (TypeVar "r"))) (TypeApp (TypeConstructor (QualifiedName { moduleNameParts: ["Type","Data","Boolean"], name: Identifier "BProxy" })) (TypeVar "o"))))))))
289-
290-
291-
qualified :: Array String -> String -> QualifiedName
292-
qualified moduleNameParts name = QualifiedName { moduleNameParts, name: Identifier name }

0 commit comments

Comments
 (0)