-
Notifications
You must be signed in to change notification settings - Fork 1
/
Types.purs
160 lines (133 loc) · 5.68 KB
/
Types.purs
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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
module Language.PureScript.Docs.RenderedCode.Types where
import Prelude
import Codec.Json.Unidirectional.Value as Json
import Data.Argonaut.Core (Json)
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Maybe (maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Show.Generic (genericShow)
import Language.PureScript.Names (ConstructorName, Ident, ModuleName, ProperName, Qualified, TypeName, fromIdent, toIdent, toModuleName, toProperName, toQualified, fromModuleName, fromProperName, fromQualified)
import Safe.Coerce (coerce)
data ContainingModule
= ThisModule
| OtherModule ModuleName
derive instance Eq ContainingModule
derive instance Ord ContainingModule
derive instance Generic ContainingModule _
instance Show ContainingModule where
show x = genericShow x
fromContainingModule :: ContainingModule -> Json
fromContainingModule = Json.fromJArray <<< case _ of
ThisModule -> [ Json.fromString "ThisModule" ]
OtherModule mn -> [ Json.fromString "OtherModule", fromModuleName mn ]
toContainingModule :: Json -> Either Json.DecodeError ContainingModule
toContainingModule = Json.altAccumulate current backwardsCompat
where
current = Json.toJArray >=> \ja -> do
tag <- Json.underIndex 0 Json.toString ja
case tag of
"ThisModule" -> pure ThisModule
"OtherModule" -> OtherModule <$> Json.underIndex 1 toModuleName ja
str -> Left $ Json.DecodeError $ "Expected 'ThisModule' or 'OtherModule' but got '" <> str <> "'."
-- For Json produced by compilers up to 0.10.5.
backwardsCompat =
Json.toNullNothingOrJust toModuleName
>>> map (maybe ThisModule OtherModule)
data Link
= NoLink
| Link ContainingModule
derive instance Eq Link
derive instance Ord Link
derive instance Generic Link _
instance Show Link where
show x = genericShow x
fromLink :: Link -> Json
fromLink = Json.fromJArray <<< case _ of
NoLink -> [ Json.fromString "NoLink" ]
Link cm -> [ Json.fromString "Link", fromContainingModule cm ]
toLink :: Json -> Either Json.DecodeError Link
toLink = Json.toJArray >=> \ja -> do
tag <- Json.underIndex 0 Json.toString ja
case tag of
"NoLink" -> pure NoLink
"Link" -> Json.underIndex 1 (toContainingModule >>> map Link) ja
str -> Left $ Json.DecodeError $ "Expected 'NoLink' or 'Link' but got '" <> str <> "'."
data Namespace
= ValueLevel
| TypeLevel
derive instance Eq Namespace
derive instance Ord Namespace
derive instance Generic Namespace _
instance Show Namespace where
show x = genericShow x
fromNamespace :: Namespace -> Json
fromNamespace = Json.fromString <<< case _ of
ValueLevel -> "ValueLevel"
TypeLevel -> "TypeLevel"
toNamespace :: Json -> Either Json.DecodeError Namespace
toNamespace = Json.toString >=> case _ of
"ValueLevel" -> pure ValueLevel
"TypeLevel" -> pure TypeLevel
str -> Left $ Json.DecodeError $ "Expected 'ValueLevel' or 'TypeLevel' but got '" <> str <> "'."
-- |
-- A single element in a rendered code fragment. The intention is to support
-- multiple output formats. For example, plain text, or highlighted HTML.
--
data RenderedCodeElement
= Syntax String
| Keyword String
| Space
-- | Any symbol which you might or might not want to link to, in any
-- namespace (value, type, or kind). Note that this is not related to the
-- kind called Symbol for type-level strings.
| Symbol Namespace String Link
| Role String
derive instance Eq RenderedCodeElement
derive instance Ord RenderedCodeElement
derive instance Generic RenderedCodeElement _
instance Show RenderedCodeElement where
show x = genericShow x
fromRenderedCodeElement :: RenderedCodeElement -> Json
fromRenderedCodeElement = Json.fromJArray <<< case _ of
Syntax str -> [ Json.fromString "syntax", Json.fromString str ]
Keyword str -> [ Json.fromString "keyword", Json.fromString str ]
Space -> [ Json.fromString "space" ]
Symbol ns str link -> [ Json.fromString "symbol", fromNamespace ns, Json.fromString str, fromLink link ]
Role role -> [ Json.fromString "role", Json.fromString role ]
toRenderedCodeElement :: Json -> Either Json.DecodeError RenderedCodeElement
toRenderedCodeElement = Json.toJArray >=> \ja -> do
ty <- Json.underIndex 0 Json.toString ja
case ty of
"syntax" ->
Syntax <$> (Json.underIndex 1 Json.toString ja)
"keyword" ->
Keyword <$> (Json.underIndex 1 Json.toString ja)
"space" ->
pure Space
"symbol" ->
Symbol
<$> (Json.underIndex 1 toNamespace ja)
<*> (Json.underIndex 2 Json.toString ja)
<*> (Json.underIndex 3 toLink ja)
"role" ->
Role <$> (Json.underIndex 1 Json.toString ja)
str -> Left $ Json.DecodeError $ "Expected 'syntax', 'keyword', 'space', 'symbol' or 'role' but got " <> str <> "'."
newtype RenderedCode = RenderedCode (Array RenderedCodeElement)
derive instance Eq RenderedCode
derive instance Ord RenderedCode
derive instance Newtype RenderedCode _
derive instance Generic RenderedCode _
instance Show RenderedCode where
show x = genericShow x
derive newtype instance Semigroup RenderedCode
derive newtype instance Monoid RenderedCode
fromRenderedCode :: RenderedCode -> Json
fromRenderedCode = unwrap >>> Json.fromArray fromRenderedCodeElement
toRenderedCode :: Json -> Either Json.DecodeError RenderedCode
toRenderedCode = coerce <<< Json.toArray toRenderedCodeElement
type FixityAlias = Qualified (Either (ProperName TypeName) (Either Ident (ProperName ConstructorName)))
fromFixityAlias :: FixityAlias -> Json
fromFixityAlias = fromQualified $ Json.fromEitherSingle fromProperName $ Json.fromEitherSingle fromIdent fromProperName
toFixityAlias :: Json -> Either Json.DecodeError FixityAlias
toFixityAlias = toQualified $ Json.toEitherSingle toProperName $ Json.toEitherSingle toIdent toProperName