144 lines
4.8 KiB
Haskell
144 lines
4.8 KiB
Haskell
-- 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 "
|
|
_ -> ", and "
|
|
in
|
|
(intercalate ", " (init swapped)) ++ finalSep ++ last swapped
|
|
|
|
--------------------------------------------------------------------------------
|
|
formatAuthor :: String -> String
|
|
formatAuthor = intercalate " "
|
|
. (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
|