git.iko.soy/rowtype-yoga/purescript-docs-search
on master help sign in
added: parser for kinds
a6e84eeklntsky
spago.dhall+1
compare with master
unifiedsplit
@@ -24,6 +24,7 @@
24 , "halogen"
24 , "halogen"
25 , "halogen-css"
25 , "halogen-css"
26 , "coroutines"
26 , "coroutines"
27+ , "test-unit"
27 ]
28 ]
28, packages =
29, packages =
29 ./packages.dhall
30 ./packages.dhall
src/Spago/Search/TypeParser.pursnew file+98
@@ -0,0 +1,98 @@
1+module Spago.Search.TypeParser where
2+
3+import Prelude
4+import Data.Argonaut.Core -- (Json, fromString, stringify, toString)
5+import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:), (.:?))
6+import Data.Argonaut.Encode (class EncodeJson, encodeJson)
7+import Data.Array as Array
8+import Data.Either
9+import Data.Generic.Rep (class Generic)
10+import Data.Generic.Rep.Show (genericShow, genericShow')
11+import Data.Maybe
12+import Data.Newtype
13+import Control.Alt
14+import Data.Traversable
15+
16+newtype QualifiedName = QualifiedName { moduleName :: Array String
17+ , name :: String
18+ }
19+
20+derive instance eqQualifiedName :: Eq QualifiedName
21+derive instance genericQualifiedName :: Generic QualifiedName _
22+derive instance newtypeQualifiedName :: Newtype QualifiedName _
23+
24+instance showQualifiedName :: Show QualifiedName where
25+ show = genericShow
26+
27+instance decodeJsonQualifiedName :: DecodeJson QualifiedName where
28+ decodeJson json = do
29+ case toArray json of
30+ Nothing -> mkJsonError "QualifiedName" json
31+ Just arrOfJsons -> do
32+ let arrOfVariants =
33+ arrOfJsons <#> \variantJson ->
34+ Left <$> decodeJson variantJson <|>
35+ Right <$> decodeJson variantJson
36+ case arrOfVariants of
37+ [ Right (Left moduleName), Right (Right name)] ->
38+ pure $ QualifiedName { moduleName, name }
39+ _ -> mkJsonError "QualifiedName" json
40+
41+mkJsonError :: forall a. String -> Json -> Either String a
42+mkJsonError name json =
43+ Left $ "Couldn't parse " <> name <> " from " <> stringify json
44+
45+-- | The data type of kinds
46+data Kind
47+ -- | Kinds for labelled, unordered rows without duplicates
48+ = Row Kind
49+ -- | Function kinds
50+ | FunKind Kind Kind
51+ -- | A named kind
52+ | NamedKind QualifiedName
53+
54+derive instance eqKind :: Eq Kind
55+derive instance genericKind :: Generic Kind _
56+
57+instance showKind :: Show Kind where
58+ show = case _ of
59+ Row k -> "(Row " <> show k <> ")"
60+ FunKind k1 k2 -> "(FunKind " <> show k1 <> " " <> show k2 <> ")"
61+ NamedKind name -> "(NamedKind " <> show name <> ")"
62+
63+newtype MaybeSingle a = MaybeSingle (Either a (Array a))
64+
65+derive instance eqMaybeSingle :: Eq a => Eq (MaybeSingle a)
66+derive instance genericMaybeSingle :: Generic (MaybeSingle a) _
67+derive instance newtypeMaybeSingle :: Newtype (MaybeSingle a) _
68+
69+instance showMaybeSingle :: Show a => Show (MaybeSingle a) where
70+ show = genericShow
71+
72+instance decodeJsonMaybeSingle :: DecodeJson a => DecodeJson (MaybeSingle a) where
73+ decodeJson json =
74+ MaybeSingle <$> (Left <$> decodeJson json <|> Right <$> decodeJson json)
75+
76+fromMaybeSingle :: forall a. MaybeSingle a -> Array a
77+fromMaybeSingle (MaybeSingle (Left a)) = Array.singleton a
78+fromMaybeSingle (MaybeSingle (Right a)) = a
79+
80+instance decodeJsonKind :: DecodeJson Kind where
81+ decodeJson json = do
82+ handle <- decodeJson json
83+ tag <- handle .: "tag"
84+ case tag of
85+ "NamedKind" -> do
86+ -- annotation <- handle .: "annotation"
87+ contents <- handle .: "contents"
88+ pure $ NamedKind contents
89+ "Row" -> do
90+ contents <- handle .: "contents"
91+ pure $ Row contents
92+ "FunKind" -> do
93+ contents <- handle .: "contents"
94+ case contents of
95+ [k1, k2] ->
96+ pure $ FunKind k1 k2
97+ _ -> mkJsonError "FunKind" json
98+ _ -> mkJsonError "Kind" json
test/Main.purs+131−2
@@ -3,7 +3,136 @@ module Test.Main where
3import Prelude
3import Prelude
4import Effect (Effect)
4import Effect (Effect)
5import Effect.Console (log)
5import Effect.Console (log)
6+import Test.Unit (suite, test, timeout)
7+import Test.Unit.Main (runTest)
8+import Test.Unit.Assert as Assert
9+import Spago.Search.TypeParser
10+import Data.Argonaut.Decode
11+import Data.Either
12+import Data.Maybe
13+import Data.Argonaut.Parser
14+import Partial.Unsafe
15+import Effect.Aff
6
16
7main :: Effect Unit
17main :: Effect Unit
8−main = do
18+main = runTest do
9− log "You should add some tests."
19+ let mkJson x = unsafePartial $ fromRight $ jsonParser x
20+ suite "TypeParser" do
21+
22+ test "QualifiedName" do
23+
24+ let qualifiedName = mkJson """
25+ [
26+ [
27+ "Prim"
28+ ],
29+ "Type"
30+ ]
31+ """
32+
33+ assertRight (decodeJson qualifiedName)
34+ (QualifiedName { moduleName: ["Prim"]
35+ , name: "Type"
36+ }
37+ )
38+
39+ test "NamedKind" do
40+ let namedKind = mkJson """
41+ {
42+ "annotation": [],
43+ "tag": "NamedKind",
44+ "contents": [
45+ [
46+ "Prim"
47+ ],
48+ "Type"
49+ ]
50+ }
51+ """
52+
53+ assertRight (decodeJson namedKind)
54+ (NamedKind $ QualifiedName { moduleName: ["Prim"]
55+ , name: "Type"
56+ }
57+ )
58+
59+ test "Row" do
60+ let row = mkJson """
61+ {
62+ "annotation": [],
63+ "tag": "Row",
64+ "contents": {
65+ "annotation": [],
66+ "tag": "NamedKind",
67+ "contents": [
68+ [
69+ "Prim"
70+ ],
71+ "Type"
72+ ]
73+ }
74+ }
75+ """
76+
77+ assertRight (decodeJson row)
78+ (Row $ NamedKind $ QualifiedName { moduleName: ["Prim"]
79+ , name: "Type"
80+ }
81+ )
82+
83+ test "FunKind" do
84+ let funKind = mkJson """
85+ {
86+ "annotation": [],
87+ "tag": "FunKind",
88+ "contents": [
89+ {
90+ "annotation": [],
91+ "tag": "Row",
92+ "contents": {
93+ "annotation": [],
94+ "tag": "NamedKind",
95+ "contents": [
96+ [
97+ "Prim"
98+ ],
99+ "Type"
100+ ]
101+ }
102+ },
103+ {
104+ "annotation": [],
105+ "tag": "Row",
106+ "contents": {
107+ "annotation": [],
108+ "tag": "NamedKind",
109+ "contents": [
110+ [
111+ "Prim"
112+ ],
113+ "Type"
114+ ]
115+ }
116+ }
117+ ]
118+ }
119+ """
120+ assertRight (decodeJson funKind)
121+ (FunKind (Row $ NamedKind $ QualifiedName { moduleName: ["Prim"]
122+ , name: "Type"
123+ }
124+ )
125+ (Row $ NamedKind $ QualifiedName { moduleName: ["Prim"]
126+ , name: "Type"
127+ }
128+ )
129+ )
130+
131+
132+assertRight :: forall a. Show a => Eq a => Either String a -> a -> Aff Unit
133+assertRight eiActual expected =
134+ case eiActual of
135+ Left string -> do
136+ Assert.equal eiActual (Right expected)
137+ Right actual -> do
138+ Assert.equal eiActual (Right expected)