citeproc-hs-0.2: test/test.hs

import Control.Arrow
import Control.Monad.State
import Data.IORef
import Language.Haskell.Parser
import Language.Haskell.Pretty (prettyPrint)
import qualified System.Console.GetOpt as O (OptDescr (..))
import System.Console.GetOpt hiding (Option)
import System.Environment
import System.Exit

import Text.CSL

main :: IO ()
main
    = do
      args  <- getArgs
      (o,f) <- getOpts args
      i     <- newIORef (Config False False [] [] [])
      doOpts i o
      c <- readIORef i
      s <- readCSLFile f
      processCitation c s

bibfile :: String
bibfile = "/home/andrea/devel/haskell/src/citeproc-hs/data/test.xml"

processCitation :: Config -> Style -> IO ()
processCitation config s
    = do
      Control.Monad.State.when (dump config) $
             case parseModule $ "style = " ++ (show s) of
               ParseOk a -> putStrLn (prettyPrint a)
               ParseFailed loc err -> error ("Could not dump the internal representation of the style" ++ show loc ++ show err ++ show s)
      when (mods config /= []) $ do
        ref <- readModsFile (mods config)
        let result = citeproc s [ref] [[(citeKey &&& const "") ref]]
        putStrLn . concatMap renderPlainStrict $ citations    result
        putStrLn . concatMap renderPlainStrict $ bibliography result

      when (modsCo config /= []) $ do
        ref <- readBiblioFile (modsCo config) "bibtex"
        let result = citeproc s ref [map (citeKey &&& const "") ref]
        case output config of
          "pandoc"  -> do let concatPan = foldr (\x xs -> if xs /= [] then x ++ "," ++ xs else x ++ xs) []
                          putStrLn $ "Pandoc (Meta [] [] []) [" ++  concatPan (map (renderPandoc' s) $ bibliography result) ++ "]"
          otherwise -> do let renderP   = if (strict config) then renderPlainStrict  else renderPlain
                          putStrLn $ unlines $ map renderP $ citations    result
                          putStrLn $ unlines $ map renderP $ bibliography result

-- The needed boilerplate code for parsing command line options

data Config
    = Config
      { dump   :: Bool
      , strict :: Bool
      , mods   :: String
      , modsCo :: String
      , output :: String
      } deriving ( Show )

data Opts
    = Help
    | Mods   String
    | ModsCo String
    | Output String
    | Strict
    | Dump
      deriving Show

opts :: [OptDescr Opts]
opts =
    [ O.Option ['h','?' ] ["help"      ] (NoArg Help            ) "This help"
    , O.Option ['d'     ] ["dump"      ] (NoArg Dump            ) "Dump the internal representation of a style"
    , O.Option ['s'     ] ["strict"    ] (NoArg Strict          ) "Evaluate the style strictly"
    , O.Option ['m'     ] ["mods"      ] (ReqArg Mods   "file"  ) "The file with a MODS record"
    , O.Option ['c'     ] ["collection"] (ReqArg ModsCo "file"  ) "The file with a MODS Collection"
    , O.Option ['o'     ] ["output"    ] (ReqArg Output "output") "The output format: 'plain' or 'pandoc'"
    ]

getOpts :: [String] -> IO ([Opts], String)
getOpts argv =
    case getOpt Permute opts argv of
      (_,[],_)   -> error $ "No imput file\n" ++ usage
      (o,[n],[]) -> return (o,n)
      (_,_,errs) -> error $ concat errs ++ usage

usage :: String
usage = (usageInfo header opts) ++ footer
    where header = "Usage: test [OPTION...] CSLFILE\n" ++
                   "Options:"
          footer = "\nMail bug reports and suggestions to " ++ mail
mail :: String
mail = "<andrea.rossato@unibz.it>\n"

doOpts :: IORef Config -> [Opts] -> IO ()
doOpts _  [] = return ()
doOpts conf (o:oo) =
    case o of
      Help     -> putStr   usage   >> exitWith ExitSuccess
      Dump     -> modifyIORef conf (\c -> (c { dump   = True})) >> go
      Strict   -> modifyIORef conf (\c -> (c { strict = True})) >> go
      Mods   m -> modifyIORef conf (\c -> (c { mods   = m   })) >> go
      ModsCo m -> modifyIORef conf (\c -> (c { modsCo = m   })) >> go
      Output o -> modifyIORef conf (\c -> (c { output = o   })) >> go
    where
      go    = doOpts conf oo