{-# LANGUAGE TupleSections #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module Futhark.CLI.Doc (main) where
import Control.Monad.State
import Data.FileEmbed
import Data.List (nubBy)
import System.FilePath
import System.Directory (createDirectoryIfMissing)
import System.Console.GetOpt
import System.IO
import System.Exit
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as T
import Text.Blaze.Html.Renderer.Text
import Futhark.Doc.Generator
import Futhark.Compiler (readLibrary, dumpError, newFutharkConfig, Imports, fileProg)
import Futhark.Pipeline (runFutharkM, FutharkM, Verbosity(..))
import Language.Futhark.Syntax (progDoc, DocComment(..))
import Futhark.Util.Options
import Futhark.Util (directoryContents, trim)
main :: String -> [String] -> IO ()
main :: String -> [String] -> IO ()
main = DocConfig
-> [FunOptDescr DocConfig]
-> String
-> ([String] -> DocConfig -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions DocConfig
initialDocConfig [FunOptDescr DocConfig]
commandLineOptions String
"options... -o outdir programs..." [String] -> DocConfig -> Maybe (IO ())
f
where f :: [String] -> DocConfig -> Maybe (IO ())
f [String
dir] DocConfig
config = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ do
Either CompilerError ()
res <- FutharkM () -> Verbosity -> IO (Either CompilerError ())
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 -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
newFutharkConfig CompilerError
err
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
Right () ->
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
f [String]
_ DocConfig
_ = Maybe (IO ())
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 -> IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Must specify output directory with -o."
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
Just String
outdir -> do
[String]
files <- IO [String] -> FutharkM [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> FutharkM [String])
-> IO [String] -> FutharkM [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
futFiles String
dir
Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DocConfig -> Bool
docVerbose DocConfig
config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ do
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Found source file "String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)) [String]
files
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Reading files..."
(Warnings
_w, Imports
imports, VNameSource
_vns) <- [String] -> FutharkM (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[String] -> m (Warnings, Imports, VNameSource)
readLibrary [String]
files
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ DocConfig -> String -> [String] -> Imports -> IO ()
printDecs DocConfig
config String
outdir [String]
files (Imports -> IO ()) -> Imports -> IO ()
forall a b. (a -> b) -> a -> b
$ ((String, FileModule) -> (String, FileModule) -> Bool)
-> Imports -> Imports
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (String, FileModule) -> (String, FileModule) -> Bool
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
futFiles :: FilePath -> IO [FilePath]
futFiles :: String -> IO [String]
futFiles String
dir = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isFut ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
directoryContents String
dir
where isFut :: String -> Bool
isFut = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
".fut") (String -> Bool) -> (String -> String) -> String -> Bool
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 = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
normalise (String -> String) -> (String -> String) -> String -> String
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 (Imports -> ([(String, Html)], Warnings))
-> Imports -> ([(String, Html)], Warnings)
forall a b. (a -> b) -> a -> b
$
((String, FileModule) -> Bool) -> Imports -> Imports
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, FileModule) -> Bool) -> (String, FileModule) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, FileModule) -> Bool
forall a. (a, FileModule) -> Bool
ignored) Imports
imports
((String, Html) -> IO ()) -> [(String, Html)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((String, Text) -> IO ()
write ((String, Text) -> IO ())
-> ((String, Html) -> (String, Text)) -> (String, Html) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Html -> Text) -> (String, Html) -> (String, Text)
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 :: (String, 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
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DocConfig -> Bool
docVerbose DocConfig
cfg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Writing " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
file
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
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 ProgBase Info VName -> Maybe DocComment
forall (f :: * -> *) vn. ProgBase f vn -> Maybe DocComment
progDoc (FileModule -> ProgBase Info VName
fileProg FileModule
fm) of
Just (DocComment String
s SrcLoc
_) -> String -> String
trim String
s String -> String -> Bool
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 :: Maybe String -> Bool -> DocConfig
DocConfig { docOutput :: Maybe String
docOutput = Maybe String
forall a. Maybe a
Nothing
, docVerbose :: Bool
docVerbose = Bool
False
}
type DocOption = OptDescr (Either (IO ()) (DocConfig -> DocConfig))
commandLineOptions :: [DocOption]
commandLineOptions :: [FunOptDescr DocConfig]
commandLineOptions = [ String
-> [String]
-> ArgDescr (Either (IO ()) (DocConfig -> DocConfig))
-> String
-> FunOptDescr DocConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"o" [String
"output-directory"]
((String -> Either (IO ()) (DocConfig -> DocConfig))
-> String -> ArgDescr (Either (IO ()) (DocConfig -> DocConfig))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
dirname -> (DocConfig -> DocConfig) -> Either (IO ()) (DocConfig -> DocConfig)
forall a b. b -> Either a b
Right ((DocConfig -> DocConfig)
-> Either (IO ()) (DocConfig -> DocConfig))
-> (DocConfig -> DocConfig)
-> Either (IO ()) (DocConfig -> DocConfig)
forall a b. (a -> b) -> a -> b
$ \DocConfig
config -> DocConfig
config { docOutput :: Maybe String
docOutput = String -> Maybe String
forall a. a -> Maybe a
Just String
dirname })
String
"DIR")
String
"Directory in which to put generated documentation."
, String
-> [String]
-> ArgDescr (Either (IO ()) (DocConfig -> DocConfig))
-> String
-> FunOptDescr DocConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"v" [String
"verbose"]
(Either (IO ()) (DocConfig -> DocConfig)
-> ArgDescr (Either (IO ()) (DocConfig -> DocConfig))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (DocConfig -> DocConfig)
-> ArgDescr (Either (IO ()) (DocConfig -> DocConfig)))
-> Either (IO ()) (DocConfig -> DocConfig)
-> ArgDescr (Either (IO ()) (DocConfig -> DocConfig))
forall a b. (a -> b) -> a -> b
$ (DocConfig -> DocConfig) -> Either (IO ()) (DocConfig -> DocConfig)
forall a b. b -> Either a b
Right ((DocConfig -> DocConfig)
-> Either (IO ()) (DocConfig -> DocConfig))
-> (DocConfig -> DocConfig)
-> Either (IO ()) (DocConfig -> DocConfig)
forall a b. (a -> b) -> a -> b
$ \DocConfig
config -> DocConfig
config { docVerbose :: Bool
docVerbose = Bool
True })
String
"Print status messages on stderr."
]