module Language.PureScript.Docs.Collect
  ( collectDocs
  ) where

import Protolude hiding (check)

import Control.Arrow ((&&&))
import Data.Aeson.BetterErrors qualified as ABE
import Data.ByteString qualified as BS
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import System.FilePath ((</>))
import System.IO.UTF8 (readUTF8FileT, readUTF8FilesT)

import Language.PureScript.Docs.Convert.ReExports (updateReExports)
import Language.PureScript.Docs.Prim (primModules)
import Language.PureScript.Docs.Types (InPackage(..), Module(..), asModule, displayPackageError, ignorePackage)

import Language.PureScript.AST qualified as P
import Language.PureScript.CST qualified as P
import Language.PureScript.Crash qualified as P
import Language.PureScript.Errors qualified as P
import Language.PureScript.Externs qualified as P
import Language.PureScript.Make qualified as P
import Language.PureScript.Names qualified as P
import Language.PureScript.Options qualified as P

import Web.Bower.PackageMeta (PackageName)

-- |
-- Given a compiler output directory, a list of input PureScript source files,
-- and a list of dependency PureScript source files, produce documentation for
-- the input files in the intermediate documentation format. Note that
-- dependency files are not included in the result.
--
-- If the output directory is not up to date with respect to the provided input
-- and dependency files, the files will be built as if with just the "docs"
-- codegen target, i.e. "purs compile --codegen docs".
--
collectDocs ::
  forall m.
  (MonadError P.MultipleErrors m, MonadIO m) =>
  FilePath ->
  [FilePath] ->
  [(PackageName, FilePath)] ->
  m ([(FilePath, Module)], Map P.ModuleName PackageName)
collectDocs :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadIO m) =>
[Char]
-> [[Char]]
-> [(PackageName, [Char])]
-> m ([([Char], Module)], Map ModuleName PackageName)
collectDocs [Char]
outputDir [[Char]]
inputFiles [(PackageName, [Char])]
depsFiles = do
  ([([Char], ModuleName)]
modulePaths, Map ModuleName PackageName
modulesDeps) <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadIO m) =>
[[Char]]
-> [(PackageName, [Char])]
-> m ([([Char], ModuleName)], Map ModuleName PackageName)
getModulePackageInfo [[Char]]
inputFiles [(PackageName, [Char])]
depsFiles
  [ExternsFile]
externs <- forall (m :: * -> *).
(MonadError MultipleErrors m, MonadIO m) =>
[Char] -> [[Char]] -> m [ExternsFile]
compileForDocs [Char]
outputDir (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> a
fst [([Char], ModuleName)]
modulePaths)

  let (ModuleName -> InPackage ModuleName
withPackage, ModuleName -> Bool
shouldKeep) =
        Map ModuleName PackageName
-> (ModuleName -> InPackage ModuleName, ModuleName -> Bool)
packageDiscriminators Map ModuleName PackageName
modulesDeps
  let go :: [([Char], ModuleName)] -> m [([Char], Module)]
go =
        forall (m :: * -> *) a b key tag.
(Monad m, Ord key, Show key) =>
(a -> key)
-> (b -> key) -> ([a] -> m [b]) -> [(tag, a)] -> m [(tag, b)]
operateAndRetag forall a. a -> a
identity Module -> ModuleName
modName forall a b. (a -> b) -> a -> b
$ \[ModuleName]
mns -> do
          [Module]
docsModules <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ModuleName -> IO Module
parseDocsJsonFile [Char]
outputDir) [ModuleName]
mns
          forall (m :: * -> *).
MonadError MultipleErrors m =>
(ModuleName -> InPackage ModuleName)
-> [Module] -> [ExternsFile] -> m [Module]
addReExports ModuleName -> InPackage ModuleName
withPackage [Module]
docsModules [ExternsFile]
externs

  [([Char], Module)]
docsModules <- [([Char], ModuleName)] -> m [([Char], Module)]
go [([Char], ModuleName)]
modulePaths
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName -> Bool
shouldKeep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
modName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([Char], Module)]
docsModules, Map ModuleName PackageName
modulesDeps)

  where
  packageDiscriminators :: Map ModuleName PackageName
