@@ -1,4 +1,5 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE DeriveGeneric #-}
3-- | Data types and functions for representing a simplified form of PureScript
4-- | Data types and functions for representing a simplified form of PureScript
4-- code, intended for use in e.g. HTML documentation.
5-- code, intended for use in e.g. HTML documentation.
@@ -11,15 +12,16 @@ module Language.PureScript.Docs.RenderedCode.Types
11 , containingModuleToMaybe
12 , containingModuleToMaybe
12 , maybeToContainingModule
13 , maybeToContainingModule
13 , fromContainingModule
14 , fromContainingModule
14 , RenderedCode
19 , RenderedCode
15 , asRenderedCode
20 , asRenderedCode
16 , outputWith
21 , outputWith
24 , keywordForall
26 , keywordForall
25 , keywordData
27 , keywordData
@@ -30,105 +32,216 @@ module Language.PureScript.Docs.RenderedCode.Types
30 , keywordWhere
32 , keywordWhere
31 , keywordFixity
33 , keywordFixity
32 , keywordKind
34 , keywordKind
35import Prelude.Compat
46import Prelude.Compat
47+import GHC.Generics (Generic)
49+import Control.DeepSeq (NFData)
37import Control.Monad.Error.Class (MonadError(..))
50import Control.Monad.Error.Class (MonadError(..))
52+import Data.Monoid ((<>))
39import Data.Aeson.BetterErrors
53import Data.Aeson.BetterErrors
40import qualified Data.Aeson as A
54import qualified Data.Aeson as A
41import Data.Text (Text)
55import 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
60+import Language.PureScript.Names
43−import qualified Language.PureScript as P
61+import Language.PureScript.AST (Associativity(..))
62+import Language.PureScript.Crash (internalError)
45−-- |
64+-- | Given a list of actions, attempt them all, returning the first success.
46−-- A single element in a rendered code fragment. The intention is to support
65+-- If all the actions fail, 'tryAll' returns the first argument.
47−-- multiple output formats. For example, plain text, or highlighted HTML.
66+tryAll :: MonadError e m => m a -> [m a] -> m a
48−--
67+tryAll = foldr $ \x y -> catchError x (const y)
49−data RenderedCodeElement
51− | Ident Text ContainingModule
52− | Ctor Text ContainingModule
56− deriving (Show, Eq, Ord)
58−instance A.ToJSON RenderedCodeElement where
69+firstEq :: Text -> Parse Text a -> Parse Text a
59− toJSON (Syntax str) =
70+firstEq str p = nth 0 (withText (eq str)) *> p
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 ]
66− A.toJSON ["kind", str]
67− toJSON (Keyword str) =
68− A.toJSON ["keyword", str]
70− A.toJSON ["space" :: Text]
72−asRenderedCodeElement :: Parse Text RenderedCodeElement
73−asRenderedCodeElement =
74− a Syntax "syntax" <|>
78− a Keyword "keyword" <|>
82− p <|> q = catchError p (const q)
72+ eq s s' = if s == s' then Right () else Left ""
84− a ctor' ctorStr = ctor' <$> (nth 0 (withText (eq ctorStr)) *> nth 1 asText)
74+-- |
85− asIdent = nth 0 (withText (eq "ident")) *> (Ident <$> nth 1 asText <*> nth 2 asContainingModule)
75+-- Try the given parsers in sequence. If all fail, fail with the given message,
86− asCtor = nth 0 (withText (eq "ctor")) *> (Ctor <$> nth 1 asText <*> nth 2 asContainingModule)
76+-- and include the JSON in the error.
87− asSpace = nth 0 (withText (eq "space")) *> pure Space
77+--
78+tryParse :: Text -> [Parse Text a] -> Parse Text a
80+ tryAll (withValue (Left . (fullMsg <>) . showJSON))
89− eq s s' = if s == s' then Right () else Left ""
82+ where
83+ fullMsg = "Invalid " <> msg <> ": "
91− unableToParse = withText Left
85+ showJSON :: A.Value -> Text
86+ showJSON = TE.decodeUtf8 . BS.toStrict . A.encode
94−-- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier
89+-- This type is isomorphic to 'Maybe' 'ModuleName'. It makes code a bit
95−-- to read, as the meaning is more explicit.
90+-- easier to read, as the meaning is more explicit.
97data ContainingModule
92data ContainingModule
98 = ThisModule
93 = ThisModule
99− | OtherModule P.ModuleName
94+ | OtherModule ModuleName
100 deriving (Show, Eq, Ord)
95 deriving (Show, Eq, Ord)
102instance A.ToJSON ContainingModule where
97instance A.ToJSON ContainingModule where
103− toJSON mn = A.toJSON (P.runModuleName <$> containingModuleToMaybe mn)
98+ toJSON = A.toJSON . go
101+ ThisModule -> ["ThisModule"]
102+ OtherModule mn -> ["OtherModule", runModuleName mn]
104+instance A.FromJSON ContainingModule where
105+ parseJSON = toAesonParser id asContainingModule
105−asContainingModule :: Parse e ContainingModule
107+asContainingModule :: Parse Text ContainingModule
106asContainingModule =
108asContainingModule =
109+ tryParse "containing module" $
110+ current ++ backwardsCompat
113+ [ firstEq "ThisModule" (pure ThisModule)
114+ , firstEq "OtherModule" (OtherModule <$> nth 1 asModuleName)
117+ -- For JSON produced by compilers up to 0.10.5.
107− maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asText)
119+ [ maybeToContainingModule <$> perhaps asModuleName
122+ asModuleName = moduleNameFromString <$> asText
110−-- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious
125+-- Convert a 'Maybe' 'ModuleName' to a 'ContainingModule', using the obvious
111-- isomorphism.
126-- isomorphism.
113−maybeToContainingModule :: Maybe P.ModuleName -> ContainingModule
128+maybeToContainingModule :: Maybe ModuleName -> ContainingModule
114maybeToContainingModule Nothing = ThisModule
129maybeToContainingModule Nothing = ThisModule
115maybeToContainingModule (Just mn) = OtherModule mn
130maybeToContainingModule (Just mn) = OtherModule mn
118−-- Convert a 'ContainingModule' to a 'Maybe' 'P.ModuleName', using the obvious
133+-- Convert a 'ContainingModule' to a 'Maybe' 'ModuleName', using the obvious
119-- isomorphism.
134-- isomorphism.
121−containingModuleToMaybe :: ContainingModule -> Maybe P.ModuleName
136+containingModuleToMaybe :: ContainingModule -> Maybe ModuleName
122containingModuleToMaybe ThisModule = Nothing
137containingModuleToMaybe ThisModule = Nothing
123containingModuleToMaybe (OtherModule mn) = Just mn
138containingModuleToMaybe (OtherModule mn) = Just mn
126-- A version of 'fromMaybe' for 'ContainingModule' values.
141-- A version of 'fromMaybe' for 'ContainingModule' values.
128−fromContainingModule :: P.ModuleName -> ContainingModule -> P.ModuleName
143+fromContainingModule :: ModuleName -> ContainingModule -> ModuleName
129fromContainingModule def ThisModule = def
144fromContainingModule def ThisModule = def
130fromContainingModule _ (OtherModule mn) = mn
145fromContainingModule _ (OtherModule mn) = mn
147+fromQualified :: Qualified a -> (ContainingModule, a)
148+fromQualified (Qualified mn x) =
149+ (maybeToContainingModule mn, x)
153+ | Link ContainingModule
154+ deriving (Show, Eq, Ord)
156+instance A.ToJSON Link where
158+ NoLink -> A.toJSON ["NoLink" :: Text]
159+ Link mn -> A.toJSON ["Link", A.toJSON mn]
161+asLink :: Parse Text Link
164+ [ firstEq "NoLink" (pure NoLink)
165+ , firstEq "Link" (Link <$> nth 1 asContainingModule)
168+instance A.FromJSON Link where
169+ parseJSON = toAesonParser id asLink
175+ deriving (Show, Eq, Ord, Generic)
177+instance NFData Namespace
179+instance A.ToJSON Namespace where
180+ toJSON = A.toJSON . show
182+asNamespace :: Parse Text Namespace
184+ tryParse "namespace"
186+ "ValueLevel" -> Right ValueLevel
187+ "TypeLevel" -> Right TypeLevel
188+ "KindLevel" -> Right KindLevel
192+instance A.FromJSON Namespace where
193+ parseJSON = toAesonParser id asNamespace
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.
199+data RenderedCodeElement
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)
209+instance A.ToJSON RenderedCodeElement where
210+ toJSON (Syntax str) =
211+ A.toJSON ["syntax", str]
212+ toJSON (Keyword str) =
213+ A.toJSON ["keyword", str]
215+ A.toJSON ["space" :: Text]
216+ toJSON (Symbol ns str link) =
217+ A.toJSON ["symbol", A.toJSON ns, A.toJSON str, A.toJSON link]
219+asRenderedCodeElement :: Parse Text RenderedCodeElement
220+asRenderedCodeElement =
221+ tryParse "RenderedCodeElement" $
223+ , a Keyword "keyword"
226+ ] ++ backwardsCompat
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)
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.
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))
133-- A type representing a highly simplified version of PureScript code, intended
246-- A type representing a highly simplified version of PureScript code, intended
134-- for use in output formats like plain text or HTML.
247-- for use in output formats like plain text or HTML.
@@ -158,21 +271,17 @@ outputWith f = foldMap f . unRC
158sp :: RenderedCode
271sp :: RenderedCode
159sp = RC [Space]
272sp = RC [Space]
275+-- Wrap a RenderedCode value in parens.
276+parens :: RenderedCode -> RenderedCode
277+parens x = syntax "(" <> x <> syntax ")"
279+-- possible TODO: instead of this function, export RenderedCode values for
280+-- each syntax element, eg syntaxArr (== syntax "->"), syntaxLBrace,
281+-- syntaxRBrace, etc.
161syntax :: Text -> RenderedCode
282syntax :: Text -> RenderedCode
162syntax x = RC [Syntax x]
283syntax x = RC [Syntax x]
164−ident :: Text -> RenderedCode
165−ident x = RC [Ident x ThisModule]
167−ident' :: Text -> ContainingModule -> RenderedCode
168−ident' x m = RC [Ident x m]
170−ctor :: Text -> ContainingModule -> RenderedCode
171−ctor x m = RC [Ctor x m]
173−kind :: Text -> RenderedCode
176keyword :: Text -> RenderedCode
285keyword :: Text -> RenderedCode
177keyword kw = RC [Keyword kw]
286keyword kw = RC [Keyword kw]
@@ -197,10 +306,78 @@ keywordInstance = keyword "instance"
197keywordWhere :: RenderedCode
306keywordWhere :: RenderedCode
198keywordWhere = keyword "where"
307keywordWhere = keyword "where"
200−keywordFixity :: P.Associativity -> RenderedCode
309+keywordFixity :: Associativity -> RenderedCode
201−keywordFixity P.Infixl = keyword "infixl"
310+keywordFixity Infixl = keyword "infixl"
202−keywordFixity P.Infixr = keyword "infixr"
311+keywordFixity Infixr = keyword "infixr"
203−keywordFixity P.Infix = keyword "infix"
312+keywordFixity Infix = keyword "infix"
205keywordKind :: RenderedCode
314keywordKind :: RenderedCode
206keywordKind = keyword "kind"
315keywordKind = keyword "kind"
317+keywordAs :: RenderedCode
318+keywordAs = keyword "as"
320+ident :: Qualified Ident -> RenderedCode
321+ident (fromQualified -> (mn, name)) =
322+ RC [Symbol ValueLevel (runIdent name) (Link mn)]
324+dataCtor :: Qualified (ProperName 'ConstructorName) -> RenderedCode
325+dataCtor (fromQualified -> (mn, name)) =
326+ RC [Symbol ValueLevel (runProperName name) (Link mn)]
328+typeCtor :: Qualified (ProperName 'TypeName) -> RenderedCode
329+typeCtor (fromQualified -> (mn, name)) =
330+ RC [Symbol TypeLevel (runProperName name) (Link mn)]
332+typeOp :: Qualified (OpName 'TypeOpName) -> RenderedCode
333+typeOp (fromQualified -> (mn, name)) =
334+ RC [Symbol TypeLevel (runOpName name) (Link mn)]
336+typeVar :: Text -> RenderedCode
337+typeVar x = RC [Symbol TypeLevel x NoLink]
339+kind :: Qualified (ProperName 'KindName) -> RenderedCode
340+kind (fromQualified -> (mn, name)) =
341+ RC [Symbol KindLevel (runProperName name) (Link mn)]
343+type FixityAlias = Qualified (Either (ProperName 'TypeName) (Either Ident (ProperName 'ConstructorName)))
345+alias :: FixityAlias -> RenderedCode
347+ prefix <> RC [Symbol ns name (Link mn)]
349+ (ns, name, mn) = unpackFixityAlias for
356+aliasName :: FixityAlias -> Text -> RenderedCode
357+aliasName for name' =
359+ (ns, _, _) = unpackFixityAlias for
360+ unParen = T.tail . T.init
361+ name = unParen name'
365+ ident (Qualified Nothing (Ident name))
367+ typeCtor (Qualified Nothing (ProperName name))
369+ internalError "Kind aliases are not supported"
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)) =
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)
381+ (ValueLevel, runIdent n, mn)
382+ Right (Right (n :: ProperName 'ConstructorName)) ->
383+ (ValueLevel, runProperName n, mn)