{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Futhark.CLI.Doc (main) where
import Control.Monad.State
import Data.FileEmbed
import Data.List (nubBy)
import Data.Text.Lazy qualified as T
import Data.Text.Lazy.IO qualified as T
import Futhark.Compiler (Imports, dumpError, fileProg, newFutharkConfig, readProgramFiles)
import Futhark.Doc.Generator
import Futhark.Pipeline (FutharkM, Verbosity (..), runFutharkM)
import Futhark.Util (directoryContents, trim)
import Futhark.Util.Options
import Language.Futhark.Syntax (DocComment (..), progDoc)
import System.Directory (createDirectoryIfMissing)
import System.Exit
import System.FilePath
import System.IO
import Text.Blaze.Html.Renderer.Text
main :: String -> [String] -> IO ()
main :: String -> [String] -> IO ()
main = forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions DocConfig
initialDocConfig [DocOption]
commandLineOptions String
"options... -o outdir programs..." [String] -> DocConfig -> Maybe (IO ())
f
where
f :: [String] -> DocConfig -> Maybe (IO ())
f [String
dir] DocConfig
config = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
Either CompilerError ()
res <- forall a. FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM (DocConfig -> String -> FutharkM ()
m DocConfig
config String
dir) Verbosity
Verbose
case Either CompilerError ()
res of
Left CompilerError
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
newFutharkConfig CompilerError
err
forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
Right () ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
f [String]
_ DocConfig
_ = forall a. Maybe a
Nothing
m :: DocConfig -> FilePath -> FutharkM ()
m :: DocConfig -> String -> FutharkM ()
m DocConfig
config String
dir =
case DocConfig -> Maybe String
docOutput DocConfig
config of
Maybe String
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Must specify output directory with -o."
forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
Just String
outdir -> do
[String]
files <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [String]
futFiles String
dir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DocConfig -> Bool
docVerbose DocConfig
config) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
stderr forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Found source file " <>)) [String]
files
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Reading files..."
(Warnings
_w, Imports
imports, VNameSource
_vns) <- forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [String] -> m (Warnings, Imports, VNameSource)
readProgramFiles [] [String]
files
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DocConfig -> String -> [String] -> Imports -> IO ()
printDecs DocConfig
config String
outdir [String]
files forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy forall {a} {b} {b}. Eq a => (a, b) -> (a, b) -> Bool
sameImport Imports
imports
sameImport :: (a, b) -> (a, b) -> Bool
sameImport (a
x, b
_) (a
y, b
_) = a
x forall a. Eq a => a -> a -> Bool
== a
y
futFiles :: FilePath -> IO [FilePath]
futFiles :: String -> IO [String]
futFiles String
dir = forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isFut forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
directoryContents String
dir
where
isFut :: String -> Bool
isFut = (forall a. Eq a => a -> a -> Bool
== String
".fut") forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension
printDecs :: DocConfig -> FilePath -> [FilePath] -> Imports -> IO ()
printDecs :: DocConfig -> String -> [String] -> Imports -> IO ()
printDecs DocConfig
cfg String
dir [String]
files Imports
imports = do
let direct_imports :: [String]
direct_imports = forall a b. (a -> b) -> [a] -> [b]
map (String -> String
normalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropExtension) [String]
files
([(String, Html)]
file_htmls, Warnings
_warnings) =
[String] -> Imports -> ([(String, Html)], Warnings)
renderFiles [String]
direct_imports forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (a, FileModule) -> Bool
ignored) Imports
imports
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((String, Text) -> IO ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> Text
renderHtml) [(String, Html)]
file_htmls
(String, Text) -> IO ()
write (String
"style.css", Text
cssFile)
where
write :: (FilePath, T.Text) -> IO ()
write :: (String, Text) -> IO ()
write (String
name, Text
content) = do
let file :: String
file = String
dir String -> String -> String
</> String -> String -> String
makeRelative String
"/" String
name
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DocConfig -> Bool
docVerbose DocConfig
cfg) forall a b. (a -> b) -> a -> b
$
Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
String
"Writing " forall a. Semigroup a => a -> a -> a
<> String
file
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
file
String -> Text -> IO ()
T.writeFile String
file Text
content
ignored :: (a, FileModule) -> Bool
ignored (a
_, FileModule
fm) =
case forall (f :: * -> *) vn. ProgBase f vn -> Maybe DocComment
progDoc (FileModule -> Prog
fileProg FileModule
fm) of
Just (DocComment String
s SrcLoc
_) -> String -> String
trim String
s forall a. Eq a => a -> a -> Bool
== String
"ignore"
Maybe DocComment
_ -> Bool
False
cssFile :: T.Text
cssFile :: Text
cssFile = $(embedStringFile "rts/futhark-doc/style.css")
data DocConfig = DocConfig
{ DocConfig -> Maybe String
docOutput :: Maybe FilePath,
DocConfig -> Bool
docVerbose :: Bool
}
initialDocConfig :: DocConfig
initialDocConfig :: DocConfig
initialDocConfig =
DocConfig
{ docOutput :: Maybe String
docOutput = forall a. Maybe a
Nothing,
docVerbose :: Bool
docVerbose = Bool
False
}
type DocOption = OptDescr (Either (IO ()) (DocConfig -> DocConfig))
commandLineOptions :: [DocOption]
commandLineOptions :: [DocOption]
commandLineOptions =
[ forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
String
"o"
[String
"output-directory"]
( forall a. (String -> a) -> String -> ArgDescr a
ReqArg
(\String
dirname -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \DocConfig
config -> DocConfig
config {docOutput :: Maybe String
docOutput = forall a. a -> Maybe a
Just String
dirname})
String
"DIR"
)
String
"Directory in which to put generated documentation.",
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
String
"v"
[String
"verbose"]
(forall a. a -> ArgDescr a
NoArg forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \DocConfig
config -> DocConfig
config {docVerbose :: Bool
docVerbose = Bool
True})
String
"Print status messages on stderr."
]