{-# OPTIONS_GHC -fno-warn-orphans #-} -- MCM - Machine Configuration Manager; manages the contents of files and directories -- Copyright (c) 2013-2018 Anthony Doggett -- -- 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 . 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 r <- mcmLoadAndParse infilename case r of Left es -> do mapM_ putStrLn es exitFailure Right f -> 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 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 = H5.span H5.! class_ (fromString . show $ c) 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 (CLinn _) = command T.empty "linn" toHtml toMarkup (CNumFormat f n) = command (T.intercalate (T.pack ",") [f,n]) "numformat" 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 (CLinn _) = False 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 (CNumFormat f n) = any (isJust . T.find isSpace) [f, n] 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