{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

-- | @futhark doc@
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

-- | Run @futhark doc@.
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

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