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