{-# 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 :: 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) <- [Name] -> [String] -> FutharkM (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [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

    -- 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 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."
  ]