@@ -5,16 +5,17 @@
55
66-- | Functions for rendering documentation generated from PureScript code.
77
8−module Language.PureScript.Docs.Render (
9− renderModule,
10− collectBookmarks
11−) where
8+module Language.PureScript.Docs.Render
9+ ( renderModule
10+ , collectBookmarks
11+ ) where
1212
1313import Control.Monad
14+import Control.Category ((>>>))
1415import Data.Either
1516import Data.Monoid ((<>))
16−import Data.Maybe (mapMaybe)
17−import Data.List (nub)
17+import Data.Maybe (mapMaybe, isNothing)
18+import Data.List (nub, isPrefixOf, isSuffixOf)
1819
1920import qualified Language.PureScript as P
2021
@@ -27,51 +28,82 @@ import Language.PureScript.Docs.Utils.MonoidExtras
2728--
2829renderModule :: P.Module -> RenderedModule
2930renderModule m@(P.Module coms moduleName _ _) =
30− RenderedModule (show moduleName) comments declarations
31+ RenderedModule (show moduleName) comments (declarations m)
3132 where
3233 comments = renderComments coms
33− declarations = groupChildren declarationsWithChildren
34− declarationsWithChildren = mapMaybe go (P.exportedDeclarations m)
35− go decl = getDeclarationTitle decl
36− >>= renderDeclaration decl
37−
38−-- | An intermediate stage which we go through during rendering.
34+ declarations =
35+ P.exportedDeclarations
36+ >>> mapMaybe (\d -> getDeclarationTitle d >>= renderDeclaration d)
37+ >>> augmentDeclarations
38+ >>> map addDefaultFixity
39+
40+-- | The data type for an intermediate stage which we go through during
41+-- rendering.
3942--
4043-- In the first pass, we take all top level declarations in the module, and
41−-- render those which should appear at the top level in the output, as well as
42−-- those which should appear as children of other declarations in the output.
44+-- collect other information which will later be used to augment the top level
45+-- declarations. These two situation correspond to the Right and Left
46+-- constructors, respectively.
4347--
44−-- In the second pass, we move all children under their respective parents,
45−-- or discard them if none are found.
48+-- In the second pass, we go over all of the Left values and augment the
49+-- relevant declarations, leaving only the augmented Right values.
4650--
47−-- This two-pass system is only necessary for type instance declarations, since
48−-- they appear at the top level in the AST, and since they might need to appear
49−-- as children in two places (for example, if a data type defined in a module
50−-- is an instance of a type class also defined in that module).
51+-- Note that in the Left case, we provide a [String] as well as augment
52+-- information. The [String] value should be a list of titles of declarations
53+-- that the augmentation should apply to. For example, for a type instance
54+-- declaration, that would be any types or type classes mentioned in the
55+-- instance. For a fixity declaration, it would be just the relevant operator's
56+-- name.
57+type IntermediateDeclaration
58+ = Either ([String], DeclarationAugment) RenderedDeclaration
59+
60+-- | Some data which will be used to augment a RenderedDeclaration in the
61+-- output.
5162--
52−-- This data type is used as an intermediate type between the two stages. The
53−-- Left case is a child declaration, together with a list of parent declaration
54−-- titles which this may appear as a child of.
63+-- The AugmentChild constructor allows us to move all children under their
64+-- respective parents. It is only necessary for type instance declarations,
65+-- since they appear at the top level in the AST, and since they might need to
66+-- appear as children in two places (for example, if a data type defined in a
67+-- module is an instance of a type class also defined in that module).
5568--
56−-- The Right case is a top level declaration which should pass straight through
57−-- the second stage; the only way it might change is if child declarations are
58−-- added to it.
59−type IntermediateDeclaration
60− = Either ([String], RenderedChildDeclaration) RenderedDeclaration
61−
62−-- | Move child declarations into their respective parents; the second pass.
63−-- See the comments under the type synonym IntermediateDeclaration for more
64−-- information.
65−groupChildren :: [IntermediateDeclaration] -> [RenderedDeclaration]
66−groupChildren (partitionEithers -> (children, toplevels)) =
67− foldl go toplevels children
69+-- The AugmentFixity constructor allows us to augment operator definitions
70+-- with their associativity and precedence.
71+data DeclarationAugment
72+ = AugmentChild RenderedChildDeclaration
73+ | AugmentFixity P.Fixity
74+
75+-- | Augment top-level declarations; the second pass. See the comments under
76+-- the type synonym IntermediateDeclaration for more information.
77+augmentDeclarations :: [IntermediateDeclaration] -> [RenderedDeclaration]
78+augmentDeclarations (partitionEithers -> (augments, toplevels)) =
79+ foldl go toplevels augments
6880 where
69− go ds (parentTitles, child) =
81+ go ds (parentTitles, a) =
7082 map (\d ->
7183 if rdTitle d `elem` parentTitles
72− then d { rdChildren = rdChildren d ++ [child] }
84+ then augmentWith a d
7385 else d) ds
7486
87+ augmentWith a d =
88+ case a of
89+ AugmentChild child ->
90+ d { rdChildren = rdChildren d ++ [child] }
91+ AugmentFixity fixity ->
92+ d { rdFixity = Just fixity }
93+
94+-- | Add the default operator fixity for operators which do not have associated
95+-- fixity declarations.
96+--
97+-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
98+-- in 0.8.
99+addDefaultFixity :: RenderedDeclaration -> RenderedDeclaration
100+addDefaultFixity rd@RenderedDeclaration{..}
101+ | isOp rdTitle && isNothing rdFixity = rd { rdFixity = Just defaultFixity }
102+ | otherwise = rd
103+ where
104+ isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
105+ defaultFixity = P.Fixity P.Infixl (-1)
106+
75107getDeclarationTitle :: P.Declaration -> Maybe String
76108getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
77109getDeclarationTitle (P.ExternDeclaration name _) = Just (show name)
@@ -80,11 +112,23 @@ getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
80112getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
81113getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
82114getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
115+getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")")
83116getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
84117getDeclarationTitle _ = Nothing
85118
119+-- | Create a basic RenderedDeclaration value.
120+mkDeclaration :: String -> RenderedCode -> RenderedDeclaration
121+mkDeclaration title code =
122+ RenderedDeclaration { rdTitle = title
123+ , rdComments = Nothing
124+ , rdCode = code
125+ , rdSourceSpan = Nothing
126+ , rdChildren = []
127+ , rdFixity = Nothing
128+ }
129+
86130basicDeclaration :: String -> RenderedCode -> Maybe IntermediateDeclaration
87−basicDeclaration title code = Just (Right (RenderedDeclaration title Nothing code Nothing []))
131+basicDeclaration title code = Just $ Right $ mkDeclaration title code
88132
89133renderDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
90134renderDeclaration (P.TypeDeclaration ident' ty) title =
@@ -100,7 +144,7 @@ renderDeclaration (P.ExternDeclaration ident' ty) title =
100144 <> sp <> syntax "::" <> sp
101145 <> renderType ty
102146renderDeclaration (P.DataDeclaration dtype name args ctors) title =
103− Just (Right (RenderedDeclaration title Nothing code Nothing children))
147+ Just (Right (mkDeclaration title code) { rdChildren = children })
104148 where
105149 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
106150 code = keyword (show dtype) <> sp <> renderType typeApp
@@ -128,7 +172,7 @@ renderDeclaration (P.TypeSynonymDeclaration name args ty) title =
128172 , renderType ty
129173 ]
130174renderDeclaration (P.TypeClassDeclaration name args implies ds) title = do
131− Just (Right (RenderedDeclaration title Nothing code Nothing children))
175+ Just (Right (mkDeclaration title code) { rdChildren = children })
132176 where
133177 code = mintersperse sp $
134178 [keywordClass]
@@ -163,7 +207,7 @@ renderDeclaration (P.TypeClassDeclaration name args implies ds) title = do
163207 in RenderedChildDeclaration (show ident') Nothing childCode Nothing ChildTypeClassMember
164208 renderClassMember _ = error "Invalid argument to renderClassMember."
165209renderDeclaration (P.TypeInstanceDeclaration name constraints className tys _) title = do
166− Just (Left (classNameString : typeNameStrings, childDecl))
210+ Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
167211 where
168212 classNameString = unQual className
169213 typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
@@ -194,14 +238,27 @@ renderDeclaration (P.TypeInstanceDeclaration name constraints className tys _) t
194238 in renderType supApp
195239
196240 classApp = foldl P.TypeApp (P.TypeConstructor className) tys
241+renderDeclaration (P.FixityDeclaration fixity _) title =
242+ Just (Left ([title], AugmentFixity fixity))
197243renderDeclaration (P.PositionedDeclaration srcSpan com d') title =
198244 fmap (addComments . addSourceSpan) (renderDeclaration d' title)
199245 where
200− addComments (Left (t, d)) = Left (t, d { rcdComments = renderComments com })
201− addComments (Right d) = Right (d { rdComments = renderComments com })
202−
203− addSourceSpan (Left (t, d)) = Left (t, d { rcdSourceSpan = Just srcSpan })
204− addSourceSpan (Right d) = Right (d { rdSourceSpan = Just srcSpan })
246+ addComments (Right d) =
247+ Right (d { rdComments = renderComments com })
248+ addComments (Left augment) =
249+ Left (withAugmentChild (\d -> d { rcdComments = renderComments com })
250+ augment)
251+
252+ addSourceSpan (Right d) =
253+ Right (d { rdSourceSpan = Just srcSpan })
254+ addSourceSpan (Left augment) =
255+ Left (withAugmentChild (\d -> d { rcdSourceSpan = Just srcSpan })
256+ augment)
257+
258+ withAugmentChild f (t, a) =
259+ case a of
260+ AugmentChild d -> (t, AugmentChild (f d))
261+ _ -> (t, a)
205262renderDeclaration _ _ = Nothing
206263
207264renderComments :: [P.Comment] -> Maybe String