{-# OPTIONS_GHC -fno-warn-orphans #-}
-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2018 Anthony Doggett <mcm@interfaces.org.uk>
--
-- Licence:
--     This program is free software: you can redistribute it and/or modify
--     it under the terms of the GNU General Public License as published by
--     the Free Software Foundation, either version 3 of the License, or
--     (at your option) any later version.
--
--     This program is distributed in the hope that it will be useful,
--     but WITHOUT ANY WARRANTY; without even the implied warranty of
--     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--     GNU General Public License for more details.
--
--     You should have received a copy of the GNU General Public License
--     along with this program.  If not, see <http://www.gnu.org/licenses/>.

-- Reads the list of commands
-- then runs them one at a time
-- and converts the output to an HTML snippet
-- NB. Based on mcm2html.hs

module Main (main)
where

import Paths_mcm (version)

import Control.Monad(when, unless)
import qualified Data.ByteString.Lazy as B
import Data.Char (isDigit)
import Data.List (foldl')
import Data.String (fromString)
import qualified Data.Text.Lazy as T
import Data.Version (showVersion)
import System.Console.GetOpt
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.Environment (getArgs)
import System.Exit (ExitCode(..), exitSuccess, exitFailure)
import System.FilePath (takeDirectory)
import System.Process (readProcessWithExitCode)
import qualified Text.Blaze.Html5 as H5
import Text.Blaze.Html5 (ToMarkup, toHtml)
import Text.Blaze.Html5.Attributes (class_, type_, charset)
import qualified Text.Blaze.Html.Renderer.Utf8 as Render_Utf8
import qualified Text.Blaze.Html.Renderer.String as Render_String
import Text.ParserCombinators.Poly.Plain

usage :: String
usage = unlines ["Usage: commands2html [OPTION..] FILE [OPTION..]"
                ,"Create .commands.html_snippet from the given .commands"
                ]

main :: IO ()
main = do
    progargs <- getArgs
    let (actions, nonOpts, msgs) = getOpt Permute options progargs
    unless (null msgs) $ error $ concat msgs ++ usageInfo usage options
    opts <- foldl' (>>=) (return defaultOptions) actions
    let Options {optOutFilenameExtension = extension
                ,optOutputWrapper = wrapper
                } = opts
    infilename <- case nonOpts of
        [i] -> return i
        xs -> do
            putStrLn $ "Error: expected a single .commands filename but received: " ++ show xs
            exitFailure
    when (extension == "") $ error "Extension can't be empty!"
    let outfilename = infilename ++ extension
        infiledir = takeDirectory infilename
    putStrLn $ "Writing " ++ outfilename
    cmds <- commandsLoadAndParse infilename
    cdir <- getCurrentDirectory
    setCurrentDirectory infiledir
    r <- mapM runCommand cmds
    setCurrentDirectory cdir
    B.writeFile outfilename $ Render_Utf8.renderHtml . wrapper $ do
        H5.pre H5.! class_ (fromString "C2H") $ mapM_ toHtml r
        newline

isComment :: String -> Bool
isComment "" = False
isComment ('#':_) = True
isComment _ = False

commandsLoadAndParse :: FilePath -> IO [String]
commandsLoadAndParse fp = do
    s <- readFile fp
    return $ filter (not . isComment) $ lines s

newtype CmdResult = CmdResult (String, ExitCode, String, String)

runCommand :: String -> IO CmdResult
runCommand cmd = do
    (exitcode, out, err) <- readProcessWithExitCode "/bin/sh" ["-c", cmd] ""
    return $ CmdResult (cmd, exitcode, out, err)

instance ToMarkup CmdResult where
    toMarkup (CmdResult (cmd, exitcode, out, err)) = do
        colourwith Prompt $ text "> "
        text cmd
        newline
        parseAndToHtml out
        parseAndToHtml err
        toHtml exitcode

instance ToMarkup ExitCode where
    toMarkup ExitSuccess = text ""
    toMarkup (ExitFailure f) = colourwith BadExit $ do
                                text "Exit failure: "
                                text . show $ f
                                newline

parseAndToHtml :: String -> H5.Html
parseAndToHtml = c . collapseNested . colourstring2nested . parse
    where
        c [] = text ""
        c (x:xs) = do
                    toHtml x
                    c xs

data Options = Options
    {optOutFilenameExtension :: String
    ,optOutputWrapper :: H5.Html -> H5.Html
    }

defaultOptions :: Options
defaultOptions = Options
    {optOutFilenameExtension = ".html_snippet"
    ,optOutputWrapper = id
    }

options :: [OptDescr (Options -> IO Options)]
options = [Option "V" ["version"] (NoArg displayVersion)         "show version and exit"
          ,Option [] ["head"]   (NoArg headOpt)   "output (to stdout) the suggested snippet for within <head> and exit"
          ,Option [] ["css"]   (NoArg cssOpt)   "output (to stdout) the suggested snippet for within an included CSS file and exit"
          ,Option [] ["fullpage"] (NoArg fullpageOpt) "write a full .html page (instead of .html_snippet)"
          ,Option "h" ["help"] (NoArg justHelp) "show this help and exit"
          ]

displayVersion :: Options -> IO Options
displayVersion _ = do
    putStrLn $ "commands2html " ++ showVersion version
    exitSuccess

justHelp ::  Options -> IO Options
justHelp _ = do
    putStrLn $ usageInfo usage options
    exitSuccess

headOpt :: Options -> IO Options
headOpt _ = do
    putStrLn . Render_String.renderHtml $ suggestedHead
    exitSuccess

suggestedHead :: H5.Html
suggestedHead = H5.meta H5.! charset (fromString "utf-8")

cssOpt :: Options -> IO Options
cssOpt _ = do
    putStrLn . Render_String.renderHtml $ suggestedCss
    exitSuccess

-- NB. Valid colours: http://www.w3.org/TR/CSS21/syndata.html#color-units
suggestedCss :: H5.Html
suggestedCss = text $ unlines
    ["pre.C2H {white-space: pre-wrap; tab-size: 4;-moz-tab-size: 4}"
    ,"pre.C2H .BadExit {font-weight: bold;color: red;background-color: white}"
    ,"pre.C2H .Prompt {font-weight: bold}"
    ,"pre.C2H .GM1 {font-weight: bold}"
    ,"pre.C2H .GM30 {color: black}" -- black
    ,"pre.C2H .GM31 {color: red}" -- red
    ,"pre.C2H .GM32 {color: green}" -- green4
    ,"pre.C2H .GM33 {color: yellow}" -- yellow
    ,"pre.C2H .GM34 {color: blue}" -- blue
    ,"pre.C2H .GM35 {color: fuchsia}" -- magenta
    ,"pre.C2H .GM36 {color: aqua}" -- cyan4
    ,"pre.C2H .GM37 {color: white}" -- white
    ,"pre.C2H .GM40 {background-color: black}" -- black
    ,"pre.C2H .GM41 {background-color: red}" -- red
    ,"pre.C2H .GM42 {background-color: green}" -- green4
    ,"pre.C2H .GM43 {background-color: yellow}" -- yellow
    ,"pre.C2H .GM44 {background-color: blue}" -- blue
    ,"pre.C2H .GM45 {background-color: fuchsia}" -- magenta
    ,"pre.C2H .GM46 {background-color: aqua}" -- cyan4
    ,"pre.C2H .GM47 {background-color: white}" -- white
    ]

fullpageOpt :: Options -> IO Options
fullpageOpt opts = return opts {optOutFilenameExtension = ".html"
    ,optOutputWrapper = fullPage
    }

fullPage :: H5.Html -> H5.Html
fullPage content = H5.docTypeHtml $ do
    H5.head $ do
        suggestedHead
        newline
        H5.style H5.! type_ (fromString "text/css") $ suggestedCss
    newline
    H5.body content
    newline

text :: String -> H5.Html
text = H5.toHtml . T.pack

newline :: H5.Html
newline = text "\n"

data ColourType = BadExit | Prompt
    deriving Show

colourwith :: ColourType -> H5.Html -> H5.Html
colourwith c = H5.span H5.! class_ (fromString . show $ c)

type P = Parser Char

data ColourString = Plain String
                  | GraphicsMode Int

data NestedColourString = NPlain String
                        | NGraphicsMode [Int] [NestedColourString]

instance ToMarkup NestedColourString where
    toMarkup (NPlain s) = text s
    toMarkup (NGraphicsMode ns cs) = H5.span H5.! class_ cl $ mapM_ toHtml cs
        where
            cl = fromString $ unwords $ map (\n -> "GM" ++ show n) ns

manySatisfy :: (Char -> Bool) -> P String
manySatisfy p = many (satisfy p)

many1Satisfy :: (Char -> Bool) -> P String
many1Satisfy p = many1 (satisfy p)

char :: Char -> P ()
char c = do
    n <- next
    unless (c == n) $ fail $ "Unexpected char: " ++ show n
--
-- Parse (a small subset of) ANSI Escape sequences
-- See http://ascii-table.com/ansi-escape-sequences.php
-- and http://hackage.haskell.org/package/ansi-terminal
-- and http://stackoverflow.com/questions/4842424/list-of-ansi-color-escape-sequences
-- and http://wiki.bash-hackers.org/scripting/terminalcodes
parse :: String -> [ColourString]
parse s = case runParser (many pBit) s of
            (Left e, _) -> error e
            (Right ps, []) -> concat ps
            (_, v) -> error $ "Failed to parse end: " ++ v

pBit :: P [ColourString]
pBit = oneOf
    [do
        char '\ESC'
        char '['
        as <- sepBy pNum (char ';')
        char 'm'
        return $ map GraphicsMode as
    ,do
        c <- next
        cs <- pManyUntilEsc
        return [Plain (c:cs)]
    ]

pManyUntilEsc :: P String
pManyUntilEsc = manySatisfy (/= '\ESC')

pNum :: P Int
pNum = do
    ds <- many1Satisfy isDigit
    return $ read ds

colourstring2nested :: [ColourString] -> [NestedColourString]
colourstring2nested [] = []
colourstring2nested xs =
    case colourstring2nested' xs of
        (r, []) -> r
        (r, xs') -> r ++ colourstring2nested xs'
    where
        colourstring2nested' :: [ColourString] -> ([NestedColourString], [ColourString])
        colourstring2nested' [] = ([], [])
        colourstring2nested' (Plain s : cs) = (NPlain s : cs', r)
            where
                (cs', r) = colourstring2nested' cs
        colourstring2nested' (GraphicsMode 0 : cs) = ([], cs)
        colourstring2nested' (GraphicsMode n : cs) = ([NGraphicsMode [n] cs'], r)
            where
                (cs', r) = colourstring2nested' cs

-- Items are commonly bold + fg, so spot these and permit easy conversion to class="bold + fg"
collapseNested :: [NestedColourString] -> [NestedColourString]
collapseNested [] = []
collapseNested (NGraphicsMode a [NGraphicsMode b bs]:ns) = collapseNested (NGraphicsMode (a++b) bs : ns)
collapseNested (n:ns) = n:collapseNested ns