git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #2533 from purescript/pursuit-json-backwards-compat
068a019Harry Garrood
src/Language/PureScript/Docs/Types.hs+3−4
compare with golang
unifiedsplit
@@ -10,6 +10,7 @@ import Control.Arrow (first, (***))
10import Control.Monad (when)
10import Control.Monad (when)
11import Control.Monad.Error.Class (catchError)
11import Control.Monad.Error.Class (catchError)
12
12
13+import Data.Monoid ((<>))
13import Data.Aeson ((.=))
14import Data.Aeson ((.=))
14import Data.Aeson.BetterErrors
15import Data.Aeson.BetterErrors
15import Data.ByteString.Lazy (ByteString)
16import Data.ByteString.Lazy (ByteString)
@@ -358,8 +359,6 @@ displayPackageError e = case e of
358 "Invalid kind: \"" <> str <> "\""
359 "Invalid kind: \"" <> str <> "\""
359 InvalidDataDeclType str ->
360 InvalidDataDeclType str ->
360 "Invalid data declaration type: \"" <> str <> "\""
361 "Invalid data declaration type: \"" <> str <> "\""
361− where
362− (<>) = T.append
363
362
364instance A.FromJSON a => A.FromJSON (Package a) where
363instance A.FromJSON a => A.FromJSON (Package a) where
365 parseJSON = toAesonParser displayPackageError
364 parseJSON = toAesonParser displayPackageError
@@ -468,8 +467,8 @@ asTypeArguments = eachInArray asTypeArgument
468 where
467 where
469 asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asKind)
468 asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asKind)
470
469
471−asKind :: Parse e P.Kind
470+asKind :: Parse PackageError P.Kind
472−asKind = fromAesonParser
471+asKind = P.kindFromJSON .! InvalidKind
473
472
474asType :: Parse e P.Type
473asType :: Parse e P.Type
475asType = fromAesonParser
474asType = fromAesonParser
src/Language/PureScript/Kinds.hs+66−4
@@ -1,12 +1,15 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3module Language.PureScript.Kinds where
1module Language.PureScript.Kinds where
4
2
5import Prelude.Compat
3import Prelude.Compat
6
4
5+import Data.Text (Text)
7−import qualified Data.Aeson.TH as A
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
8
10
9import Language.PureScript.Names
11import Language.PureScript.Names
12+import qualified Language.PureScript.Constants as C
10
13
11-- | The data type of kinds
14-- | The data type of kinds
12data Kind
15data Kind
@@ -20,7 +23,66 @@ data Kind
20 | NamedKind (Qualified (ProperName 'KindName))
23 | NamedKind (Qualified (ProperName 'KindName))
21 deriving (Show, Eq, Ord)
24 deriving (Show, Eq, Ord)
22
25
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
24
86
25everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
87everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
26everywhereOnKinds f = go
88everywhereOnKinds f = go