mcm-0.6.4.10: mcm2html.hs
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2016 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/>.
module Main (main)
where
import Parser (mcmLoadAndParse)
import ParserTypes (Import(..), Section(..), Define(..), Invocation(..), InvocationArgs(..), CondLocal(..), Content(..), Group(..), Separator(..), Prepend(..), Append(..), InvocationCmd(..), Ident(..), OptArgs(..), Locals(..), Value(..), MCMFile(..), VarsExpand(..))
import Paths_mcm (version)
import VarsParser (expandString)
import Control.Monad(when, unless)
import qualified Data.ByteString.Lazy as B
import Data.Char (isSpace)
import Data.List (foldl', intersperse, sort, sortBy)
import qualified Data.Map as Map
import Data.Maybe (isJust)
import Data.Ord (comparing)
import Data.String (fromString)
import qualified Data.Text.Lazy as T
import Data.Version (showVersion)
import System.Console.GetOpt
import System.Environment (getArgs)
import System.Exit (exitSuccess, exitFailure)
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
usage :: String
usage = unlines ["Usage: mcm2html [OPTION..] FILE [OPTION..]"
,"Create .mcm.html_snippet from the given .mcm"
]
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 .mcm filename but received: " ++ show xs
exitFailure
when (extension == "") $ error "Extension can't be empty!"
let outfilename = infilename ++ extension
putStrLn $ "Writing " ++ outfilename
f <- mcmLoadAndParse infilename
B.writeFile outfilename $ Render_Utf8.renderHtml . wrapper $ toHtml f
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 $ "mcm2html " ++ 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
suggestedCss :: H5.Html
suggestedCss = text $ unlines
["pre.MCM {white-space: pre-wrap; tab-size: 4;-moz-tab-size: 4}"
,"pre.MCM .Keyword {color: #ff6060}"
,"pre.MCM .Invoke {color: #ff40ff}"
,"pre.MCM .Iden {color: #8535e0}"
,"pre.MCM .Escaped {color: #3585e0}"
,"pre.MCM .Cmd {color: #0000ff}"
,"pre.MCM .Con {background-color: #80ff80}"
,"pre.MCM .IdenUse {color: #ff0000}"
,"pre.MCM .WhenText {background-color: #8080ff}"
]
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 = Keyword | Invoke | Iden | Con | Cmd | IdenUse | WhenText | Escaped
deriving Show
colourwith :: ColourType -> H5.Html -> H5.Html
colourwith c h = H5.span H5.! class_ (fromString . show $ c) $ h
instance ToMarkup MCMFile where
toMarkup (MCMFile pp s) = do
H5.pre H5.! class_ (fromString "MCM") $ do
colourwith Keyword $ text "MCM"
text " "
text . show $ pp
newline
toHtml s
newline
instance ToMarkup Section where
toMarkup (Section is plets defines) = do
when (is /= []) newline
mapM_ toHtml is
unless (Map.null plets) $ do
newline
let (x:xs) = sortBy (comparing fst) $ Map.toList plets
toHtmlLetHead x
mapM_ toHtmlLetTail xs
mapM_ toHtml $ sortBy (comparing defName) $ Map.elems defines
toHtmlLetHead :: (Ident, [Content]) -> H5.Html
toHtmlLetHead (i, cs) = do
colourwith Keyword $ text "let"
text " "
toHtmlIdentContent Let (i, cs)
newline
toHtmlLetTail :: (Ident, [Content]) -> H5.Html
toHtmlLetTail (i, cs) = do
text "\t\t"
toHtmlIdentContent Let (i, cs)
newline
toHtmlInvArg :: (Ident, [Content]) -> H5.Html
toHtmlInvArg (i, cs) = do
text "\t\t"
toHtmlIdentContent Arg (i, cs)
newline
toHtmlInvWordArg :: (Ident, [Content]) -> H5.Html
toHtmlInvWordArg (i, cs) = do
text " "
toHtmlIdentContent WordArg (i, cs)
toHtmlWhen :: (Value, Locals) -> H5.Html
toHtmlWhen (v, Locals ls) = do
text "\t"
colourwith Keyword $ text "when"
text " "
colourwith WhenText $ text . show $ v
newline
let ls' = sortBy (comparing fst) $ Map.toList ls
when (ls' /= []) $ mapM_ toHtmlLetTail ls'
data ICStyle = Let | Arg | WordArg
instance Show ICStyle where
show Arg = ":"
show WordArg = ">"
show Let = " ="
toHtmlIdentContent :: ICStyle -> (Ident, [Content]) -> H5.Html
toHtmlIdentContent icstyle (i, cs) = do
colourwith Iden $ text . show $ i
text . show $ icstyle
let toHtmlRemainingContent :: [Content] -> H5.Html
toHtmlRemainingContent [] = text ""
toHtmlRemainingContent xs = do
newline
text "\t\t\t"
toHtmlRemainingContent' xs
toHtmlRemainingContent' :: [Content] -> H5.Html
toHtmlRemainingContent' [] = error "It is supposed to be impossible to get here within toHtmlRemainingContent'"
toHtmlRemainingContent' [CNewline] = text "+"
toHtmlRemainingContent' [x] = do {text "\\"; toHtml x}
toHtmlRemainingContent' (CNewline:(xs@(CNewline:_))) = do {text "+"; toHtmlRemainingContent xs}
toHtmlRemainingContent' (CNewline:x:xs) = do {text "+"; toHtml x; toHtmlRemainingContent xs}
toHtmlRemainingContent' (x:xs) = do {text "\\"; toHtml x; toHtmlRemainingContent xs}
case cs of
[] -> text ""
xs@(CNewline:_) -> toHtmlRemainingContent xs
[x] -> toHtml x
(x:xs) -> do
toHtml x
toHtmlRemainingContent xs
command :: T.Text -> String -> (T.Text -> H5.Html) -> H5.Html
command content cmd contentConverter =
if T.null content
then colourwith Cmd $ text $ "$" ++ cmd ++ "()"
else do colourwith Cmd $ text $ "$" ++ cmd ++ "("
colourwith Con $ contentConverter content
colourwith Cmd $ text ")"
expandAts :: T.Text -> H5.Html
expandAts t =
let ve = VarsExpand (\_ s -> Just . colourwith IdenUse $ toHtml s) toHtml toHtml (\_ b -> colourwith Escaped $ toHtml b)
in case expandString ve t of
Left s -> error $ "Internal error: " ++ s
Right e -> e
instance ToMarkup Content where
toMarkup CEmpty = text ""
toMarkup (CString s) = if T.null s then text " " else do {text " "; colourwith Con $ expandAts s}
toMarkup (CExplicitString s) = command s "string" expandAts
toMarkup (CRawString s) = command s "rawstring" toHtml
toMarkup (CFile f) = command f "file" expandAts
toMarkup (CRawFile f) = command f "rawfile" expandAts
toMarkup (CFragments (Group g) (Prepend p) (Append a) (Separator s)) =
command (T.intercalate (T.pack ",") [g,p,a,s]) "fragments" expandAts
toMarkup CNewline = error "Unexpected CNewline"
instance ToMarkup Import where
toMarkup (Import pp as) = do
colourwith Keyword $ text "import"
text " "
text . show $ pp
text " "
colourwith Keyword $ text "as"
text " "
H5.toHtml as
newline
instance ToMarkup Define where
toMarkup (Define n a oa l cl i) = do
newline
colourwith Keyword $ text "define"
text " "
text . show $ n
text "("
toHtml $ intersperse (text " ") $ map (colourwith Iden . text . show) $ sort a
toHtml oa
text ")"
newline
toHtml l
mapM_ toHtml cl
mapM_ toHtml i
instance ToMarkup Locals where
toMarkup (Locals l) = unless (Map.null l) $ do
let (x:xs) = sortBy (comparing fst) $ Map.toList l
text "\t"
toHtmlLetHead x
mapM_ toHtmlLetTail xs
instance ToMarkup Invocation where
toMarkup (Invocation c a) = do
text "\t"
colourwith Invoke $ toHtml c
toHtml a
instance ToMarkup InvocationCmd where
toMarkup InvFile = text "File"
toMarkup InvDir = text "Dir"
toMarkup InvAbsent = text "Absent"
toMarkup InvFragment = text "Fragment"
toMarkup InvSymlink = text "Symlink"
toMarkup (InvLocal u) = do
text "."
expandAts . T.pack . show $ u
toMarkup (InvImport a b) = do
toHtml a
text "."
expandAts . T.pack . show $ b
instance ToMarkup InvocationArgs where
toMarkup (InvocationArgs as) = do
let (wordas, otheras) = bucketArgs $ Map.toList as
when (wordas /= []) $ mapM_ toHtmlInvWordArg wordas
newline
mapM_ toHtmlInvArg otheras
containsWhitespaceOrEmpty :: Content -> Bool
containsWhitespaceOrEmpty CEmpty = True
containsWhitespaceOrEmpty CNewline = True
containsWhitespaceOrEmpty (CString s) = isJust $ T.find isSpace s
containsWhitespaceOrEmpty (CExplicitString s) = containsWhitespaceOrEmpty (CString s)
containsWhitespaceOrEmpty (CRawString s) = isJust $ T.find isSpace s
containsWhitespaceOrEmpty (CFile f) = isJust $ T.find isSpace f
containsWhitespaceOrEmpty (CRawFile f) = isJust $ T.find isSpace f
containsWhitespaceOrEmpty (CFragments (Group g) (Prepend p) (Append a) (Separator s)) = any (isJust . T.find isSpace) [g, p, a, s]
type ICs = [(Ident, [Content])]
bucketArgs :: ICs -> (ICs, ICs)
bucketArgs zs = (sortByFirst as', sortByFirst bs')
where
sortByFirst = sortBy (comparing fst)
(as', bs') = bucketArgs' ([], []) zs
bucketArgs' (ws, os) [] = (ws, os)
bucketArgs' (ws, os) (x@(_,[c]):xs) =
if containsWhitespaceOrEmpty c
then bucketArgs' (ws, x:os) xs
else bucketArgs' (x:ws, os) xs
bucketArgs' (ws, os) (x:xs) = bucketArgs' (ws, x:os) xs
instance ToMarkup OptArgs where
toMarkup (OptArgs o) | Map.null o = text ""
toMarkup (OptArgs o) = do
newline
mapM_ toHtmlLetTail $ sortBy (comparing fst) $ Map.toList o
text "\t"
instance ToMarkup CondLocal where
toMarkup (CondLocal i ls) = do
text "\t"
colourwith Keyword $ text "case"
text " "
colourwith Iden $ text . show $ i
newline
mapM_ toHtmlWhen $ sortBy (comparing fst) $ Map.toList ls