scmdoc

  1{-# LANGUAGE LambdaCase #-}
  2{-# LANGUAGE RecordWildCards #-}
  3
  4module Main where
  5
  6import Control.Exception
  7import Control.Monad
  8import qualified Data.Text as T
  9import Options.Applicative
 10import System.Directory
 11import System.FilePath
 12import System.IO
 13import System.Exit (die)
 14
 15import SchemeDoc
 16import SchemeDoc.Error
 17import qualified SchemeDoc.Format.Library as L
 18import SchemeDoc.Parser.R7RS
 19import SchemeDoc.Types
 20
 21data Opts = Opts
 22    { css :: String
 23    , noWarn :: Bool
 24    , title :: String
 25    , directory :: FilePath
 26    , libraries :: [FilePath]
 27    }
 28
 29{- FOURMOLU_DISABLE -}
 30parseOpts :: Parser Opts
 31parseOpts = Opts
 32    <$> option str
 33        ( long "stylesheet"
 34       <> short 's'
 35       <> value "https://cdn.jsdelivr.net/gh/kognise/water.css@latest/dist/dark.css"
 36       <> help "URL used for the stylesheet in the generated HTML" )
 37    <*> switch
 38        ( long "no-warn"
 39       <> short 'w'
 40       <> help "Don't warn about unexported identifiers" )
 41    <*> option str
 42        ( long "title"
 43       <> short 't'
 44       <> value ""
 45       <> help "Title used for the metadata of the generated HTML" )
 46    <*> option str
 47        ( long "output"
 48       <> short 'o'
 49       <> value "."
 50       <> help "Output directory to which generated files are written" )
 51    <*> some (argument str (metavar "FILE..."))
 52{- FOURMOLU_ENABLE -}
 53
 54------------------------------------------------------------------------
 55
 56libFileName :: DocLib -> FilePath
 57libFileName (_, l) =
 58    T.unpack $
 59        T.append
 60            (T.map (\c -> if c == ' ' then '/' else c) $ L.name l)
 61            (T.pack ".html")
 62
 63writeDoc :: Opts -> FilePath -> FilePath -> DocLib -> IO ()
 64writeDoc Opts{..} inFp outFp docLib@(_, lib) = do
 65    -- Expand all includes relative to given Scheme file.
 66    (comps, failed) <- withCurrentDirectory (takeDirectory inFp) (docDecls docLib)
 67
 68    forM_
 69        failed
 70        (\f -> warn $ "Failed to find formatter for:\n\n\t" ++ show f ++ "\n")
 71    unless noWarn $
 72        forM_
 73            (findUndocumented lib comps)
 74            (\i -> warn $ "Exported but undocumented: " ++ show i)
 75
 76    let hTitle =
 77            if null title
 78                then show $ L.ident lib
 79                else title
 80
 81    let hbody = docFmt docLib comps
 82    let html = mkDoc hTitle css hbody
 83    writeFile outFp $ html ++ "\n"
 84  where
 85    warn msg = hPutStrLn stderr $ "WARNING: " ++ msg
 86
 87writeAll :: Opts -> [(FilePath, DocLib)] -> IO ()
 88writeAll opts@(Opts{directory = optDir}) =
 89    mapM_
 90        (\(p, l) -> mkDestPath l >>= flip (writeDoc opts p) l)
 91  where
 92    mkDestPath :: DocLib -> IO FilePath
 93    mkDestPath l =
 94        let fp = joinPath [optDir, libFileName l]
 95         in fp <$ createDirectoryIfMissing True (takeDirectory fp)
 96
 97findAllLibs :: [[Sexp]] -> [FilePath] -> IO [(FilePath, DocLib)]
 98findAllLibs srcs files =
 99    foldM
100        ( \acc (path, src) -> do
101            l <- findDocLibs' src
102            pure $ map ((,) path) l ++ acc
103        )
104        []
105        (zip files srcs)
106  where
107    findDocLibs' :: [Sexp] -> IO [DocLib]
108    findDocLibs' exprs = either (throwIO . ErrSyntax) pure $ findDocLibs exprs
109
110main' :: Opts -> IO ()
111main' opts@(Opts{libraries = optFiles}) =
112    catch
113        ( do
114            srcs <- mapM parseFromFile optFiles
115            libs <- findAllLibs srcs optFiles
116
117            if null libs
118                then die "Found no documented define-library expression"
119                else writeAll opts libs
120        )
121        ( \case
122            ErrSyntax (SyntaxError expr err) ->
123                hPutStrLn stderr $ "Syntax error on expression `" ++ show expr ++ "`: " ++ err
124            ErrParser err ->
125                hPrint stderr err
126        )
127
128main :: IO ()
129main = main' =<< execParser opts
130  where
131    opts =
132        info
133            (parseOpts <**> helper)
134            ( fullDesc
135                <> progDesc "Generate HTML documentation for a R⁷RS Scheme library"
136            )