@@ -1,4 +1,5 @@
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE DeriveGeneric #-}
23
34-- | Data types and functions for representing a simplified form of PureScript
45-- code, intended for use in e.g. HTML documentation.
@@ -11,15 +12,16 @@ module Language.PureScript.Docs.RenderedCode.Types
1112 , containingModuleToMaybe
1213 , maybeToContainingModule
1314 , fromContainingModule
15+ , fromQualified
16+ , Namespace(..)
17+ , Link(..)
18+ , FixityAlias
1419 , RenderedCode
1520 , asRenderedCode
1621 , outputWith
1722 , sp
23+ , parens
1824 , syntax
19− , ident
20− , ident'
21− , ctor
22− , kind
2325 , keyword
2426 , keywordForall
2527 , keywordData
@@ -30,105 +32,216 @@ module Language.PureScript.Docs.RenderedCode.Types
3032 , keywordWhere
3133 , keywordFixity
3234 , keywordKind
35+ , keywordAs
36+ , ident
37+ , dataCtor
38+ , typeCtor
39+ , typeOp
40+ , typeVar
41+ , kind
42+ , alias
43+ , aliasName
3344 ) where
3445
3546import Prelude.Compat
47+import GHC.Generics (Generic)
3648
49+import Control.DeepSeq (NFData)
3750import Control.Monad.Error.Class (MonadError(..))
3851
52+import Data.Monoid ((<>))
3953import Data.Aeson.BetterErrors
4054import qualified Data.Aeson as A
4155import Data.Text (Text)
56+import qualified Data.Text as T
57+import qualified Data.ByteString.Lazy as BS
58+import qualified Data.Text.Encoding as TE
4259
43−import qualified Language.PureScript as P
60+import Language.PureScript.Names
61+import Language.PureScript.AST (Associativity(..))
62+import Language.PureScript.Crash (internalError)
4463
45−-- |
46−-- A single element in a rendered code fragment. The intention is to support
47−-- multiple output formats. For example, plain text, or highlighted HTML.
48−--
49−data RenderedCodeElement
50− = Syntax Text
51− | Ident Text ContainingModule
52− | Ctor Text ContainingModule
53− | Kind Text
54− | Keyword Text
55− | Space
56− deriving (Show, Eq, Ord)
64+-- | Given a list of actions, attempt them all, returning the first success.
65+-- If all the actions fail, 'tryAll' returns the first argument.
66+tryAll :: MonadError e m => m a -> [m a] -> m a
67+tryAll = foldr $ \x y -> catchError x (const y)
5768
58−instance A.ToJSON RenderedCodeElement where
59− toJSON (Syntax str) =
60− A.toJSON ["syntax", str]
61− toJSON (Ident str mn) =
62− A.toJSON ["ident", A.toJSON str, A.toJSON mn]
63− toJSON (Ctor str mn) =
64− A.toJSON ["ctor", A.toJSON str, A.toJSON mn ]
65− toJSON (Kind str) =
66− A.toJSON ["kind", str]
67− toJSON (Keyword str) =
68− A.toJSON ["keyword", str]
69− toJSON Space =
70− A.toJSON ["space" :: Text]
71−
72−asRenderedCodeElement :: Parse Text RenderedCodeElement
73−asRenderedCodeElement =
74− a Syntax "syntax" <|>
75− asIdent <|>
76− asCtor <|>
77− a Kind "kind" <|>
78− a Keyword "keyword" <|>
79− asSpace <|>
80− unableToParse
69+firstEq :: Text -> Parse Text a -> Parse Text a
70+firstEq str p = nth 0 (withText (eq str)) *> p
8171 where
82− p <|> q = catchError p (const q)
72+ eq s s' = if s == s' then Right () else Left ""
8373
84− a ctor' ctorStr = ctor' <$> (nth 0 (withText (eq ctorStr)) *> nth 1 asText)
85− asIdent = nth 0 (withText (eq "ident")) *> (Ident <$> nth 1 asText <*> nth 2 asContainingModule)
86− asCtor = nth 0 (withText (eq "ctor")) *> (Ctor <$> nth 1 asText <*> nth 2 asContainingModule)
87− asSpace = nth 0 (withText (eq "space")) *> pure Space
74+-- |
75+-- Try the given parsers in sequence. If all fail, fail with the given message,
76+-- and include the JSON in the error.
77+--
78+tryParse :: Text -> [Parse Text a] -> Parse Text a
79+tryParse msg =
80+ tryAll (withValue (Left . (fullMsg <>) . showJSON))
8881
89− eq s s' = if s == s' then Right () else Left ""
82+ where
83+ fullMsg = "Invalid " <> msg <> ": "
9084
91− unableToParse = withText Left
85+ showJSON :: A.Value -> Text
86+ showJSON = TE.decodeUtf8 . BS.toStrict . A.encode
9287
9388-- |
94−-- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier
95−-- to read, as the meaning is more explicit.
89+-- This type is isomorphic to 'Maybe' 'ModuleName'. It makes code a bit
90+-- easier to read, as the meaning is more explicit.
9691--
9792data ContainingModule
9893 = ThisModule
99− | OtherModule P.ModuleName
94+ | OtherModule ModuleName
10095 deriving (Show, Eq, Ord)
10196
10297instance A.ToJSON ContainingModule where
103− toJSON mn = A.toJSON (P.runModuleName <$> containingModuleToMaybe mn)
98+ toJSON = A.toJSON . go
99+ where
100+ go = \case
101+ ThisModule -> ["ThisModule"]
102+ OtherModule mn -> ["OtherModule", runModuleName mn]
104103
105−asContainingModule :: Parse e ContainingModule
104+instance A.FromJSON ContainingModule where
105+ parseJSON = toAesonParser id asContainingModule
106+
107+asContainingModule :: Parse Text ContainingModule
106108asContainingModule =
107− maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asText)
109+ tryParse "containing module" $
110+ current ++ backwardsCompat
111+ where
112+ current =
113+ [ firstEq "ThisModule" (pure ThisModule)
114+ , firstEq "OtherModule" (OtherModule <$> nth 1 asModuleName)
115+ ]
116+
117+ -- For JSON produced by compilers up to 0.10.5.
118+ backwardsCompat =
119+ [ maybeToContainingModule <$> perhaps asModuleName
120+ ]
121+
122+ asModuleName = moduleNameFromString <$> asText
108123
109124-- |
110−-- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious
125+-- Convert a 'Maybe' 'ModuleName' to a 'ContainingModule', using the obvious
111126-- isomorphism.
112127--
113−maybeToContainingModule :: Maybe P.ModuleName -> ContainingModule
128+maybeToContainingModule :: Maybe ModuleName -> ContainingModule
114129maybeToContainingModule Nothing = ThisModule
115130maybeToContainingModule (Just mn) = OtherModule mn
116131
117132-- |
118−-- Convert a 'ContainingModule' to a 'Maybe' 'P.ModuleName', using the obvious
133+-- Convert a 'ContainingModule' to a 'Maybe' 'ModuleName', using the obvious
119134-- isomorphism.
120135--
121−containingModuleToMaybe :: ContainingModule -> Maybe P.ModuleName
136+containingModuleToMaybe :: ContainingModule -> Maybe ModuleName
122137containingModuleToMaybe ThisModule = Nothing
123138containingModuleToMaybe (OtherModule mn) = Just mn
124139
125140-- |
126141-- A version of 'fromMaybe' for 'ContainingModule' values.
127142--
128−fromContainingModule :: P.ModuleName -> ContainingModule -> P.ModuleName
143+fromContainingModule :: ModuleName -> ContainingModule -> ModuleName
129144fromContainingModule def ThisModule = def
130145fromContainingModule _ (OtherModule mn) = mn
131146
147+fromQualified :: Qualified a -> (ContainingModule, a)
148+fromQualified (Qualified mn x) =
149+ (maybeToContainingModule mn, x)
150+
151+data Link
152+ = NoLink
153+ | Link ContainingModule
154+ deriving (Show, Eq, Ord)
155+
156+instance A.ToJSON Link where
157+ toJSON = \case
158+ NoLink -> A.toJSON ["NoLink" :: Text]
159+ Link mn -> A.toJSON ["Link", A.toJSON mn]
160+
161+asLink :: Parse Text Link
162+asLink =
163+ tryParse "link"
164+ [ firstEq "NoLink" (pure NoLink)
165+ , firstEq "Link" (Link <$> nth 1 asContainingModule)
166+ ]
167+
168+instance A.FromJSON Link where
169+ parseJSON = toAesonParser id asLink
170+
171+data Namespace
172+ = ValueLevel
173+ | TypeLevel
174+ | KindLevel
175+ deriving (Show, Eq, Ord, Generic)
176+
177+instance NFData Namespace
178+
179+instance A.ToJSON Namespace where
180+ toJSON = A.toJSON . show
181+
182+asNamespace :: Parse Text Namespace
183+asNamespace =
184+ tryParse "namespace"
185+ [ withText $ \case
186+ "ValueLevel" -> Right ValueLevel
187+ "TypeLevel" -> Right TypeLevel
188+ "KindLevel" -> Right KindLevel
189+ _ -> Left ""
190+ ]
191+
192+instance A.FromJSON Namespace where
193+ parseJSON = toAesonParser id asNamespace
194+
195+-- |
196+-- A single element in a rendered code fragment. The intention is to support
197+-- multiple output formats. For example, plain text, or highlighted HTML.
198+--
199+data RenderedCodeElement
200+ = Syntax Text
201+ | Keyword Text
202+ | Space
203+ -- | Any symbol which you might or might not want to link to, in any
204+ -- namespace (value, type, or kind). Note that this is not related to the
205+ -- kind called Symbol for type-level strings.
206+ | Symbol Namespace Text Link
207+ deriving (Show, Eq, Ord)
208+
209+instance A.ToJSON RenderedCodeElement where
210+ toJSON (Syntax str) =
211+ A.toJSON ["syntax", str]
212+ toJSON (Keyword str) =
213+ A.toJSON ["keyword", str]
214+ toJSON Space =
215+ A.toJSON ["space" :: Text]
216+ toJSON (Symbol ns str link) =
217+ A.toJSON ["symbol", A.toJSON ns, A.toJSON str, A.toJSON link]
218+
219+asRenderedCodeElement :: Parse Text RenderedCodeElement
220+asRenderedCodeElement =
221+ tryParse "RenderedCodeElement" $
222+ [ a Syntax "syntax"
223+ , a Keyword "keyword"
224+ , asSpace
225+ , asSymbol
226+ ] ++ backwardsCompat
227+ where
228+ a ctor' ctorStr = firstEq ctorStr (ctor' <$> nth 1 asText)
229+ asSymbol = firstEq "symbol" (Symbol <$> nth 1 asNamespace <*> nth 2 asText <*> nth 3 asLink)
230+ asSpace = firstEq "space" (pure Space)
231+
232+ -- These will make some mistakes e.g. treating data constructors as types,
233+ -- because the old code did not save information which is necessary to
234+ -- distinguish these cases. This is the best we can do.
235+ backwardsCompat =
236+ [ oldAsIdent
237+ , oldAsCtor
238+ , oldAsKind
239+ ]
240+
241+ oldAsIdent = firstEq "ident" (Symbol ValueLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule))
242+ oldAsCtor = firstEq "ctor" (Symbol TypeLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule))
243+ oldAsKind = firstEq "kind" (Symbol KindLevel <$> nth 1 asText <*> pure (Link ThisModule))
244+
132245-- |
133246-- A type representing a highly simplified version of PureScript code, intended
134247-- for use in output formats like plain text or HTML.
@@ -158,21 +271,17 @@ outputWith f = foldMap f . unRC
158271sp :: RenderedCode
159272sp = RC [Space]
160273
274+-- |
275+-- Wrap a RenderedCode value in parens.
276+parens :: RenderedCode -> RenderedCode
277+parens x = syntax "(" <> x <> syntax ")"
278+
279+-- possible TODO: instead of this function, export RenderedCode values for
280+-- each syntax element, eg syntaxArr (== syntax "->"), syntaxLBrace,
281+-- syntaxRBrace, etc.
161282syntax :: Text -> RenderedCode
162283syntax x = RC [Syntax x]
163284
164−ident :: Text -> RenderedCode
165−ident x = RC [Ident x ThisModule]
166−
167−ident' :: Text -> ContainingModule -> RenderedCode
168−ident' x m = RC [Ident x m]
169−
170−ctor :: Text -> ContainingModule -> RenderedCode
171−ctor x m = RC [Ctor x m]
172−
173−kind :: Text -> RenderedCode
174−kind x = RC [Kind x]
175−
176285keyword :: Text -> RenderedCode
177286keyword kw = RC [Keyword kw]
178287
@@ -197,10 +306,78 @@ keywordInstance = keyword "instance"
197306keywordWhere :: RenderedCode
198307keywordWhere = keyword "where"
199308
200−keywordFixity :: P.Associativity -> RenderedCode
201−keywordFixity P.Infixl = keyword "infixl"
202−keywordFixity P.Infixr = keyword "infixr"
203−keywordFixity P.Infix = keyword "infix"
309+keywordFixity :: Associativity -> RenderedCode
310+keywordFixity Infixl = keyword "infixl"
311+keywordFixity Infixr = keyword "infixr"
312+keywordFixity Infix = keyword "infix"
204313
205314keywordKind :: RenderedCode
206315keywordKind = keyword "kind"
316+
317+keywordAs :: RenderedCode
318+keywordAs = keyword "as"
319+
320+ident :: Qualified Ident -> RenderedCode
321+ident (fromQualified -> (mn, name)) =
322+ RC [Symbol ValueLevel (runIdent name) (Link mn)]
323+
324+dataCtor :: Qualified (ProperName 'ConstructorName) -> RenderedCode
325+dataCtor (fromQualified -> (mn, name)) =
326+ RC [Symbol ValueLevel (runProperName name) (Link mn)]
327+
328+typeCtor :: Qualified (ProperName 'TypeName) -> RenderedCode
329+typeCtor (fromQualified -> (mn, name)) =
330+ RC [Symbol TypeLevel (runProperName name) (Link mn)]
331+
332+typeOp :: Qualified (OpName 'TypeOpName) -> RenderedCode
333+typeOp (fromQualified -> (mn, name)) =
334+ RC [Symbol TypeLevel (runOpName name) (Link mn)]
335+
336+typeVar :: Text -> RenderedCode
337+typeVar x = RC [Symbol TypeLevel x NoLink]
338+
339+kind :: Qualified (ProperName 'KindName) -> RenderedCode
340+kind (fromQualified -> (mn, name)) =
341+ RC [Symbol KindLevel (runProperName name) (Link mn)]
342+
343+type FixityAlias = Qualified (Either (ProperName 'TypeName) (Either Ident (ProperName 'ConstructorName)))
344+
345+alias :: FixityAlias -> RenderedCode
346+alias for =
347+ prefix <> RC [Symbol ns name (Link mn)]
348+ where
349+ (ns, name, mn) = unpackFixityAlias for
350+ prefix = case ns of
351+ TypeLevel ->
352+ keywordType <> sp
353+ _ ->
354+ mempty
355+
356+aliasName :: FixityAlias -> Text -> RenderedCode
357+aliasName for name' =
358+ let
359+ (ns, _, _) = unpackFixityAlias for
360+ unParen = T.tail . T.init
361+ name = unParen name'
362+ in
363+ case ns of
364+ ValueLevel ->
365+ ident (Qualified Nothing (Ident name))
366+ TypeLevel ->
367+ typeCtor (Qualified Nothing (ProperName name))
368+ KindLevel ->
369+ internalError "Kind aliases are not supported"
370+
371+-- | Converts a FixityAlias into a different representation which is more
372+-- useful to other functions in this module.
373+unpackFixityAlias :: FixityAlias -> (Namespace, Text, ContainingModule)
374+unpackFixityAlias (fromQualified -> (mn, x)) =
375+ case x of
376+ -- We add some seemingly superfluous type signatures here just to be extra
377+ -- sure we are not mixing up our namespaces.
378+ Left (n :: ProperName 'TypeName) ->
379+ (TypeLevel, runProperName n, mn)
380+ Right (Left n) ->
381+ (ValueLevel, runIdent n, mn)
382+ Right (Right (n :: ProperName 'ConstructorName)) ->
383+ (ValueLevel, runProperName n, mn)