justin-site/app/HakyllBibTex.hs

144 lines
4.8 KiB
Haskell
Raw Normal View History

-- 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)
2018-02-17 18:18:06 +00:00
import Data.Text (pack, unpack)
import Data.Typeable (Typeable)
import Hakyll
2015-01-05 04:43:45 +00:00
import qualified Bibtex as B
2018-02-17 18:18:06 +00:00
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"
2016-10-14 02:43:11 +00:00
x -> x
--------------------------------------------------------------------------------
-- Inefficient...
trimSpace :: String -> String
trimSpace = f . f
2016-02-19 04:43:24 +00:00
where f = reverse . dropWhile isSpace
2018-02-17 18:18:06 +00:00
-- Remove <p> and </p> tags...
trimPara :: String -> String
trimPara str = concat $ splitOn "</p>" $ drop 3 str
--------------------------------------------------------------------------------
2018-02-17 18:18:06 +00:00
latexToHtml :: String -> String
latexToHtml tex =
2018-02-17 18:18:06 +00:00
let res = runPure $ readLaTeX def (pack tex)
>>= writeHtml5String def
>>= return . trimPara . unpack
in case res of
Left _ -> ""
Right html -> html