git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1770 from hdgarrood/reexport-docs
604f69dGary Burgess
.gitignore+2
compare with golang
unifiedsplit
@@ -16,3 +16,5 @@ tmp/
16.stack-work/
16.stack-work/
17tests/support/flattened/
17tests/support/flattened/
18output
18output
19+examples/docs/docs/
20+core-tests/full-core-docs.md
.travis.yml+2
@@ -57,6 +57,8 @@ install:
57 # Snapshot state of the sandbox now, so we don't need to make new one for test install
57 # Snapshot state of the sandbox now, so we don't need to make new one for test install
58 - rm -rf ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}
58 - rm -rf ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}
59 - cp -r .cabal-sandbox ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}
59 - cp -r .cabal-sandbox ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none}
60+ # Install bower globally (for psc-docs/psc-publish tests)
61+ - npm install -g bower
60script:
62script:
61 - ./travis/configure.sh
63 - ./travis/configure.sh
62 - cabal build --ghc-options="-Werror"
64 - cabal build --ghc-options="-Werror"
core-tests/test-everything.sh+5−3
@@ -18,9 +18,7 @@ if [ "$force_reinstall" = "true" ] && [ -d "bower_components" ]; then
18 rm -r bower_components
18 rm -r bower_components
19fi
19fi
20
20
21−npm install bower
22−
23−node_modules/.bin/bower i \
21+bower i \
24 purescript-prelude \
22 purescript-prelude \
25 purescript-eff \
23 purescript-eff \
26 purescript-st \
24 purescript-st \
@@ -75,3 +73,7 @@ fi
75../dist/build/psc/psc tests/*/*.purs \
73../dist/build/psc/psc tests/*/*.purs \
76 'bower_components/purescript-*/src/**/*.purs' \
74 'bower_components/purescript-*/src/**/*.purs' \
77 --ffi 'bower_components/purescript-*/src/**/*.js'
75 --ffi 'bower_components/purescript-*/src/**/*.js'
76+
77+../dist/build/psc-docs/psc-docs tests/*/*.purs \
78+ 'bower_components/purescript-*/src/**/*.purs' \
79+ > full-core-docs.md
examples/docs/bower.jsonnew file+19
@@ -0,0 +1,19 @@
1+{
2+ "name": "docs-test-package",
3+ "version": "1.0.0",
4+ "moduleType": [
5+ "node"
6+ ],
7+ "repository": {
8+ "type": "git",
9+ "url": "git://github.com/not-real/not-a-real-repo.git"
10+ },
11+ "ignore": [
12+ "**/.*",
13+ "node_modules",
14+ "bower_components",
15+ "output"
16+ ],
17+ "dependencies": {
18+ }
19+}
examples/docs/bower_components/purescript-prelude/src/Prelude.pursnew file+8
@@ -0,0 +1,8 @@
1+module Prelude where
2+
3+newtype Unit = Unit {}
4+
5+unit :: Unit
6+unit = Unit {}
7+
8+data Boolean2 = True | False
examples/docs/src/Clash.pursnew file+32
@@ -0,0 +1,32 @@
1+module Clash (module Clash1) where
2+
3+import Clash1 as Clash1
4+import Clash2 as Clash2
5+
6+module Clash1 (module Clash1a) where
7+
8+import Clash1a
9+
10+module Clash1a where
11+
12+value :: Int
13+value = 0
14+
15+type Type = Int
16+
17+class TypeClass a where
18+ typeClassMember :: a
19+
20+module Clash2 (module Clash2a) where
21+
22+import Clash2a
23+
24+module Clash2a where
25+
26+value :: String
27+value = "hello"
28+
29+type Type = String
30+
31+class TypeClass a b where
32+ typeClassMember :: a -> b
examples/docs/src/DuplicateNames.pursnew file+9
@@ -0,0 +1,9 @@
1+module DuplicateNames
2+ ( module DuplicateNames
3+ , module Prelude
4+ ) where
5+
6+import Prelude (Unit)
7+
8+unit :: Int
9+unit = 0
examples/docs/src/Example.pursnew file+7
@@ -0,0 +1,7 @@
1+module Example
2+ ( module Prelude
3+ , module Example2
4+ ) where
5+
6+import Prelude (Unit())
7+import Example2 (one)
examples/docs/src/Example2.pursnew file+7
@@ -0,0 +1,7 @@
1+module Example2 where
2+
3+one :: Int
4+one = 1
5+
6+two :: Int
7+two = 2
examples/docs/src/MultiVirtual.pursnew file+27
@@ -0,0 +1,27 @@
1+module MultiVirtual
2+ ( module X )
3+ where
4+
5+import MultiVirtual1 as X
6+import MultiVirtual2 as X
7+
8+
9+module MultiVirtual1 where
10+
11+foo :: Int
12+foo = 1
13+
14+module MultiVirtual2
15+ ( module MultiVirtual2
16+ , module MultiVirtual3
17+ ) where
18+
19+import MultiVirtual3
20+
21+bar :: Int
22+bar = 2
23+
24+module MultiVirtual3 where
25+
26+baz :: Int
27+baz = 3
examples/docs/src/NewOperators.pursnew file+12
@@ -0,0 +1,12 @@
1+module NewOperators
2+ ( module NewOperators2 )
3+ where
4+
5+import NewOperators2
6+
7+module NewOperators2 where
8+
9+infixl 8 _compose as >>>
10+
11+_compose :: forall a b c. (b -> c) -> (a -> b) -> (a -> c)
12+_compose f g x = f (g x)
examples/docs/src/NotAllCtors.pursnew file+5
@@ -0,0 +1,5 @@
1+module NotAllCtors
2+ ( module Prelude )
3+ where
4+
5+import Prelude (Boolean2(True))
examples/docs/src/OldOperators.pursnew file+10
@@ -0,0 +1,10 @@
1+
2+-- Remove this after 0.9.
3+module OldOperators (module OldOperators2) where
4+
5+import OldOperators2
6+
7+module OldOperators2 where
8+
9+(>>) :: forall a. a -> a -> a
10+(>>) a b = b
examples/docs/src/ReExportedTypeClass.pursnew file+5
@@ -0,0 +1,5 @@
1+module ReExportedTypeClass
2+ ( module SomeTypeClass )
3+ where
4+
5+import SomeTypeClass
examples/docs/src/SolitaryTypeClassMember.pursnew file+6
@@ -0,0 +1,6 @@
1+module SolitaryTypeClassMember
2+ ( module SomeTypeClass )
3+ where
4+
5+import SomeTypeClass (member)
6+
examples/docs/src/SomeTypeClass.pursnew file+5
@@ -0,0 +1,5 @@
1+
2+module SomeTypeClass where
3+
4+class SomeClass a where
5+ member :: a
examples/docs/src/Transitive1.pursnew file+5
@@ -0,0 +1,5 @@
1+module Transitive1
2+ ( module Transitive2 )
3+ where
4+
5+import Transitive2
examples/docs/src/Transitive2.pursnew file+5
@@ -0,0 +1,5 @@
1+module Transitive2
2+ ( module Transitive3 )
3+ where
4+
5+import Transitive3
examples/docs/src/Transitive3.pursnew file+4
@@ -0,0 +1,4 @@
1+module Transitive3 where
2+
3+transitive3 :: Int
4+transitive3 = 0
examples/docs/src/TypeClassWithoutMembers.pursnew file+11
@@ -0,0 +1,11 @@
1+module TypeClassWithoutMembers
2+ ( module Intermediate )
3+ where
4+
5+import Intermediate
6+
7+module Intermediate
8+ ( module SomeTypeClass )
9+ where
10+
11+import SomeTypeClass (SomeClass)
examples/docs/src/UTF8.pursnew file+7
@@ -0,0 +1,7 @@
1+module UTF8 where
2+
3+import Prelude (Unit, unit)
4+
5+-- | üÜäÄ 😰
6+thing :: Unit
7+thing = unit
examples/docs/src/Virtual.pursnew file+5
@@ -0,0 +1,5 @@
1+module Virtual
2+ ( module VirtualPrelude )
3+ where
4+
5+import Prelude as VirtualPrelude
psc-docs/Main.hs+44−30
@@ -16,6 +16,7 @@
16module Main where
16module Main where
17
17
18import Control.Applicative
18import Control.Applicative
19+import Control.Monad.Trans.Except (runExceptT)
19import Control.Arrow (first, second)
20import Control.Arrow (first, second)
20import Control.Category ((>>>))
21import Control.Category ((>>>))
21import Control.Monad.Writer
22import Control.Monad.Writer
@@ -68,55 +69,68 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
68 Etags -> dumpTags input dumpEtags
69 Etags -> dumpTags input dumpEtags
69 Ctags -> dumpTags input dumpCtags
70 Ctags -> dumpTags input dumpCtags
70 Markdown -> do
71 Markdown -> do
71− e <- D.parseAndDesugar input [] (\_ ms -> return ms)
72+ ms <- runExceptT (D.parseAndDesugar input []
72− case e of
73+ >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms)))
73− Left err -> do
74+ >>= successOrExit
74− hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
75+
75− exitFailure
76− Right ms' ->
77− case output of
76+ case output of
78− EverythingToStdOut ->
77+ EverythingToStdOut ->
79− putStrLn (D.renderModulesAsMarkdown ms')
78+ putStrLn (D.runDocs (D.modulesAsMarkdown ms))
80− ToStdOut names -> do
79+ ToStdOut names -> do
81− let (ms, missing) = takeModulesByName ms' names
80+ let (ms', missing) = takeByName ms (map P.runModuleName names)
82− guardMissing missing
81+ guardMissing missing
83− putStrLn (D.renderModulesAsMarkdown ms)
82+ putStrLn (D.runDocs (D.modulesAsMarkdown ms'))
84− ToFiles names -> do
83+ ToFiles names -> do
85− let (ms, missing) = takeModulesByName' ms' names
84+ let (ms', missing) = takeByName' ms (map (first P.runModuleName) names)
86− guardMissing missing
85+ guardMissing missing
86+
87− 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'
88− forM_ ms'' $ \grp -> do
88+ forM_ ms'' $ \grp -> do
89− let fp = fst (head grp)
89+ let fp = fst (head grp)
90− createDirectoryIfMissing True (takeDirectory fp)
90+ createDirectoryIfMissing True (takeDirectory fp)
91− writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)
91+ writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))
92+
92 where
93 where
93 guardMissing [] = return ()
94 guardMissing [] = return ()
94 guardMissing [mn] = do
95 guardMissing [mn] = do
95− hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")
96+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"")
96 exitFailure
97 exitFailure
97 guardMissing mns = do
98 guardMissing mns = do
98 hPutStrLn stderr "psc-docs: error: unknown modules:"
99 hPutStrLn stderr "psc-docs: error: unknown modules:"
99 forM_ mns $ \mn ->
100 forM_ mns $ \mn ->
100− hPutStrLn stderr (" * " ++ show mn)
101+ hPutStrLn stderr (" * " ++ mn)
101 exitFailure
102 exitFailure
102
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+
103-- |
116-- |
104-- 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
105-- 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
106-- for which no module could be found in the module list.
119-- for which no module could be found in the module list.
107--
120--
108−takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])
121+takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n])
109−takeModulesByName modules names =
122+takeModulesByName getModuleName modules names =
110− first (map fst) (takeModulesByName' modules (map (,()) names))
123+ first (map fst) (takeModulesByName' getModuleName modules (map (,()) names))
111
124
112-- |
125-- |
113−-- Like takeModulesByName but also keeps some extra data with the module.
126+-- Like takeModulesByName, but also keeps some extra information with each
127+-- module.
114--
128--
115−takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])
129+takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n])
116−takeModulesByName' modules = foldl go ([], [])
130+takeModulesByName' getModuleName modules = foldl go ([], [])
117 where
131 where
118 go (ms, missing) (name, x) =
132 go (ms, missing) (name, x) =
119− case find ((== name) . P.getModuleName) modules of
133+ case find ((== name) . getModuleName) modules of
120 Just m -> ((m, x) : ms, missing)
134 Just m -> ((m, x) : ms, missing)
121 Nothing -> (ms, name : missing)
135 Nothing -> (ms, name : missing)
122
136
purescript.cabal+8−1
@@ -20,6 +20,9 @@ tested-with: GHC==7.8
20
20
21extra-source-files: examples/passing/*.purs
21extra-source-files: examples/passing/*.purs
22 , examples/failing/*.purs
22 , examples/failing/*.purs
23+ , examples/docs/bower_components/purescript-prelude/src/*.purs
24+ , examples/docs/bower.json
25+ , examples/docs/src/*.purs
23 , tests/support/setup.js
26 , tests/support/setup.js
24 , tests/support/package.json
27 , tests/support/package.json
25 , tests/support/bower.json
28 , tests/support/bower.json
@@ -159,6 +162,8 @@ library
159
162
160 Language.PureScript.Docs
163 Language.PureScript.Docs
161 Language.PureScript.Docs.Convert
164 Language.PureScript.Docs.Convert
165+ Language.PureScript.Docs.Convert.Single
166+ Language.PureScript.Docs.Convert.ReExports
162 Language.PureScript.Docs.Render
167 Language.PureScript.Docs.Render
163 Language.PureScript.Docs.Types
168 Language.PureScript.Docs.Types
164 Language.PureScript.Docs.RenderedCode
169 Language.PureScript.Docs.RenderedCode
@@ -220,7 +225,8 @@ executable psc-docs
220 build-depends: base >=4 && <5, purescript -any,
225 build-depends: base >=4 && <5, purescript -any,
221 optparse-applicative >= 0.10.0, process -any, mtl -any,
226 optparse-applicative >= 0.10.0, process -any, mtl -any,
222 split -any, ansi-wl-pprint -any, directory -any,
227 split -any, ansi-wl-pprint -any, directory -any,
223− filepath -any, Glob -any
228+ filepath -any, Glob -any, transformers -any,
229+ transformers-compat -any
224 main-is: Main.hs
230 main-is: Main.hs
225 buildable: True
231 buildable: True
226 hs-source-dirs: psc-docs
232 hs-source-dirs: psc-docs
@@ -272,6 +278,7 @@ test-suite tests
272 main-is: Main.hs
278 main-is: Main.hs
273 other-modules: TestsSetup
279 other-modules: TestsSetup
274 TestPscPublish
280 TestPscPublish
281+ TestDocs
275 buildable: True
282 buildable: True
276 hs-source-dirs: tests tests/common
283 hs-source-dirs: tests tests/common
277
284
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+32−24
@@ -1,4 +1,5 @@
1{-# LANGUAGE TupleSections #-}
1{-# LANGUAGE TupleSections #-}
2+{-# LANGUAGE FlexibleContexts #-}
2
3
3module Language.PureScript.Docs.ParseAndDesugar
4module Language.PureScript.Docs.ParseAndDesugar
4 ( parseAndDesugar
5 ( parseAndDesugar
@@ -11,7 +12,6 @@ import qualified Data.Map as M
11import Control.Arrow (first)
12import Control.Arrow (first)
12import Control.Monad
13import Control.Monad
13
14
14−import Control.Monad.Trans.Except
15import Control.Monad.Writer.Strict (runWriterT)
15import Control.Monad.Writer.Strict (runWriterT)
16import Control.Monad.Error.Class (MonadError(..))
16import Control.Monad.Error.Class (MonadError(..))
17import Control.Monad.IO.Class (MonadIO(..))
17import Control.Monad.IO.Class (MonadIO(..))
@@ -29,40 +29,41 @@ import Language.PureScript.Docs.Convert (collectBookmarks)
29-- * A list of local source files
29-- * A list of local source files
30-- * A list of source files from external dependencies, together with their
30-- * A list of source files from external dependencies, together with their
31-- package names
31-- package names
32−-- * A callback, taking a list of bookmarks, and a list of desugared modules
33--
32--
34-- This function does the following:
33-- This function does the following:
35--
34--
36-- * 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
37−-- * Partially desugar all of the resulting modules
38+-- * Partially desugar all of the resulting modules (just enough for
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
41+-- * Return the desugared modules, the bookmarks, and the imports/exports
40−-- dependencies)
42+-- Env (which is needed for producing documentation).
41−-- * Call the callback with the bookmarks and desugared module list.
42parseAndDesugar ::
43parseAndDesugar ::
44+ (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>
43 [FilePath]
45 [FilePath]
44 -> [(PackageName, FilePath)]
46 -> [(PackageName, FilePath)]
45− -> ([Bookmark] -> [P.Module] -> IO a)
47+ -> m ([InPackage P.Module], [Bookmark], P.Env)
46− -> IO (Either P.MultipleErrors a)
47−parseAndDesugar inputFiles depsFiles callback = do
48+parseAndDesugar inputFiles depsFiles = do
48 inputFiles' <- traverse (parseAs Local) inputFiles
49 inputFiles' <- traverse (parseAs Local) inputFiles
49 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
50 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
50
51
51− runExceptT $ do
52− ms <- parseFiles (inputFiles' ++ depsFiles')
52+ ms <- parseFiles (inputFiles' ++ depsFiles')
53− ms' <- sortModules (map snd ms)
53+ ms' <- sortModules (map snd ms)
54− (bs, ms'') <- desugarWithBookmarks ms ms'
54+ desugarWithBookmarks ms ms'
55− liftIO $ callback bs ms''
56
55
57parseFiles ::
56parseFiles ::
57+ (MonadError P.MultipleErrors m, MonadIO m) =>
58 [(FileInfo, FilePath)]
58 [(FileInfo, FilePath)]
59− -> ExceptT P.MultipleErrors IO [(FileInfo, P.Module)]
59+ -> m [(FileInfo, P.Module)]
60parseFiles =
60parseFiles =
61 throwLeft . P.parseModulesFromFiles fileInfoToString
61 throwLeft . P.parseModulesFromFiles fileInfoToString
62
62
63sortModules ::
63sortModules ::
64+ (Functor m, MonadError P.MultipleErrors m, MonadIO m) =>
64 [P.Module]
65 [P.Module]
65− -> ExceptT P.MultipleErrors IO [P.Module]
66+ -> m [P.Module]
66sortModules =
67sortModules =
67 fmap fst . throwLeft . sortModules' . map importPrim
68 fmap fst . throwLeft . sortModules' . map importPrim
68 where
69 where
@@ -70,17 +71,18 @@ sortModules =
70 sortModules' = P.sortModules
71 sortModules' = P.sortModules
71
72
72desugarWithBookmarks ::
73desugarWithBookmarks ::
74+ (MonadError P.MultipleErrors m, MonadIO m) =>
73 [(FileInfo, P.Module)]
75 [(FileInfo, P.Module)]
74 -> [P.Module]
76 -> [P.Module]
75− -> ExceptT P.MultipleErrors IO ([Bookmark], [P.Module])
77+ -> m ([InPackage P.Module], [Bookmark], P.Env)
76desugarWithBookmarks msInfo msSorted = do
78desugarWithBookmarks msInfo msSorted = do
77− msDesugared <- throwLeft (desugar msSorted)
79+ (env, msDesugared) <- throwLeft (desugar msSorted)
78
80
79 let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)
81 let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo)
80 msPackages = map (addPackage msDeps) msDesugared
82 msPackages = map (addPackage msDeps) msDesugared
81 bookmarks = concatMap collectBookmarks msPackages
83 bookmarks = concatMap collectBookmarks msPackages
82
84
83− return (bookmarks, takeLocals msPackages)
85+ return (msPackages, bookmarks, env)
84
86
85throwLeft :: (MonadError l m) => Either l r -> m r
87throwLeft :: (MonadError l m) => Either l r -> m r
86throwLeft = either throwError return
88throwLeft = either throwError return
@@ -101,18 +103,24 @@ fileInfoToString (FromDep _ fn) = fn
101importPrim :: P.Module -> P.Module
103importPrim :: P.Module -> P.Module
102importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
104importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
103
105
104−desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]
106+desugar ::
107+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
108+ [P.Module]
109+ -> m (P.Env, [P.Module])
105desugar = P.evalSupplyT 0 . desugar'
110desugar = P.evalSupplyT 0 . desugar'
106 where
111 where
107− desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]
112+ desugar' =
108− desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports []
113+ traverse P.desugarDoModule
114+ >=> P.desugarCasesModule
115+ >=> ignoreWarnings . P.desugarImportsWithEnv []
116+
109 ignoreWarnings m = liftM fst (runWriterT m)
117 ignoreWarnings m = liftM fst (runWriterT m)
110
118
111parseFile :: FilePath -> IO (FilePath, String)
119parseFile :: FilePath -> IO (FilePath, String)
112parseFile input' = (,) input' <$> readFile input'
120parseFile input' = (,) input' <$> readFile input'
113
121
114−parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)
122+parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)
115−parseAs g = fmap (first g) . parseFile
123+parseAs g = fmap (first g) . liftIO . parseFile
116
124
117getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
125getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
118getDepsModuleNames = foldl go M.empty
126getDepsModuleNames = foldl go M.empty
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+13−4
@@ -146,11 +146,20 @@ 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− liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)
149+ (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles
150+
151+ case runExcept (D.convertModulesInPackage env modules') of
152+ Right modules -> return (bookmarks, modules)
150− >>= either (userError . CompileError) return
153+ Left err -> userError (CompileError err)
154+
151 where
155 where
152− renderModules bookmarks modules =
156+ parseAndDesugar inputFiles depsFiles = do
153− return (bookmarks, map D.convertModule modules)
157+ r <- liftIO . runExceptT $ D.parseAndDesugar inputFiles depsFiles
158+ case r of
159+ Right r' ->
160+ return r'
161+ Left err ->
162+ userError (CompileError err)
154
163
155data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)
164data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)
156
165
src/Language/PureScript/Sugar/Names.hs+19−3
@@ -1,8 +1,15 @@
1{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TupleSections #-}
4
5
5−module Language.PureScript.Sugar.Names (desugarImports) where
6+module Language.PureScript.Sugar.Names
7+ ( desugarImports
8+ , desugarImportsWithEnv
9+ , Env
10+ , Imports(..)
11+ , Exports(..)
12+ ) where
6
13
7import Prelude ()
14import Prelude ()
8import Prelude.Compat
15import Prelude.Compat
@@ -35,11 +42,20 @@ import Language.PureScript.Linter.Imports
35-- modules should be topologically sorted beforehand.
42-- modules should be topologically sorted beforehand.
36--
43--
37desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
44desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
38−desugarImports externs modules = do
45+desugarImports externs modules =
46+ fmap snd (desugarImportsWithEnv externs modules)
47+
48+desugarImportsWithEnv
49+ :: forall m
50+ . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
51+ => [ExternsFile]
52+ -> [Module]
53+ -> m (Env, [Module])
54+desugarImportsWithEnv externs modules = do
39 env <- silence $ foldM externsEnv primEnv externs
55 env <- silence $ foldM externsEnv primEnv externs
40 modules' <- traverse updateExportRefs modules
56 modules' <- traverse updateExportRefs modules
41 (modules'', env') <- foldM updateEnv ([], env) modules'
57 (modules'', env') <- foldM updateEnv ([], env) modules'
42− traverse (renameInModule' env') modules''
58+ (env',) <$> traverse (renameInModule' env') modules''
43 where
59 where
44 silence :: m a -> m a
60 silence :: m a -> m a
45 silence = censor (const mempty)
61 silence = censor (const mempty)
tests/Main.hs+18−2
@@ -30,6 +30,7 @@
30-- -- @shouldFailWith TypesDoNotUnify
30-- -- @shouldFailWith TypesDoNotUnify
31-- -- @shouldFailWith TypesDoNotUnify
31-- -- @shouldFailWith TypesDoNotUnify
32-- -- @shouldFailWith TransitiveExportError
32-- -- @shouldFailWith TransitiveExportError
33+--
33
34
34module Main (main) where
35module Main (main) where
35
36
@@ -39,6 +40,7 @@ import Prelude.Compat
39import qualified Language.PureScript as P
40import qualified Language.PureScript as P
40import qualified Language.PureScript.CodeGen.JS as J
41import qualified Language.PureScript.CodeGen.JS as J
41import qualified Language.PureScript.CoreFn as CF
42import qualified Language.PureScript.CoreFn as CF
43+import qualified Language.PureScript.Docs as Docs
42
44
43import Data.Char (isSpace)
45import Data.Char (isSpace)
44import Data.Maybe (mapMaybe, fromMaybe)
46import Data.Maybe (mapMaybe, fromMaybe)
@@ -69,6 +71,7 @@ import Text.Parsec (ParseError)
69
71
70import TestsSetup
72import TestsSetup
71import TestPscPublish
73import TestPscPublish
74+import qualified TestDocs
72
75
73modulesDir :: FilePath
76modulesDir :: FilePath
74modulesDir = ".test_modules" </> "node_modules"
77modulesDir = ".test_modules" </> "node_modules"
@@ -172,8 +175,20 @@ assertDoesNotCompile inputFiles foreigns = do
172
175
173main :: IO ()
176main :: IO ()
174main = do
177main = do
178+ heading "Main compiler test suite"
175 testCompiler
179 testCompiler
180+ heading "Documentation test suite"
181+ TestDocs.main
182+ -- heading "psc-publish test suite"
176− testPscPublish
183+ -- testPscPublish
184+
185+ where
186+ heading msg = do
187+ putStrLn ""
188+ putStrLn $ replicate 79 '#'
189+ putStrLn $ "# " ++ msg
190+ putStrLn $ replicate 79 '#'
191+ putStrLn ""
177
192
178testCompiler :: IO ()
193testCompiler :: IO ()
179testCompiler = do
194testCompiler = do
@@ -201,7 +216,7 @@ testCompiler = do
201 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
216 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
202
217
203 if null failures
218 if null failures
204− then exitSuccess
219+ then pure ()
205 else do
220 else do
206 putStrLn "Failures:"
221 putStrLn "Failures:"
207 forM_ failures $ \(fp, err) ->
222 forM_ failures $ \(fp, err) ->
@@ -213,6 +228,7 @@ testPscPublish :: IO ()
213testPscPublish = do
228testPscPublish = do
214 testPackage "tests/support/prelude"
229 testPackage "tests/support/prelude"
215
230
231+
216supportModules :: [String]
232supportModules :: [String]
217supportModules =
233supportModules =
218 [ "Control.Monad.Eff.Class"
234 [ "Control.Monad.Eff.Class"
tests/TestDocs.hsnew file+232
@@ -0,0 +1,232 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE ViewPatterns #-}
3+{-# LANGUAGE DataKinds #-}
4+
5+module TestDocs where
6+
7+import Prelude ()
8+import Prelude.Compat
9+
10+import Data.Version (Version(..))
11+
12+import Control.Monad hiding (forM_)
13+import Control.Applicative
14+import Control.Arrow
15+import Data.Maybe (fromMaybe)
16+import Data.List ((\\))
17+import Data.Foldable
18+import Data.Traversable
19+import System.Exit
20+import qualified Text.Parsec as Parsec
21+
22+import qualified Language.PureScript as P
23+import qualified Language.PureScript.Docs as Docs
24+import qualified Language.PureScript.Publish as Publish
25+
26+import qualified TestPscPublish
27+
28+publishOpts :: Publish.PublishOptions
29+publishOpts = Publish.defaultPublishOptions
30+ { Publish.publishGetVersion = return testVersion
31+ , Publish.publishWorkingTreeDirty = return ()
32+ }
33+ where testVersion = ("v999.0.0", Version [999,0,0] [])
34+
35+main :: IO ()
36+main = do
37+ TestPscPublish.pushd "examples/docs" $ do
38+ Docs.Package{..} <- Publish.preparePackage publishOpts
39+ forM_ testCases $ \(mn, pragmas) ->
40+ let mdl = takeJust ("module not found in docs: " ++ mn)
41+ (find ((==) mn . Docs.modName) pkgModules)
42+ in forM_ pragmas (flip runAssertionIO mdl)
43+
44+takeJust :: String -> Maybe a -> a
45+takeJust msg = maybe (error msg) id
46+
47+data Assertion
48+ -- | Assert that a particular declaration is documented with the given
49+ -- children
50+ = ShouldBeDocumented P.ModuleName String [String]
51+ -- | Assert that a particular declaration is not documented
52+ | ShouldNotBeDocumented P.ModuleName String
53+ -- | Assert that a particular declaration exists, but without a particular
54+ -- child.
55+ | ChildShouldNotBeDocumented P.ModuleName String String
56+ -- | Assert that a particular declaration has a particular type class
57+ -- constraint.
58+ | ShouldBeConstrained P.ModuleName String String
59+ deriving (Show)
60+
61+data AssertionFailure
62+ -- | A declaration was not documented, but should have been
63+ = NotDocumented P.ModuleName String
64+ -- | A child declaration was not documented, but should have been
65+ | ChildrenNotDocumented P.ModuleName String [String]
66+ -- | A declaration was documented, but should not have been
67+ | Documented P.ModuleName String
68+ -- | A child declaration was documented, but should not have been
69+ | ChildDocumented P.ModuleName String String
70+ -- | A constraint was missing.
71+ | ConstraintMissing P.ModuleName String String
72+ -- | A declaration had the wrong "type" (ie, value, type, type class)
73+ -- Fields: declaration title, expected "type", actual "type".
74+ | WrongDeclarationType P.ModuleName String String String
75+ deriving (Show)
76+
77+data AssertionResult
78+ = Pass
79+ | Fail AssertionFailure
80+ deriving (Show)
81+
82+runAssertion :: Assertion -> Docs.Module -> AssertionResult
83+runAssertion assertion Docs.Module{..} =
84+ case assertion of
85+ ShouldBeDocumented mn decl children ->
86+ case findChildren decl (declarationsFor mn) of
87+ Nothing ->
88+ Fail (NotDocumented mn decl)
89+ Just actualChildren ->
90+ case children \\ actualChildren of
91+ [] -> Pass
92+ cs -> Fail (ChildrenNotDocumented mn decl cs)
93+
94+ ShouldNotBeDocumented mn decl ->
95+ case findChildren decl (declarationsFor mn) of
96+ Just _ ->
97+ Fail (Documented mn decl)
98+ Nothing ->
99+ Pass
100+
101+ ChildShouldNotBeDocumented mn decl child ->
102+ case findChildren decl (declarationsFor mn) of
103+ Just children ->
104+ if child `elem` children
105+ then Fail (ChildDocumented mn decl child)
106+ else Pass
107+ Nothing ->
108+ Fail (NotDocumented mn decl)
109+
110+ ShouldBeConstrained mn decl tyClass ->
111+ case find ((==) decl . Docs.declTitle) (declarationsFor mn) of
112+ Nothing ->
113+ Fail (NotDocumented mn decl)
114+ Just Docs.Declaration{..} ->
115+ case declInfo of
116+ Docs.ValueDeclaration ty ->
117+ if checkConstrained ty tyClass
118+ then Pass
119+ else Fail (ConstraintMissing mn decl tyClass)
120+ _ ->
121+ Fail (WrongDeclarationType mn decl "value"
122+ (Docs.declInfoToString declInfo))
123+
124+ where
125+ declarationsFor mn =
126+ if P.runModuleName mn == modName
127+ then modDeclarations
128+ else fromMaybe [] (lookup mn modReExports)
129+
130+ findChildren title =
131+ fmap childrenTitles . find ((==) title . Docs.declTitle)
132+
133+ childrenTitles = map Docs.cdeclTitle . Docs.declChildren
134+
135+checkConstrained ty tyClass =
136+ -- Note that we don't recurse on ConstrainedType if none of the constraints
137+ -- match; this is by design, as constraints should be moved to the front
138+ -- anyway.
139+ case ty of
140+ P.ConstrainedType cs _ | any (matches tyClass) cs ->
141+ True
142+ P.ForAll _ ty' _ ->
143+ checkConstrained ty' tyClass
144+ _ ->
145+ False
146+ where
147+ matches className =
148+ (==) className . P.runProperName . P.disqualify . fst
149+
150+runAssertionIO :: Assertion -> Docs.Module -> IO ()
151+runAssertionIO assertion mdl = do
152+ putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion)
153+ case runAssertion assertion mdl of
154+ Pass -> pure ()
155+ fail -> do
156+ putStrLn (show fail)
157+ exitFailure
158+
159+testCases :: [(String, [Assertion])]
160+testCases =
161+ [ ("Example",
162+ [ -- From dependencies
163+ ShouldBeDocumented (n "Prelude") "Unit" []
164+ , ShouldNotBeDocumented (n "Prelude") "unit"
165+
166+ -- From local files
167+ , ShouldBeDocumented (n "Example2") "one" []
168+ , ShouldNotBeDocumented (n "Example2") "two"
169+ ])
170+ , ("Example2",
171+ [ ShouldBeDocumented (n "Example2") "one" []
172+ , ShouldBeDocumented (n "Example2") "two" []
173+ ])
174+
175+ , ("UTF8",
176+ [ ShouldBeDocumented (n "UTF8") "thing" []
177+ ])
178+
179+ , ("Transitive1",
180+ [ ShouldBeDocumented (n "Transitive2") "transitive3" []
181+ ])
182+
183+ , ("NotAllCtors",
184+ [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"]
185+ , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
186+ ])
187+
188+ , ("DuplicateNames",
189+ [ ShouldBeDocumented (n "Prelude") "Unit" []
190+ , ShouldBeDocumented (n "DuplicateNames") "unit" []
191+ , ShouldNotBeDocumented (n "Prelude") "unit"
192+ ])
193+
194+ , ("MultiVirtual",
195+ [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
196+ , ShouldBeDocumented (n "MultiVirtual2") "bar" []
197+ , ShouldBeDocumented (n "MultiVirtual2") "baz" []
198+ ])
199+
200+ , ("Clash",
201+ [ ShouldBeDocumented (n "Clash1") "value" []
202+ , ShouldBeDocumented (n "Clash1") "Type" []
203+ , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
204+ ])
205+
206+ , ("SolitaryTypeClassMember",
207+ [ ShouldBeDocumented (n "SomeTypeClass") "member" []
208+ , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
209+ , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass"
210+ ])
211+
212+ , ("ReExportedTypeClass",
213+ [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
214+ ])
215+
216+ , ("TypeClassWithoutMembers",
217+ [ ShouldBeDocumented (n "Intermediate") "SomeClass" []
218+ , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member"
219+ ])
220+
221+ -- Remove this after 0.9.
222+ , ("OldOperators",
223+ [ ShouldBeDocumented (n "OldOperators2") "(>>)" []
224+ ])
225+
226+ , ("NewOperators",
227+ [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
228+ ])
229+ ]
230+
231+ where
232+ n = P.moduleNameFromString
tests/TestPscPublish.hs+3−3
@@ -60,6 +60,6 @@ testPackage dir = do
60 case r of
60 case r of
61 Pass _ -> pure ()
61 Pass _ -> pure ()
62 other -> do
62 other -> do
63− hPutStrLn stderr ("psc-publish tests failed on " ++ dir ++ ":")
63+ putStrLn ("psc-publish tests failed on " ++ dir ++ ":")
64− hPutStrLn stderr (show other)
64+ putStrLn (show other)
65− exitFailure
65+ exitFailure