-> (ModuleName -> InPackage ModuleName, ModuleName -> Bool)
packageDiscriminators Map ModuleName PackageName
modulesDeps =
    let
      shouldKeep :: ModuleName -> Bool
shouldKeep ModuleName
mn = ModuleName -> Bool
isLocal ModuleName
mn Bool -> Bool -> Bool
&& Bool -> Bool
not (ModuleName -> Bool
P.isBuiltinModuleName ModuleName
mn)

      withPackage :: P.ModuleName -> InPackage P.ModuleName
      withPackage :: ModuleName -> InPackage ModuleName
withPackage ModuleName
mn =
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
mn Map ModuleName PackageName
modulesDeps of
          Just PackageName
pkgName -> forall a. PackageName -> a -> InPackage a
FromDep PackageName
pkgName ModuleName
mn
          Maybe PackageName
Nothing -> forall a. a -> InPackage a
Local ModuleName
mn

      isLocal :: P.ModuleName -> Bool
      isLocal :: ModuleName -> Bool
isLocal = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Bool
Map.member Map ModuleName PackageName
modulesDeps
    in
      (ModuleName -> InPackage ModuleName
withPackage, ModuleName -> Bool
shouldKeep)

-- |
-- Compile with just the 'docs' codegen target, writing results into the given
-- output directory.
--
compileForDocs ::
  forall m.
  (MonadError P.MultipleErrors m, MonadIO m) =>
  FilePath ->
  [FilePath] ->
  m [P.ExternsFile]
compileForDocs :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadIO m) =>
[Char] -> [[Char]] -> m [ExternsFile]
compileForDocs [Char]
outputDir [[Char]]
inputFiles = do
  Either MultipleErrors [ExternsFile]
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    [([Char], Text)]
moduleFiles <- [[Char]] -> IO [([Char], Text)]
readUTF8FilesT [[Char]]
inputFiles
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a.
Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
P.runMake Options
testOptions forall a b. (a -> b) -> a -> b
$ do
      [([Char], PartialResult Module)]
ms <- forall (m :: * -> *) k.
MonadError MultipleErrors m =>
(k -> [Char]) -> [(k, Text)] -> m [(k, PartialResult Module)]
P.parseModulesFromFiles forall a. a -> a
identity [([Char], Text)]
moduleFiles
      let filePathMap :: Map ModuleName (Either RebuildPolicy [Char])
filePathMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\([Char]
fp, PartialResult Module
pm) -> (Module -> ModuleName
P.getModuleName forall a b. (a -> b) -> a -> b
$ forall a. PartialResult a -> a
P.resPartial PartialResult Module
pm, forall a b. b -> Either a b
Right [Char]
fp)) [([Char], PartialResult Module)]
ms
      Map ModuleName [Char]
foreigns <- forall (m :: * -> *).
MonadIO m =>
Map ModuleName (Either RebuildPolicy [Char])
-> m (Map ModuleName [Char])
P.inferForeignModules Map ModuleName (Either RebuildPolicy [Char])
filePathMap
      let makeActions :: MakeActions Make
makeActions =
            ([Char]
-> Map ModuleName (Either RebuildPolicy [Char])
-> Map ModuleName [Char]
-> Bool
-> MakeActions Make
P.buildMakeActions [Char]
outputDir Map ModuleName (Either RebuildPolicy [Char])
filePathMap Map ModuleName [Char]
foreigns Bool
False)
              { progress :: ProgressMessage -> Make ()
P.progress = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
TIO.hPutStr Handle
stdout forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> Text
"\n") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ProgressMessage -> Text
P.renderProgressMessage Text
"Compiling documentation for "
              }
      forall (m :: * -> *).
(MonadBaseControl IO m, MonadError MultipleErrors m,
 MonadWriter MultipleErrors m) =>
MakeActions m -> [PartialResult Module] -> m [ExternsFile]
P.make MakeActions Make
makeActions (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> b
snd [([Char], PartialResult Module)]
ms)
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (m :: * -> *) a. Monad m => a -> m a
return Either MultipleErrors [ExternsFile]
result

  where
  testOptions :: P.Options
  testOptions :: Options
