{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

-- | @futhark doc@
module Futhark.CLI.Doc (main) where

import Control.Monad.State
import Data.FileEmbed
import Data.List (nubBy)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as T
import Futhark.Compiler (Imports, dumpError, fileProg, newFutharkConfig, readLibrary)
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

-- | Run @futhark doc@.
main :: String -> [String] -> IO ()
main :: FilePath -> [FilePath] -> IO ()
main = DocConfig
-> [FunOptDescr DocConfig]
-> FilePath
-> ([FilePath] -> DocConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> FilePath
-> ([FilePath] -> cfg -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
mainWithOptions DocConfig
initialDocConfig [FunOptDescr DocConfig]
commandLineOptions FilePath
"options... -o outdir programs..." [FilePath] -> DocConfig -> Maybe (IO ())
f
  where
    f :: [FilePath] -> DocConfig -> Maybe (IO ())
f [FilePath
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 -> FilePath -> FutharkM ()
m DocConfig
config FilePath
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 [FilePath]
_ DocConfig
_ = Maybe (IO ())
forall a. Maybe a
Nothing

    m :: DocConfig -> FilePath -> FutharkM ()
    m :: DocConfig -> FilePath -> FutharkM ()
m DocConfig
config FilePath
dir =
      case DocConfig -> Maybe FilePath
docOutput DocConfig
config of
        Maybe FilePath
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 -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"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 FilePath
outdir -> do
          [FilePath]
files <- IO [FilePath] -> FutharkM [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> FutharkM [FilePath])
-> IO [FilePath] -> FutharkM [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
futFiles FilePath
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
              (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"Found source file " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>)) [FilePath]
files
              Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"Reading files..."
          (Warnings
_w, Imports
imports, VNameSource
_vns) <- [Name] -> [FilePath] -> FutharkM (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [FilePath] -> m (Warnings, Imports, VNameSource)
readLibrary [] [FilePath]
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 -> FilePath -> [FilePath] -> Imports -> IO ()
printDecs DocConfig
config FilePath
outdir [FilePath]
files (Imports -> IO ()) -> Imports -> IO ()
forall a b. (a -> b) -> a -> b
$ ((FilePath, FileModule) -> (FilePath, FileModule) -> Bool)
-> Imports -> Imports
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (FilePath, FileModule) -> (FilePath, 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 :: FilePath -> IO [FilePath]
futFiles FilePath
dir = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isFut ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
directoryContents FilePath
dir
  where
    isFut :: FilePath -> Bool
isFut = (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".fut") (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension

printDecs :: DocConfig -> FilePath -> [FilePath] -> Imports -> IO ()
printDecs :: DocConfig -> FilePath -> [FilePath] -> Imports -> IO ()
printDecs DocConfig
cfg FilePath
dir [FilePath]
files Imports
imports = do
  let direct_imports :: [FilePath]
direct_imports = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
normalise (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
dropExtension) [FilePath]
files
      ([(FilePath, Html)]
file_htmls, Warnings
_warnings) =
        [FilePath] -> Imports -> ([(FilePath, Html)], Warnings)
renderFiles [FilePath]
direct_imports (Imports -> ([(FilePath, Html)], Warnings))
-> Imports -> ([(FilePath, Html)], Warnings)
forall a b. (a -> b) -> a -> b
$
          ((FilePath, FileModule) -> Bool) -> Imports -> Imports
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((FilePath, FileModule) -> Bool)
-> (FilePath, FileModule)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FileModule) -> Bool
forall {a}. (a, FileModule) -> Bool
ignored) Imports
imports
  ((FilePath, Html) -> IO ()) -> [(FilePath, Html)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FilePath, Text) -> IO ()
write ((FilePath, Text) -> IO ())
-> ((FilePath, Html) -> (FilePath, Text))
-> (FilePath, Html)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Html -> Text) -> (FilePath, Html) -> (FilePath, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> Text
renderHtml) [(FilePath, Html)]
file_htmls
  (FilePath, Text) -> IO ()
write (FilePath
"style.css", Text
cssFile)
  where
    write :: (String, T.Text) -> IO ()
    write :: (FilePath, Text) -> IO ()
write (FilePath
name, Text
content) = do
      let file :: FilePath
file = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
makeRelative FilePath
"/" FilePath
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 -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Writing " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
file
      FilePath -> Text -> IO ()
T.writeFile FilePath
file Text
content

    -- Some files are not worth documenting; typically because
    -- they contain tests.  The current crude mechanism is to
    -- recognise them by a file comment containing "ignore".
    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 FilePath
s SrcLoc
_) -> FilePath -> FilePath
trim FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"ignore"
        Maybe DocComment
_ -> Bool
False

cssFile :: T.Text
cssFile :: Text
cssFile = $(embedStringFile "rts/futhark-doc/style.css")

data DocConfig = DocConfig
  { DocConfig -> Maybe FilePath
docOutput :: Maybe FilePath,
    DocConfig -> Bool
docVerbose :: Bool
  }

initialDocConfig :: DocConfig
initialDocConfig :: DocConfig
initialDocConfig =
  DocConfig :: Maybe FilePath -> Bool -> DocConfig
DocConfig
    { docOutput :: Maybe FilePath
docOutput = Maybe FilePath
forall a. Maybe a
Nothing,
      docVerbose :: Bool
docVerbose = Bool
False
    }

type DocOption = OptDescr (Either (IO ()) (DocConfig -> DocConfig))

commandLineOptions :: [DocOption]
commandLineOptions :: [FunOptDescr DocConfig]
commandLineOptions =
  [ FilePath
-> [FilePath]
-> ArgDescr (Either (IO ()) (DocConfig -> DocConfig))
-> FilePath
-> FunOptDescr DocConfig
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      FilePath
"o"
      [FilePath
"output-directory"]
      ( (FilePath -> Either (IO ()) (DocConfig -> DocConfig))
-> FilePath -> ArgDescr (Either (IO ()) (DocConfig -> DocConfig))
forall a. (FilePath -> a) -> FilePath -> ArgDescr a
ReqArg
          (\FilePath
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 FilePath
docOutput = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dirname})
          FilePath
"DIR"
      )
      FilePath
"Directory in which to put generated documentation.",
    FilePath
-> [FilePath]
-> ArgDescr (Either (IO ()) (DocConfig -> DocConfig))
-> FilePath
-> FunOptDescr DocConfig
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      FilePath
"v"
      [FilePath
"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})
      FilePath
"Print status messages on stderr."
  ]