From a7190b2d5d6d71a290a049c3b1d44d83b6fdabb3 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Sun, 14 Jan 2018 11:25:44 -0500 Subject: [PATCH 1/5] allow for explicit exports in generating tags fixes https://github.com/purescript/purescript/issues/3204 Reuses other formats' (HTML, Markdown) machinery for converting PS modules to a friendlier doc module format before generating tags. This eliminates some error-prone ad-hoc logic for converting declarations directly to tags. --- app/Command/Docs.hs | 38 ++++++-------------------------------- app/Command/Docs/Ctags.hs | 6 +++--- app/Command/Docs/Etags.hs | 6 +++--- app/Command/Docs/Tags.hs | 32 +++++++++++++++++--------------- 4 files changed, 29 insertions(+), 53 deletions(-) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 8e728eb19c..5e1992a7d7 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -2,8 +2,6 @@ module Command.Docs (command, infoModList) where -import Protolude (ordNub) - import Command.Docs.Etags import Command.Docs.Ctags import Command.Docs.Html @@ -12,12 +10,10 @@ import Control.Arrow (first, second) import Control.Category ((>>>)) import Control.Monad.Writer import Control.Monad.Trans.Except (runExceptT) -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Function (on) import Data.List -import Data.Maybe (fromMaybe) import Data.Tuple (swap) import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D @@ -28,8 +24,8 @@ import System.Directory (createDirectoryIfMissing) import System.Exit (exitFailure) import System.FilePath (takeDirectory) import System.FilePath.Glob (glob) -import System.IO (hPutStrLn, hPrint, stderr) -import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT) +import System.IO (hPutStrLn, stderr) +import System.IO.UTF8 (writeUTF8FileT) -- | Available output formats data Format @@ -60,19 +56,17 @@ docgen (PSCDocsOptions fmt inputGlob output) = do hPutStrLn stderr "purs docs: no input files." exitFailure + ms <- parseAndConvert input case fmt of - Etags -> dumpTags input dumpEtags - Ctags -> dumpTags input dumpCtags + Etags -> mapM_ putStrLn $ dumpEtags $ zip input ms + Ctags -> mapM_ putStrLn $ dumpCtags $ zip input ms Html -> do let outputDir = "./generated-docs" -- TODO: make this configurable - ms <- parseAndConvert input let msHtml = map asHtml (D.primDocsModule : ms) createDirectoryIfMissing False outputDir writeHtmlModules outputDir msHtml - Markdown -> do - ms <- parseAndConvert input - + Markdown -> case output of EverythingToStdOut -> T.putStrLn (D.runDocs (D.modulesAsMarkdown ms)) @@ -139,26 +133,6 @@ takeModulesByName' getModuleName modules = foldl go ([], []) Just m -> ((m, x) : ms, missing) Nothing -> (ms, name : missing) -dumpTags :: [FilePath] -> ([(String, P.Module)] -> [String]) -> IO () -dumpTags input renderTags = do - e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (ordNub input) - case e of - Left err -> do - hPrint stderr err - exitFailure - Right ms -> - ldump (renderTags (pairs ms)) - - where - pairs :: [(Maybe String, m)] -> [(String, m)] - pairs = map (first (fromMaybe "")) - - ldump :: [String] -> IO () - ldump = mapM_ putStrLn - -parseFile :: FilePath -> IO (FilePath, Text) -parseFile input = (,) input <$> readUTF8FileT input - inputFile :: Opts.Parser FilePath inputFile = Opts.strArgument $ Opts.metavar "FILE" diff --git a/app/Command/Docs/Ctags.hs b/app/Command/Docs/Ctags.hs index 9cfd71442f..f97e4b8e58 100644 --- a/app/Command/Docs/Ctags.hs +++ b/app/Command/Docs/Ctags.hs @@ -2,12 +2,12 @@ module Command.Docs.Ctags (dumpCtags) where import Command.Docs.Tags import Data.List (sort) -import qualified Language.PureScript as P +import Language.PureScript.Docs.Types (Module) -dumpCtags :: [(String, P.Module)] -> [String] +dumpCtags :: [(String, Module)] -> [String] dumpCtags = sort . concatMap renderModCtags -renderModCtags :: (String, P.Module) -> [String] +renderModCtags :: (String, Module) -> [String] renderModCtags (path, mdl) = sort tagLines where tagLines = map tagLine $ tags mdl tagLine (name, line) = name ++ "\t" ++ path ++ "\t" ++ show line diff --git a/app/Command/Docs/Etags.hs b/app/Command/Docs/Etags.hs index c6e431916e..8136adea8c 100644 --- a/app/Command/Docs/Etags.hs +++ b/app/Command/Docs/Etags.hs @@ -1,12 +1,12 @@ module Command.Docs.Etags (dumpEtags) where import Command.Docs.Tags -import qualified Language.PureScript as P +import Language.PureScript.Docs.Types (Module) -dumpEtags :: [(String, P.Module)] -> [String] +dumpEtags :: [(String, Module)] -> [String] dumpEtags = concatMap renderModEtags -renderModEtags :: (String, P.Module) -> [String] +renderModEtags :: (String, Module) -> [String] renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines where tagsLen = sum $ map length tagLines tagLines = map tagLine $ tags mdl diff --git a/app/Command/Docs/Tags.hs b/app/Command/Docs/Tags.hs index ebf3ae82ad..f49df2d090 100644 --- a/app/Command/Docs/Tags.hs +++ b/app/Command/Docs/Tags.hs @@ -1,21 +1,23 @@ module Command.Docs.Tags where import Control.Arrow (first) +import Data.Maybe (mapMaybe) import qualified Data.Text as T -import qualified Language.PureScript as P +import Language.PureScript.AST (SourceSpan, sourcePosLine, spanStart) +import Language.PureScript.Docs.Types -tags :: P.Module -> [(String, Int)] -tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations +tags :: Module -> [(String, Int)] +tags = map (first T.unpack) . concatMap dtags . modDeclarations where - dtags :: P.Declaration -> [(P.Text, Int)] - dtags (P.DataDeclaration (ss, _) _ name _ dcons) = (P.runProperName name, pos ss) : consNames - where consNames = map (\(cname, _) -> (P.runProperName cname, pos ss)) dcons - dtags (P.TypeDeclaration (P.TypeDeclarationData (ss, _) ident _)) = [(P.showIdent ident, pos ss)] - dtags (P.ExternDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)] - dtags (P.TypeSynonymDeclaration (ss, _) name _ _) = [(P.runProperName name, pos ss)] - dtags (P.TypeClassDeclaration (ss, _) name _ _ _ _) = [(P.runProperName name, pos ss)] - dtags (P.TypeInstanceDeclaration (ss, _) _ _ name _ _ _ _) = [(P.showIdent name, pos ss)] - dtags (P.ExternKindDeclaration (ss, _) name) = [(P.runProperName name, pos ss)] - dtags _ = [] - pos :: P.SourceSpan -> Int - pos = P.sourcePosLine . P.spanStart + dtags :: Declaration -> [(T.Text, Int)] + dtags decl = case declSourceSpan decl of + Just ss -> (declTitle decl, pos ss):(mapMaybe subtag $ declChildren decl) + Nothing -> mapMaybe subtag $ declChildren decl + + subtag :: ChildDeclaration -> Maybe (T.Text, Int) + subtag cdecl = case cdeclSourceSpan cdecl of + Just ss -> Just (cdeclTitle cdecl, pos ss) + Nothing -> Nothing + + pos :: SourceSpan -> Int + pos = sourcePosLine . spanStart From b7795e30a4e4b6a312a35c78007c804301e366a5 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Fri, 19 Jan 2018 22:25:10 -0500 Subject: [PATCH 2/5] move tag generation into lib this makes tag generation more testable --- app/Command/Docs.hs | 3 +-- app/Command/Docs/Ctags.hs | 13 ---------- app/Command/Docs/Etags.hs | 13 ---------- package.yaml | 3 --- .../Language/PureScript}/Docs/Tags.hs | 25 ++++++++++++++++++- 5 files changed, 25 insertions(+), 32 deletions(-) delete mode 100644 app/Command/Docs/Ctags.hs delete mode 100644 app/Command/Docs/Etags.hs rename {app/Command => src/Language/PureScript}/Docs/Tags.hs (50%) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 5e1992a7d7..28b00590ab 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -2,8 +2,6 @@ module Command.Docs (command, infoModList) where -import Command.Docs.Etags -import Command.Docs.Ctags import Command.Docs.Html import Control.Applicative import Control.Arrow (first, second) @@ -18,6 +16,7 @@ import Data.Tuple (swap) import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D import qualified Language.PureScript.Docs.AsMarkdown as D +import Language.PureScript.Docs.Tags (dumpCtags, dumpEtags) import qualified Options.Applicative as Opts import qualified Text.PrettyPrint.ANSI.Leijen as PP import System.Directory (createDirectoryIfMissing) diff --git a/app/Command/Docs/Ctags.hs b/app/Command/Docs/Ctags.hs deleted file mode 100644 index f97e4b8e58..0000000000 --- a/app/Command/Docs/Ctags.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Command.Docs.Ctags (dumpCtags) where - -import Command.Docs.Tags -import Data.List (sort) -import Language.PureScript.Docs.Types (Module) - -dumpCtags :: [(String, Module)] -> [String] -dumpCtags = sort . concatMap renderModCtags - -renderModCtags :: (String, Module) -> [String] -renderModCtags (path, mdl) = sort tagLines - where tagLines = map tagLine $ tags mdl - tagLine (name, line) = name ++ "\t" ++ path ++ "\t" ++ show line diff --git a/app/Command/Docs/Etags.hs b/app/Command/Docs/Etags.hs deleted file mode 100644 index 8136adea8c..0000000000 --- a/app/Command/Docs/Etags.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Command.Docs.Etags (dumpEtags) where - -import Command.Docs.Tags -import Language.PureScript.Docs.Types (Module) - -dumpEtags :: [(String, Module)] -> [String] -dumpEtags = concatMap renderModEtags - -renderModEtags :: (String, Module) -> [String] -renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines - where tagsLen = sum $ map length tagLines - tagLines = map tagLine $ tags mdl - tagLine (name, line) = "\x7f" ++ name ++ "\x01" ++ show line ++ "," diff --git a/package.yaml b/package.yaml index 6a2b0bf4d6..19ce9c58c2 100644 --- a/package.yaml +++ b/package.yaml @@ -120,10 +120,7 @@ executables: - Command.Bundle - Command.Compile - Command.Docs - - Command.Docs.Ctags - - Command.Docs.Etags - Command.Docs.Html - - Command.Docs.Tags - Command.Hierarchy - Command.Ide - Command.Publish diff --git a/app/Command/Docs/Tags.hs b/src/Language/PureScript/Docs/Tags.hs similarity index 50% rename from app/Command/Docs/Tags.hs rename to src/Language/PureScript/Docs/Tags.hs index f49df2d090..fe7c10dd6e 100644 --- a/app/Command/Docs/Tags.hs +++ b/src/Language/PureScript/Docs/Tags.hs @@ -1,6 +1,12 @@ -module Command.Docs.Tags where +module Language.PureScript.Docs.Tags + ( dumpCtags + , dumpEtags + ) where + +import Prelude import Control.Arrow (first) +import Data.List (sort) import Data.Maybe (mapMaybe) import qualified Data.Text as T import Language.PureScript.AST (SourceSpan, sourcePosLine, spanStart) @@ -21,3 +27,20 @@ tags = map (first T.unpack) . concatMap dtags . modDeclarations pos :: SourceSpan -> Int pos = sourcePosLine . spanStart + +dumpEtags :: [(String, Module)] -> [String] +dumpEtags = concatMap renderModEtags + +renderModEtags :: (String, Module) -> [String] +renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines + where tagsLen = sum $ map length tagLines + tagLines = map tagLine $ tags mdl + tagLine (name, line) = "\x7f" ++ name ++ "\x01" ++ show line ++ "," + +dumpCtags :: [(String, Module)] -> [String] +dumpCtags = sort . concatMap renderModCtags + +renderModCtags :: (String, Module) -> [String] +renderModCtags (path, mdl) = sort tagLines + where tagLines = map tagLine $ tags mdl + tagLine (name, line) = name ++ "\t" ++ path ++ "\t" ++ show line From d1bdf56941998e67a6fe6f616c5f15758b446411 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Sat, 20 Jan 2018 10:35:46 -0500 Subject: [PATCH 3/5] ensure proper sorting in tag generation For all tags, use a Map to ensure that filenames and modules correspond correctly. For ctags, add a comment explaining why we sort on tag name. For etags, ensure that they are sorted by module. --- app/Command/Docs.hs | 25 ++++++++++++++----- .../PureScript/Docs/ParseInPackage.hs | 11 ++++---- src/Language/PureScript/Docs/Tags.hs | 8 +++++- src/Language/PureScript/Publish.hs | 2 +- 4 files changed, 33 insertions(+), 13 deletions(-) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 28b00590ab..58defd1ad9 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -8,6 +8,8 @@ import Control.Arrow (first, second) import Control.Category ((>>>)) import Control.Monad.Writer import Control.Monad.Trans.Except (runExceptT) +import qualified Data.Map.Strict as M +import Data.Maybe (fromJust) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Function (on) @@ -55,10 +57,11 @@ docgen (PSCDocsOptions fmt inputGlob output) = do hPutStrLn stderr "purs docs: no input files." exitFailure - ms <- parseAndConvert input + fileMs <- parseAndConvert input + let ms = map snd fileMs case fmt of - Etags -> mapM_ putStrLn $ dumpEtags $ zip input ms - Ctags -> mapM_ putStrLn $ dumpCtags $ zip input ms + Etags -> mapM_ putStrLn $ dumpEtags fileMs + Ctags -> mapM_ putStrLn $ dumpCtags fileMs Html -> do let outputDir = "./generated-docs" -- TODO: make this configurable let msHtml = map asHtml (D.primDocsModule : ms) @@ -107,9 +110,19 @@ docgen (PSCDocsOptions fmt inputGlob output) = do takeByName' = takeModulesByName' D.modName parseAndConvert input = - runExceptT (D.parseFilesInPackages input [] - >>= uncurry D.convertModulesInPackage) - >>= successOrExit + runExceptT (do + (modules, moduleMap) <- D.parseFilesInPackages input [] + + let moduleNameToFileMap = + M.fromList $ swap . fmap P.getModuleName <$> modules + getModuleFile docModule = + fromJust $ M.lookup (D.modName docModule) moduleNameToFileMap + pairDocModule docModule = + (getModuleFile docModule, docModule) + + convertedModules <- D.convertModulesInPackage (map snd modules) moduleMap + pure $ pairDocModule <$> convertedModules + ) >>= successOrExit -- | -- Given a list of module names and a list of modules, return a list of modules diff --git a/src/Language/PureScript/Docs/ParseInPackage.hs b/src/Language/PureScript/Docs/ParseInPackage.hs index 311980b4ac..7a90a84067 100644 --- a/src/Language/PureScript/Docs/ParseInPackage.hs +++ b/src/Language/PureScript/Docs/ParseInPackage.hs @@ -23,14 +23,15 @@ import Web.Bower.PackageMeta (PackageName) -- * Parse all of the input and dependency source files -- * Associate each dependency module with its package name, thereby -- distinguishing these from local modules --- * Return the parsed modules and a Map mapping module names to package --- names for modules which come from dependencies. If a module does not --- exist in the map, it can safely be assumed to be local. +-- * Return the paths paired with parsed modules, and a Map of module names +-- to package names for modules which come from dependencies. +-- If a module does not exist in the map, it can safely be assumed to be +-- local. parseFilesInPackages :: (MonadError P.MultipleErrors m, MonadIO m) => [FilePath] -> [(PackageName, FilePath)] - -> m ([P.Module], Map P.ModuleName PackageName) + -> m ([(FilePath, P.Module)], Map P.ModuleName PackageName) parseFilesInPackages inputFiles depsFiles = do inputFiles' <- traverse (readFileAs . Local) inputFiles depsFiles' <- traverse (readFileAs . uncurry FromDep) depsFiles @@ -39,7 +40,7 @@ parseFilesInPackages inputFiles depsFiles = do let mnMap = M.fromList (mapMaybe (\(inpkg, m) -> (P.getModuleName m,) <$> inPkgToMaybe inpkg) modules) - pure (map snd modules, mnMap) + pure (map (first fileInfoToString) modules, mnMap) where parse :: diff --git a/src/Language/PureScript/Docs/Tags.hs b/src/Language/PureScript/Docs/Tags.hs index fe7c10dd6e..1a6871675e 100644 --- a/src/Language/PureScript/Docs/Tags.hs +++ b/src/Language/PureScript/Docs/Tags.hs @@ -28,8 +28,11 @@ tags = map (first T.unpack) . concatMap dtags . modDeclarations pos :: SourceSpan -> Int pos = sourcePosLine . spanStart +-- etags files appear to be sorted on module file name: +-- from emacs source, `emacs/lib-src/etags.c`: +-- "In etags mode, sort by file name." dumpEtags :: [(String, Module)] -> [String] -dumpEtags = concatMap renderModEtags +dumpEtags = concatMap renderModEtags . sort renderModEtags :: (String, Module) -> [String] renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines @@ -37,6 +40,9 @@ renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines tagLines = map tagLine $ tags mdl tagLine (name, line) = "\x7f" ++ name ++ "\x01" ++ show line ++ "," +-- ctags files are required to be sorted: http://ctags.sourceforge.net/FORMAT +-- "The tags file is sorted on {tagname}. This allows for a binary search in +-- the file." dumpCtags :: [(String, Module)] -> [String] dumpCtags = sort . concatMap renderModCtags diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index e41620e33b..73545bf488 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -149,7 +149,7 @@ getModules paths = do (inputFiles, depsFiles) <- liftIO (getInputAndDepsFiles paths) (modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles - case runExcept (D.convertModulesInPackage modules' moduleMap) of + case runExcept (D.convertModulesInPackage (map snd modules') moduleMap) of Right modules -> return (modules, moduleMap) Left err -> userError (CompileError err) From 53513d77479dc8518dd4cd5c1dd8e0ed0df85836 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Sun, 14 Jan 2018 17:54:59 -0500 Subject: [PATCH 4/5] test tags --- examples/docs/src/ExplicitExport.purs | 7 ++ src/Language/PureScript/Docs.hs | 1 + src/Language/PureScript/Docs/Tags.hs | 3 +- tests/TestDocs.hs | 122 +++++++++++++++++++++++--- 4 files changed, 121 insertions(+), 12 deletions(-) create mode 100644 examples/docs/src/ExplicitExport.purs diff --git a/examples/docs/src/ExplicitExport.purs b/examples/docs/src/ExplicitExport.purs new file mode 100644 index 0000000000..43e7ba6610 --- /dev/null +++ b/examples/docs/src/ExplicitExport.purs @@ -0,0 +1,7 @@ +module ExplicitExport (one) where + +one :: Int +one = 1 + +two :: Int +two = 2 diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs index f63544c639..16673c053e 100644 --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -11,5 +11,6 @@ import Language.PureScript.Docs.Prim as Docs import Language.PureScript.Docs.ParseInPackage as Docs import Language.PureScript.Docs.Render as Docs import Language.PureScript.Docs.RenderedCode as Docs +import Language.PureScript.Docs.Tags as Docs import Language.PureScript.Docs.Types as Docs import Language.PureScript.Docs.Css as Docs diff --git a/src/Language/PureScript/Docs/Tags.hs b/src/Language/PureScript/Docs/Tags.hs index 1a6871675e..0310bb7a63 100644 --- a/src/Language/PureScript/Docs/Tags.hs +++ b/src/Language/PureScript/Docs/Tags.hs @@ -1,5 +1,6 @@ module Language.PureScript.Docs.Tags - ( dumpCtags + ( tags + , dumpCtags , dumpEtags ) where diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 8311fefad5..5d438d86ad 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -15,6 +15,7 @@ import Control.Monad.IO.Class (liftIO) import Data.List (findIndex) import Data.Foldable import Safe (headMay) +import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import Data.Text (Text) @@ -64,18 +65,31 @@ spec = do let linksCtx = Docs.getLinksContext pkg - context "Language.PureScript.Docs" $ - forM_ testCases $ \(mnString, assertions) -> do - let mn = P.moduleNameFromString mnString - mdl = find ((==) mn . Docs.modName) pkgModules + context "Language.PureScript.Docs" $ do + context "Doc generation tests:" $ + forM_ testCases $ \(mnString, assertions) -> do + let mn = P.moduleNameFromString mnString + mdl = find ((==) mn . Docs.modName) pkgModules - context ("in module " ++ T.unpack mnString) $ do - case mdl of - Nothing -> - it "exists in docs output" $ - expectationFailure ("module not found in docs: " ++ T.unpack mnString) - Just mdl' -> - toHspec linksCtx mdl' assertions + context ("in module " ++ T.unpack mnString) $ + case mdl of + Nothing -> + it "exists in docs output" $ + expectationFailure ("module not found in docs: " ++ T.unpack mnString) + Just mdl' -> + toHspec linksCtx mdl' assertions + + context "Tag generation tests:" $ + forM_ testTagsCases $ \(mnString, assertions) -> do + let mn = P.moduleNameFromString mnString + mdl = find ((==) mn . Docs.modName) pkgModules + context ("in module " ++ T.unpack mnString) $ + case mdl of + Nothing -> + it "exists in docs output" $ + expectationFailure ("module not found in docs: " ++ T.unpack mnString) + Just mdl' -> + tagAssertionsToHspec mdl' assertions where toHspec :: Docs.LinksContext -> Docs.Module -> [DocsAssertion] -> Spec @@ -88,6 +102,17 @@ spec = do Fail reason -> expectationFailure (T.unpack (displayAssertionFailure reason)) + tagAssertionsToHspec :: Docs.Module -> [TagsAssertion] -> Spec + tagAssertionsToHspec mdl assertions = + let tags = Map.fromList $ Docs.tags mdl + in forM_ assertions $ \a -> + it (T.unpack (displayTagsAssertion a)) $ do + case runTagsAssertion a tags of + TagsPass -> + pure () + TagsFail reason -> + expectationFailure (T.unpack (displayTagsAssertionFailure reason)) + takeJust :: String -> Maybe a -> a takeJust msg = fromMaybe (error msg) @@ -130,6 +155,12 @@ data DocsAssertion -- | Assert that a given declaration comes before another in the output | ShouldComeBefore P.ModuleName Text Text +data TagsAssertion + -- | Assert that a particular declaration is tagged + = ShouldBeTagged Text Int + -- | Assert that a particular declaration is not tagged + | ShouldNotBeTagged Text + displayAssertion :: DocsAssertion -> Text displayAssertion = \case ShouldBeDocumented mn decl children -> @@ -167,6 +198,13 @@ displayAssertion = \case showQual mn declA <> " should come before " <> showQual mn declB <> " in the docs" +displayTagsAssertion :: TagsAssertion -> Text +displayTagsAssertion = \case + ShouldBeTagged decl l -> + decl <> " should be tagged at line " <> T.pack (show l) + ShouldNotBeTagged decl -> + decl <> " should not be tagged" + data DocsAssertionFailure -- | A declaration was not documented, but should have been = NotDocumented P.ModuleName Text @@ -211,6 +249,14 @@ data DocsAssertionFailure -- | Declarations were in the wrong order | WrongOrder P.ModuleName Text Text +data TagsAssertionFailure + -- | A declaration was not tagged, but should have been + = NotTagged Text + -- | A declaration was tagged, but should not have been + | Tagged Text Int + -- | A declaration was tagged on the wrong line + | TaggedWrongLine Text Int Int + displayAssertionFailure :: DocsAssertionFailure -> Text displayAssertionFailure = \case NotDocumented _ decl -> @@ -251,10 +297,25 @@ displayAssertionFailure = \case WrongOrder _ before after -> "expected to see " <> before <> " before " <> after +displayTagsAssertionFailure :: TagsAssertionFailure -> Text +displayTagsAssertionFailure = \case + NotTagged decl -> + decl <> " was not tagged, but should have been" + Tagged decl line -> + decl <> " was tagged at line " <> T.pack (show line) <> + ", but should not have been" + TaggedWrongLine decl taggedLine desiredLine -> + decl <> " was tagged at line " <> T.pack (show taggedLine) <> + ", but should have been tagged at line " <> T.pack (show desiredLine) + data DocsAssertionResult = Pass | Fail DocsAssertionFailure +data TagsAssertionResult + = TagsPass + | TagsFail TagsAssertionFailure + runAssertion :: DocsAssertion -> Docs.LinksContext -> Docs.Module -> DocsAssertionResult runAssertion assertion linksCtx Docs.Module{..} = case assertion of @@ -423,6 +484,22 @@ runAssertion assertion linksCtx Docs.Module{..} = _ -> Nothing +runTagsAssertion :: TagsAssertion -> Map.Map String Int -> TagsAssertionResult +runTagsAssertion assertion tags = + case assertion of + ShouldBeTagged decl line -> + case Map.lookup (T.unpack decl) tags of + Just taggedLine -> + if taggedLine == line + then TagsPass + else TagsFail $ TaggedWrongLine decl taggedLine line + Nothing -> TagsFail $ NotTagged decl + + ShouldNotBeTagged decl -> + case Map.lookup (T.unpack decl) tags of + Just taggedLine -> TagsFail $ Tagged decl taggedLine + Nothing -> TagsPass + checkConstrained :: P.Type -> Text -> Bool checkConstrained ty tyClass = case ty of @@ -584,6 +661,29 @@ testCases = shouldBeOrdered mn declNames = zipWith (ShouldComeBefore mn) declNames (tail declNames) +testTagsCases :: [(Text, [TagsAssertion])] +testTagsCases = + [ ("DeclOrder", + [ -- explicit exports + ShouldBeTagged "x1" 10 + , ShouldBeTagged "x3" 11 + , ShouldBeTagged "X2" 13 + , ShouldBeTagged "X4" 14 + , ShouldBeTagged "A" 16 + , ShouldBeTagged "B" 17 + ]) + , ("Example2", + [ -- all symbols exported + ShouldBeTagged "one" 3 + , ShouldBeTagged "two" 6 + ]) + , ("ExplicitExport", + [ -- only one of two symbols exported + ShouldBeTagged "one" 3 + , ShouldNotBeTagged "two" + ]) + ] + showQual :: P.ModuleName -> Text -> Text showQual mn decl = P.runModuleName mn <> "." <> decl From b89492f9ec856b49aa0427107d79b1624ddef0f3 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Sun, 21 Jan 2018 17:14:27 -0500 Subject: [PATCH 5/5] docs/tags: move logic for linking paths to modules Move the logic for maintaining a map between module paths and data from Command.Docs to Language.PureScript.Docs.Convert, allowing other callers to reuse the functionality. --- app/Command/Docs.hs | 18 +++-------------- src/Language/PureScript/Docs/Convert.hs | 26 +++++++++++++++++++++++++ 2 files changed, 29 insertions(+), 15 deletions(-) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 58defd1ad9..1a4841f094 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -8,8 +8,6 @@ import Control.Arrow (first, second) import Control.Category ((>>>)) import Control.Monad.Writer import Control.Monad.Trans.Except (runExceptT) -import qualified Data.Map.Strict as M -import Data.Maybe (fromJust) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Function (on) @@ -110,19 +108,9 @@ docgen (PSCDocsOptions fmt inputGlob output) = do takeByName' = takeModulesByName' D.modName parseAndConvert input = - runExceptT (do - (modules, moduleMap) <- D.parseFilesInPackages input [] - - let moduleNameToFileMap = - M.fromList $ swap . fmap P.getModuleName <$> modules - getModuleFile docModule = - fromJust $ M.lookup (D.modName docModule) moduleNameToFileMap - pairDocModule docModule = - (getModuleFile docModule, docModule) - - convertedModules <- D.convertModulesInPackage (map snd modules) moduleMap - pure $ pairDocModule <$> convertedModules - ) >>= successOrExit + runExceptT (D.parseFilesInPackages input [] + >>= uncurry D.convertTaggedModulesInPackage) + >>= successOrExit -- | -- Given a list of module names and a list of modules, return a list of modules diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 17b72aea80..af3cf067cd 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -4,6 +4,7 @@ module Language.PureScript.Docs.Convert ( convertModules , convertModulesWithEnv + , convertTaggedModulesInPackage , convertModulesInPackage , convertModulesInPackageWithEnv ) where @@ -25,6 +26,31 @@ import Web.Bower.PackageMeta (PackageName) import Text.Parsec (eof) +-- | +-- Like convertModuleInPackage, but with the modules tagged by their +-- file paths. +-- +convertTaggedModulesInPackage :: + (MonadError P.MultipleErrors m) => + [(FilePath, P.Module)] -> + Map P.ModuleName PackageName -> + m [(FilePath, Module)] +convertTaggedModulesInPackage taggedModules modulesDeps = + traverse pairDocModule =<< convertModulesInPackage modules modulesDeps + where + modules = map snd taggedModules + + moduleNameToFileMap = + Map.fromList $ swap . fmap P.getModuleName <$> taggedModules + + getModuleFile docModule = + case Map.lookup (modName docModule) moduleNameToFileMap of + Just filePath -> pure filePath + Nothing -> throwError . P.errorMessage $ + P.ModuleNotFound $ modName docModule + + pairDocModule docModule = (, docModule) <$> getModuleFile docModule + -- | -- Like convertModules, except that it takes a list of modules, together with -- their dependency status, and discards dependency modules in the resulting