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

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

    import Control.Monad
    import Control.Monad.State
    import Data.FileEmbed
    import Data.List (nubBy)
    import Data.Text qualified as T
    import Data.Text.IO qualified as T
    import Data.Text.Lazy qualified as LT
    import Futhark.Compiler (Imports, dumpError, fileProg, newFutharkConfig, readProgramFiles)
    import Futhark.Doc.Generator
    import Futhark.Pipeline (FutharkM, Verbosity (..), runFutharkM)
    import Futhark.Util (directoryContents)
    import Futhark.Util.Options
    import Futhark.Util.Pretty (hPutDoc)
    import Language.Futhark.Semantic (mkInitialImport)
    import Language.Futhark.Syntax (DocComment (..), progDoc)
    import Language.Futhark.Warnings (prettyWarnings)
    import System.Directory (createDirectoryIfMissing)
    import System.Exit
    import System.FilePath
    import System.IO
    import Text.Blaze.Html.Renderer.Text

    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 = Maybe String
    forall a. Maybe a
    Nothing,
          docVerbose :: Bool
    docVerbose = Bool
    False
        }

    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 :: [ImportName]
    direct_imports =
            (String -> ImportName) -> [String] -> [ImportName]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> ImportName
    mkInitialImport (String -> ImportName)
    -> (String -> String) -> String -> ImportName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . 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) = do
            [ImportName] -> Imports -> ([(String, Html)], Warnings)
    renderFiles [ImportName]
    direct_imports (Imports -> ([(String, Html)], Warnings))
    -> Imports -> ([(String, Html)], Warnings)
    forall a b. (a -> b) -> a -> b
    $
              ((ImportName, FileModule) -> Bool) -> Imports -> Imports
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool)
    -> ((ImportName, FileModule) -> Bool)
    -> (ImportName, FileModule)
    -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ImportName, FileModule) -> Bool
    forall {a}. (a, FileModule) -> Bool
    ignored) Imports
    imports
      Handle -> Doc AnsiStyle -> IO ()
    hPutDoc Handle
    stderr (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Warnings -> Doc AnsiStyle
    prettyWarnings Warnings
    warnings
      ((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 a b. (a -> b) -> (String, a) -> (String, b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (LazyText -> Text
    LT.toStrict (LazyText -> Text) -> (Html -> LazyText) -> Html -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Html -> LazyText
    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
          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 Text
    s SrcLoc
    _) -> Text -> Text
    T.strip Text
    s Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "ignore"
            Maybe DocComment
    _ -> Bool
    False

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

    commandLineOptions :: [DocOption]
    commandLineOptions :: [DocOption]
    commandLineOptions =
      [ String
    -> [String]
    -> ArgDescr (Either (IO ()) (DocConfig -> DocConfig))
    -> String
    -> DocOption
    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 = Just dirname})
              String
    "DIR"
          )
          String
    "Directory in which to put generated documentation.",
        String
    -> [String]
    -> ArgDescr (Either (IO ()) (DocConfig -> DocConfig))
    -> String
    -> DocOption
    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 = True})
          String
    "Print status messages on stderr."
      ]

    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

    -- | Run @futhark doc@.
    main :: String -> [String] -> IO ()
    main :: String -> [String] -> IO ()
    main = DocConfig
    -> [DocOption]
    -> String
    -> ([String] -> DocConfig -> Maybe (IO ()))
    -> String
    -> [String]
    -> IO ()
    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 = IO () -> Maybe (IO ())
    forall a. a -> Maybe a
    Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
    forall a b. (a -> b) -> a -> b
    $ do
          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 res of
            Left CompilerError
    err -> IO () -> IO ()
    forall a. IO a -> IO a
    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 a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
        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 a. IO a -> FutharkM a
    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
              files <- IO [String] -> FutharkM [String]
    forall a. IO a -> FutharkM a
    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
              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 :: (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