1-- | Data types and functions for representing a simplified form of PureScript
2-- code, intended for use in e.g. HTML documentation.
3
4module Language.PureScript.Docs.RenderedCode.Types
5 ( RenderedCodeElement(..)
6 , ContainingModule(..)
7 , asContainingModule
8 , maybeToContainingModule
9 , fromQualified
10 , Namespace(..)
11 , Link(..)
12 , FixityAlias
13 , RenderedCode
14 , outputWith
15 , sp
16 , syntax
17 , keyword
18 , keywordForall
19 , keywordData
20 , keywordType
21 , keywordClass
22 , keywordWhere
23 , keywordFixity
24 , keywordAs
25 , ident
26 , dataCtor
27 , typeCtor
28 , typeOp
29 , typeVar
30 , alias
31 , aliasName
32 ) where
33
34import Prelude.Compat
35import GHC.Generics (Generic)
36
37import Control.DeepSeq (NFData)
38import Control.Monad.Error.Class (MonadError(..))
39
40import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText)
41import qualified Data.Aeson as A
42import Data.Text (Text)
43import qualified Data.Text as T
44import qualified Data.ByteString.Lazy as BS
45import qualified Data.Text.Encoding as TE
46
47import Language.PureScript.Names
48import Language.PureScript.AST (Associativity(..))
49
50-- | Given a list of actions, attempt them all, returning the first success.
51-- If all the actions fail, 'tryAll' returns the first argument.
52tryAll :: MonadError e m => m a -> [m a] -> m a
53tryAll = foldr $ \x y -> catchError x (const y)
54
55firstEq :: Text -> Parse Text a -> Parse Text a
56firstEq str p = nth 0 (withText (eq str)) *> p
57  where
58  eq s s' = if s == s' then Right () else Left ""
59
60-- |
61-- Try the given parsers in sequence. If all fail, fail with the given message,
62-- and include the JSON in the error.
63--
64tryParse :: Text -> [Parse Text a] -> Parse Text a
65tryParse msg =
66  tryAll (withValue (Left . (fullMsg <>) . showJSON))
67
68  where
69  fullMsg = "Invalid " <> msg <> ": "
70
71  showJSON :: A.Value -> Text
72  showJSON = TE.decodeUtf8 . BS.toStrict . A.encode
73
74-- |
75-- This type is isomorphic to 'Maybe' 'ModuleName'. It makes code a bit
76-- easier to read, as the meaning is more explicit.
77--
78data ContainingModule
79  = ThisModule
80  | OtherModule ModuleName
81  deriving (Show, Eq, Ord)
82
83instance A.ToJSON ContainingModule where
84  toJSON = A.toJSON . go
85    where
86    go = \case
87      ThisModule -> ["ThisModule"]
88      OtherModule mn -> ["OtherModule", runModuleName mn]
89
90instance A.FromJSON ContainingModule where
91  parseJSON = toAesonParser id asContainingModule
92
93asContainingModule :: Parse Text ContainingModule
94asContainingModule =
95  tryParse "containing module" $
96    current ++ backwardsCompat
97  where
98  current =
99    [ firstEq "ThisModule" (pure ThisModule)
100    , firstEq "OtherModule" (OtherModule <$> nth 1 asModuleName)
101    ]
102
103  -- For JSON produced by compilers up to 0.10.5.
104  backwardsCompat =
105    [ maybeToContainingModule <$> perhaps asModuleName
106    ]
107
108  asModuleName = moduleNameFromString <$> asText
109
110-- |
111-- Convert a 'Maybe' 'ModuleName' to a 'ContainingModule', using the obvious
112-- isomorphism.
113--
114maybeToContainingModule :: Maybe ModuleName -> ContainingModule
115maybeToContainingModule Nothing = ThisModule
116maybeToContainingModule (Just mn) = OtherModule mn
117
118fromQualified :: Qualified a -> (ContainingModule, a)
119fromQualified (Qualified mn x) =
120  (maybeToContainingModule mn, x)
121
122data Link
123  = NoLink
124  | Link ContainingModule
125  deriving (Show, Eq, Ord)
126
127instance A.ToJSON Link where
128  toJSON = \case
129    NoLink -> A.toJSON ["NoLink" :: Text]
130    Link mn -> A.toJSON ["Link", A.toJSON mn]
131
132asLink :: Parse Text Link
133asLink =
134  tryParse "link"
135    [ firstEq "NoLink" (pure NoLink)
136    , firstEq "Link" (Link <$> nth 1 asContainingModule)
137    ]
138
139instance A.FromJSON Link where
140  parseJSON = toAesonParser id asLink
141
142data Namespace
143  = ValueLevel
144  | TypeLevel
145  deriving (Show, Eq, Ord, Generic)
146
147instance NFData Namespace
148
149instance A.ToJSON Namespace where
150  toJSON = A.toJSON . show
151
152asNamespace :: Parse Text Namespace
153asNamespace =
154  tryParse "namespace"
155    [ withText $ \case
156        "ValueLevel" -> Right ValueLevel
157        "TypeLevel" -> Right TypeLevel
158        _ -> Left ""
159    ]
160
161instance A.FromJSON Namespace where
162  parseJSON = toAesonParser id asNamespace
163
164-- |
165-- A single element in a rendered code fragment. The intention is to support
166-- multiple output formats. For example, plain text, or highlighted HTML.
167--
168data RenderedCodeElement
169  = Syntax Text
170  | Keyword Text
171  | Space
172  -- | Any symbol which you might or might not want to link to, in any
173  -- namespace (value, type, or kind). Note that this is not related to the
174  -- kind called Symbol for type-level strings.
175  | Symbol Namespace Text Link
176  deriving (Show, Eq, Ord)
177
178instance A.ToJSON RenderedCodeElement where
179  toJSON (Syntax str) =
180    A.toJSON ["syntax", str]
181  toJSON (Keyword str) =
182    A.toJSON ["keyword", str]
183  toJSON Space =
184    A.toJSON ["space" :: Text]
185  toJSON (Symbol ns str link) =
186    A.toJSON ["symbol", A.toJSON ns, A.toJSON str, A.toJSON link]
187
188-- |
189-- A type representing a highly simplified version of PureScript code, intended
190-- for use in output formats like plain text or HTML.
191--
192newtype RenderedCode
193  = RC { unRC :: [RenderedCodeElement] }
194  deriving (Show, Eq, Ord, Semigroup, Monoid)
195
196instance A.ToJSON RenderedCode where
197  toJSON (RC elems) = A.toJSON elems
198
199-- |
200-- This function allows conversion of a 'RenderedCode' value into a value of
201-- some other type (for example, plain text, or HTML). The first argument
202-- is a function specifying how each individual 'RenderedCodeElement' should be
203-- rendered.
204--
205outputWith :: Monoid a => (RenderedCodeElement -> a) -> RenderedCode -> a
206outputWith f = foldMap f . unRC
207
208-- |
209-- A 'RenderedCode' fragment representing a space.
210--
211sp :: RenderedCode
212sp = RC [Space]
213
214-- possible TODO: instead of this function, export RenderedCode values for
215-- each syntax element, eg syntaxArr (== syntax "->"), syntaxLBrace,
216-- syntaxRBrace, etc.
217syntax :: Text -> RenderedCode
218syntax x = RC [Syntax x]
219
220keyword :: Text -> RenderedCode
221keyword kw = RC [Keyword kw]
222
223keywordForall :: RenderedCode
224keywordForall = keyword "forall"
225
226keywordData :: RenderedCode
227keywordData = keyword "data"
228
229keywordType :: RenderedCode
230keywordType = keyword "type"
231
232keywordClass :: RenderedCode
233keywordClass = keyword "class"
234
235keywordWhere :: RenderedCode
236keywordWhere = keyword "where"
237
238keywordFixity :: Associativity -> RenderedCode
239keywordFixity Infixl = keyword "infixl"
240keywordFixity Infixr = keyword "infixr"
241keywordFixity Infix = keyword "infix"
242
243keywordAs :: RenderedCode
244keywordAs = keyword "as"
245
246ident :: Qualified Ident -> RenderedCode
247ident (fromQualified -> (mn, name)) =
248  RC [Symbol ValueLevel (runIdent name) (Link mn)]
249
250dataCtor :: Qualified (ProperName 'ConstructorName) -> RenderedCode
251dataCtor (fromQualified -> (mn, name)) =
252  RC [Symbol ValueLevel (runProperName name) (Link mn)]
253
254typeCtor :: Qualified (ProperName 'TypeName) -> RenderedCode
255typeCtor (fromQualified -> (mn, name)) =
256  RC [Symbol TypeLevel (runProperName name) (Link mn)]
257
258typeOp :: Qualified (OpName 'TypeOpName) -> RenderedCode
259typeOp (fromQualified -> (mn, name)) =
260  RC [Symbol TypeLevel (runOpName name) (Link mn)]
261
262typeVar :: Text -> RenderedCode
263typeVar x = RC [Symbol TypeLevel x NoLink]
264
265type FixityAlias = Qualified (Either (ProperName 'TypeName) (Either Ident (ProperName 'ConstructorName)))
266
267alias :: FixityAlias -> RenderedCode
268alias for =
269  prefix <> RC [Symbol ns name (Link mn)]
270  where
271  (ns, name, mn) = unpackFixityAlias for
272  prefix = case ns of
273    TypeLevel ->
274      keywordType <> sp
275    _ ->
276      mempty
277
278aliasName :: FixityAlias -> Text -> RenderedCode
279aliasName for name' =
280  let
281    (ns, _, _) = unpackFixityAlias for
282    unParen = T.tail . T.init
283    name = unParen name'
284  in
285    case ns of
286      ValueLevel ->
287        ident (Qualified Nothing (Ident name))
288      TypeLevel ->
289        typeCtor (Qualified Nothing (ProperName name))
290
291-- | Converts a FixityAlias into a different representation which is more
292-- useful to other functions in this module.
293unpackFixityAlias :: FixityAlias -> (Namespace, Text, ContainingModule)
294unpackFixityAlias (fromQualified -> (mn, x)) =
295  case x of
296    -- We add some seemingly superfluous type signatures here just to be extra
297    -- sure we are not mixing up our namespaces.
298    Left (n :: ProperName 'TypeName) ->
299      (TypeLevel, runProperName n, mn)
300    Right (Left n) ->
301      (ValueLevel, runIdent n, mn)
302    Right (Right (n :: ProperName 'ConstructorName)) ->
303      (ValueLevel, runProperName n, mn)
304