diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# commonmark-cli + +A command-line tool for converting and syntax-highlighting +commonmark documents. See the output of +`commonmark-cli --help` for basic usage. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +# Changelog for commonmark-cli + +## Unreleased changes diff --git a/commonmark-cli.cabal b/commonmark-cli.cabal new file mode 100644 --- /dev/null +++ b/commonmark-cli.cabal @@ -0,0 +1,46 @@ +name: commonmark-cli +version: 0.1.0.0 +synopsis: Command-line commonmark converter and highlighter. +description: This package provides a command-line tool, `commonmark`, + for converting and syntax-highlighting commonmark documents. +category: Text +homepage: https://github.com/jgm/commonmark-hs +bug-reports: https://github.com/jgm/commonmark-hs/issues +author: John MacFarlane +maintainer: jgm@berkeley.edu +copyright: 2018-2020 John MacFarlane +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + changelog.md + README.md + +source-repository head + type: git + location: https://github.com/jgm/commonmark-hs + +executable commonmark + main-is: convert.hs + hs-source-dirs: src + if impl(ghc >= 8.8) + ghc-options: -fwrite-ide-info -hiedir=.hie + ghc-options: -threaded -rtsopts + build-depends: base >=4.7 && <5 + , commonmark >= 0.1 && < 0.2 + , commonmark-extensions >= 0.1 && < 0.2 + , commonmark-pandoc >= 0.1 && < 0.2 + , pandoc-types + , aeson + , bytestring + , containers + , pretty-simple + , mtl + , bytestring + , text + , ansi-terminal + other-modules: + Paths_commonmark_cli + default-language: Haskell2010 diff --git a/src/convert.hs b/src/convert.hs new file mode 100644 --- /dev/null +++ b/src/convert.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE CPP #-} +{-# 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) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid +#endif +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 + if SourcePos `elem` opts then 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 + else + if PandocJSON `elem` opts then 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" + else 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, + HasEmoji il, + HasSpan il, + ToPlainText il, + HasStrikethrough il, + HasSuperscript il, + HasSubscript il, + HasDefinitionList il bl, + HasDiv bl, + HasTaskList 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) + ,("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, HasEmoji il, + HasSpan il, + ToPlainText il, + HasStrikethrough il, + HasSuperscript il, + HasSubscript il, + HasDefinitionList il bl, + HasDiv bl, + HasTaskList 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