pandoc-citeproc.hs

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import           Prelude
import           Control.Applicative              (many, (<|>))
import           Control.Exception                as E
import           Control.Monad
import           Data.Aeson.Encode.Pretty         (Config (..), Indent (Spaces),
                                                   NumberFormat (Generic),
                                                   defConfig, encodePretty')
import           Data.Attoparsec.ByteString.Char8 as Attoparsec
import qualified Data.ByteString                  as B
import qualified Data.ByteString.Char8            as B8
import qualified Data.ByteString.Lazy             as BL
import           Data.Char                        (chr, toLower)
import           Data.List                        (group, sort)
import qualified Data.Text                        as T
import           Data.Text.Encoding               (encodeUtf8, decodeUtf8)
import           Data.Version                     (showVersion)
import           Data.Yaml.Builder                (toByteStringWith, setWidth)
import           Text.Libyaml                     (defaultFormatOptions)
import           Paths_pandoc_citeproc            (version)
import           System.Console.GetOpt
import           System.Environment               (getArgs)
import           System.Exit
import           System.FilePath                  (takeExtension)
import           System.IO
import           Text.CSL.Data                    (getLicense, getManPage)
import           Text.CSL.Exception
import           Text.CSL.Input.Bibutils          (BibFormat (..),
                                                   readBiblioString)
import           Text.CSL.Pandoc                  (processCites')
import           Safe                             (readMay)
import           Text.CSL.Reference               (Literal (..),
                                                   Reference (refId))
import           Text.Pandoc.JSON                 hiding (Format)
import qualified Text.Pandoc.UTF8                 as UTF8
import           Text.Pandoc.Walk

main :: IO ()
main = do
  argv <- getArgs
  let (flags, args, errs) = getOpt Permute options argv
  let header = "Usage: pandoc-citeproc [options] [file..]"
  unless (null errs) $ do
    UTF8.hPutStrLn stderr $ usageInfo (unlines $ errs ++ [header]) options
    exitWith $ ExitFailure 1
  when (Version `elem` flags) $ do
    UTF8.putStrLn $ "pandoc-citeproc " ++ showVersion version
    exitSuccess
  when (Help `elem` flags) $ do
    UTF8.putStrLn $ usageInfo header options
    exitSuccess
  when (Man `elem` flags) $ do
    getManPage >>= BL.putStr
    exitSuccess
  when (License `elem` flags) $ do
    getLicense >>= BL.putStr
    exitSuccess

  E.handle
    (\(e :: CiteprocException) -> do
        UTF8.hPutStrLn stderr $ renderError e
        exitWith (ExitFailure 1)) $
    if Bib2YAML `elem` flags || Bib2JSON `elem` flags
       then do
         colwidth <- case Prelude.take 1 $
                          reverse [readMay n | Columns n <- flags] of
                          []        -> return $ Just 80
                          [Just 0]  -> return $ Nothing
                          [Just x]  -> return $ Just x
                          _         -> do
                            UTF8.hPutStrLn stderr $
                              "--columns must be followed by a number"
                            exitWith $ ExitFailure 7
         let fmtOpts = setWidth colwidth defaultFormatOptions
         let mbformat = case [f | Format f <- flags] of
                             [x] -> readFormat x
                             _   -> Nothing
         bibformat <- case mbformat <|>
                           msum (map formatFromExtension args) of
                           Just f   -> return f
                           Nothing  -> do
                              UTF8.hPutStrLn stderr $ usageInfo
                                ("Unknown format\n" ++ header) options
                              exitWith $ ExitFailure 4
         bibstring <- case args of
                           [] -> B.getContents
                           xs -> mconcat <$> mapM B.readFile xs
         readBiblioString (const True) bibformat (decodeUtf8 bibstring) >>=
           (if Quiet `elem` flags then return else warnDuplicateKeys) >>=
           if Bib2YAML `elem` flags
              then outputYamlBlock .
                   B8.intercalate (B.singleton 10) .
                   map (unescapeTags . toByteStringWith fmtOpts . (:[]))
              else B8.putStrLn . unescapeUnicode . B.concat . BL.toChunks .
                encodePretty' defConfig{ confIndent = Spaces 2
                                       , confCompare = compare
                                       , confNumFormat = Generic }
       else toJSONFilter (doCites (Quiet `elem` flags))

formatFromExtension :: FilePath -> Maybe BibFormat
formatFromExtension = readFormat . dropWhile (=='.') . takeExtension

readFormat :: String -> Maybe BibFormat
readFormat = go . map toLower
  where go "biblatex"   = Just BibLatex
        go "bib"        = Just BibLatex
        go "bibtex"     = Just Bibtex
        go "json"       = Just Json
        go "yaml"       = Just Yaml
#ifdef USE_BIBUTILS
        go "ris"        = Just Ris
        go "endnote"    = Just Endnote
        go "enl"        = Just Endnote
        go "endnotexml" = Just EndnotXml
        go "xml"        = Just EndnotXml
        go "wos"        = Just Isi
        go "isi"        = Just Isi
        go "medline"    = Just Medline
        go "copac"      = Just Copac
        go "mods"       = Just Mods
        go "nbib"       = Just Nbib
#endif
        go _            = Nothing


doCites :: Bool -> Pandoc -> IO Pandoc
doCites beQuiet doc = do
  doc' <- processCites' doc
  let warnings = query findWarnings doc'
  unless beQuiet $ mapM_ (UTF8.hPutStrLn stderr) warnings
  return doc'

findWarnings :: Inline -> [String]
findWarnings (Span (_,["citeproc-not-found"],[("data-reference-id",ref)]) _) =
  ["pandoc-citeproc: reference " ++ T.unpack ref ++ " not found" | ref /= "*"]
findWarnings (Span (_,["citeproc-no-output"],_) _) =
  ["pandoc-citeproc: reference with no printed form"]
findWarnings _ = []

data Option =
      Help
    | Man
    | License
    | Version
    | Convert
    | Format String
    | Columns String
    | Bib2YAML
    | Bib2JSON
    | Quiet
  deriving (Ord, Eq, Show)

options :: [OptDescr Option]
options =
  [ Option ['h'] ["help"] (NoArg Help) "show usage information"
  , Option [] ["man"] (NoArg Man) "print man page to stdout"
  , Option [] ["license"] (NoArg License) "print license to stdout"
  , Option ['V'] ["version"] (NoArg Version) "show program version"
  , Option ['y'] ["bib2yaml"] (NoArg Bib2YAML) "convert bibliography to YAML"
  , Option ['j'] ["bib2json"] (NoArg Bib2JSON) "convert bibliography to JSON"
  , Option ['q'] ["quiet"] (NoArg Quiet) "silence all warnings"
  , Option ['f'] ["format"] (ReqArg Format "FORMAT") "bibliography format"
  , Option ['c'] ["columns"] (ReqArg Columns "NUMBER") "column width (or 0)"
  ]

warnDuplicateKeys :: [Reference] -> IO [Reference]
warnDuplicateKeys refs = mapM_ warnDup dupKeys >> return refs
  where warnDup k = UTF8.hPutStrLn stderr $
                    "biblio2yaml: duplicate key " ++ T.unpack k
        allKeys   = map (unLiteral . refId) refs
        dupKeys   = [x | (x:_:_) <- group (sort allKeys)]

outputYamlBlock :: B.ByteString -> IO ()
outputYamlBlock contents = do
  UTF8.putStrLn "---\nreferences:"
  B.putStr contents
  UTF8.putStrLn "..."

-- turn
-- id: ! "\u043F\u0443\u043D\u043A\u04423"
-- into
-- id: пункт3
unescapeTags :: B.ByteString -> B.ByteString
unescapeTags bs = case parseOnly (many $ tag <|> other) bs of
                       Left e  -> error e
                       Right r -> B.concat r

unescapeUnicode :: B.ByteString -> B.ByteString
unescapeUnicode bs = case parseOnly (many other) bs of
                       Left e  -> error e
                       Right r -> B.concat r

tag :: Attoparsec.Parser B.ByteString
tag = do
  _ <- string $ B8.pack ": ! "
  c <- char '\'' <|> char '"'
  cs <- manyTill (escaped c <|> other) (char c)
  return $ B8.pack ": " <> B8.singleton c <> B.concat cs <> B8.singleton c

escaped :: Char -> Attoparsec.Parser B.ByteString
escaped c = string $ B8.pack ['\\',c]

other :: Attoparsec.Parser B.ByteString
other = uchar <|> Attoparsec.takeWhile1 notspecial <|> regchar
  where notspecial = not . inClass ":!\\\"'"

uchar :: Attoparsec.Parser B.ByteString
uchar = do
  _ <- char '\\'
  num <- (2 <$ char 'x') <|> (4 <$ char 'u') <|> (8 <$ char 'U')
  cs <- count num $ satisfy $ inClass "0-9a-fA-F"
  let n = read ('0':'x':cs)
  return $ encodeUtf8 $ T.pack [chr n]

regchar :: Attoparsec.Parser B.ByteString
regchar = B8.singleton <$> anyChar