@@ -1,12 +1,15 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
31module Language.PureScript.Kinds where
42
53import Prelude.Compat
64
7−import qualified Data.Aeson.TH as A
5+import Data.Text (Text)
6+import qualified Data.Text as T
7+import Data.Aeson.BetterErrors (Parse, key, asText, asIntegral, nth, fromAesonParser, toAesonParser, throwCustomError)
8+import Data.Aeson ((.=))
9+import qualified Data.Aeson as A
810
911import Language.PureScript.Names
12+import qualified Language.PureScript.Constants as C
1013
1114-- | The data type of kinds
1215data Kind
@@ -20,7 +23,66 @@ data Kind
2023 | NamedKind (Qualified (ProperName 'KindName))
2124 deriving (Show, Eq, Ord)
2225
23−$(A.deriveJSON A.defaultOptions ''Kind)
26+-- This is equivalent to the derived Aeson ToJSON instance, except that we
27+-- write it out manually so that we can define a parser which is
28+-- backwards-compatible.
29+instance A.ToJSON Kind where
30+ toJSON kind = case kind of
31+ KUnknown i ->
32+ obj "KUnknown" i
33+ Row k ->
34+ obj "Row" k
35+ FunKind k1 k2 ->
36+ obj "FunKind" [k1, k2]
37+ NamedKind n ->
38+ obj "NamedKind" n
39+ where
40+ obj :: A.ToJSON a => Text -> a -> A.Value
41+ obj tag contents =
42+ A.object [ "tag" .= tag, "contents" .= contents ]
43+
44+-- This is equivalent to the derived Aeson FromJSON instance, except that it
45+-- also handles JSON generated by compilers up to 0.10.3 and maps them to the
46+-- new representations (i.e. NamedKinds which are defined in the Prim module).
47+kindFromJSON :: Parse Text Kind
48+kindFromJSON = do
49+ t <- key "tag" asText
50+ case t of
51+ "KUnknown" ->
52+ KUnknown <$> key "contents" (nth 0 asIntegral)
53+ "Star" ->
54+ pure kindType
55+ "Bang" ->
56+ pure kindEffect
57+ "Row" ->
58+ Row <$> key "contents" kindFromJSON
59+ "FunKind" ->
60+ let
61+ kindAt n = key "contents" (nth n kindFromJSON)
62+ in
63+ FunKind <$> kindAt 0 <*> kindAt 1
64+ "Symbol" ->
65+ pure kindSymbol
66+ "NamedKind" ->
67+ NamedKind <$> key "contents" fromAesonParser
68+ other ->
69+ throwCustomError (T.append "Unrecognised tag: " other)
70+
71+ where
72+ -- The following are copied from Environment and reimplemented to avoid
73+ -- circular dependencies.
74+ primName :: Text -> Qualified (ProperName a)
75+ primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
76+
77+ primKind :: Text -> Kind
78+ primKind = NamedKind . primName
79+
80+ kindType = primKind "Type"
81+ kindEffect = primKind "Effect"
82+ kindSymbol = primKind "Symbol"
83+
84+instance A.FromJSON Kind where
85+ parseJSON = toAesonParser id kindFromJSON
2486
2587everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
2688everywhereOnKinds f = go