testOptions = Options
P.defaultOptions { optionsCodegenTargets :: Set CodegenTarget
P.optionsCodegenTargets = forall a. a -> Set a
Set.singleton CodegenTarget
P.Docs }

parseDocsJsonFile :: FilePath -> P.ModuleName -> IO Module
parseDocsJsonFile :: [Char] -> ModuleName -> IO Module
parseDocsJsonFile [Char]
outputDir ModuleName
mn =
  let
    filePath :: [Char]
filePath = [Char]
outputDir [Char] -> [Char] -> [Char]
</> Text -> [Char]
T.unpack (ModuleName -> Text
P.runModuleName ModuleName
mn) [Char] -> [Char] -> [Char]
</> [Char]
"docs.json"
  in do
    ByteString
str <- [Char] -> IO ByteString
BS.readFile [Char]
filePath
    case forall err a.
Parse err a -> ByteString -> Either (ParseError err) a
ABE.parseStrict Parse PackageError Module
asModule ByteString
str of
      Right Module
m -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Module
m
      Left ParseError PackageError
err -> forall a. HasCallStack => [Char] -> a
P.internalError forall a b. (a -> b) -> a -> b
$
        [Char]
"Failed to decode: " forall a. [a] -> [a] -> [a]
++ [Char]
filePath forall a. [a] -> [a] -> [a]
++
        forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> [Char]
T.unpack (forall err. (err -> Text) -> ParseError err -> [Text]
ABE.displayError PackageError -> Text
displayPackageError ParseError PackageError
err))

addReExports ::
  (MonadError P.MultipleErrors m) =>
  (P.ModuleName -> InPackage P.ModuleName) ->
  [Module] ->
  [P.ExternsFile] ->
  m [Module]
addReExports :: forall (m :: * -> *).
MonadError MultipleErrors m =>
(ModuleName -> InPackage ModuleName)
-> [Module] -> [ExternsFile] -> m [Module]
addReExports ModuleName -> InPackage ModuleName
withPackage [Module]
docsModules [ExternsFile]
externs = do
  -- We add the Prim docs modules here, so that docs generation is still
  -- possible if the modules we are generating docs for re-export things from
  -- Prim submodules. Note that the Prim modules do not exist as
  -- @Language.PureScript.Module@ values because they do not contain anything
  -- that exists at runtime. However, we have pre-constructed
  -- @Language.PureScript.Docs.Types.Module@ values for them, which we use
  -- here.
  let moduleMap :: Map ModuleName Module
moduleMap =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Module -> ModuleName
modName forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
identity)
               ([Module]
docsModules forall a. [a] -> [a] -> [a]
++ [Module]
primModules))

  let withReExports :: Map ModuleName Module
withReExports = [ExternsFile]
-> (ModuleName -> InPackage ModuleName)
-> Map ModuleName Module
-> Map ModuleName Module
updateReExports [ExternsFile]
externs ModuleName -> InPackage ModuleName
withPackage Map ModuleName Module
moduleMap
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Map k a -> [a]
Map.elems Map ModuleName Module
withReExports)

-- |
-- Perform an operation on a list of things which are tagged, and reassociate
-- the things with their tags afterwards.
--
operateAndRetag ::
  forall m a b key tag.
  Monad m =>
  Ord key =>
  Show key =>
  (a -> key) ->
  (b -> key) ->
  ([a] -> m [b]) ->
  [(tag, a)] ->
  m [(tag, b)]
operateAndRetag :: forall (m :: * -> *) a b key tag.
(Monad m, Ord key, Show key) =>
(a -> key)
-> (b -> key) -> ([a] -> m [b]) -> [(tag, a)] -> m [(tag, b)]
operateAndRetag a -> key
keyA b -> key
keyB [a] -> m [b]
operation [(tag, a)]
input =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map b -> (tag, b)
retag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> m [b]
operation (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> b
snd [(tag, a)]
input)
  where
  tags :: Map key tag
  tags :: Map key tag
tags = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(tag
tag, a
a) -> (a -> key
keyA a
a, tag
tag)) [(tag, a)]
input

  findTag :: key -> tag
  findTag :: key -> tag
findTag key
key =
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup key
key Map key tag
tags of
      Just tag
tag -> tag
tag
      Maybe tag
