{-# LANGUAGE TupleSections #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
-- | @futhark doc@
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)

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

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