justin-site/app/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 qualified Data.Map                 as M (empty)
import           Data.Text                (pack, unpack)
import           Data.Typeable            (Typeable)
import           Hakyll
import qualified Bibtex                   as B
import           Text.Pandoc
import qualified Text.Parsec              as Parsec

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

unwrapBE :: BibEntry -> B.Item
unwrapBE (BE it) = it

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

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

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

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


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


--------------------------------------------------------------------------------
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 BE (B.resolveCrossRefs True xs)


--------------------------------------------------------------------------------
lookupBibEntry :: String -> BibFile -> BibEntry
lookupBibEntry name (BibFile es) =
    case [BE t | BE 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

-- Remove <p> and </p> tags...
trimPara :: String -> String
trimPara str = concat $ splitOn "</p>" $ drop 3 str

--------------------------------------------------------------------------------
latexToHtml :: String -> String
latexToHtml tex =
    let res = runPure $ readLaTeX def (pack tex)
                        >>= writeHtml5String def 
                        >>= return . trimPara . unpack
    in case res of
            Left   _    -> ""
            Right  html -> html