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)
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)
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
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)
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)
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)