git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Documentation for re-exports (fixes #1677)

* Add a new field in Language.PureScript.Docs.Types.Module for re-exported declarations * Split two child modules out of Language.PureScript.Docs.Convert: Single, which is essentially what Convert previously was, and ReExports, which handles re-exports. * Handle re-exports while converting declarations for documentation (which were previously just ignored). Notably, converting docs can now throw MultipleErrors as a result (although if the code compiles normally, it should always succeed here too). * Update Language.PureScript.Docs.AsMarkdown to include re-exports in the generated documentation. * Export more values from Language.PureScript.Docs.AsMarkdown (because psc-docs needs them now) As an incidental consequence of the above changes, this commit also fixes #1681.

commitc0aeec91681fb4486051ab607bc8c6f6d40fd924 authorHarry Garrood <harry@garrood.me> dateTue 29 Dec 2015, 08:48 (11 years ago) parentc3b8b36
10 files changed+877−254
compare with golang
unifiedsplit
psc-docs/Main.hs+43−30 purescript.cabal+2 src/Language/PureScript/Docs/AsMarkdown.hs+26−7 src/Language/PureScript/Docs/Convert.hs+56−200 src/Language/PureScript/Docs/Convert/ReExports.hs+444 src/Language/PureScript/Docs/Convert/Single.hs+230 src/Language/PureScript/Docs/ParseAndDesugar.hs+5−5 src/Language/PureScript/Docs/Render.hs+1−4 src/Language/PureScript/Docs/Types.hs+66−6 src/Language/PureScript/Publish.hs+4−2
psc-docs/Main.hs+43−30
@@ -69,55 +69,68 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
6969 Etags -> dumpTags input dumpEtags
7070 Ctags -> dumpTags input dumpCtags
7171 Markdown -> do
72− e <- liftIO . runExceptT $ D.parseAndDesugar input []
73− case e of
74− Left err -> do
75− hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
76− exitFailure
77− Right (ms', _, _) ->
78− case output of
79− EverythingToStdOut ->
80− putStrLn (D.renderModulesAsMarkdown ms')
81− ToStdOut names -> do
82− let (ms, missing) = takeModulesByName ms' names
83− guardMissing missing
84− putStrLn (D.renderModulesAsMarkdown ms)
85− ToFiles names -> do
86− let (ms, missing) = takeModulesByName' ms' names
87− guardMissing missing
88− let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms
89− forM_ ms'' $ \grp -> do
90− let fp = fst (head grp)
91− createDirectoryIfMissing True (takeDirectory fp)
92− writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)
72+ ms <- runExceptT (D.parseAndDesugar input []
73+ >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))
74+ >>= successOrExit
75+
76+ case output of
77+ EverythingToStdOut ->
78+ putStrLn (D.runDocs (D.modulesAsMarkdown ms))
79+ ToStdOut names -> do
80+ let (ms', missing) = takeByName ms (map P.runModuleName names)
81+ guardMissing missing
82+ putStrLn (D.runDocs (D.modulesAsMarkdown ms'))
83+ ToFiles names -> do
84+ let (ms', missing) = takeByName' ms (map (first P.runModuleName) names)
85+ guardMissing missing
86+
87+ let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'
88+ forM_ ms'' $ \grp -> do
89+ let fp = fst (head grp)
90+ createDirectoryIfMissing True (takeDirectory fp)
91+ writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))
92+
9393 where
9494 guardMissing [] = return ()
9595 guardMissing [mn] = do
96− hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")
96+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"")
9797 exitFailure
9898 guardMissing mns = do
9999 hPutStrLn stderr "psc-docs: error: unknown modules:"
100100 forM_ mns $ \mn ->
101− hPutStrLn stderr (" * " ++ show mn)
101+ hPutStrLn stderr (" * " ++ mn)
102102 exitFailure
103103
104+ successOrExit :: Either P.MultipleErrors a -> IO a
105+ successOrExit act =
106+ case act of
107+ Right x ->
108+ return x
109+ Left err -> do
110+ hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
111+ exitFailure
112+
113+ takeByName = takeModulesByName D.modName
114+ takeByName' = takeModulesByName' D.modName
115+
104116-- |
105117-- Given a list of module names and a list of modules, return a list of modules
106118-- whose names appeared in the given name list, together with a list of names
107119-- for which no module could be found in the module list.
108120--
109−takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])
110−takeModulesByName modules names =
111− first (map fst) (takeModulesByName' modules (map (,()) names))
121+takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n])
122+takeModulesByName getModuleName modules names =
123+ first (map fst) (takeModulesByName' getModuleName modules (map (,()) names))
112124
113125-- |
114−-- Like takeModulesByName but also keeps some extra data with the module.
126+-- Like takeModulesByName, but also keeps some extra information with each
127+-- module.
115128--
116−takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])
117−takeModulesByName' modules = foldl go ([], [])
129+takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n])
130+takeModulesByName' getModuleName modules = foldl go ([], [])
118131 where
119132 go (ms, missing) (name, x) =
120− case find ((== name) . P.getModuleName) modules of
133+ case find ((== name) . getModuleName) modules of
121134 Just m -> ((m, x) : ms, missing)
122135 Nothing -> (ms, name : missing)
123136
purescript.cabal+2
@@ -162,6 +162,8 @@ library
162162
163163 Language.PureScript.Docs
164164 Language.PureScript.Docs.Convert
165+ Language.PureScript.Docs.Convert.Single
166+ Language.PureScript.Docs.Convert.ReExports
165167 Language.PureScript.Docs.Render
166168 Language.PureScript.Docs.Types
167169 Language.PureScript.Docs.RenderedCode
src/Language/PureScript/Docs/AsMarkdown.hs+26−7
@@ -1,10 +1,19 @@
11{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE FlexibleContexts #-}
23
3−module Language.PureScript.Docs.AsMarkdown (
4− renderModulesAsMarkdown
5−) where
4+module Language.PureScript.Docs.AsMarkdown
5+ ( renderModulesAsMarkdown
6+ , Docs
7+ , runDocs
8+ , modulesAsMarkdown
9+ ) where
610
7−import Control.Monad.Writer hiding (First)
11+import Prelude ()
12+import Prelude.Compat
13+
14+import Control.Monad (unless, zipWithM_)
15+import Control.Monad.Writer (Writer, tell, execWriter)
16+import Control.Monad.Error.Class (MonadError)
817import Data.Foldable (for_)
918import Data.List (partition)
1019
@@ -19,9 +28,14 @@ import qualified Language.PureScript.Docs.Render as Render
1928-- Take a list of modules and render them all in order, returning a single
2029-- Markdown-formatted String.
2130--
22−renderModulesAsMarkdown :: [P.Module] -> String
23−renderModulesAsMarkdown =
24− runDocs . modulesAsMarkdown . map Convert.convertModule
31+renderModulesAsMarkdown ::
32+ (Functor m, Applicative m,
33+ MonadError P.MultipleErrors m) =>
34+ P.Env ->
35+ [P.Module] ->
36+ m String
37+renderModulesAsMarkdown env =
38+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env
2539
2640modulesAsMarkdown :: [Module] -> Docs
2741modulesAsMarkdown = mapM_ moduleAsMarkdown
@@ -33,6 +47,11 @@ moduleAsMarkdown Module{..} = do
3347 for_ modComments tell'
3448 mapM_ (declAsMarkdown modName) modDeclarations
3549 spacer
50+ for_ modReExports $ \(mn, decls) -> do
51+ let modName' = P.runModuleName mn
52+ headerLevel 3 $ "Re-exported from " ++ modName' ++ ":"
53+ spacer
54+ mapM_ (declAsMarkdown modName') decls
3655
3756declAsMarkdown :: String -> Declaration -> Docs
3857declAsMarkdown mn decl@Declaration{..} = do
src/Language/PureScript/Docs/Convert.hs+56−200
@@ -2,230 +2,86 @@
22{-# LANGUAGE OverloadedStrings #-}
33{-# LANGUAGE RecordWildCards #-}
44{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE FlexibleContexts #-}
56
67-- | Functions for converting PureScript ASTs into values of the data types
78-- from Language.PureScript.Docs.
89
910module Language.PureScript.Docs.Convert
10− ( convertModule
11+ ( convertModules
12+ , convertModulesInPackage
1113 , collectBookmarks
1214 ) where
1315
1416import Prelude ()
1517import Prelude.Compat
1618
17−import Control.Monad
19+import Control.Monad.Error.Class (MonadError)
20+import Control.Arrow ((&&&))
1821import Control.Category ((>>>))
19−import Data.Either
20−import Data.Maybe (mapMaybe, isNothing)
21−import Data.List (nub, isPrefixOf, isSuffixOf)
22+import qualified Data.Map as Map
2223
2324import qualified Language.PureScript as P
2425
2526import Language.PureScript.Docs.Types
27+import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)
28+import Language.PureScript.Docs.Convert.ReExports (updateReExports)
2629
2730-- |
28−-- Convert a single Module.
31+-- Like convertModules, except that it takes a list of modules, together with
32+-- their dependency status, and discards dependency modules in the resulting
33+-- documentation.
2934--
30−convertModule :: P.Module -> Module
31−convertModule m@(P.Module _ coms moduleName _ _) =
32− Module (P.runModuleName moduleName) comments (declarations m)
35+convertModulesInPackage ::
36+ (Functor m, MonadError P.MultipleErrors m) =>
37+ P.Env ->
38+ [InPackage P.Module] ->
39+ m [Module]
40+convertModulesInPackage env modules =
41+ go modules
3342 where
34− comments = convertComments coms
35− declarations =
36− P.exportedDeclarations
37− >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
38− >>> augmentDeclarations
39− >>> map addDefaultFixity
43+ localNames =
44+ map (P.runModuleName . P.getModuleName) (takeLocals modules)
45+ go =
46+ map ignorePackage
47+ >>> convertModules env
48+ >>> fmap (filter ((`elem` localNames) . modName))
4049
41−-- | The data type for an intermediate stage which we go through during
42−-- converting.
43−--
44−-- In the first pass, we take all top level declarations in the module, and
45−-- collect other information which will later be used to augment the top level
46−-- declarations. These two situation correspond to the Right and Left
47−-- constructors, respectively.
50+-- |
51+-- Convert a group of modules to the intermediate format, designed for
52+-- producing documentation from. It is also necessary to pass an Env containing
53+-- imports/exports information about the list of modules, which is needed for
54+-- documenting re-exports.
4855--
49−-- In the second pass, we go over all of the Left values and augment the
50−-- relevant declarations, leaving only the augmented Right values.
56+-- Preconditions:
5157--
52−-- Note that in the Left case, we provide a [String] as well as augment
53−-- information. The [String] value should be a list of titles of declarations
54−-- that the augmentation should apply to. For example, for a type instance
55−-- declaration, that would be any types or type classes mentioned in the
56−-- instance. For a fixity declaration, it would be just the relevant operator's
57−-- name.
58−type IntermediateDeclaration
59− = Either ([String], DeclarationAugment) Declaration
60−
61−-- | Some data which will be used to augment a Declaration in the
62−-- output.
58+-- * If any module in the list re-exports documentation from other
59+-- modules, those modules must also be included in the list.
60+-- * The modules passed must have had names desugared and re-exports
61+-- elaborated first.
6362--
64−-- The AugmentChild constructor allows us to move all children under their
65−-- respective parents. It is only necessary for type instance declarations,
66−-- since they appear at the top level in the AST, and since they might need to
67−-- appear as children in two places (for example, if a data type defined in a
68−-- module is an instance of a type class also defined in that module).
63+-- If either of these are not satisfied, an internal error will be thrown. To
64+-- avoid this, it is recommended to use
65+-- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this
66+-- function.
6967--
70−-- The AugmentFixity constructor allows us to augment operator definitions
71−-- with their associativity and precedence.
72−data DeclarationAugment
73− = AugmentChild ChildDeclaration
74− | AugmentFixity P.Fixity
68+convertModules ::
69+ (Functor m, MonadError P.MultipleErrors m) =>
70+ P.Env ->
71+ [P.Module] ->
72+ m [Module]
73+convertModules env =
74+ P.sortModules >>> fmap (convertSorted env . fst)
7575
76−-- | Augment top-level declarations; the second pass. See the comments under
77−-- the type synonym IntermediateDeclaration for more information.
78−augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
79−augmentDeclarations (partitionEithers -> (augments, toplevels)) =
80− foldl go toplevels augments
81− where
82− go ds (parentTitles, a) =
83− map (\d ->
84− if declTitle d `elem` parentTitles
85− then augmentWith a d
86− else d) ds
87−
88− augmentWith a d =
89− case a of
90− AugmentChild child ->
91− d { declChildren = declChildren d ++ [child] }
92− AugmentFixity fixity ->
93− d { declFixity = Just fixity }
94−
95−-- | Add the default operator fixity for operators which do not have associated
96−-- fixity declarations.
76+-- |
77+-- Convert a sorted list of modules.
9778--
98−-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
99−-- in 0.9.
100−addDefaultFixity :: Declaration -> Declaration
101−addDefaultFixity decl@Declaration{..}
102− | isOp declTitle && isNothing declFixity =
103− decl { declFixity = Just defaultFixity }
104− | otherwise =
105− decl
106− where
107− isOp :: String -> Bool
108− isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
109− defaultFixity = P.Fixity P.Infixl (-1)
110−
111−getDeclarationTitle :: P.Declaration -> Maybe String
112−getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)
113−getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)
114−getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
115−getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
116−getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
117−getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)
118−getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
119−getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")
120−getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
121−getDeclarationTitle _ = Nothing
122−
123−-- | Create a basic Declaration value.
124−mkDeclaration :: String -> DeclarationInfo -> Declaration
125−mkDeclaration title info =
126− Declaration { declTitle = title
127− , declComments = Nothing
128− , declSourceSpan = Nothing
129− , declChildren = []
130− , declFixity = Nothing
131− , declInfo = info
132− }
133−
134−basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration
135−basicDeclaration title info = Just $ Right $ mkDeclaration title info
136−
137−convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
138−convertDeclaration (P.TypeDeclaration _ ty) title =
139− basicDeclaration title (ValueDeclaration ty)
140−convertDeclaration (P.ExternDeclaration _ ty) title =
141− basicDeclaration title (ValueDeclaration ty)
142−convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
143− Just (Right (mkDeclaration title info) { declChildren = children })
144− where
145− info = DataDeclaration dtype args
146− children = map convertCtor ctors
147− convertCtor (ctor', tys) =
148− ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)
149−convertDeclaration (P.ExternDataDeclaration _ kind') title =
150− basicDeclaration title (ExternDataDeclaration kind')
151−convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
152− basicDeclaration title (TypeSynonymDeclaration args ty)
153−convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =
154− Just (Right (mkDeclaration title info) { declChildren = children })
155− where
156− info = TypeClassDeclaration args implies
157− children = map convertClassMember ds
158− convertClassMember (P.PositionedDeclaration _ _ d) =
159− convertClassMember d
160− convertClassMember (P.TypeDeclaration ident' ty) =
161− ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)
162− convertClassMember _ =
163− P.internalError "convertDeclaration: Invalid argument to convertClassMember."
164−convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =
165− Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
166− where
167− classNameString = unQual className
168− typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
169− unQual x = let (P.Qualified _ y) = x in P.runProperName y
170−
171− extractProperNames (P.TypeConstructor n) = [unQual n]
172− extractProperNames _ = []
173−
174− childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
175− classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys
176−convertDeclaration (P.FixityDeclaration fixity _ Nothing) title =
177− Just (Left ([title], AugmentFixity fixity))
178−convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title =
179− Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity }
180−convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
181− fmap (addComments . addSourceSpan) (convertDeclaration d' title)
182− where
183− addComments (Right d) =
184− Right (d { declComments = convertComments com })
185− addComments (Left augment) =
186− Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })
187− augment)
188−
189− addSourceSpan (Right d) =
190− Right (d { declSourceSpan = Just srcSpan })
191− addSourceSpan (Left augment) =
192− Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })
193− augment)
194−
195− withAugmentChild f (t, a) =
196− case a of
197− AugmentChild d -> (t, AugmentChild (f d))
198− _ -> (t, a)
199−convertDeclaration _ _ = Nothing
200−
201−convertComments :: [P.Comment] -> Maybe String
202−convertComments cs = do
203− let raw = concatMap toLines cs
204− guard (all hasPipe raw && not (null raw))
205− return (go raw)
206− where
207− go = unlines . map stripPipes
208−
209− toLines (P.LineComment s) = [s]
210− toLines (P.BlockComment s) = lines s
211−
212− hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
213−
214− stripPipes = dropPipe . dropWhile (== ' ')
215−
216− dropPipe ('|':' ':s) = s
217− dropPipe ('|':s) = s
218− dropPipe s = s
219−
220−-- | Go through a PureScript module and extract a list of Bookmarks; references
221−-- to data types or values, to be used as a kind of index. These are used for
222−-- generating links in the HTML documentation, for example.
223−collectBookmarks :: InPackage P.Module -> [Bookmark]
224−collectBookmarks (Local m) = map Local (collectBookmarks' m)
225−collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
226−
227−collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
228−collectBookmarks' m =
229− map (P.getModuleName m, )
230− (mapMaybe getDeclarationTitle
231− (P.exportedDeclarations m))
79+convertSorted :: P.Env -> [P.Module] -> [Module]
80+convertSorted env modules =
81+ let
82+ traversalOrder =
83+ map P.getModuleName modules
84+ moduleMap =
85+ Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules
86+ in
87+ Map.elems (updateReExports env traversalOrder moduleMap)
src/Language/PureScript/Docs/Convert/ReExports.hsnew file+444
@@ -0,0 +1,444 @@
1+{-# LANGUAGE ViewPatterns #-}
2+{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+
6+module Language.PureScript.Docs.Convert.ReExports
7+ ( updateReExports
8+ ) where
9+
10+import Prelude ()
11+import Prelude.Compat
12+
13+import Control.Monad
14+import Control.Monad.Trans.State.Strict (execState)
15+import Control.Monad.State.Class (MonadState, gets, modify)
16+import Control.Arrow ((&&&), first, second)
17+import Data.Either
18+import Data.Maybe (mapMaybe)
19+import Data.Map (Map)
20+import qualified Data.Map as Map
21+import Data.Monoid ((<>))
22+
23+import qualified Language.PureScript as P
24+
25+import Language.PureScript.Docs.Types
26+
27+-- |
28+-- Given:
29+--
30+-- * The Imports/Exports Env
31+-- * An order to traverse the modules (which must be topological)
32+-- * A map of modules, indexed by their names, which are assumed to not
33+-- have their re-exports listed yet
34+--
35+-- This function adds all the missing re-exports.
36+--
37+updateReExports ::
38+ P.Env ->
39+ [P.ModuleName] ->
40+ Map P.ModuleName Module ->
41+ Map P.ModuleName Module
42+updateReExports env order modules =
43+ execState action modules
44+ where
45+ action =
46+ void (traverse go order)
47+
48+ go mn = do
49+ mdl <- lookup' mn
50+ reExports <- getReExports env mn
51+ let mdl' = mdl { modReExports = reExports }
52+ modify (Map.insert mn mdl')
53+
54+ lookup' mn = do
55+ v <- gets (Map.lookup mn)
56+ case v of
57+ Just v' ->
58+ pure v'
59+ Nothing ->
60+ internalError ("Module missing: " ++ P.runModuleName mn)
61+
62+-- |
63+-- Collect all of the re-exported declarations for a single module.
64+--
65+-- We require that modules have already been sorted (P.sortModules) in order to
66+-- ensure that by the time we convert a particular module, all its dependencies
67+-- have already been converted.
68+--
69+getReExports ::
70+ (Functor m, Applicative m,
71+ MonadState (Map P.ModuleName Module) m) =>
72+ P.Env ->
73+ P.ModuleName ->
74+ m [(P.ModuleName, [Declaration])]
75+getReExports env mn =
76+ case Map.lookup mn env of
77+ Nothing ->
78+ internalError ("Module missing: " ++ P.runModuleName mn)
79+ Just (_, imports, exports) ->
80+ let notLocal = (/= mn) . fst
81+ in filter notLocal <$> collectDeclarations imports exports
82+
83+-- |
84+-- Assemble a list of declarations re-exported from a particular module, based
85+-- on the Imports and Exports value for that module, and by extracting the
86+-- declarations from the current state.
87+--
88+-- This function works by searching through the lists of exported declarations
89+-- in the Exports, and looking them up in the associated Imports value to find
90+-- the module they were imported from.
91+--
92+-- Additionally:
93+--
94+-- * Attempts to move re-exported type class members under their parent
95+-- type classes, if possible, or otherwise, "promote" them from
96+-- ChildDeclarations to proper Declarations.
97+-- * Filters data declarations to ensure that only re-exported data
98+-- constructors are listed.
99+-- * Filters type class declarations to ensure that only re-exported type
100+-- class members are listed.
101+--
102+collectDeclarations ::
103+ (Functor m, Applicative m, MonadState (Map P.ModuleName Module) m) =>
104+ P.Imports ->
105+ P.Exports ->
106+ m [(P.ModuleName, [Declaration])]
107+collectDeclarations imports exports = do
108+ valsAndMembers <- collect lookupValueDeclaration impVals expVals
109+ typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs
110+ types <- collect lookupTypeDeclaration impTypes expTypes
111+
112+ let (vals, classes) = handleTypeClassMembers valsAndMembers typeClasses
113+
114+ let filteredTypes = filterDataConstructors expCtors types
115+ let filteredClasses = filterTypeClassMembers (map fst expVals) classes
116+
117+ pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals]))
118+
119+ where
120+ collect lookup' imps exps =
121+ Map.fromListWith (<>) <$> traverse (uncurry lookup')
122+ (map (findImport imps) exps)
123+
124+ expVals = P.exportedValues exports
125+ impVals = concat (Map.elems (P.importedValues imports))
126+
127+ expTypes = map (first fst) (P.exportedTypes exports)
128+ impTypes = concat (Map.elems (P.importedTypes imports))
129+
130+ expCtors = concatMap (snd . fst) (P.exportedTypes exports)
131+
132+ expTCs = P.exportedTypeClasses exports
133+ impTCs = concat (Map.elems (P.importedTypeClasses imports))
134+
135+-- |
136+-- Given a list of imported declarations (of a particular kind, ie. type, data,
137+-- class, value, etc), and the name of an exported declaration of the same
138+-- kind, together with the module it was originally defined in, return a tuple
139+-- of:
140+--
141+-- * the module that exported declaration was imported from (note that
142+-- this can be different from the module it was originally defined in, if
143+-- it is a re-export),
144+-- * that same declaration's name.
145+--
146+-- This function uses a type variable for names because we want to be able to
147+-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'.
148+--
149+findImport ::
150+ (Show name, Eq name) =>
151+ [(P.Qualified name, P.ModuleName)] ->
152+ (name, P.ModuleName) ->
153+ (P.ModuleName, name)
154+findImport imps (name, orig) =
155+ case filter (\(qual, mn) -> P.disqualify qual == name && mn == orig) imps of
156+ [(P.Qualified (Just importedFrom) _, _)] ->
157+ (importedFrom, name)
158+ other ->
159+ internalError ("findImport: unexpected result: " ++ show other)
160+
161+lookupValueDeclaration ::
162+ (MonadState (Map P.ModuleName Module) m, Applicative m) =>
163+ P.ModuleName ->
164+ P.Ident ->
165+ m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration])
166+lookupValueDeclaration importedFrom ident = do
167+ decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom
168+ let
169+ rs =
170+ filter (\d -> declTitle d == P.showIdent ident
171+ && (isValue d || isAlias d)) decls
172+ errOther other =
173+ internalError
174+ ("lookupValueDeclaration: unexpected result:\n" ++
175+ "other: " ++ show other ++ "\n" ++
176+ "ident: " ++ show ident ++ "\n" ++
177+ "decls: " ++ show decls)
178+
179+ case rs of
180+ [r] ->
181+ pure (importedFrom, [Right r])
182+ [] ->
183+ -- It's a type class member.
184+ -- Note that we need to filter based on the child declaration info using
185+ -- `isTypeClassMember` anyway, because child declarations of type classes
186+ -- are not necessarily members; they could also be instances.
187+ let
188+ allTypeClassChildDecls =
189+ decls
190+ |> mapMaybe (\d -> (d,) <$> typeClassConstraintFor d)
191+ |> concatMap (\(d, constr) ->
192+ map (declTitle d, constr,)
193+ (declChildren d))
194+
195+ matchesIdent cdecl =
196+ cdeclTitle cdecl == P.showIdent ident
197+
198+ matchesAndIsTypeClassMember =
199+ uncurry (&&) . (matchesIdent &&& isTypeClassMember)
200+
201+ in
202+ case filter (matchesAndIsTypeClassMember . thd) allTypeClassChildDecls of
203+ [r'] ->
204+ pure (importedFrom, [Left r'])
205+ other ->
206+ errOther other
207+ other -> do
208+ errOther other
209+
210+ where
211+ thd :: (a, b, c) -> c
212+ thd (_, _, x) = x
213+
214+-- |
215+-- Extract a particular type declaration. For data declarations, constructors
216+-- are only included in the output if they are listed in the arguments.
217+--
218+lookupTypeDeclaration ::
219+ (MonadState (Map P.ModuleName Module) m, Applicative m) =>
220+ P.ModuleName ->
221+ P.ProperName 'P.TypeName ->
222+ m (P.ModuleName, [Declaration])
223+lookupTypeDeclaration importedFrom ty = do
224+ decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom
225+ let
226+ ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls
227+ case ds of
228+ [d] ->
229+ pure (importedFrom, [d])
230+ other ->
231+ internalError
232+ ("lookupTypeDeclaration: unexpected result: " ++ show other)
233+
234+lookupTypeClassDeclaration ::
235+ (MonadState (Map P.ModuleName Module) m, Applicative m) =>
236+ P.ModuleName ->
237+ P.ProperName 'P.ClassName ->
238+ m (P.ModuleName, [Declaration])
239+lookupTypeClassDeclaration importedFrom tyClass = do
240+ decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom
241+ let
242+ ds = filter (\d -> declTitle d == P.runProperName tyClass
243+ && isTypeClass d)
244+ decls
245+ case ds of
246+ [d] ->
247+ pure (importedFrom, [d])
248+ other ->
249+ internalError ("lookupTypeClassDeclaration: unexpected result: "
250+ ++ (unlines . map show) other)
251+
252+-- |
253+-- Get the full list of declarations for a particular module out of the
254+-- state, or raise an internal error if it is not there.
255+--
256+lookupModuleDeclarations ::
257+ (Applicative m, MonadState (Map P.ModuleName Module) m) =>
258+ String ->
259+ P.ModuleName ->
260+ m [Declaration]
261+lookupModuleDeclarations definedIn moduleName = do
262+ mmdl <- gets (Map.lookup moduleName)
263+ case mmdl of
264+ Nothing ->
265+ internalError (definedIn ++ ": module missing: "
266+ ++ P.runModuleName moduleName)
267+ Just mdl ->
268+ pure (allDeclarations mdl)
269+
270+handleTypeClassMembers ::
271+ Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] ->
272+ Map P.ModuleName [Declaration] ->
273+ (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration])
274+handleTypeClassMembers valsAndMembers typeClasses =
275+ let
276+ moduleEnvs =
277+ Map.unionWith (<>)
278+ (fmap valsAndMembersToEnv valsAndMembers)
279+ (fmap typeClassesToEnv typeClasses)
280+ in
281+ moduleEnvs
282+ |> fmap handleEnv
283+ |> splitMap
284+
285+valsAndMembersToEnv ::
286+ [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv
287+valsAndMembersToEnv xs =
288+ let (envUnhandledMembers, envValues) = partitionEithers xs
289+ envTypeClasses = []
290+ in TypeClassEnv{..}
291+
292+typeClassesToEnv :: [Declaration] -> TypeClassEnv
293+typeClassesToEnv classes =
294+ TypeClassEnv
295+ { envUnhandledMembers = []
296+ , envValues = []
297+ , envTypeClasses = classes
298+ }
299+
300+-- |
301+-- An intermediate data type, used for either moving type class members under
302+-- their parent type classes, or promoting them to normal Declaration values
303+-- if their parent type class has not been re-exported.
304+--
305+data TypeClassEnv = TypeClassEnv
306+ { -- |
307+ -- Type class members which have not yet been dealt with. The String is the
308+ -- name of the type class they belong to, and the constraint is used to
309+ -- make sure that they have the correct type if they get promoted.
310+ --
311+ envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)]
312+ -- |
313+ -- A list of normal value declarations. Type class members will be added to
314+ -- this list if their parent type class is not available.
315+ --
316+ , envValues :: [Declaration]
317+ -- |
318+ -- A list of type class declarations. Type class members will be added to
319+ -- their parents in this list, if they exist.
320+ --
321+ , envTypeClasses :: [Declaration]
322+ }
323+ deriving (Show)
324+
325+instance Monoid TypeClassEnv where
326+ mempty =
327+ TypeClassEnv mempty mempty mempty
328+ mappend (TypeClassEnv a1 b1 c1)
329+ (TypeClassEnv a2 b2 c2) =
330+ TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2)
331+
332+-- |
333+-- Take a TypeClassEnv and handle all of the type class members in it, either
334+-- adding them to their parent classes, or promoting them to normal Declaration
335+-- values.
336+--
337+-- Returns a tuple of (values, type classes).
338+--
339+handleEnv :: TypeClassEnv -> ([Declaration], [Declaration])
340+handleEnv TypeClassEnv{..} =
341+ envUnhandledMembers
342+ |> foldl go (envValues, mkMap envTypeClasses)
343+ |> second Map.elems
344+
345+ where
346+ mkMap =
347+ Map.fromList . map (declTitle &&& id)
348+
349+ go (values, tcs) (title, constraint, childDecl) =
350+ case Map.lookup title tcs of
351+ Just _ ->
352+ -- Leave the state unchanged; if the type class is there, the child
353+ -- will be too.
354+ (values, tcs)
355+ Nothing ->
356+ (promoteChild constraint childDecl : values, tcs)
357+
358+ promoteChild constraint ChildDeclaration{..} =
359+ case cdeclInfo of
360+ ChildTypeClassMember typ ->
361+ Declaration
362+ { declTitle = cdeclTitle
363+ , declComments = cdeclComments
364+ , declSourceSpan = cdeclSourceSpan
365+ , declChildren = []
366+ , declFixity = Nothing
367+ , declInfo = ValueDeclaration (addConstraint constraint typ)
368+ }
369+ _ ->
370+ internalError
371+ ("handleEnv: Bad child declaration passed to promoteChild: "
372+ ++ cdeclTitle)
373+
374+ addConstraint constraint =
375+ P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint]
376+
377+splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2)
378+splitMap = foldl go (Map.empty, Map.empty) . Map.toList
379+ where
380+ go (m1, m2) (k, (v1, v2)) =
381+ (Map.insert k v1 m1, Map.insert k v2 m2)
382+
383+-- |
384+-- Given a list of exported constructor names, remove any data constructor
385+-- names in the provided Map of declarations which are not in the list.
386+--
387+filterDataConstructors ::
388+ [P.ProperName 'P.ConstructorName] ->
389+ Map P.ModuleName [Declaration] ->
390+ Map P.ModuleName [Declaration]
391+filterDataConstructors =
392+ filterExportedChildren isDataConstructor P.runProperName
393+
394+-- |
395+-- Given a list of exported type class member names, remove any data
396+-- type class member names in the provided Map of declarations which are not in
397+-- the list.
398+--
399+filterTypeClassMembers ::
400+ [P.Ident] ->
401+ Map P.ModuleName [Declaration] ->
402+ Map P.ModuleName [Declaration]
403+filterTypeClassMembers =
404+ filterExportedChildren isTypeClassMember P.showIdent
405+
406+filterExportedChildren ::
407+ (Functor f) =>
408+ (ChildDeclaration -> Bool) ->
409+ (name -> String) ->
410+ [name] ->
411+ f [Declaration] ->
412+ f [Declaration]
413+filterExportedChildren isTargetedKind runName expNames =
414+ fmap filterDecls
415+ where
416+ filterDecls =
417+ map (filterChildren (\c -> not (isTargetedKind c) ||
418+ cdeclTitle c `elem` expNames'))
419+
420+ expNames' = map runName expNames
421+
422+allDeclarations :: Module -> [Declaration]
423+allDeclarations Module{..} =
424+ modDeclarations ++ concatMap snd modReExports
425+
426+(|>) :: a -> (a -> b) -> b
427+x |> f = f x
428+
429+internalError :: String -> a
430+internalError = P.internalError . ("Docs.Convert.ReExports: " ++)
431+
432+-- |
433+-- If the provided Declaration is a TypeClassDeclaration, construct an
434+-- appropriate Constraint for use with the types of its members.
435+--
436+typeClassConstraintFor :: Declaration -> Maybe P.Constraint
437+typeClassConstraintFor Declaration{..} =
438+ case declInfo of
439+ TypeClassDeclaration tyArgs _ ->
440+ Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs)
441+ _ ->
442+ Nothing
443+ where
444+ mkConstraint = map (P.TypeVar . fst)
src/Language/PureScript/Docs/Convert/Single.hsnew file+230
@@ -0,0 +1,230 @@
1+{-# LANGUAGE TupleSections #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+
7+module Language.PureScript.Docs.Convert.Single
8+ ( convertSingleModule
9+ , collectBookmarks
10+ ) where
11+
12+import Prelude ()
13+import Prelude.Compat
14+
15+import Control.Monad
16+import Control.Category ((>>>))
17+import Data.Maybe (mapMaybe, isNothing)
18+import Data.Either
19+import Data.List (nub, isPrefixOf, isSuffixOf)
20+
21+import qualified Language.PureScript as P
22+
23+import Language.PureScript.Docs.Types
24+
25+-- |
26+-- Convert a single Module, but ignore re-exports; any re-exported types or
27+-- values will not appear in the result.
28+--
29+convertSingleModule :: P.Module -> Module
30+convertSingleModule m@(P.Module _ coms moduleName _ _) =
31+ Module (P.runModuleName moduleName) comments (declarations m) []
32+ where
33+ comments = convertComments coms
34+ declarations =
35+ P.exportedDeclarations
36+ >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
37+ >>> augmentDeclarations
38+ >>> map addDefaultFixity
39+
40+-- | The data type for an intermediate stage which we go through during
41+-- converting.
42+--
43+-- In the first pass, we take all top level declarations in the module, and
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.
47+--
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.
50+--
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) Declaration
59+
60+-- | Some data which will be used to augment a Declaration in the
61+-- output.
62+--
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).
68+--
69+-- The AugmentFixity constructor allows us to augment operator definitions
70+-- with their associativity and precedence.
71+data DeclarationAugment
72+ = AugmentChild ChildDeclaration
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] -> [Declaration]
78+augmentDeclarations (partitionEithers -> (augments, toplevels)) =
79+ foldl go toplevels augments
80+ where
81+ go ds (parentTitles, a) =
82+ map (\d ->
83+ if declTitle d `elem` parentTitles
84+ then augmentWith a d
85+ else d) ds
86+
87+ augmentWith a d =
88+ case a of
89+ AugmentChild child ->
90+ d { declChildren = declChildren d ++ [child] }
91+ AugmentFixity fixity ->
92+ d { declFixity = 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.9.
99+addDefaultFixity :: Declaration -> Declaration
100+addDefaultFixity decl@Declaration{..}
101+ | isOp declTitle && isNothing declFixity =
102+ decl { declFixity = Just defaultFixity }
103+ | otherwise =
104+ decl
105+ where
106+ isOp :: String -> Bool
107+ isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
108+ defaultFixity = P.Fixity P.Infixl (-1)
109+
110+getDeclarationTitle :: P.Declaration -> Maybe String
111+getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name)
112+getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name)
113+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name)
114+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name)
115+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name)
116+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name)
117+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name)
118+getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")")
119+getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
120+getDeclarationTitle _ = Nothing
121+
122+-- | Create a basic Declaration value.
123+mkDeclaration :: String -> DeclarationInfo -> Declaration
124+mkDeclaration title info =
125+ Declaration { declTitle = title
126+ , declComments = Nothing
127+ , declSourceSpan = Nothing
128+ , declChildren = []
129+ , declFixity = Nothing
130+ , declInfo = info
131+ }
132+
133+basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration
134+basicDeclaration title info = Just $ Right $ mkDeclaration title info
135+
136+convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
137+convertDeclaration (P.TypeDeclaration _ ty) title =
138+ basicDeclaration title (ValueDeclaration ty)
139+convertDeclaration (P.ExternDeclaration _ ty) title =
140+ basicDeclaration title (ValueDeclaration ty)
141+convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
142+ Just (Right (mkDeclaration title info) { declChildren = children })
143+ where
144+ info = DataDeclaration dtype args
145+ children = map convertCtor ctors
146+ convertCtor (ctor', tys) =
147+ ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys)
148+convertDeclaration (P.ExternDataDeclaration _ kind') title =
149+ basicDeclaration title (ExternDataDeclaration kind')
150+convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
151+ basicDeclaration title (TypeSynonymDeclaration args ty)
152+convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =
153+ Just (Right (mkDeclaration title info) { declChildren = children })
154+ where
155+ info = TypeClassDeclaration args implies
156+ children = map convertClassMember ds
157+ convertClassMember (P.PositionedDeclaration _ _ d) =
158+ convertClassMember d
159+ convertClassMember (P.TypeDeclaration ident' ty) =
160+ ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)
161+ convertClassMember _ =
162+ P.internalError "convertDeclaration: Invalid argument to convertClassMember."
163+convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =
164+ Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
165+ where
166+ classNameString = unQual className
167+ typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
168+ unQual x = let (P.Qualified _ y) = x in P.runProperName y
169+
170+ extractProperNames (P.TypeConstructor n) = [unQual n]
171+ extractProperNames _ = []
172+
173+ childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
174+ classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys
175+convertDeclaration (P.FixityDeclaration fixity _ Nothing) title =
176+ Just (Left ([title], AugmentFixity fixity))
177+convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title =
178+ Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity }
179+convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
180+ fmap (addComments . addSourceSpan) (convertDeclaration d' title)
181+ where
182+ addComments (Right d) =
183+ Right (d { declComments = convertComments com })
184+ addComments (Left augment) =
185+ Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })
186+ augment)
187+
188+ addSourceSpan (Right d) =
189+ Right (d { declSourceSpan = Just srcSpan })
190+ addSourceSpan (Left augment) =
191+ Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })
192+ augment)
193+
194+ withAugmentChild f (t, a) =
195+ case a of
196+ AugmentChild d -> (t, AugmentChild (f d))
197+ _ -> (t, a)
198+convertDeclaration _ _ = Nothing
199+
200+convertComments :: [P.Comment] -> Maybe String
201+convertComments cs = do
202+ let raw = concatMap toLines cs
203+ guard (all hasPipe raw && not (null raw))
204+ return (go raw)
205+ where
206+ go = unlines . map stripPipes
207+
208+ toLines (P.LineComment s) = [s]
209+ toLines (P.BlockComment s) = lines s
210+
211+ hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
212+
213+ stripPipes = dropPipe . dropWhile (== ' ')
214+
215+ dropPipe ('|':' ':s) = s
216+ dropPipe ('|':s) = s
217+ dropPipe s = s
218+
219+-- | Go through a PureScript module and extract a list of Bookmarks; references
220+-- to data types or values, to be used as a kind of index. These are used for
221+-- generating links in the HTML documentation, for example.
222+collectBookmarks :: InPackage P.Module -> [Bookmark]
223+collectBookmarks (Local m) = map Local (collectBookmarks' m)
224+collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
225+
226+collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
227+collectBookmarks' m =
228+ map (P.getModuleName m, )
229+ (mapMaybe getDeclarationTitle
230+ (P.exportedDeclarations m))
src/Language/PureScript/Docs/ParseAndDesugar.hs+5−5
@@ -33,18 +33,18 @@ import Language.PureScript.Docs.Convert (collectBookmarks)
3333-- This function does the following:
3434--
3535-- * Parse all of the input and dependency source files
36+-- * Associate each dependency module with its package name, thereby
37+-- distinguishing these from local modules
3638-- * Partially desugar all of the resulting modules (just enough for
3739-- producing documentation from them)
3840-- * Collect a list of bookmarks from the whole set of source files
39−-- * Collect a list of desugared modules from just the input source files (not
40−-- dependencies)
4141-- * Return the desugared modules, the bookmarks, and the imports/exports
4242-- Env (which is needed for producing documentation).
4343parseAndDesugar ::
4444 (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>
4545 [FilePath]
4646 -> [(PackageName, FilePath)]
47− -> m ([P.Module], [Bookmark], P.Env)
47+ -> m ([InPackage P.Module], [Bookmark], P.Env)
4848parseAndDesugar inputFiles depsFiles = do
4949 inputFiles' <- traverse (parseAs Local) inputFiles
5050 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
@@ -74,7 +74,7 @@ desugarWithBookmarks ::
7474 (MonadError P.MultipleErrors m, MonadIO m) =>
7575 [(FileInfo, P.Module)]
7676 -> [P.Module]
77− -> m ([P.Module], [Bookmark], P.Env)
77+ -> m ([InPackage P.Module], [Bookmark], P.Env)
7878desugarWithBookmarks msInfo msSorted = do
7979 (env, msDesugared) <- throwLeft (desugar msSorted)
8080
@@ -82,7 +82,7 @@ desugarWithBookmarks msInfo msSorted = do
8282 msPackages = map (addPackage msDeps) msDesugared
8383 bookmarks = concatMap collectBookmarks msPackages
8484
85− return (takeLocals msPackages, bookmarks, env)
85+ return (msPackages, bookmarks, env)
8686
8787throwLeft :: (MonadError l m) => Either l r -> m r
8888throwLeft = either throwError return
src/Language/PureScript/Docs/Render.hs+1−4
@@ -49,7 +49,7 @@ renderDeclarationWithOptions opts Declaration{..} =
4949 [ keywordClass ]
5050 ++ maybeToList superclasses
5151 ++ [renderType' (typeApp declTitle args)]
52− ++ [keywordWhere | any (isTypeClassMember . cdeclInfo) declChildren]
52+ ++ [keywordWhere | any isTypeClassMember declChildren]
5353
5454 where
5555 superclasses
@@ -58,9 +58,6 @@ renderDeclarationWithOptions opts Declaration{..} =
5858 syntax "("
5959 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)
6060 <> syntax ")" <> sp <> syntax "<="
61−
62− isTypeClassMember (ChildTypeClassMember _) = True
63− isTypeClassMember _ = False
6461 AliasDeclaration for (P.Fixity associativity precedence) ->
6562 [ keywordFixity associativity
6663 , syntax $ show precedence
src/Language/PureScript/Docs/Types.hs+66−6
@@ -76,6 +76,8 @@ data Module = Module
7676 { modName :: String
7777 , modComments :: Maybe String
7878 , modDeclarations :: [Declaration]
79+ -- Re-exported values from other modules
80+ , modReExports :: [(P.ModuleName, [Declaration])]
7981 }
8082 deriving (Show, Eq, Ord)
8183
@@ -142,6 +144,37 @@ declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"
142144declInfoToString (TypeClassDeclaration _ _) = "typeClass"
143145declInfoToString (AliasDeclaration _ _) = "alias"
144146
147+isTypeClass :: Declaration -> Bool
148+isTypeClass Declaration{..} =
149+ case declInfo of
150+ TypeClassDeclaration{} -> True
151+ _ -> False
152+
153+isValue :: Declaration -> Bool
154+isValue Declaration{..} =
155+ case declInfo of
156+ ValueDeclaration{} -> True
157+ _ -> False
158+
159+isType :: Declaration -> Bool
160+isType Declaration{..} =
161+ case declInfo of
162+ TypeSynonymDeclaration{} -> True
163+ DataDeclaration{} -> True
164+ ExternDataDeclaration{} -> True
165+ _ -> False
166+
167+isAlias :: Declaration -> Bool
168+isAlias Declaration{..} =
169+ case declInfo of
170+ AliasDeclaration{} -> True
171+ _ -> False
172+
173+-- | Discard any children which do not satisfy the given predicate.
174+filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration
175+filterChildren p decl =
176+ decl { declChildren = filter p (declChildren decl) }
177+
145178data ChildDeclaration = ChildDeclaration
146179 { cdeclTitle :: String
147180 , cdeclComments :: Maybe String
@@ -174,6 +207,18 @@ childDeclInfoToString (ChildInstance _ _) = "instance"
174207childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
175208childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
176209
210+isTypeClassMember :: ChildDeclaration -> Bool
211+isTypeClassMember ChildDeclaration{..} =
212+ case cdeclInfo of
213+ ChildTypeClassMember{} -> True
214+ _ -> False
215+
216+isDataConstructor :: ChildDeclaration -> Bool
217+isDataConstructor ChildDeclaration{..} =
218+ case cdeclInfo of
219+ ChildDataConstructor{} -> True
220+ _ -> False
221+
177222newtype GithubUser
178223 = GithubUser { runGithubUser :: String }
179224 deriving (Show, Eq, Ord)
@@ -304,6 +349,7 @@ asModule =
304349 Module <$> key "name" asString
305350 <*> key "comments" (perhaps asString)
306351 <*> key "declarations" (eachInArray asDeclaration)
352+ <*> key "reExports" (eachInArray asReExport)
307353
308354asDeclaration :: Parse PackageError Declaration
309355asDeclaration =
@@ -314,6 +360,19 @@ asDeclaration =
314360 <*> key "fixity" (perhaps asFixity)
315361 <*> key "info" asDeclarationInfo
316362
363+asReExport :: Parse PackageError (P.ModuleName, [Declaration])
364+asReExport =
365+ (,) <$> key "moduleName" fromAesonParser
366+ <*> key "declarations" (eachInArray asDeclaration)
367+
368+asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a)
369+asInPackage inner =
370+ build <$> key "package" (perhaps (withString parsePackageName))
371+ <*> key "item" inner
372+ where
373+ build Nothing = Local
374+ build (Just pn) = FromDep pn
375+
317376asFixity :: Parse PackageError P.Fixity
318377asFixity =
319378 P.Fixity <$> key "associativity" asAssociativity
@@ -410,12 +469,8 @@ asBookmarks = eachInArray asBookmark
410469
411470asBookmark :: Parse BowerError Bookmark
412471asBookmark =
413− build <$> key "package" (perhaps (withString parsePackageName))
414− <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)
415− <*> nth 1 asString)
416− where
417− build Nothing = Local
418− build (Just pn) = FromDep pn
472+ asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)
473+ <*> nth 1 asString)
419474
420475asResolvedDependencies :: Parse PackageError [(PackageName, Version)]
421476asResolvedDependencies =
@@ -460,7 +515,12 @@ instance A.ToJSON Module where
460515 A.object [ "name" .= modName
461516 , "comments" .= modComments
462517 , "declarations" .= modDeclarations
518+ , "reExports" .= map toObj modReExports
463519 ]
520+ where
521+ toObj (mn, decls) = A.object [ "moduleName" .= mn
522+ , "declarations" .= decls
523+ ]
464524
465525instance A.ToJSON Declaration where
466526 toJSON Declaration{..} =
src/Language/PureScript/Publish.hs+4−2
@@ -146,9 +146,11 @@ preparePackage' opts = do
146146getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
147147getModulesAndBookmarks = do
148148 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
149− (modules', bookmarks, _) <- parseAndDesugar inputFiles depsFiles
149+ (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles
150150
151− return (bookmarks, map D.convertModule modules')
151+ case runExcept (D.convertModulesInPackage env modules') of
152+ Right modules -> return (bookmarks, modules)
153+ Left err -> userError (CompileError err)
152154
153155 where
154156 parseAndDesugar inputFiles depsFiles = do