Add KindedType

Author: klntsky

src/Docs/Search/App/SearchResults.purs

@@ -561,6 +561,9 @@ renderType = case _ of
   ty@REmpty -> renderRow true ty
   ty@(RCons _ _ _) -> renderRow true ty
 
+  Kinded t1 t2 ->
+    HH.span_ [ renderType t1, space, syntax "::", space, renderType t2 ]
+
   BinaryNoParensType op t1 t2 ->
     HH.span_
     [ renderType t1

src/Docs/Search/TypeDecoder.purs

@@ -112,10 +112,8 @@ data Type
   | REmpty
   -- | A non-empty row
   | RCons Identifier Type Type
-  {-
   -- | A type with a kind annotation
-  | Kinded Type Kind
-  -}
+  | Kinded Type Type
   -- | Binary operator application. During the rebracketing phase of desugaring,
   -- this data constructor will be removed.
   | BinaryNoParensType Type Type Type
@@ -168,6 +166,9 @@ instance decodeJsonType :: DecodeJson Type where
       "RCons" ->
         decodeContents (decodeTriple RCons (const err)) (Left err) json
         where err = mkJsonError' "RCons" json
+      "KindedType" ->
+        decodeContents (decodeTuple Kinded (const err)) (Left err) json
+        where err = mkJsonError' "KindedType" json
       "BinaryNoParensType" ->
         decodeContents (decodeTriple BinaryNoParensType (const err)) (Left err) json
         where err = mkJsonError' "BinaryNoParens" json
@@ -191,6 +192,7 @@ instance encodeJsonType :: EncodeJson Type where
     ConstrainedType c t    -> tagged "ConstrainedType" (encodeTuple c t)
     REmpty                 -> tagged "REmpty"          jsonEmptyObject
     RCons s t1 t2          -> tagged "RCons"           (encodeTriple s t1 t2)
+    Kinded t1 t2           -> tagged "KindedType"      (encodeTuple t1 t2)
     ParensInType t         -> tagged "ParensInType"    (encodeJson t)
     TypeWildcard           -> tagged "TypeWildcard"    jsonEmptyObject
     BinaryNoParensType t1 t2 t3 ->

src/Docs/Search/TypePrinter.purs

@@ -51,6 +51,8 @@ showType = case _ of
   ty@REmpty -> showRow true ty
   ty@(RCons _ _ _) -> showRow true ty
 
+  Kinded t1 t2 -> showType t1 <> " :: " <> showType t2
+
   BinaryNoParensType op t1 t2 ->
     showType t1 <>
     space <>

src/Docs/Search/TypeQuery.purs

@@ -236,13 +236,13 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
     -- * Names
     go acc ({ q: QConst qname, t: TypeConstructor (QualifiedName { name }) } : rest) =
       go (Match qname name : acc) rest
-    go acc ({ q: QConst qname, t } : rest) =
+    go acc ({ q: QConst _, t } : rest) =
       go (TypeMismatch t : acc) rest
-    go acc ({ q, t: TypeConstructor (QualifiedName { name }) } : rest) =
+    go acc ({ q, t: TypeConstructor (QualifiedName _) } : rest) =
       go (QueryMismatch q : acc) rest
 
     -- type operators can't appear in type queries: this is always a mismatch
-    go acc ({ q, t: TypeOp (QualifiedName { name }) } : rest) =
+    go acc ({ q, t: TypeOp (QualifiedName _) } : rest) =
       go (QueryMismatch q : acc) rest
     go acc ({ q, t: t@(BinaryNoParensType _ _ _) } : rest) =
       go (Mismatch q t : acc) rest
@@ -253,15 +253,15 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
                                     (QualifiedName { moduleNameParts: [ "Prim" ]
                                                    , name: Identifier "Function" })) t1) t2 } : rest) =
       go acc ({ q: q1, t: t1 } : { q: q2, t: t2 } : rest)
-    go acc ({ q: q@(QFun q1 q2), t } : rest) =
+    go acc ({ q: q@(QFun _ _), t } : rest) =
       go (Mismatch q t : acc) rest
 
     -- * Rows
     go acc ({ q: QApp (QConst (Identifier "Record")) (QRow qRows)
             , t: TypeApp (TypeConstructor
                            (QualifiedName { moduleNameParts: [ "Prim" ]
                                           , name: Identifier "Record" })) row } : rest) =
-      let { rows, ty } = joinRows row
+      let { rows } = joinRows row
           qRowsLength = List.length qRows
           rowsLength = List.length rows in
         if rowsLength == qRowsLength then
@@ -297,7 +297,10 @@ unify query type_ = go Nil (List.singleton { q: query, t: type_ })
     go acc ({ q, t: REmpty } : rest) =
       go (QueryMismatch q : acc) rest
 
-    go acc ({ q, t: t@(KindApp _ _) } : rest) =
+    go acc ({ q, t: Kinded _ _} : rest) =
+      go (QueryMismatch q : acc) rest
+
+    go acc ({ t: t@(KindApp _ _) } : rest) =
       go (TypeMismatch t : acc) rest
 
 
@@ -429,6 +432,8 @@ typeSize = go 0 <<< List.singleton
       go (n + 1) (t1 : t2 : rest)
     go n (REmpty : rest) =
       go (n + 1) rest
+    go n (Kinded t1 t2 : rest) =
+      go n (t1 : t2 : rest)
     go n (BinaryNoParensType op t1 t2 : rest) =
       go (n + 1) (t1 : t2 : rest)
     go n (ParensInType t : rest) =

src/Docs/Search/TypeShape.purs

@@ -139,6 +139,8 @@ shapeOfType ty = List.reverse $ go (pure ty) Nil
             sorted = List.sortBy (\x y -> compare x.row y.row) joined.rows
             typesInRow = sorted <#> (_.ty)
 
+        Kinded t1 _t2 -> go (t1 : rest) acc
+
         BinaryNoParensType op l r ->
           go (TypeApp (TypeApp op l) r : rest) acc
 

test/Test/TypeJson.purs

@@ -268,6 +268,19 @@ tests = do
       """
       assertRight (decodeJson kindAppJson) $
         KindApp REmpty (TypeConstructor (qualified ["Prim"] "Type"))
+    test "KindedType" do
+      let kindedTypeJson = mkJson """
+      {"annotation":[],"tag":"KindedType","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Const"],"Const"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Type"]}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Type"]}]}]}
+      """
+      assertRight (decodeJson kindedTypeJson) $
+        Kinded
+        (TypeApp
+         (TypeConstructor (qualified ["Data","Const"] "Const"))
+         (TypeConstructor (qualified ["Data","Void"] "Void")))
+        (TypeApp (TypeApp
+                  (TypeConstructor (qualified ["Prim"] "Function"))
+                  (TypeConstructor (qualified ["Prim"] "Type" )))
+         (TypeConstructor (qualified ["Prim"] "Type")))
   suite "jsons" do
 
     test "jsons #1" do