forked from purescript/purescript
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathKinds.hs
More file actions
106 lines (93 loc) · 3.06 KB
/
Kinds.hs
File metadata and controls
106 lines (93 loc) · 3.06 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
module Language.PureScript.Kinds where
import Prelude.Compat
import Data.Text (Text)
import qualified Data.Text as T
import Data.Aeson.BetterErrors (Parse, key, asText, asIntegral, nth, fromAesonParser, toAesonParser, throwCustomError)
import Data.Aeson ((.=))
import qualified Data.Aeson as A
import Language.PureScript.Names
import qualified Language.PureScript.Constants as C
-- | The data type of kinds
data Kind
-- | Unification variable of type Kind
= KUnknown Int
-- | Kinds for labelled, unordered rows without duplicates
| Row Kind
-- | Function kinds
| FunKind Kind Kind
-- | A named kind
| NamedKind (Qualified (ProperName 'KindName))
deriving (Show, Eq, Ord)
-- This is equivalent to the derived Aeson ToJSON instance, except that we
-- write it out manually so that we can define a parser which is
-- backwards-compatible.
instance A.ToJSON Kind where
toJSON kind = case kind of
KUnknown i ->
obj "KUnknown" i
Row k ->
obj "Row" k
FunKind k1 k2 ->
obj "FunKind" [k1, k2]
NamedKind n ->
obj "NamedKind" n
where
obj :: A.ToJSON a => Text -> a -> A.Value
obj tag contents =
A.object [ "tag" .= tag, "contents" .= contents ]
-- This is equivalent to the derived Aeson FromJSON instance, except that it
-- also handles JSON generated by compilers up to 0.10.3 and maps them to the
-- new representations (i.e. NamedKinds which are defined in the Prim module).
kindFromJSON :: Parse Text Kind
kindFromJSON = do
t <- key "tag" asText
case t of
"KUnknown" ->
KUnknown <$> key "contents" (nth 0 asIntegral)
"Star" ->
pure kindType
"Bang" ->
pure kindEffect
"Row" ->
Row <$> key "contents" kindFromJSON
"FunKind" ->
let
kindAt n = key "contents" (nth n kindFromJSON)
in
FunKind <$> kindAt 0 <*> kindAt 1
"Symbol" ->
pure kindSymbol
"NamedKind" ->
NamedKind <$> key "contents" fromAesonParser
other ->
throwCustomError (T.append "Unrecognised tag: " other)
where
-- The following are copied from Environment and reimplemented to avoid
-- circular dependencies.
primName :: Text -> Qualified (ProperName a)
primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
primKind :: Text -> Kind
primKind = NamedKind . primName
kindType = primKind "Type"
kindEffect = primKind "Effect"
kindSymbol = primKind "Symbol"
instance A.FromJSON Kind where
parseJSON = toAesonParser id kindFromJSON
everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
everywhereOnKinds f = go
where
go (Row k1) = f (Row (go k1))
go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
go other = f other
everywhereOnKindsM :: Monad m => (Kind -> m Kind) -> Kind -> m Kind
everywhereOnKindsM f = go
where
go (Row k1) = (Row <$> go k1) >>= f
go (FunKind k1 k2) = (FunKind <$> go k1 <*> go k2) >>= f
go other = f other
everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
everythingOnKinds (<>) f = go
where
go k@(Row k1) = f k <> go k1
go k@(FunKind k1 k2) = f k <> go k1 <> go k2
go other = f other