{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Commonmark
import Commonmark.Extensions
import Commonmark.Pandoc
import Data.Maybe (isJust)
import Data.Aeson (encode)
import qualified Data.Sequence as Seq
import qualified Data.ByteString.Lazy as BL
import qualified Text.Pandoc.Builder as B
import Control.Monad
import Control.Monad.Identity
import Control.Monad.State
import Data.Typeable
import qualified Data.Text.IO as TIO
import qualified Data.Text.Lazy.IO as TLIO
import qualified Data.Map as M
import qualified Data.Text as T
import System.Environment
import System.Exit
import System.IO
import System.Console.GetOpt
import Paths_commonmark_cli (version)
import Data.Version (showVersion)
import Control.Exception (AsyncException, catch, throwIO)
import GHC.Stack (currentCallStack)
import System.Console.ANSI
data Opt =
Help
| Version
| Tokenize
| SourcePos
| Highlight
| PandocJSON
| ListExtensions
| Extension String
deriving Eq
options :: [OptDescr Opt]
options =
[ Option ['t'] ["tokenize"] (NoArg Tokenize) "tokenize"
, Option ['x'] ["extension"] (ReqArg Extension "extension") "use extension"
, Option ['p'] ["sourcepos"] (NoArg SourcePos) "source positions"
, Option [] ["highlight"] (NoArg Highlight) "highlight using ANSI"
, Option ['j'] ["json"] (NoArg PandocJSON) "pandoc JSON output"
, Option ['v'] ["version"] (NoArg Version) "version info"
, Option [] ["list-extensions"] (NoArg ListExtensions) "list extensions"
, Option ['h'] ["help"] (NoArg Help) "help message"
]
usageMessage :: String -> [OptDescr Opt] -> String
usageMessage programName = usageInfo (programName ++ " [OPTIONS] [FILES]")
main :: IO ()
main = catch (do
(opts, files, errs) <- getOpt Permute options <$> getArgs
unless (null errs) $ do
mapM_ (hPutStrLn stderr) errs
exitWith (ExitFailure 1)
prg <- getProgName
when (Help `elem` opts) $ do
putStr (usageMessage prg options)
exitSuccess
when (ListExtensions `elem` opts) $ do
listExtensions
exitSuccess
when (Version `elem` opts) $ do
putStrLn $ prg ++ " " ++ showVersion version
exitSuccess
toks <- if null files
then tokenize "stdin" <$> TIO.getContents
else mconcat <$> mapM (\f -> tokenize f <$> TIO.readFile f) files
when (Tokenize `elem` opts) $ do
print toks
exitSuccess
if Highlight `elem` opts then do
spec <- specFromExtensionNames [x | Extension x <- opts]
case runWithSourceMap <$>
runIdentity (parseCommonmarkWith spec toks) of
Left e -> errExit e
Right (_ :: Html (), sm) -> highlightWith sm toks
else do
let sourcepos = SourcePos `elem` opts
let json = PandocJSON `elem` opts
case (json, sourcepos) of
(True, True) -> do
spec <- specFromExtensionNames [x | Extension x <- opts]
case runIdentity (parseCommonmarkWith spec toks) of
Left e -> errExit e
Right (r :: Cm SourceRange B.Blocks) -> do
BL.putStr . encode $ B.doc $ unCm r
BL.putStr "\n"
(True, False) -> do
spec <- specFromExtensionNames [x | Extension x <- opts]
case runIdentity (parseCommonmarkWith spec toks) of
Left e -> errExit e
Right (r :: Cm () B.Blocks) -> do
BL.putStr . encode $ B.doc $ unCm r
BL.putStr "\n"
(False, True) -> do
spec <- specFromExtensionNames [x | Extension x <- opts]
case runIdentity (parseCommonmarkWith spec toks) of
Left e -> errExit e
Right (r :: Html SourceRange) -> TLIO.putStr . renderHtml $ r
(False, False) -> do
spec <- specFromExtensionNames [x | Extension x <- opts]
case runIdentity (parseCommonmarkWith spec toks) of
Left e -> errExit e
Right (r :: Html ()) -> TLIO.putStr . renderHtml $ r)
(\(e :: AsyncException) -> do
currentCallStack >>= mapM_ (hPutStrLn stderr)
throwIO e)
errExit :: ParseError -> IO a
errExit err = do
hPrint stderr err
exitWith (ExitFailure 1)
extensions :: (Monad m, Typeable m,
Typeable bl, Typeable il,
IsBlock il bl, IsInline il,
HasPipeTable il bl,
HasMath il,
HasQuoted il,
HasEmoji il,
HasWikilinks il,
HasSpan il,
ToPlainText il,
HasStrikethrough il,
HasSuperscript il,
HasSubscript il,
HasDefinitionList il bl,
HasDiv bl,
HasTaskList il bl,
HasAlerts il bl,
HasFootnote il bl)
=> [(String, SyntaxSpec m il bl)]
extensions =
[ ("autolinks", autolinkSpec)
,("pipe_tables", pipeTableSpec)
,("hard_line_breaks", hardLineBreaksSpec)
,("strikethrough", strikethroughSpec)
,("superscript", superscriptSpec)
,("subscript", subscriptSpec)
,("smart", smartPunctuationSpec)
,("math", mathSpec)
,("emoji", emojiSpec)
,("footnotes", footnoteSpec)
,("definition_lists", definitionListSpec)
,("fancy_lists", fancyListSpec)
,("task_lists", taskListSpec)
,("attributes", attributesSpec)
,("raw_attribute", rawAttributeSpec)
,("bracketed_spans", bracketedSpanSpec)
,("fenced_divs", fencedDivSpec)
,("auto_identifiers", autoIdentifiersSpec)
,("auto_identifiers_ascii", autoIdentifiersAsciiSpec)
,("implicit_heading_references", implicitHeadingReferencesSpec)
,("wikilinks_title_before_pipe", wikilinksSpec TitleBeforePipe)
,("wikilinks_title_after_pipe", wikilinksSpec TitleAfterPipe)
,("rebase_relative_paths", rebaseRelativePathsSpec)
,("alerts", alertSpec)
,("gfm", gfmExtensions)
]
extensionList :: [String]
extensionList = map fst
(extensions :: [(String, SyntaxSpec IO (Html ()) (Html ()))])
listExtensions :: IO ()
listExtensions =
putStr $ "Available extensions (or 'all' for all):\n" ++
unlines (map (" " ++) extensionList)
specFromExtensionNames ::
(Monad m, Typeable m, Typeable bl, Typeable il,
IsBlock il bl, IsInline il,
HasPipeTable il bl, HasMath il, HasQuoted il, HasEmoji il,
HasWikilinks il, HasSpan il,
ToPlainText il,
HasStrikethrough il,
HasSuperscript il,
HasSubscript il,
HasDefinitionList il bl,
HasDiv bl,
HasAlerts il bl,
HasTaskList il bl,
HasAlerts il bl,
HasFootnote il bl)
=> [String] -> IO (SyntaxSpec m il bl)
specFromExtensionNames extnames = do
let extFromName name =
case lookup name extensions of
Just ext -> return ext
Nothing -> do
hPutStrLn stderr $ "Unknown extension " ++ name
listExtensions
exitWith (ExitFailure 1)
exts <- if "all" `elem` extnames
then return $ mconcat (map snd extensions)
else mconcat <$> mapM extFromName extnames
return $ exts <> defaultSyntaxSpec
highlightWith :: SourceMap -> [Tok] -> IO ()
highlightWith sm ts = evalStateT (mapM_ (hlTok sm) ts) (mempty, [])
hlTok :: SourceMap -> Tok
-> StateT (Seq.Seq T.Text, [SGR]) IO ()
hlTok (SourceMap !sm) (Tok toktype !pos !t) = do
(xs, sgrs) <- get
-- When we encounter a line end, we store it in mbLineEnd
-- and output it after the formatting codes at the beginning
-- of the next line. Otherwise the wrong lines are affected.
case M.lookup pos sm of
Nothing -> liftIO $ do
when (toktype == LineEnd) $
-- This escape sequence paints rest of line with current
-- background color; otherwise we get bad results with scrolling.
TIO.putStr "\27[K"
TIO.putStr t
Just (starts, ends) -> do
let xsMinusEnds = foldr (\e s ->
case Seq.viewr s of
Seq.EmptyR -> s
z Seq.:> x
| x == e -> z
| otherwise -> s) xs (Seq.reverse ends)
let xs' = xsMinusEnds <> starts
let isStr = xs' `has` "str"
let sgrs' = if xs == xs'
then sgrs
else Reset :
SetConsoleIntensity
(if isStr
then NormalIntensity
else FaintIntensity) :
foldMap sgrFrom xs'
put (xs', sgrs')
liftIO $ do
when (sgrs /= sgrs') $ setSGR sgrs'
when (toktype == LineEnd) $
TIO.putStr "\27[K"
TIO.putStr t
sgrFrom :: T.Text -> [SGR]
sgrFrom t =
case t of
"link" -> [SetUnderlining SingleUnderline]
"image" -> [SetColor Foreground Vivid Magenta]
"entity" -> [SetColor Foreground Vivid Magenta]
"escapedChar" -> [SetColor Foreground Vivid Magenta]
"code" -> [SetColor Foreground Vivid White,
SetColor Background Dull Cyan]
"codeBlock" -> [SetColor Foreground Vivid White,
SetColor Background Dull Cyan]
"rawInline" -> [SetColor Foreground Vivid Green]
"rawBlock" -> [SetColor Foreground Vivid Green]
"heading1" -> [SetColor Foreground Vivid Blue]
"heading2" -> [SetColor Foreground Vivid Blue]
"heading3" -> [SetColor Foreground Vivid Blue]
"heading4" -> [SetColor Foreground Vivid Blue]
"heading5" -> [SetColor Foreground Vivid Blue]
"heading6" -> [SetColor Foreground Vivid Blue]
"blockQuote" -> [SetColor Foreground Dull Cyan]
"referenceLinkDefinition"
-> [SetColor Foreground Dull Cyan,
SetUnderlining SingleUnderline]
"emoji" -> [SetColor Foreground Vivid Magenta]
"math" -> [SetColor Foreground Vivid Magenta]
"strikethrough" -> [SetColor Foreground Vivid Magenta]
"superscript" -> [SetColor Foreground Vivid Magenta]
"subscript" -> [SetColor Foreground Vivid Magenta]
"footnote" -> [SetColor Foreground Vivid Magenta]
"footnoteRef" -> [SetColor Foreground Vivid Magenta]
_ -> []
has :: Seq.Seq T.Text -> T.Text -> Bool
has xs t = isJust $ t `Seq.elemIndexL` xs