git.iko.soy/rowtype-yoga/purescript-native
on ff4866a help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Kinds.hs
106 lines 3.1 kB history raw
1module Language.PureScript.Kinds where
3import Prelude.Compat
5import Data.Text (Text)
6import qualified Data.Text as T
7import Data.Aeson.BetterErrors (Parse, key, asText, asIntegral, nth, fromAesonParser, toAesonParser, throwCustomError)
8import Data.Aeson ((.=))
9import qualified Data.Aeson as A
11import Language.PureScript.Names
12import qualified Language.PureScript.Constants as C
14-- | The data type of kinds
15data Kind
16 -- | Unification variable of type Kind
17 = KUnknown Int
18 -- | Kinds for labelled, unordered rows without duplicates
19 | Row Kind
20 -- | Function kinds
21 | FunKind Kind Kind
22 -- | A named kind
23 | NamedKind (Qualified (ProperName 'KindName))
24 deriving (Show, Eq, Ord)
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.
29instance 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 ]
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).
47kindFromJSON :: Parse Text Kind
48kindFromJSON = 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)
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
77 primKind :: Text -> Kind
78 primKind = NamedKind . primName
80 kindType = primKind "Type"
81 kindEffect = primKind "Effect"
82 kindSymbol = primKind "Symbol"
84instance A.FromJSON Kind where
85 parseJSON = toAesonParser id kindFromJSON
87everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
88everywhereOnKinds f = go
89 where
90 go (Row k1) = f (Row (go k1))
91 go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
92 go other = f other
94everywhereOnKindsM :: Monad m => (Kind -> m Kind) -> Kind -> m Kind
95everywhereOnKindsM f = go
96 where
97 go (Row k1) = (Row <$> go k1) >>= f
98 go (FunKind k1 k2) = (FunKind <$> go k1 <*> go k2) >>= f
99 go other = f other
101everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
102everythingOnKinds (<>) f = go
103 where
104 go k@(Row k1) = f k <> go k1
105 go k@(FunKind k1 k2) = f k <> go k1 <> go k2
106 go other = f other