mirror of
https://github.com/rowtype-yoga/purescript-docs-search.git
synced 2024-09-11 12:35:37 +03:00
added: parser for kinds
This commit is contained in:
parent
0f3f5665d6
commit
a6e84ee6fd
@ -24,6 +24,7 @@
|
||||
, "halogen"
|
||||
, "halogen-css"
|
||||
, "coroutines"
|
||||
, "test-unit"
|
||||
]
|
||||
, packages =
|
||||
./packages.dhall
|
||||
|
98
src/Spago/Search/TypeParser.purs
Normal file
98
src/Spago/Search/TypeParser.purs
Normal file
@ -0,0 +1,98 @@
|
||||
module Spago.Search.TypeParser where
|
||||
|
||||
import Prelude
|
||||
import Data.Argonaut.Core -- (Json, fromString, stringify, toString)
|
||||
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:), (.:?))
|
||||
import Data.Argonaut.Encode (class EncodeJson, encodeJson)
|
||||
import Data.Array as Array
|
||||
import Data.Either
|
||||
import Data.Generic.Rep (class Generic)
|
||||
import Data.Generic.Rep.Show (genericShow, genericShow')
|
||||
import Data.Maybe
|
||||
import Data.Newtype
|
||||
import Control.Alt
|
||||
import Data.Traversable
|
||||
|
||||
newtype QualifiedName = QualifiedName { moduleName :: Array String
|
||||
, name :: String
|
||||
}
|
||||
|
||||
derive instance eqQualifiedName :: Eq QualifiedName
|
||||
derive instance genericQualifiedName :: Generic QualifiedName _
|
||||
derive instance newtypeQualifiedName :: Newtype QualifiedName _
|
||||
|
||||
instance showQualifiedName :: Show QualifiedName where
|
||||
show = genericShow
|
||||
|
||||
instance decodeJsonQualifiedName :: DecodeJson QualifiedName where
|
||||
decodeJson json = do
|
||||
case toArray json of
|
||||
Nothing -> mkJsonError "QualifiedName" json
|
||||
Just arrOfJsons -> do
|
||||
let arrOfVariants =
|
||||
arrOfJsons <#> \variantJson ->
|
||||
Left <$> decodeJson variantJson <|>
|
||||
Right <$> decodeJson variantJson
|
||||
case arrOfVariants of
|
||||
[ Right (Left moduleName), Right (Right name)] ->
|
||||
pure $ QualifiedName { moduleName, name }
|
||||
_ -> mkJsonError "QualifiedName" json
|
||||
|
||||
mkJsonError :: forall a. String -> Json -> Either String a
|
||||
mkJsonError name json =
|
||||
Left $ "Couldn't parse " <> name <> " from " <> stringify json
|
||||
|
||||
-- | The data type of kinds
|
||||
data Kind
|
||||
-- | Kinds for labelled, unordered rows without duplicates
|
||||
= Row Kind
|
||||
-- | Function kinds
|
||||
| FunKind Kind Kind
|
||||
-- | A named kind
|
||||
| NamedKind QualifiedName
|
||||
|
||||
derive instance eqKind :: Eq Kind
|
||||
derive instance genericKind :: Generic Kind _
|
||||
|
||||
instance showKind :: Show Kind where
|
||||
show = case _ of
|
||||
Row k -> "(Row " <> show k <> ")"
|
||||
FunKind k1 k2 -> "(FunKind " <> show k1 <> " " <> show k2 <> ")"
|
||||
NamedKind name -> "(NamedKind " <> show name <> ")"
|
||||
|
||||
newtype MaybeSingle a = MaybeSingle (Either a (Array a))
|
||||
|
||||
derive instance eqMaybeSingle :: Eq a => Eq (MaybeSingle a)
|
||||
derive instance genericMaybeSingle :: Generic (MaybeSingle a) _
|
||||
derive instance newtypeMaybeSingle :: Newtype (MaybeSingle a) _
|
||||
|
||||
instance showMaybeSingle :: Show a => Show (MaybeSingle a) where
|
||||
show = genericShow
|
||||
|
||||
instance decodeJsonMaybeSingle :: DecodeJson a => DecodeJson (MaybeSingle a) where
|
||||
decodeJson json =
|
||||
MaybeSingle <$> (Left <$> decodeJson json <|> Right <$> decodeJson json)
|
||||
|
||||
fromMaybeSingle :: forall a. MaybeSingle a -> Array a
|
||||
fromMaybeSingle (MaybeSingle (Left a)) = Array.singleton a
|
||||
fromMaybeSingle (MaybeSingle (Right a)) = a
|
||||
|
||||
instance decodeJsonKind :: DecodeJson Kind where
|
||||
decodeJson json = do
|
||||
handle <- decodeJson json
|
||||
tag <- handle .: "tag"
|
||||
case tag of
|
||||
"NamedKind" -> do
|
||||
-- annotation <- handle .: "annotation"
|
||||
contents <- handle .: "contents"
|
||||
pure $ NamedKind contents
|
||||
"Row" -> do
|
||||
contents <- handle .: "contents"
|
||||
pure $ Row contents
|
||||
"FunKind" -> do
|
||||
contents <- handle .: "contents"
|
||||
case contents of
|
||||
[k1, k2] ->
|
||||
pure $ FunKind k1 k2
|
||||
_ -> mkJsonError "FunKind" json
|
||||
_ -> mkJsonError "Kind" json
|
133
test/Main.purs
133
test/Main.purs
@ -3,7 +3,136 @@ module Test.Main where
|
||||
import Prelude
|
||||
import Effect (Effect)
|
||||
import Effect.Console (log)
|
||||
import Test.Unit (suite, test, timeout)
|
||||
import Test.Unit.Main (runTest)
|
||||
import Test.Unit.Assert as Assert
|
||||
import Spago.Search.TypeParser
|
||||
import Data.Argonaut.Decode
|
||||
import Data.Either
|
||||
import Data.Maybe
|
||||
import Data.Argonaut.Parser
|
||||
import Partial.Unsafe
|
||||
import Effect.Aff
|
||||
|
||||
main :: Effect Unit
|
||||
main = do
|
||||
log "You should add some tests."
|
||||
main = runTest do
|
||||
let mkJson x = unsafePartial $ fromRight $ jsonParser x
|
||||
suite "TypeParser" do
|
||||
|
||||
test "QualifiedName" do
|
||||
|
||||
let qualifiedName = mkJson """
|
||||
[
|
||||
[
|
||||
"Prim"
|
||||
],
|
||||
"Type"
|
||||
]
|
||||
"""
|
||||
|
||||
assertRight (decodeJson qualifiedName)
|
||||
(QualifiedName { moduleName: ["Prim"]
|
||||
, name: "Type"
|
||||
}
|
||||
)
|
||||
|
||||
test "NamedKind" do
|
||||
let namedKind = mkJson """
|
||||
{
|
||||
"annotation": [],
|
||||
"tag": "NamedKind",
|
||||
"contents": [
|
||||
[
|
||||
"Prim"
|
||||
],
|
||||
"Type"
|
||||
]
|
||||
}
|
||||
"""
|
||||
|
||||
assertRight (decodeJson namedKind)
|
||||
(NamedKind $ QualifiedName { moduleName: ["Prim"]
|
||||
, name: "Type"
|
||||
}
|
||||
)
|
||||
|
||||
test "Row" do
|
||||
let row = mkJson """
|
||||
{
|
||||
"annotation": [],
|
||||
"tag": "Row",
|
||||
"contents": {
|
||||
"annotation": [],
|
||||
"tag": "NamedKind",
|
||||
"contents": [
|
||||
[
|
||||
"Prim"
|
||||
],
|
||||
"Type"
|
||||
]
|
||||
}
|
||||
}
|
||||
"""
|
||||
|
||||
assertRight (decodeJson row)
|
||||
(Row $ NamedKind $ QualifiedName { moduleName: ["Prim"]
|
||||
, name: "Type"
|
||||
}
|
||||
)
|
||||
|
||||
test "FunKind" do
|
||||
let funKind = mkJson """
|
||||
{
|
||||
"annotation": [],
|
||||
"tag": "FunKind",
|
||||
"contents": [
|
||||
{
|
||||
"annotation": [],
|
||||
"tag": "Row",
|
||||
"contents": {
|
||||
"annotation": [],
|
||||
"tag": "NamedKind",
|
||||
"contents": [
|
||||
[
|
||||
"Prim"
|
||||
],
|
||||
"Type"
|
||||
]
|
||||
}
|
||||
},
|
||||
{
|
||||
"annotation": [],
|
||||
"tag": "Row",
|
||||
"contents": {
|
||||
"annotation": [],
|
||||
"tag": "NamedKind",
|
||||
"contents": [
|
||||
[
|
||||
"Prim"
|
||||
],
|
||||
"Type"
|
||||
]
|
||||
}
|
||||
}
|
||||
]
|
||||
}
|
||||
"""
|
||||
assertRight (decodeJson funKind)
|
||||
(FunKind (Row $ NamedKind $ QualifiedName { moduleName: ["Prim"]
|
||||
, name: "Type"
|
||||
}
|
||||
)
|
||||
(Row $ NamedKind $ QualifiedName { moduleName: ["Prim"]
|
||||
, name: "Type"
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
assertRight :: forall a. Show a => Eq a => Either String a -> a -> Aff Unit
|
||||
assertRight eiActual expected =
|
||||
case eiActual of
|
||||
Left string -> do
|
||||
Assert.equal eiActual (Right expected)
|
||||
Right actual -> do
|
||||
Assert.equal eiActual (Right expected)
|
||||
|
Loading…
Reference in New Issue
Block a user