Doc.hs

{-# 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 = mainWithOptions initialDocConfig commandLineOptions "options... -o outdir programs..." f
  where
    f [dir] config = Just $ do
      res <- runFutharkM (m config dir) Verbose
      case res of
        Left err -> liftIO $ do
          dumpError newFutharkConfig err
          exitWith $ ExitFailure 2
        Right () ->
          pure ()
    f _ _ = Nothing

    m :: DocConfig -> FilePath -> FutharkM ()
    m config dir =
      case docOutput config of
        Nothing -> liftIO $ do
          hPutStrLn stderr "Must specify output directory with -o."
          exitWith $ ExitFailure 1
        Just outdir -> do
          files <- liftIO $ futFiles dir
          when (docVerbose config) $
            liftIO $ do
              mapM_ (hPutStrLn stderr . ("Found source file " <>)) files
              hPutStrLn stderr "Reading files..."
          (_w, imports, _vns) <- readProgramFiles [] files
          liftIO $ printDecs config outdir files $ nubBy sameImport imports

    sameImport (x, _) (y, _) = x == y

futFiles :: FilePath -> IO [FilePath]
futFiles dir = filter isFut <$> directoryContents dir
  where
    isFut = (== ".fut") . takeExtension

printDecs :: DocConfig -> FilePath -> [FilePath] -> Imports -> IO ()
printDecs cfg dir files imports = do
  let direct_imports = map (normalise . dropExtension) files
      (file_htmls, _warnings) =
        renderFiles direct_imports $
          filter (not . ignored) imports
  mapM_ (write . fmap renderHtml) file_htmls
  write ("style.css", cssFile)
  where
    write :: (FilePath, T.Text) -> IO ()
    write (name, content) = do
      let file = dir </> makeRelative "/" name
      when (docVerbose cfg) $
        hPutStrLn stderr $
          "Writing " <> file
      createDirectoryIfMissing True $ takeDirectory file
      T.writeFile file 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 (_, fm) =
      case progDoc (fileProg fm) of
        Just (DocComment s _) -> trim s == "ignore"
        _ -> False

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

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

initialDocConfig :: DocConfig
initialDocConfig =
  DocConfig
    { docOutput = Nothing,
      docVerbose = False
    }

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

commandLineOptions :: [DocOption]
commandLineOptions =
  [ Option
      "o"
      ["output-directory"]
      ( ReqArg
          (\dirname -> Right $ \config -> config {docOutput = Just dirname})
          "DIR"
      )
      "Directory in which to put generated documentation.",
    Option
      "v"
      ["verbose"]
      (NoArg $ Right $ \config -> config {docVerbose = True})
      "Print status messages on stderr."
  ]