130 lines
4.6 KiB
Haskell
130 lines
4.6 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 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)
|
|
|
|
--------------------------------------------------------------------------------
|
|
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 -> 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]
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
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 "
|
|
_ -> ", 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"
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Inefficient...
|
|
trimSpace :: String -> String
|
|
trimSpace = f . f
|
|
where f = reverse . dropWhile isSpace
|
|
|
|
--------------------------------------------------------------------------------
|
|
latexToHtml tex =
|
|
let p = case Pandoc.readLaTeX Pandoc.def tex of
|
|
Pandoc.Pandoc meta [Pandoc.Para para] ->
|
|
Pandoc.Pandoc meta [Pandoc.Plain para]
|
|
x -> x
|
|
in Pandoc.writeHtmlString Pandoc.def p
|