Nothing -> forall a. HasCallStack => [Char] -> a
P.internalError ([Char]
"Missing tag for: " forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, StringConv [Char] b) => a -> b
show key
key)

  retag :: b -> (tag, b)
  retag :: b -> (tag, b)
retag b
b = (key -> tag
findTag (b -> key
keyB b
b), b
b)

-- |
-- Given:
--
--    * A list of local source files
--    * A list of source files from external dependencies, together with their
--      package names
--
-- This function does the following:
--
--    * Partially parse all of the input and dependency source files to get
--      the module name of each module
--    * Associate each dependency module with its package name, thereby
--      distinguishing these from local modules
--    * Return the file paths paired with the names of the modules they
--      contain, 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.
getModulePackageInfo ::
  (MonadError P.MultipleErrors m, MonadIO m) =>
  [FilePath]
  -> [(PackageName, FilePath)]
  -> m ([(FilePath, P.ModuleName)], Map P.ModuleName PackageName)
getModulePackageInfo :: forall (m :: * -> *).
(MonadError MultipleErrors m, MonadIO m) =>
[[Char]]
-> [(PackageName, [Char])]
-> m ([([Char], ModuleName)], Map ModuleName PackageName)
getModulePackageInfo [[Char]]
inputFiles [(PackageName, [Char])]
depsFiles = do
  [(InPackage [Char], Text)]
inputFiles' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
MonadIO m =>
InPackage [Char] -> m (InPackage [Char], Text)
readFileAs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> InPackage a
Local) [[Char]]
inputFiles
  [(InPackage [Char], Text)]
depsFiles'  <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
MonadIO m =>
InPackage [Char] -> m (InPackage [Char], Text)
readFileAs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. PackageName -> a -> InPackage a
FromDep) [(PackageName, [Char])]
depsFiles

  [(InPackage [Char], ModuleName)]
moduleNames <- forall (m :: * -> *).
MonadError MultipleErrors m =>
[(InPackage [Char], Text)] -> m [(InPackage [Char], ModuleName)]
getModuleNames ([(InPackage [Char], Text)]
inputFiles' forall a. [a] -> [a] -> [a]
++ [(InPackage [Char], Text)]
depsFiles')

  let mnMap :: Map ModuleName PackageName
mnMap =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(InPackage [Char]
pkgPath, ModuleName
mn) -> (ModuleName
mn,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. InPackage a -> Maybe PackageName
getPkgName InPackage [Char]
pkgPath) [(InPackage [Char], ModuleName)]
moduleNames

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. InPackage a -> a
ignorePackage) [(InPackage [Char], ModuleName)]
moduleNames, Map ModuleName PackageName
mnMap)

  where
  getModuleNames ::
    (MonadError P.MultipleErrors m) =>
    [(InPackage FilePath, Text)]
    -> m [(InPackage FilePath, P.ModuleName)]
  getModuleNames :: forall (m :: * -> *).
MonadError MultipleErrors m =>
[(InPackage [Char], Text)] -> m [(InPackage [Char], ModuleName)]
getModuleNames =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Module -> ModuleName
P.getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
P.resPartial)))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (m :: * -> *) a. Monad m => a -> m a
return
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) k.
MonadError MultipleErrors m =>
(k -> [Char]) -> [(k, Text)] -> m [(k, PartialResult Module)]
P.parseModulesFromFiles forall a. InPackage a -> a
ignorePackage

  getPkgName :: InPackage a -> Maybe PackageName
getPkgName = \case
    Local a
_ -> forall a. Maybe a
Nothing
    FromDep PackageName
pkgName a
_ -> forall a. a -> Maybe a
Just PackageName
pkgName

  readFileAs ::
    (MonadIO m) =>
    InPackage FilePath ->
    m (InPackage FilePath, Text)
  readFileAs :: forall (m :: * -> *).
MonadIO m =>
InPackage [Char] -> m (InPackage [Char], Text)
readFileAs InPackage [Char]
fi =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InPackage [Char]
fi,) forall a b. (a -> b) -> a -> b
$ [Char] -> IO Text
readUTF8FileT (forall a. InPackage a -> a
ignorePackage InPackage [Char]
fi)