justin-site/HakyllBibTex.hs

-- JH: From hakyll-bibtex by jaspervdj, using the Pandoc parser.
--------------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module HakyllBibTex
    ( BibEntry (..)
    , bibEntryContext
    , BibFile (..)
    , bibFileEntryNames
    , parseBibFile
    , lookupBibEntry
    ) where


--------------------------------------------------------------------------------
import           Control.Applicative
import           Data.Binary              (Binary (..))
import           Data.Char                (isSpace)
import           Data.List.Split          (splitOn)
import           Data.List                (intercalate)
import           Data.Map                 (empty)
import           Data.Typeable            (Typeable)
import           Hakyll
import qualified Bibtex                   as B
import qualified Text.Pandoc              as Pandoc
import qualified Text.Parsec              as Parsec

--------------------------------------------------------------------------------
newtype BibEntry = BibEntry B.Item
    deriving (Typeable)

--------------------------------------------------------------------------------
instance Binary BibEntry where
    put (BibEntry t) = do
        put $ B.entryType t
        put $ B.identifier t
        put $ B.fields t

    get = BibEntry <$> (B.Item <$> get <*> get <*> get)

--------------------------------------------------------------------------------
-- XXX refactor to use Context monoid XXX
bibEntryContext :: Context BibEntry
bibEntryContext = Context $ \key _ item ->
    let BibEntry t = itemBody item
    in case key of
        "identifier" -> return $ StringField $ B.identifier t
        _            -> case lookup key (B.fields t) of
            Nothing  -> Control.Applicative.empty
            Just val -> case key of
                "author" -> return $ StringField $ formatAuthors val
                "month"  -> return $ StringField $ expandMonth val
                "url"    -> return $ StringField $ val
                _        -> return $ StringField $ latexToHtml val

--------------------------------------------------------------------------------
newtype BibFile = BibFile [BibEntry]
    deriving (Binary, Typeable)


--------------------------------------------------------------------------------
bibFileEntryNames :: BibFile -> [String]
bibFileEntryNames (BibFile es) = [B.identifier t | BibEntry t <- es]


--------------------------------------------------------------------------------
-- XXX refactor to use Text.CSL.readBiblioFile XXX
parseBibFile :: String -> BibFile
parseBibFile string = case Parsec.runParser (B.bibEntries <* Parsec.eof)
                           [] "<bib file>" string of
    Left err -> error $ show err
    Right xs -> BibFile $ map BibEntry (B.resolveCrossRefs True xs)


--------------------------------------------------------------------------------
lookupBibEntry :: String -> BibFile -> BibEntry
lookupBibEntry name (BibFile es) =
    case [BibEntry t | BibEntry t <- es, B.identifier t == name] of
        []      -> error $ name ++ " not found in BibFile"
        (x : _) -> x

--------------------------------------------------------------------------------
formatAuthors :: String -> String
formatAuthors auth =
  let auths = splitOn "and" auth
      swapped = fmap formatAuthor auths 
      finalSep = case (length auths) of
          1 -> ""
          2 -> " and&nbsp;"
          _ -> ", and&nbsp;"
      in
      (intercalate ", " (init swapped)) ++ finalSep ++ last swapped

--------------------------------------------------------------------------------
formatAuthor :: String -> String
formatAuthor = intercalate "&nbsp;"
               . (splitOn " ")
               . latexToHtml
               . trimSpace
               . (intercalate " ")
               . reverse
               . (splitOn ",")

--------------------------------------------------------------------------------
expandMonth :: String -> String
expandMonth mon = case mon of
    "jan" -> "January"
    "feb" -> "February"
    "mar" -> "March"
    "apr" -> "April"
    "may" -> "May"
    "jun" -> "June"
    "jul" -> "July"
    "aug" -> "August"
    "sep" -> "September"
    "oct" -> "October"
    "nov" -> "November"
    "dec" -> "December"
    x     -> x

--------------------------------------------------------------------------------
-- Inefficient...
trimSpace :: String -> String
trimSpace = f . f
    where f = reverse . dropWhile isSpace

--------------------------------------------------------------------------------
latexToHtml tex =
    let p = case Pandoc.readLaTeX Pandoc.def tex of
                Right (Pandoc.Pandoc meta [Pandoc.Para para]) ->
                    Pandoc.Pandoc meta [Pandoc.Plain para]
                Left _                                        ->
                    Pandoc.Pandoc (Pandoc.Meta Data.Map.empty) []
    in Pandoc.writeHtmlString Pandoc.def p