git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Documentation for re-exports (fixes #1677)
c0aeec9Harry Garrood
psc-docs/Main.hs+43−30
compare with golang
unifiedsplit
@@ -69,55 +69,68 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
69 Etags -> dumpTags input dumpEtags
69 Etags -> dumpTags input dumpEtags
70 Ctags -> dumpTags input dumpCtags
70 Ctags -> dumpTags input dumpCtags
71 Markdown -> do
71 Markdown -> do
72− e <- liftIO . runExceptT $ D.parseAndDesugar input []
72+ ms <- runExceptT (D.parseAndDesugar input []
73− case e of
73+ >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))
74− Left err -> do
74+ >>= successOrExit
75− hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
75+
76− exitFailure
77− Right (ms', _, _) ->
78− case output of
76+ case output of
79− EverythingToStdOut ->
77+ EverythingToStdOut ->
80− putStrLn (D.renderModulesAsMarkdown ms')
78+ putStrLn (D.runDocs (D.modulesAsMarkdown ms))
81− ToStdOut names -> do
79+ ToStdOut names -> do
82− let (ms, missing) = takeModulesByName ms' names
80+ let (ms', missing) = takeByName ms (map P.runModuleName names)
83− guardMissing missing
81+ guardMissing missing
84− putStrLn (D.renderModulesAsMarkdown ms)
82+ putStrLn (D.runDocs (D.modulesAsMarkdown ms'))
85− ToFiles names -> do
83+ ToFiles names -> do
86− let (ms, missing) = takeModulesByName' ms' names
84+ let (ms', missing) = takeByName' ms (map (first P.runModuleName) names)
87− guardMissing missing
85+ guardMissing missing
86+
88− let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms
87+ let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'
89− forM_ ms'' $ \grp -> do
88+ forM_ ms'' $ \grp -> do
90− let fp = fst (head grp)
89+ let fp = fst (head grp)
91− createDirectoryIfMissing True (takeDirectory fp)
90+ createDirectoryIfMissing True (takeDirectory fp)
92− writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)
91+ writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))
92+
93 where
93 where
94 guardMissing [] = return ()
94 guardMissing [] = return ()
95 guardMissing [mn] = do
95 guardMissing [mn] = do
96− hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")
96+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"")
97 exitFailure
97 exitFailure
98 guardMissing mns = do
98 guardMissing mns = do
99 hPutStrLn stderr "psc-docs: error: unknown modules:"
99 hPutStrLn stderr "psc-docs: error: unknown modules:"
100 forM_ mns $ \mn ->
100 forM_ mns $ \mn ->
101− hPutStrLn stderr (" * " ++ show mn)
101+ hPutStrLn stderr (" * " ++ mn)
102 exitFailure
102 exitFailure
103
103
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+
104-- |
116-- |
105-- Given a list of module names and a list of modules, return a list of modules
117-- Given a list of module names and a list of modules, return a list of modules
106-- whose names appeared in the given name list, together with a list of names
118-- whose names appeared in the given name list, together with a list of names
107-- for which no module could be found in the module list.
119-- for which no module could be found in the module list.
108--
120--
109−takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])
121+takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n])
110−takeModulesByName modules names =
122+takeModulesByName getModuleName modules names =
111− first (map fst) (takeModulesByName' modules (map (,()) names))
123+ first (map fst) (takeModulesByName' getModuleName modules (map (,()) names))
112
124
113-- |
125-- |
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.
115--
128--
116−takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])
129+takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n])
117−takeModulesByName' modules = foldl go ([], [])
130+takeModulesByName' getModuleName modules = foldl go ([], [])
118 where
131 where
119 go (ms, missing) (name, x) =
132 go (ms, missing) (name, x) =
120− case find ((== name) . P.getModuleName) modules of
133+ case find ((== name) . getModuleName) modules of
121 Just m -> ((m, x) : ms, missing)
134 Just m -> ((m, x) : ms, missing)
122 Nothing -> (ms, name : missing)
135 Nothing -> (ms, name : missing)
123
136
purescript.cabal+2
@@ -162,6 +162,8 @@ library
162
162
163 Language.PureScript.Docs
163 Language.PureScript.Docs
164 Language.PureScript.Docs.Convert
164 Language.PureScript.Docs.Convert
165+ Language.PureScript.Docs.Convert.Single
166+ Language.PureScript.Docs.Convert.ReExports
165 Language.PureScript.Docs.Render
167 Language.PureScript.Docs.Render
166 Language.PureScript.Docs.Types
168 Language.PureScript.Docs.Types
167 Language.PureScript.Docs.RenderedCode
169 Language.PureScript.Docs.RenderedCode
src/Language/PureScript/Docs/AsMarkdown.hs+26−7
@@ -1,10 +1,19 @@
1{-# LANGUAGE RecordWildCards #-}
1{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE FlexibleContexts #-}
2
3
3−module Language.PureScript.Docs.AsMarkdown (
4+module Language.PureScript.Docs.AsMarkdown
4− renderModulesAsMarkdown
5+ ( renderModulesAsMarkdown
6+ , Docs
7+ , runDocs
8+ , modulesAsMarkdown
5−) where
9+ ) where
6
10
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)
8import Data.Foldable (for_)
17import Data.Foldable (for_)
9import Data.List (partition)
18import Data.List (partition)
10
19
@@ -19,9 +28,14 @@ import qualified Language.PureScript.Docs.Render as Render
19-- Take a list of modules and render them all in order, returning a single
28-- Take a list of modules and render them all in order, returning a single
20-- Markdown-formatted String.
29-- Markdown-formatted String.
21--
30--
22−renderModulesAsMarkdown :: [P.Module] -> String
31+renderModulesAsMarkdown ::
32+ (Functor m, Applicative m,
33+ MonadError P.MultipleErrors m) =>
34+ P.Env ->
35+ [P.Module] ->
36+ m String
23−renderModulesAsMarkdown =
37+renderModulesAsMarkdown env =
24− runDocs . modulesAsMarkdown . map Convert.convertModule
38+ fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env
25
39
26modulesAsMarkdown :: [Module] -> Docs
40modulesAsMarkdown :: [Module] -> Docs
27modulesAsMarkdown = mapM_ moduleAsMarkdown
41modulesAsMarkdown = mapM_ moduleAsMarkdown
@@ -33,6 +47,11 @@ moduleAsMarkdown Module{..} = do
33 for_ modComments tell'
47 for_ modComments tell'
34 mapM_ (declAsMarkdown modName) modDeclarations
48 mapM_ (declAsMarkdown modName) modDeclarations
35 spacer
49 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
36
55
37declAsMarkdown :: String -> Declaration -> Docs
56declAsMarkdown :: String -> Declaration -> Docs
38declAsMarkdown mn decl@Declaration{..} = do
57declAsMarkdown mn decl@Declaration{..} = do
src/Language/PureScript/Docs/Convert.hs+56−200
@@ -2,230 +2,86 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE FlexibleContexts #-}
5
6
6-- | Functions for converting PureScript ASTs into values of the data types
7-- | Functions for converting PureScript ASTs into values of the data types
7-- from Language.PureScript.Docs.
8-- from Language.PureScript.Docs.
8
9
9module Language.PureScript.Docs.Convert
10module Language.PureScript.Docs.Convert
10− ( convertModule
11+ ( convertModules
12+ , convertModulesInPackage
11 , collectBookmarks
13 , collectBookmarks
12 ) where
14 ) where
13
15
14import Prelude ()
16import Prelude ()
15import Prelude.Compat
17import Prelude.Compat
16
18
17−import Control.Monad
19+import Control.Monad.Error.Class (MonadError)
20+import Control.Arrow ((&&&))
18import Control.Category ((>>>))
21import Control.Category ((>>>))
19−import Data.Either
22+import qualified Data.Map as Map
20−import Data.Maybe (mapMaybe, isNothing)
21−import Data.List (nub, isPrefixOf, isSuffixOf)
22
23
23import qualified Language.PureScript as P
24import qualified Language.PureScript as P
24
25
25import Language.PureScript.Docs.Types
26import Language.PureScript.Docs.Types
27+import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)
28+import Language.PureScript.Docs.Convert.ReExports (updateReExports)
26
29
27-- |
30-- |
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.
29--
34--
30−convertModule :: P.Module -> Module
35+convertModulesInPackage ::
31−convertModule m@(P.Module _ coms moduleName _ _) =
36+ (Functor m, MonadError P.MultipleErrors m) =>
32− Module (P.runModuleName moduleName) comments (declarations m)
37+ P.Env ->
38+ [InPackage P.Module] ->
39+ m [Module]
40+convertModulesInPackage env modules =
41+ go modules
33 where
42 where
34− comments = convertComments coms
43+ localNames =
35− declarations =
44+ map (P.runModuleName . P.getModuleName) (takeLocals modules)
36− P.exportedDeclarations
45+ go =
37− >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
46+ map ignorePackage
38− >>> augmentDeclarations
47+ >>> convertModules env
39− >>> map addDefaultFixity
48+ >>> fmap (filter ((`elem` localNames) . modName))
40
49
41−-- | The data type for an intermediate stage which we go through during
50+-- |
42−-- converting.
51+-- Convert a group of modules to the intermediate format, designed for
43−--
52+-- producing documentation from. It is also necessary to pass an Env containing
44−-- In the first pass, we take all top level declarations in the module, and
53+-- imports/exports information about the list of modules, which is needed for
45−-- collect other information which will later be used to augment the top level
54+-- documenting re-exports.
46−-- declarations. These two situation correspond to the Right and Left
47−-- constructors, respectively.
48--
55--
49−-- In the second pass, we go over all of the Left values and augment the
56+-- Preconditions:
50−-- relevant declarations, leaving only the augmented Right values.
51--
57--
52−-- Note that in the Left case, we provide a [String] as well as augment
58+-- * If any module in the list re-exports documentation from other
53−-- information. The [String] value should be a list of titles of declarations
59+-- modules, those modules must also be included in the list.
54−-- that the augmentation should apply to. For example, for a type instance
60+-- * The modules passed must have had names desugared and re-exports
55−-- declaration, that would be any types or type classes mentioned in the
61+-- elaborated first.
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.
63--
62--
64−-- The AugmentChild constructor allows us to move all children under their
63+-- If either of these are not satisfied, an internal error will be thrown. To
65−-- respective parents. It is only necessary for type instance declarations,
64+-- avoid this, it is recommended to use
66−-- since they appear at the top level in the AST, and since they might need to
65+-- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this
67−-- appear as children in two places (for example, if a data type defined in a
66+-- function.
68−-- module is an instance of a type class also defined in that module).
69--
67--
70−-- The AugmentFixity constructor allows us to augment operator definitions
68+convertModules ::
71−-- with their associativity and precedence.
69+ (Functor m, MonadError P.MultipleErrors m) =>
72−data DeclarationAugment
70+ P.Env ->
73− = AugmentChild ChildDeclaration
71+ [P.Module] ->
74− | AugmentFixity P.Fixity
72+ m [Module]
73+convertModules env =
74+ P.sortModules >>> fmap (convertSorted env . fst)
75
75
76−-- | Augment top-level declarations; the second pass. See the comments under
76+-- |
77−-- the type synonym IntermediateDeclaration for more information.
77+-- Convert a sorted list of modules.
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.
97--
78--
98−-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
79+convertSorted :: P.Env -> [P.Module] -> [Module]
99−-- in 0.9.
80+convertSorted env modules =
100−addDefaultFixity :: Declaration -> Declaration
81+ let
101−addDefaultFixity decl@Declaration{..}
82+ traversalOrder =
102− | isOp declTitle && isNothing declFixity =
83+ map P.getModuleName modules
103− decl { declFixity = Just defaultFixity }
84+ moduleMap =
104− | otherwise =
85+ Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules
105− decl
86+ in
106− where
87+ Map.elems (updateReExports env traversalOrder moduleMap)
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))
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)
33-- This function does the following:
33-- This function does the following:
34--
34--
35-- * Parse all of the input and dependency source files
35-- * 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
36-- * Partially desugar all of the resulting modules (just enough for
38-- * Partially desugar all of the resulting modules (just enough for
37-- producing documentation from them)
39-- producing documentation from them)
38-- * Collect a list of bookmarks from the whole set of source files
40-- * 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)
41-- * Return the desugared modules, the bookmarks, and the imports/exports
41-- * Return the desugared modules, the bookmarks, and the imports/exports
42-- Env (which is needed for producing documentation).
42-- Env (which is needed for producing documentation).
43parseAndDesugar ::
43parseAndDesugar ::
44 (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>
44 (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>
45 [FilePath]
45 [FilePath]
46 -> [(PackageName, FilePath)]
46 -> [(PackageName, FilePath)]
47− -> m ([P.Module], [Bookmark], P.Env)
47+ -> m ([InPackage P.Module], [Bookmark], P.Env)
48parseAndDesugar inputFiles depsFiles = do
48parseAndDesugar inputFiles depsFiles = do
49 inputFiles' <- traverse (parseAs Local) inputFiles
49 inputFiles' <- traverse (parseAs Local) inputFiles
50 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
50 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
@@ -74,7 +74,7 @@ desugarWithBookmarks ::
74 (MonadError P.MultipleErrors m, MonadIO m) =>
74 (MonadError P.MultipleErrors m, MonadIO m) =>
75 [(FileInfo, P.Module)]
75 [(FileInfo, P.Module)]
76 -> [P.Module]
76 -> [P.Module]
77− -> m ([P.Module], [Bookmark], P.Env)
77+ -> m ([InPackage P.Module], [Bookmark], P.Env)
78desugarWithBookmarks msInfo msSorted = do
78desugarWithBookmarks msInfo msSorted = do
79 (env, msDesugared) <- throwLeft (desugar msSorted)
79 (env, msDesugared) <- throwLeft (desugar msSorted)
80
80
@@ -82,7 +82,7 @@ desugarWithBookmarks msInfo msSorted = do
82 msPackages = map (addPackage msDeps) msDesugared
82 msPackages = map (addPackage msDeps) msDesugared
83 bookmarks = concatMap collectBookmarks msPackages
83 bookmarks = concatMap collectBookmarks msPackages
84
84
85− return (takeLocals msPackages, bookmarks, env)
85+ return (msPackages, bookmarks, env)
86
86
87throwLeft :: (MonadError l m) => Either l r -> m r
87throwLeft :: (MonadError l m) => Either l r -> m r
88throwLeft = either throwError return
88throwLeft = either throwError return
src/Language/PureScript/Docs/Render.hs+1−4
@@ -49,7 +49,7 @@ renderDeclarationWithOptions opts Declaration{..} =
49 [ keywordClass ]
49 [ keywordClass ]
50 ++ maybeToList superclasses
50 ++ maybeToList superclasses
51 ++ [renderType' (typeApp declTitle args)]
51 ++ [renderType' (typeApp declTitle args)]
52− ++ [keywordWhere | any (isTypeClassMember . cdeclInfo) declChildren]
52+ ++ [keywordWhere | any isTypeClassMember declChildren]
53
53
54 where
54 where
55 superclasses
55 superclasses
@@ -58,9 +58,6 @@ renderDeclarationWithOptions opts Declaration{..} =
58 syntax "("
58 syntax "("
59 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)
59 <> mintersperse (syntax "," <> sp) (map renderConstraint implies)
60 <> syntax ")" <> sp <> syntax "<="
60 <> syntax ")" <> sp <> syntax "<="
61−
62− isTypeClassMember (ChildTypeClassMember _) = True
63− isTypeClassMember _ = False
64 AliasDeclaration for (P.Fixity associativity precedence) ->
61 AliasDeclaration for (P.Fixity associativity precedence) ->
65 [ keywordFixity associativity
62 [ keywordFixity associativity
66 , syntax $ show precedence
63 , syntax $ show precedence
src/Language/PureScript/Docs/Types.hs+66−6
@@ -76,6 +76,8 @@ data Module = Module
76 { modName :: String
76 { modName :: String
77 , modComments :: Maybe String
77 , modComments :: Maybe String
78 , modDeclarations :: [Declaration]
78 , modDeclarations :: [Declaration]
79+ -- Re-exported values from other modules
80+ , modReExports :: [(P.ModuleName, [Declaration])]
79 }
81 }
80 deriving (Show, Eq, Ord)
82 deriving (Show, Eq, Ord)
81
83
@@ -142,6 +144,37 @@ declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"
142declInfoToString (TypeClassDeclaration _ _) = "typeClass"
144declInfoToString (TypeClassDeclaration _ _) = "typeClass"
143declInfoToString (AliasDeclaration _ _) = "alias"
145declInfoToString (AliasDeclaration _ _) = "alias"
144
146
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+
145data ChildDeclaration = ChildDeclaration
178data ChildDeclaration = ChildDeclaration
146 { cdeclTitle :: String
179 { cdeclTitle :: String
147 , cdeclComments :: Maybe String
180 , cdeclComments :: Maybe String
@@ -174,6 +207,18 @@ childDeclInfoToString (ChildInstance _ _) = "instance"
174childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
207childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
175childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
208childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
176
209
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+
177newtype GithubUser
222newtype GithubUser
178 = GithubUser { runGithubUser :: String }
223 = GithubUser { runGithubUser :: String }
179 deriving (Show, Eq, Ord)
224 deriving (Show, Eq, Ord)
@@ -304,6 +349,7 @@ asModule =
304 Module <$> key "name" asString
349 Module <$> key "name" asString
305 <*> key "comments" (perhaps asString)
350 <*> key "comments" (perhaps asString)
306 <*> key "declarations" (eachInArray asDeclaration)
351 <*> key "declarations" (eachInArray asDeclaration)
352+ <*> key "reExports" (eachInArray asReExport)
307
353
308asDeclaration :: Parse PackageError Declaration
354asDeclaration :: Parse PackageError Declaration
309asDeclaration =
355asDeclaration =
@@ -314,6 +360,19 @@ asDeclaration =
314 <*> key "fixity" (perhaps asFixity)
360 <*> key "fixity" (perhaps asFixity)
315 <*> key "info" asDeclarationInfo
361 <*> key "info" asDeclarationInfo
316
362
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+
317asFixity :: Parse PackageError P.Fixity
376asFixity :: Parse PackageError P.Fixity
318asFixity =
377asFixity =
319 P.Fixity <$> key "associativity" asAssociativity
378 P.Fixity <$> key "associativity" asAssociativity
@@ -410,12 +469,8 @@ asBookmarks = eachInArray asBookmark
410
469
411asBookmark :: Parse BowerError Bookmark
470asBookmark :: Parse BowerError Bookmark
412asBookmark =
471asBookmark =
413− build <$> key "package" (perhaps (withString parsePackageName))
414− <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)
472+ asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString)
415− <*> nth 1 asString)
473+ <*> nth 1 asString)
416− where
417− build Nothing = Local
418− build (Just pn) = FromDep pn
419
474
420asResolvedDependencies :: Parse PackageError [(PackageName, Version)]
475asResolvedDependencies :: Parse PackageError [(PackageName, Version)]
421asResolvedDependencies =
476asResolvedDependencies =
@@ -460,7 +515,12 @@ instance A.ToJSON Module where
460 A.object [ "name" .= modName
515 A.object [ "name" .= modName
461 , "comments" .= modComments
516 , "comments" .= modComments
462 , "declarations" .= modDeclarations
517 , "declarations" .= modDeclarations
518+ , "reExports" .= map toObj modReExports
463 ]
519 ]
520+ where
521+ toObj (mn, decls) = A.object [ "moduleName" .= mn
522+ , "declarations" .= decls
523+ ]
464
524
465instance A.ToJSON Declaration where
525instance A.ToJSON Declaration where
466 toJSON Declaration{..} =
526 toJSON Declaration{..} =
src/Language/PureScript/Publish.hs+4−2
@@ -146,9 +146,11 @@ preparePackage' opts = do
146getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
146getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
147getModulesAndBookmarks = do
147getModulesAndBookmarks = do
148 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
148 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
149− (modules', bookmarks, _) <- parseAndDesugar inputFiles depsFiles
149+ (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles
150
150
151+ case runExcept (D.convertModulesInPackage env modules') of
151− return (bookmarks, map D.convertModule modules')
152+ Right modules -> return (bookmarks, modules)
153+ Left err -> userError (CompileError err)
152
154
153 where
155 where
154 parseAndDesugar inputFiles depsFiles = do
156 parseAndDesugar inputFiles depsFiles = do