purescript · hdgarrood · Jan 23, 2018 · Jan 14, 2018 · Jan 20, 2018 · Jan 20, 2018
diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs
@@ -2,34 +2,29 @@
 
 module Command.Docs (command, infoModList) where
 
-import           Protolude (ordNub)
-
-import           Command.Docs.Etags
-import           Command.Docs.Ctags
 import           Command.Docs.Html
 import           Control.Applicative
 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
 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)
 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 +55,18 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
     hPutStrLn stderr "purs docs: no input files."
     exitFailure
 
+  fileMs <- parseAndConvert input
+  let ms = map snd fileMs
   case fmt of
-    Etags -> dumpTags input dumpEtags
-    Ctags -> dumpTags input dumpCtags
+    Etags -> mapM_ putStrLn $ dumpEtags fileMs
+    Ctags -> mapM_ putStrLn $ dumpCtags fileMs
     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))
@@ -115,7 +109,7 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
 
   parseAndConvert input =
     runExceptT (D.parseFilesInPackages input []
-               >>= uncurry D.convertModulesInPackage)
+                >>= uncurry D.convertTaggedModulesInPackage)
     >>= successOrExit
 
 -- |
@@ -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
diff --git a/app/Command/Docs/Etags.hs b/app/Command/Docs/Etags.hs
diff --git a/app/Command/Docs/Tags.hs b/app/Command/Docs/Tags.hs
diff --git a/examples/docs/src/ExplicitExport.purs 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/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/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/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

diff --git 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
@@ -0,0 +1,53 @@
+module Language.PureScript.Docs.Tags
+  ( 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)
+import Language.PureScript.Docs.Types
+
+tags :: Module -> [(String, Int)]
+tags = map (first T.unpack) . concatMap dtags . modDeclarations
+  where
+    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
+
+-- 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 . sort
+
+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 ++ ","
+
+-- 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
+
+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/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)