path: root/src/Text/Pandoc/Citeproc/BibTeX.hs

{-# LANGUAGE ViewPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.CSL.Input.Bibtex
-- Copyright   :  (c) John MacFarlane
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  John MacFarlane <fiddlosopher@gmail.com>
-- Stability   :  unstable-- Portability :  unportable
--
-----------------------------------------------------------------------------

module Text.Pandoc.Citeproc.BibTeX
    ( Variant(..)
    , readBibtexString
    )
    where

import Text.Pandoc.Definition
import Text.Pandoc.Builder as B
import Text.Pandoc.Readers.LaTeX (readLaTeX)
import Text.Pandoc.Extensions (Extension(..), extensionsFromList)
import Text.Pandoc.Options (ReaderOptions(..))
import Text.Pandoc.Class (runPure)
import Text.Pandoc.Error (PandocError)
import Text.Pandoc.Shared (stringify)
import qualified Text.Pandoc.Walk       as Walk
import Citeproc.Types
import Citeproc.Pandoc ()
import Text.Pandoc.Citeproc.Util (toIETF)
import Text.Pandoc.Citeproc.Data (biblatexStringMap)
import Data.Default
import           Data.Text              (Text)
import qualified Data.Text              as T
import qualified Data.Map               as Map
import           Data.Maybe
import           Text.Pandoc.Parsing hiding ((<|>), many)
import           Control.Applicative
import           Data.List.Split        (splitOn, splitWhen, wordsBy)
import           Control.Monad.RWS      hiding ((<>))
import qualified Data.Sequence          as Seq
import           Data.Char              (isAlphaNum, isDigit, isLetter,
                                         isUpper, toLower, toUpper,
                                         isLower, isPunctuation)
import           Data.List              (foldl', intercalate)
import           Safe                   (readMay)

data Variant = Bibtex | Biblatex
  deriving (Show, Eq, Ord)

-- | Parse BibTeX or BibLaTeX into a list of 'Reference's.
readBibtexString :: Variant           -- ^ bibtex or biblatex
                 -> Locale            -- ^ Locale
                 -> (Text -> Bool)    -- ^ Filter on citation ids
                 -> Text              -- ^ bibtex/biblatex text
                 -> Either ParseError [Reference Inlines]
readBibtexString variant locale idpred contents = do
  case runParser (((resolveCrossRefs variant <$> bibEntries) <* eof) >>=
                   mapM (itemToReference locale variant) .
                      filter (\item -> idpred (identifier item) &&
                                        entryType item /= "xdata"))
           (fromMaybe defaultLang $ localeLanguage locale, Map.empty)
           "" contents of
          Left err -> Left err
          Right xs -> return xs

defaultLang :: Lang
defaultLang = Lang "en" (Just "US")

-- a map of bibtex "string" macros
type StringMap = Map.Map Text Text

type BibParser = Parser Text (Lang, StringMap)

data Item = Item{ identifier :: Text
                , sourcePos  :: SourcePos
                , entryType  :: Text
                , fields     :: Map.Map Text Text
                }
                deriving (Show, Ord, Eq)

itemToReference :: Locale -> Variant -> Item -> BibParser (Reference Inlines)
itemToReference locale variant item = do
  setPosition (sourcePos item)
  bib item $ do
    let lang = fromMaybe defaultLang $ localeLanguage locale
    modify $ \st -> st{ localeLang = lang,
                        untitlecase = case lang of
                                           (Lang "en" _) -> True
                                           _             -> False }

    id' <- asks identifier
    otherIds <- (Just <$> getRawField "ids")
                  <|> return Nothing
    (reftype, genre) <- getTypeAndGenre
    -- hyphenation:
    let getLangId = do
             langid <- T.strip . T.toLower <$> getRawField "langid"
             idopts <- T.strip . T.toLower . stringify <$>
                           getField "langidopts" <|> return ""
             case (langid, idopts) of
                  ("english","variant=british")    -> return "british"
                  ("english","variant=american")   -> return "american"
                  ("english","variant=us")         -> return "american"
                  ("english","variant=usmax")      -> return "american"
                  ("english","variant=uk")         -> return "british"
                  ("english","variant=australian") -> return "australian"
                  ("english","variant=newzealand") -> return "newzealand"
                  (x,_)                            -> return x
    hyphenation <- (Just . toIETF . T.toLower <$>
                     (getLangId <|> getRawField "hyphenation"))
                  <|> return Nothing
    modify $ \s -> s{ untitlecase = untitlecase s &&
                                      case hyphenation of
                                        Just x -> "en-" `T.isPrefixOf` x
                                        _ -> True }


    opts <- (parseOptions <$> getRawField "options") <|> return []

    et <- asks entryType

    -- titles
    let isArticle = et `elem`
                     ["article", "periodical", "suppperiodical", "review"]
    let isPeriodical = et == "periodical"
    let isChapterlike = et `elem`
           ["inbook","incollection","inproceedings","inreference","bookinbook"]

    let getFieldMaybe f = (Just <$> getField f) <|> return Nothing

    -- names
    let getNameList' f = Just <$>
         getNameList (("bibtex", case variant of
                                      Bibtex   -> "true"
                                      Biblatex -> "false") : opts) f

    author' <- getNameList' "author" <|> return Nothing
    containerAuthor' <- getNameList' "bookauthor" <|> return Nothing
    translator' <- getNameList' "translator" <|> return Nothing
    editortype <- getRawField "editortype" <|> return mempty
    editor'' <- getNameList' "editor" <|> return Nothing
    director'' <- getNameList' "director" <|> return Nothing
    let (editor', director') = case editortype of
                                    "director" -> (Nothing, editor'')
                                    _          -> (editor'', director'')
    -- FIXME: add same for editora, editorb, editorc

    -- dates
    issued' <- (Just <$> (getDate "date" <|> getOldDate mempty)) <|>
               return Nothing
    eventDate' <- (Just <$> (getDate "eventdate" <|> getOldDate "event")) <|>
                   return Nothing
    origDate' <- (Just <$> (getDate "origdate" <|> getOldDate "orig")) <|>
                   return Nothing
    accessed' <- (Just <$> (getDate "urldate" <|> getOldDate "url")) <|>
                    return Nothing

    -- locators
    pages' <- getFieldMaybe "pages"
    volume' <- getFieldMaybe "volume"
    part' <- getFieldMaybe "part"
    volumes' <- getFieldMaybe "volumes"
    pagetotal' <- getFieldMaybe "pagetotal"
    chapter' <- getFieldMaybe "chapter"
    edition' <- getFieldMaybe "edition"
    version' <- getFieldMaybe "version"
    (number', collectionNumber', issue') <-
       (getField "number" >>= \x ->
         if et `elem` ["book","collection","proceedings","reference",
                       "mvbook","mvcollection","mvproceedings", "mvreference",
                       "bookinbook","inbook", "incollection","inproceedings",
                       "inreference", "suppbook","suppcollection"]
         then return (Nothing, Just x, Nothing)
         else if isArticle
              then (getField "issue" >>= \y ->
                      return (Nothing, Nothing, Just $ concatWith ',' [x,y]))
                 <|> return (Nothing, Nothing, Just x)
              else return (Just x, Nothing, Nothing))
        <|> return (Nothing, Nothing, Nothing)

    -- titles
    hasMaintitle <- (True <$ getRawField "maintitle") <|> return False

    title' <- Just <$>
              ((guard isPeriodical >> getTitle "issuetitle")
              <|> (guard hasMaintitle >>
                   guard (not isChapterlike) >>
                   getTitle "maintitle")
              <|> getTitle "title")
              <|> return Nothing

    subtitle' <- (guard isPeriodical >> getTitle "issuesubtitle")
                  <|> (guard hasMaintitle >>
                       guard (not isChapterlike) >>
                       getTitle "mainsubtitle")
                  <|> getTitle "subtitle"
                  <|> return mempty
    titleaddon' <- (guard hasMaintitle >>
                     guard (not isChapterlike) >>
                     getTitle "maintitleaddon")
                    <|> getTitle "titleaddon"
                    <|> return mempty

    volumeTitle' <- Just <$>
                    ((guard hasMaintitle >>
                      guard (not isChapterlike) >>
                      getTitle "title")
                     <|> (guard hasMaintitle >>
                          guard isChapterlike >>
                          getTitle "booktitle"))
                    <|> return Nothing
    volumeSubtitle' <- (guard hasMaintitle >>
                        guard (not isChapterlike) >>
                        getTitle "subtitle")
                       <|> (guard hasMaintitle >>
                            guard isChapterlike >>
                            getTitle "booksubtitle")
                       <|> return mempty
    volumeTitleAddon' <- (guard hasMaintitle >>
                          guard (not isChapterlike) >>
                          getTitle "titleaddon")
                         <|> (guard hasMaintitle >>
                              guard isChapterlike >>
                              getTitle "booktitleaddon")
                         <|> return mempty

    containerTitle' <- Just <$>
                       ((guard isPeriodical >> getPeriodicalTitle "title")
                       <|> (guard isChapterlike >> getTitle "maintitle")
                       <|> (guard isChapterlike >> getTitle "booktitle")
                       <|> getPeriodicalTitle "journaltitle"
                       <|> getPeriodicalTitle "journal")
                       <|> return Nothing
    containerSubtitle' <- (guard isPeriodical >> getPeriodicalTitle "subtitle")
                          <|> (guard isChapterlike >> getTitle "mainsubtitle")
                          <|> (guard isChapterlike >> getTitle "booksubtitle")
                          <|> getPeriodicalTitle "journalsubtitle"
                          <|> return mempty
    containerTitleAddon' <- (guard isPeriodical >>
                             getPeriodicalTitle "titleaddon")
                            <|> (guard isChapterlike >>
                                 getTitle "maintitleaddon")
                            <|> (guard isChapterlike >>
                                 getTitle "booktitleaddon")
                            <|> return mempty
    containerTitleShort' <- Just <$>
                            ((guard isPeriodical >>
                              guard (not hasMaintitle) >>
                              getField "shorttitle")
                            <|> getPeriodicalTitle "shortjournal")
                           <|> return Nothing

    -- change numerical series title to e.g. 'series 3'
    let fixSeriesTitle [Str xs] | isNumber xs =
          [Str (ordinalize locale xs), Space, Str (resolveKey' lang "jourser")]
        fixSeriesTitle xs = xs
    seriesTitle' <- (Just . B.fromList . fixSeriesTitle .
                     B.toList . resolveKey lang <$>
                        getTitle "series") <|>
                    return Nothing
    shortTitle' <- (Just <$> (guard (not hasMaintitle || isChapterlike) >>
                              getTitle "shorttitle"))
                 <|> (if (subtitle' /= mempty || titleaddon' /= mempty) &&
                          not hasMaintitle
                          then getShortTitle False "title"
                          else getShortTitle True  "title")
                 <|> return Nothing

    eventTitle' <- Just <$> getTitle "eventtitle" <|> return Nothing
    origTitle' <- Just <$> getTitle "origtitle" <|> return Nothing

    -- publisher
    pubfields <- mapM (\f -> Just `fmap`
                         (if variant == Bibtex || f == "howpublished"
                          then getField f
                          else getLiteralList' f)
                        <|> return Nothing)
           ["school","institution","organization", "howpublished","publisher"]
    let publisher' = case catMaybes pubfields of
                       [] -> Nothing
                       xs -> Just $ concatWith ';' xs
    origpublisher' <- (Just <$> getField "origpublisher") <|> return Nothing

    -- places
    venue' <- (Just <$> getField "venue") <|> return Nothing
    address' <- Just <$>
                  (if variant == Bibtex
                      then getField "address"
                      else getLiteralList' "address"
                         <|> (guard (et /= "patent") >>
                              getLiteralList' "location"))
                <|> return Nothing
    origLocation' <- Just <$>
                  (if variant == Bibtex
                      then getField "origlocation"
                      else getLiteralList' "origlocation")
                    <|> return Nothing
    jurisdiction' <- if reftype == "patent"
                     then Just <$>
                        (concatWith ';' . map (resolveKey lang) <$>
                             getLiteralList "location") <|> return Nothing
                     else return Nothing

    -- url, doi, isbn, etc.:
    -- note that with eprinttype = arxiv, we take eprint to be a partial url
    -- archivePrefix is an alias for eprinttype
    url' <- (guard (et == "online" || lookup "url" opts /= Just "false")
             >> Just <$> getRawField "url")
         <|> (do etype <- getRawField "eprinttype"
                 eprint <- getRawField "eprint"
                 let baseUrl =
                       case T.toLower etype of
                         "arxiv"       -> "http://arxiv.org/abs/"
                         "jstor"       -> "http://www.jstor.org/stable/"
                         "pubmed"      -> "http://www.ncbi.nlm.nih.gov/pubmed/"
                         "googlebooks" -> "http://books.google.com?id="
                         _             -> ""
                 if T.null baseUrl
                    then mzero
                    else return $ Just $ baseUrl <> eprint)
         <|> return Nothing
    doi' <- (guard (lookup "doi" opts /= Just "false") >>
             Just <$> getRawField "doi")
           <|> return Nothing
    isbn' <- Just <$> getRawField "isbn" <|> return Nothing
    issn' <- Just <$> getRawField "issn" <|> return Nothing
    pmid' <- Just <$> getRawField  "pmid" <|> return Nothing
    pmcid' <- Just <$> getRawField "pmcid" <|> return Nothing
    callNumber' <- Just <$> getRawField "library" <|> return Nothing

    -- notes
    annotation' <- Just <$>
                   (getField "annotation" <|> getField "annote")
                     <|> return Nothing
    abstract' <- Just <$> getField "abstract" <|> return Nothing
    keywords' <- Just <$> getField "keywords" <|> return Nothing
    note' <- if et == "periodical"
             then return Nothing
             else Just <$> getField "note" <|> return Nothing
    addendum' <- if variant == Bibtex
                    then return Nothing
                    else Just <$> getField "addendum"
                 <|> return Nothing
    pubstate' <- (  (Just . resolveKey lang <$> getField "pubstate")
                  <|> case dateLiteral <$> issued' of
                           Just (Just "forthcoming") ->
                             return $ Just $ B.str "forthcoming"
                           _ -> return Nothing
                   )




    let addField (_, Nothing) = id
        addField (f, Just x)  = Map.insert f x
    let vars = foldr addField mempty
                [ ("other-ids", TextVal <$> otherIds)
                , ("genre", TextVal <$> genre)
                , ("language", TextVal <$> hyphenation)
                -- dates
                , ("accessed", DateVal <$> accessed')
                , ("event-date", DateVal <$> eventDate')
                , ("issued", DateVal <$> issued')
                , ("original-date", DateVal <$> origDate')
                -- names
                , ("author", NamesVal <$> author')
                , ("editor", NamesVal <$> editor')
                , ("translator", NamesVal <$> translator')
                , ("director", NamesVal <$> director')
                , ("container-author", NamesVal <$> containerAuthor')
                -- locators
                , ("page", FancyVal . Walk.walk convertEnDash <$> pages')
                , ("number-of-pages", FancyVal <$> pagetotal')
                , ("volume", case (volume', part') of
                               (Nothing, Nothing) -> Nothing
                               (Just v, Nothing) -> Just $ FancyVal v
                               (Nothing, Just p) -> Just $ FancyVal p
                               (Just v, Just p)  ->
                                 Just $ FancyVal $ v <> B.str "." <> p)
                , ("number-of-volumes", FancyVal <$> volumes')
                , ("chapter-number", FancyVal <$> chapter')
                , ("edition", FancyVal <$> edition')
                , ("version", FancyVal <$> version')
                , ("number", FancyVal <$> number')
                , ("collection-number", FancyVal <$> collectionNumber')
                , ("issue", FancyVal <$> issue')
                -- title
                , ("original-title", FancyVal <$> origTitle')
                , ("event", FancyVal <$> eventTitle')
                , ("title", case title' of
                              Just t -> Just $ FancyVal $
                                         concatWith '.' [
                                             concatWith ':' [t, subtitle']
                                           , titleaddon' ]
                              Nothing -> Nothing)
                , ("volume-title",
                            case volumeTitle' of
                              Just t -> Just $ FancyVal $
                                         concatWith '.' [
                                             concatWith ':' [t, volumeSubtitle']
                                           , volumeTitleAddon' ]
                              Nothing -> Nothing)
                , ("container-title",
                            case containerTitle' of
                              Just t -> Just $ FancyVal $
                                         concatWith '.' [
                                             concatWith ':' [t,
                                               containerSubtitle']
                                           , containerTitleAddon' ]
                              Nothing -> Nothing)
                , ("container-title-short", FancyVal <$> containerTitleShort')
                , ("collection-title", FancyVal <$> seriesTitle')
                , ("title-short", FancyVal <$> shortTitle')
                -- publisher
                , ("publisher", FancyVal <$> publisher')
                , ("original-publisher", FancyVal <$> origpublisher')
                -- places
                , ("jurisdiction", FancyVal <$> jurisdiction')
                , ("event-place",  FancyVal <$> venue')
                , ("publisher-place", FancyVal <$> address')
                , ("original-publisher-place", FancyVal <$> origLocation')
                -- urls
                , ("url", TextVal <$> url')
                , ("doi", TextVal <$> doi')
                , ("isbn", TextVal <$> isbn')
                , ("issn", TextVal <$> issn')
                , ("pmcid", TextVal <$> pmcid')
                , ("pmid", TextVal <$> pmid')
                , ("call-number", TextVal <$> callNumber')
                -- notes
                , ("note", case catMaybes [note', addendum'] of
                             [] -> Nothing
                             xs -> return $ FancyVal $ concatWith '.' xs)
                , ("annote", FancyVal <$> annotation')
                , ("abstract", FancyVal <$> abstract')
                , ("keyword", FancyVal <$> keywords')
                , ("status", FancyVal <$> pubstate')
                ]
    return $ Reference
      { referenceId             = ItemId id'
      , referenceType           = reftype
      , referenceDisambiguation = Nothing
      , referenceVariables      = vars }


bib :: Item -> Bib a -> BibParser a
bib entry m = fst <$> evalRWST m entry (BibState True (Lang "en" (Just "US")))

resolveCrossRefs :: Variant -> [Item] -> [Item]
resolveCrossRefs variant entries =
  map (resolveCrossRef variant entries) entries

resolveCrossRef :: Variant -> [Item] -> Item -> Item
resolveCrossRef variant entries entry =
  Map.foldrWithKey go entry (fields entry)
  where go key val entry' =
          if key == "crossref" || key == "xdata"
          then entry'{ fields = fields entry' <>
                          Map.fromList (getXrefFields variant
                                        entry entries val) }
          else entry'

getXrefFields :: Variant -> Item -> [Item] -> Text -> [(Text, Text)]
getXrefFields variant baseEntry entries keys = do
  let keys' = splitKeys keys
  xrefEntry <- [e | e <- entries, identifier e `elem` keys']
  (k, v) <- Map.toList $ fields xrefEntry
  if k == "crossref" || k == "xdata"
     then do
       xs <- mapM (getXrefFields variant baseEntry entries)
                   (splitKeys v)
       (x, y) <- xs
       guard $ isNothing $ Map.lookup x $ fields xrefEntry
       return (x, y)
     else do
       k' <- case variant of
               Bibtex -> return k
               Biblatex -> transformKey
                            (entryType xrefEntry) (entryType baseEntry) k
       guard $ isNothing $ Map.lookup k' $ fields baseEntry
       return (k',v)



data BibState = BibState{
           untitlecase    :: Bool
         , localeLang     :: Lang
         }

type Bib = RWST Item () BibState BibParser

blocksToInlines :: [Block] -> Inlines
blocksToInlines bs =
  case bs of
       [Plain xs] -> B.fromList xs
       [Para  xs] -> B.fromList xs
       _          -> B.fromList $ Walk.query (:[]) bs

adjustSpans :: Lang -> Inline -> Inline
adjustSpans lang (RawInline (Format "latex") s)
  | s == "\\hyphen" || s == "\\hyphen " = Str "-"
  | otherwise = parseRawLaTeX lang s
adjustSpans _ SoftBreak = Space
adjustSpans _ x = x

parseRawLaTeX :: Lang -> Text -> Inline
parseRawLaTeX lang t@(T.stripPrefix "\\" -> Just xs) =
  case parseLaTeX lang contents of
          Right [Para ys]  -> f command ys
          Right [Plain ys] -> f command ys
          Right []         -> f command []
          _                -> RawInline (Format "latex") t
   where (command', contents') = T.break (\c -> c =='{' || c =='\\') xs
         command  = T.strip command'
         contents = T.drop 1 $ T.dropEnd 1 contents'
         f "mkbibquote"    ils = Span nullAttr [Quoted DoubleQuote ils]
         f "mkbibemph"     ils = Span nullAttr [Emph ils]
         f "mkbibitalic"   ils = Span nullAttr [Emph ils]
         f "mkbibbold"     ils = Span nullAttr [Strong ils]
         f "mkbibparens"   ils = Span nullAttr $
                                  [Str "("] ++ ils ++ [Str ")"]
         f "mkbibbrackets" ils = Span nullAttr $
                                  [Str "["] ++ ils ++ [Str "]"]
         -- ... both should be nestable & should work in year fields
         f "autocap"    ils    = Span nullAttr ils
           -- TODO: should work in year fields
         f "textnormal" ils    = Span ("",["nodecor"],[]) ils
         f "bibstring" [Str s] = Str $ resolveKey' lang s
         f "adddot"    []      = Str "."
         f "adddotspace" []    = Span nullAttr [Str ".", Space]
         f "addabbrvspace" []  = Space
         f _            ils    = Span nullAttr ils
parseRawLaTeX _ t = RawInline (Format "latex") t

latex' :: Text -> Bib [Block]
latex' t = do
  lang <- gets localeLang
  case parseLaTeX lang t of
    Left _   -> mzero
    Right bs -> return bs

parseLaTeX :: Lang -> Text -> Either PandocError [Block]
parseLaTeX lang t =
  case runPure (readLaTeX
                def{ readerExtensions =
                      extensionsFromList [Ext_raw_tex, Ext_smart] } t) of
    Left e              -> Left e
    Right (Pandoc _ bs) -> Right $ Walk.walk (adjustSpans lang) bs

latex :: Text -> Bib Inlines
latex = fmap blocksToInlines . latex' . T.strip

type Options = [(Text, Text)]

parseOptions :: Text -> Options
parseOptions = map breakOpt . T.splitOn ","
  where breakOpt x = case T.break (=='=') x of
                          (w,v) -> (T.toLower $ T.strip w,
                                    T.toLower $ T.strip $ T.drop 1 v)

bibEntries :: BibParser [Item]
bibEntries = do
  skipMany nonEntry
  many (bibItem <* skipMany nonEntry)
 where nonEntry = bibSkip <|>
                  try (char '@' >>
                       (bibComment <|> bibPreamble <|> bibString))

bibSkip :: BibParser ()
bibSkip = () <$ take1WhileP (/='@')

bibComment :: BibParser ()
bibComment = do
  cistring "comment"
  spaces
  void inBraces <|> bibSkip <|> return ()

bibPreamble :: BibParser ()
bibPreamble = do
  cistring "preamble"
  spaces
  void inBraces

bibString :: BibParser ()
bibString = do
  cistring "string"
  spaces
  char '{'
  spaces
  (k,v) <- entField
  char '}'
  updateState (\(l,m) -> (l, Map.insert k v m))
  return ()

inBraces :: BibParser Text
inBraces = do
  char '{'
  res <- manyTill
         (  take1WhileP (\c -> c /= '{' && c /= '}' && c /= '\\')
        <|> (char '\\' >> (  (char '{' >> return "\\{")
                         <|> (char '}' >> return "\\}")
                         <|> return "\\"))
        <|> (braced <$> inBraces)
         ) (char '}')
  return $ T.concat res

braced :: Text -> Text
braced = T.cons '{' . flip T.snoc '}'

inQuotes :: BibParser Text
inQuotes = do
  char '"'
  T.concat <$> manyTill
             ( take1WhileP (\c -> c /= '{' && c /= '"' && c /= '\\')
               <|> (char '\\' >> T.cons '\\' . T.singleton <$> anyChar)
               <|> braced <$> inBraces
            ) (char '"')

fieldName :: BibParser Text
fieldName = resolveAlias . T.toLower
  <$> take1WhileP (\c ->
         isAlphaNum c || c == '-' || c == '_' || c == ':' || c == '+')

isBibtexKeyChar :: Char -> Bool
isBibtexKeyChar c =
  isAlphaNum c || c `elem` (".:;?!`'()/*@_+=-[]*&" :: [Char])

bibItem :: BibParser Item
bibItem = do
  char '@'
  pos <- getPosition
  enttype <- T.toLower <$> take1WhileP isLetter
  spaces
  char '{'
  spaces
  entid <- take1WhileP isBibtexKeyChar
  spaces
  char ','
  spaces
  entfields <- entField `sepEndBy` (char ',' >> spaces)
  spaces
  char '}'
  return $ Item entid pos enttype (Map.fromList entfields)

entField :: BibParser (Text, Text)
entField = do
  k <- fieldName
  spaces
  char '='
  spaces
  vs <- (expandString <|> inQuotes <|> inBraces <|> rawWord) `sepBy`
            try (spaces >> char '#' >> spaces)
  spaces
  return (k, T.concat vs)

resolveAlias :: Text -> Text
resolveAlias "archiveprefix" = "eprinttype"
resolveAlias "primaryclass" = "eprintclass"
resolveAlias s = s

rawWord :: BibParser Text
rawWord = take1WhileP isAlphaNum

expandString :: BibParser Text
expandString = do
  k <- fieldName
  (lang, strs) <- getState
  case Map.lookup k strs of
       Just v  -> return v
       Nothing -> return $ resolveKey' lang k

cistring :: Text -> BibParser Text
cistring s = try (go s)
 where go t = case T.uncons t of
         Nothing     -> return ""
         Just (c,cs) -> do
           x <- char (toLower c) <|> char (toUpper c)
           xs <- go cs
           return (T.cons x xs)

splitKeys :: Text -> [Text]
splitKeys = filter (not . T.null) . T.split (\c -> c == ' ' || c == ',')

-- Biblatex Localization Keys (see Biblatex manual)
-- Currently we only map a subset likely to be used in Biblatex *databases*
-- (in fields such as `type`, and via `\bibstring{}` commands).

parseMonth :: Text -> Maybe Int
parseMonth s =
  case T.toLower s of
         "jan" -> Just 1
         "feb" -> Just 2
         "mar" -> Just 3
         "apr" -> Just 4
         "may" -> Just 5
         "jun" -> Just 6
         "jul" -> Just 7
         "aug" -> Just 8
         "sep" -> Just 9
         "oct" -> Just 10
         "nov" -> Just 11
         "dec" -> Just 12
         _     -> readMay (T.unpack s)

notFound :: Text -> Bib a
notFound f = Prelude.fail $ T.unpack f ++ " not found"

getField :: Text -> Bib Inlines
getField f = do
  fs <- asks fields
  case Map.lookup f fs of
       Just x  -> latex x
       Nothing -> notFound f


getPeriodicalTitle :: Text -> Bib Inlines
getPeriodicalTitle f = do
  ils <- getField f
  return ils

protectCase :: (Inlines -> Inlines) -> (Inlines -> Inlines)
protectCase f = Walk.walk unprotect . f . Walk.walk protect
 where
  protect (Span ("",[],[]) xs) = Span ("",["nocase"],[]) xs
  protect  x = x
  unprotect (Span ("",["nocase"],[]) xs)
    | hasLowercaseWord xs = Span ("",["nocase"],[]) xs
    | otherwise           = Span ("",[],[]) xs
  unprotect x = x
  hasLowercaseWord = any startsWithLowercase . splitStrWhen isPunctuation
  startsWithLowercase (Str (T.uncons -> Just (x,_))) = isLower x
  startsWithLowercase _           = False

unTitlecase :: Maybe Lang -> Inlines -> Inlines
unTitlecase mblang = protectCase (addTextCase mblang SentenceCase)

getTitle :: Text -> Bib Inlines
getTitle f = do
  ils <- getField f
  utc <- gets untitlecase
  lang <- gets localeLang
  let processTitle = if utc then unTitlecase (Just lang) else id
  return $ processTitle ils

getShortTitle :: Bool -> Text -> Bib (Maybe Inlines)
getShortTitle requireColon f = do
  ils <- splitStrWhen (==':') . B.toList <$> getTitle f
  if not requireColon || containsColon ils
     then return $ Just $ B.fromList $ upToColon ils
     else return Nothing

containsColon :: [Inline] -> Bool
containsColon xs = Str ":" `elem` xs

upToColon :: [Inline] -> [Inline]
upToColon xs = takeWhile (/= Str ":") xs

isNumber :: Text -> Bool
isNumber t = case T.uncons t of
  Just ('-', ds) -> T.all isDigit ds
  Just _         -> T.all isDigit t
  Nothing        -> False

getDate :: Text -> Bib Date
getDate f = do
  -- the ~ can used for approx dates, but the latex reader
  -- parses this as a nonbreaking space, so we need to convert it back!
  let nbspToTilde '\160' = '~'
      nbspToTilde c      = c
  mbd <- rawDateEDTF . T.map nbspToTilde <$> getRawField f
  case mbd of
    Nothing -> Prelude.fail "expected date"
    Just d  -> return d

-- A negative (BC) year might be written with -- or --- in bibtex:
fixLeadingDash :: Text -> Text
fixLeadingDash t = case T.uncons t of
  Just (c, ds) | (c == '–' || c == '—') && firstIsDigit ds -> T.cons '–' ds
  _ -> t
 where firstIsDigit = maybe False (isDigit . fst) . T.uncons

getOldDate :: Text -> Bib Date
getOldDate prefix = do
  year' <- (readMay . T.unpack . fixLeadingDash . stringify
              <$> getField (prefix <> "year")) <|> return Nothing
  month' <- (parseMonth <$> getRawField (prefix <> "month"))
            <|> return Nothing
  day' <- (readMay . T.unpack <$> getRawField (prefix <> "day"))
          <|> return Nothing
  endyear' <- (readMay . T.unpack . fixLeadingDash . stringify
              <$> getField (prefix <> "endyear")) <|> return Nothing
  endmonth' <- (parseMonth . stringify
                 <$> getField (prefix <> "endmonth")) <|> return Nothing
  endday' <- (readMay . T.unpack . stringify <$>
                 getField (prefix <> "endday")) <|> return Nothing
  let toDateParts (y', m', d') =
              DateParts $
                 case y' of
                   Nothing -> []
                   Just y  ->
                     case m' of
                       Nothing -> [y]
                       Just m  ->
                         case d' of
                           Nothing -> [y,m]
                           Just d  -> [y,m,d]
  let dateparts = filter (\x -> x /= DateParts [])
                  $ map toDateParts [(year',month',day'),
                                     (endyear',endmonth',endday')]
  literal <- if null dateparts
                then Just <$> getRawField (prefix <> "year")
                else return Nothing
  return $
    Date { dateParts = dateparts
         , dateCirca = False
         , dateSeason = Nothing
         , dateLiteral = literal }

getRawField :: Text -> Bib Text
getRawField f = do
  fs <- asks fields
  case Map.lookup f fs of
       Just x  -> return x
       Nothing -> notFound f

getLiteralList :: Text -> Bib [Inlines]
getLiteralList f = do
  fs <- asks fields
  case Map.lookup f fs of
       Just x  -> latex' x >>= toLiteralList
       Nothing -> notFound f

-- separates items with semicolons
getLiteralList' :: Text -> Bib Inlines
getLiteralList' f = do
  fs <- asks fields
  case Map.lookup f fs of
    Just x    -> do
      x' <- latex' x
      case x' of
        [Para xs]  ->
          return $ B.fromList
                 $ intercalate [Str ";", Space]
                 $ splitByAnd xs
        [Plain xs] ->
          return $ B.fromList
                 $ intercalate [Str ";", Space]
                 $ splitByAnd xs
        _          -> mzero
    Nothing   -> notFound f

splitByAnd :: [Inline] -> [[Inline]]
splitByAnd = splitOn [Space, Str "and", Space]

toLiteralList :: [Block] -> Bib [Inlines]
toLiteralList [Para xs] =
  return $ map B.fromList $ splitByAnd xs
toLiteralList [Plain xs] = toLiteralList [Para xs]
toLiteralList _ = mzero

concatWith :: Char -> [Inlines] -> Inlines
concatWith sep = foldl' go mempty
  where go :: Inlines -> Inlines -> Inlines
        go accum s
          | s == mempty = accum
          | otherwise   =
              case Seq.viewr (B.unMany accum) of
                     Seq.EmptyR -> s
                     _ Seq.:> Str x
                       | not (T.null x) &&
                         T.last x `elem` ("!?.,:;" :: String)
                                    -> accum <> B.space <> s
                     _ -> accum <> B.str (T.singleton sep) <>
                                                B.space <> s


getNameList :: Options -> Text -> Bib [Name]
getNameList opts  f = do
  fs <- asks fields
  case Map.lookup f fs of
       Just x  -> latexNames opts x
       Nothing -> notFound f

toNameList :: Options -> [Block] -> Bib [Name]
toNameList opts [Para xs] =
  filter (/= emptyName) <$> mapM (toName opts . addSpaceAfterPeriod)
                                    (splitByAnd xs)
toNameList opts [Plain xs] = toNameList opts [Para xs]
toNameList _ _ = mzero

latexNames :: Options -> Text -> Bib [Name]
latexNames opts t = latex' (T.strip t) >>= toNameList opts

-- see issue 392 for motivation.  We want to treat
-- "J.G. Smith" and "J. G. Smith" the same.
addSpaceAfterPeriod :: [Inline] -> [Inline]
addSpaceAfterPeriod = go . splitStrWhen (=='.')
  where
    go [] = []
    go (Str (T.unpack -> [c]):Str ".":Str (T.unpack -> [d]):xs)
      | isLetter d
      , isLetter c
      , isUpper c
      , isUpper d
        = Str (T.singleton c):Str ".":Space:go (Str (T.singleton d):xs)
    go (x:xs) = x:go xs

emptyName :: Name
emptyName =
    Name {  nameFamily              = Nothing
          , nameGiven               = Nothing
          , nameDroppingParticle    = Nothing
          , nameNonDroppingParticle = Nothing
          , nameSuffix              = Nothing
          , nameLiteral             = Nothing
          , nameCommaSuffix         = False
          , nameStaticOrdering      = False
          }

toName :: Options -> [Inline] -> Bib Name
toName _ [Str "others"] =
  return emptyName{ nameLiteral = Just "others" }
toName _ [Span ("",[],[]) ils] = -- corporate author
  return emptyName{ nameLiteral = Just $ stringify ils }
 -- extended BibLaTeX name format - see #266
toName _ ils@(Str ys:_) | T.any (== '=') ys = do
  let commaParts = splitWhen (== Str ",")
                   . splitStrWhen (\c -> c == ',' || c == '=' || c == '\160')
                   $ ils
  let addPart ag (Str "given" : Str "=" : xs) =
        ag{ nameGiven = case nameGiven ag of
                          Nothing -> Just $ stringify xs
                          Just t  -> Just $ t <> " " <> stringify xs }
      addPart ag (Str "family" : Str "=" : xs) =
        ag{ nameFamily = Just $ stringify xs }
      addPart ag (Str "prefix" : Str "=" : xs) =
        ag{ nameDroppingParticle =  Just $ stringify xs }
      addPart ag (Str "useprefix" : Str "=" : Str "true" : _) =
        ag{ nameNonDroppingParticle = nameDroppingParticle ag
          , nameDroppingParticle    = Nothing }
      addPart ag (Str "suffix" : Str "=" : xs) =
        ag{ nameSuffix = Just $ stringify xs }
      addPart ag (Space : xs) = addPart ag xs
      addPart ag _ = ag
  return $ foldl' addPart emptyName commaParts
-- First von Last
-- von Last, First
-- von Last, Jr ,First
-- NOTE: biblatex and bibtex differ on:
-- Drummond de Andrade, Carlos
-- bibtex takes "Drummond de" as the von;
-- biblatex takes the whole as a last name.
-- See https://github.com/plk/biblatex/issues/236
-- Here we implement the more sensible biblatex behavior.
toName opts ils = do
  let useprefix = optionSet "useprefix" opts
  let usecomma  = optionSet "juniorcomma" opts
  let bibtex    = optionSet "bibtex" opts
  let words' = wordsBy (\x -> x == Space || x == Str "\160")
  let commaParts = map words' $ splitWhen (== Str ",")
                              $ splitStrWhen
                                   (\c -> c == ',' || c == '\160') ils
  let (first, vonlast, jr) =
          case commaParts of
               --- First is the longest sequence of white-space separated
               -- words starting with an uppercase and that is not the
               -- whole string. von is the longest sequence of whitespace
               -- separated words whose last word starts with lower case
               -- and that is not the whole string.
               [fvl]      -> let (caps', rest') = span isCapitalized fvl
                             in  if null rest' && not (null caps')
                                 then (init caps', [last caps'], [])
                                 else (caps', rest', [])
               [vl,f]     -> (f, vl, [])
               (vl:j:f:_) -> (f, vl, j )
               []         -> ([], [], [])

  let (von, lastname) =
         if bibtex
            then case span isCapitalized $ reverse vonlast of
                        ([],w:ws) -> (reverse ws, [w])
                        (vs, ws)    -> (reverse ws, reverse vs)
            else case break isCapitalized vonlast of
                        (vs@(_:_), []) -> (init vs, [last vs])
                        (vs, ws)       -> (vs, ws)
  let prefix = T.unwords $ map stringify von
  let family = T.unwords $ map stringify lastname
  let suffix = T.unwords $ map stringify jr
  let given = T.unwords $ map stringify first
  return
    Name {  nameFamily              = if T.null family
                                         then Nothing
                                         else Just family
          , nameGiven               = if T.null given
                                         then Nothing
                                         else Just given
          , nameDroppingParticle    = if useprefix || T.null prefix
                                         then Nothing
                                         else Just prefix
          , nameNonDroppingParticle = if useprefix && not (T.null prefix)
                                         then Just prefix
                                         else Nothing
          , nameSuffix              = if T.null suffix
                                         then Nothing
                                         else Just suffix
          , nameLiteral             = Nothing
          , nameCommaSuffix         = usecomma
          , nameStaticOrdering      = False
          }

splitStrWhen :: (Char -> Bool) -> [Inline] -> [Inline]
splitStrWhen _ [] = []
splitStrWhen p (Str xs : ys) = map Str (go xs) ++ splitStrWhen p ys
  where go s =
          let (w,z) = T.break p s
           in if T.null z
                 then if T.null w
                         then []
                         else [w]
                 else if T.null w
                         then (T.take 1 z : go (T.drop 1 z))
                         else (w : T.take 1 z : go (T.drop 1 z))
splitStrWhen p (x : ys) = x : splitStrWhen p ys

ordinalize :: Locale -> Text -> Text
ordinalize locale n =
  let terms = localeTerms locale
      pad0 t = case T.length t of
                 0 -> "00"
                 1 -> "0" <> t
                 _ -> t
   in case Map.lookup ("ordinal-" <> pad0 n) terms <|>
           Map.lookup "ordinal" terms of
        Nothing    -> n
        Just []    -> n
        Just (t:_) -> n <> snd t

isCapitalized :: [Inline] -> Bool
isCapitalized (Str (T.uncons -> Just (c,cs)) : rest)
  | isUpper c = True
  | isDigit c = isCapitalized (Str cs : rest)
  | otherwise = False
isCapitalized (_:rest) = isCapitalized rest
isCapitalized [] = True

optionSet :: Text -> Options -> Bool
optionSet key opts = case lookup key opts of
                      Just "true" -> True
                      Just s      -> s == mempty
                      _           -> False

getTypeAndGenre :: Bib (Text, Maybe Text)
getTypeAndGenre = do
  lang <- gets localeLang
  et <- asks entryType
  reftype' <- resolveKey' lang <$> getRawField "type"
         <|> return mempty
  st <- getRawField "entrysubtype" <|> return mempty
  isEvent <- (True <$ (getRawField "eventdate"
                     <|> getRawField "eventtitle"
                     <|> getRawField "venue")) <|> return False
  let reftype =
        case et of
           "article"
             | st == "magazine"  -> "article-magazine"
             | st == "newspaper" -> "article-newspaper"
             | otherwise         -> "article-journal"
           "book"                -> "book"
           "booklet"             -> "pamphlet"
           "bookinbook"          -> "chapter"
           "collection"          -> "book"
           "dataset"             -> "dataset"
           "electronic"          -> "webpage"
           "inbook"              -> "chapter"
           "incollection"        -> "chapter"
           "inreference"         -> "entry-encyclopedia"
           "inproceedings"       -> "paper-conference"
           "manual"              -> "book"
           "mastersthesis"       -> "thesis"
           "misc"                -> ""
           "mvbook"              -> "book"
           "mvcollection"        -> "book"
           "mvproceedings"       -> "book"
           "mvreference"         -> "book"
           "online"              -> "webpage"
           "patent"              -> "patent"
           "periodical"
             | st == "magazine"  -> "article-magazine"
             | st == "newspaper" -> "article-newspaper"
             | otherwise         -> "article-journal"
           "phdthesis"           -> "thesis"
           "proceedings"         -> "book"
           "reference"           -> "book"
           "report"              -> "report"
           "software"            -> "book"    -- no "software" type in CSL
           "suppbook"            -> "chapter"
           "suppcollection"      -> "chapter"
           "suppperiodical"
             | st == "magazine"  -> "article-magazine"
             | st == "newspaper" -> "article-newspaper"
             | otherwise         -> "article-journal"
           "techreport"          -> "report"
           "thesis"              -> "thesis"
           "unpublished"         -> if isEvent then "speech" else "manuscript"
           "www"                 -> "webpage"
           -- biblatex, "unsupported"
           "artwork"             -> "graphic"
           "audio"               -> "song"    -- for audio *recordings*
           "commentary"          -> "book"
           "image"               -> "graphic"   -- or "figure" ?
           "jurisdiction"        -> "legal_case"
           "legislation"         -> "legislation"  -- or "bill" ?
           "legal"               -> "treaty"
           "letter"              -> "personal_communication"
           "movie"               -> "motion_picture"
           "music"               -> "song"        -- for musical *recordings*
           "performance"         -> "speech"
           "review"              -> "review"      -- or "review-book" ?
           "standard"            -> "legislation"
           "video"               -> "motion_picture"
           -- biblatex-apa:
           "data"                -> "dataset"
           "letters"             -> "personal_communication"
           "newsarticle"         -> "article-newspaper"
           _                     -> ""

  let refgenre =
        case et of
          "mastersthesis"  -> if T.null reftype'
                                 then Just $ resolveKey' lang "mathesis"
                                 else Just reftype'
          "phdthesis"      -> if T.null reftype'
                                 then Just $ resolveKey' lang "phdthesis"
                                 else Just reftype'
          _                -> if T.null reftype'
                                 then Nothing
                                 else Just reftype'
  return (reftype, refgenre)


-- transformKey source target key
-- derived from Appendix C of bibtex manual
transformKey :: Text -> Text -> Text -> [Text]
transformKey _ _ "ids"            = []
transformKey _ _ "crossref"       = []
transformKey _ _ "xref"           = []
transformKey _ _ "entryset"       = []
transformKey _ _ "entrysubtype"   = []
transformKey _ _ "execute"        = []
transformKey _ _ "label"          = []
transformKey _ _ "options"        = []
transformKey _ _ "presort"        = []
transformKey _ _ "related"        = []
transformKey _ _ "relatedoptions" = []
transformKey _ _ "relatedstring"  = []
transformKey _ _ "relatedtype"    = []
transformKey _ _ "shorthand"      = []
transformKey _ _ "shorthandintro" = []
transformKey _ _ "sortkey"        = []
transformKey x y "author"
  | x `elem` ["mvbook", "book"] &&
    y `elem` ["inbook", "bookinbook", "suppbook"] = ["bookauthor", "author"]
-- note: this next clause is not in the biblatex manual, but it makes
-- sense in the context of CSL conversion:
transformKey x y "author"
  | x == "mvbook" && y == "book" = ["bookauthor", "author"]
transformKey "mvbook" y z
  | y `elem` ["book", "inbook", "bookinbook", "suppbook"] = standardTrans z
transformKey x y z
  | x `elem` ["mvcollection", "mvreference"] &&
    y `elem` ["collection", "reference", "incollection", "inreference",
               "suppcollection"] = standardTrans z
transformKey "mvproceedings" y z
  | y `elem` ["proceedings", "inproceedings"] = standardTrans z
transformKey "book" y z
  | y `elem` ["inbook", "bookinbook", "suppbook"] = bookTrans z
transformKey x y z
  | x `elem` ["collection", "reference"] &&
    y `elem` ["incollection", "inreference", "suppcollection"] = bookTrans z
transformKey "proceedings" "inproceedings" z = bookTrans z
transformKey "periodical" y z
  | y `elem` ["article", "suppperiodical"] =
  case z of
       "title"          -> ["journaltitle"]
       "subtitle"       -> ["journalsubtitle"]
       "shorttitle"     -> []
       "sorttitle"      -> []
       "indextitle"     -> []
       "indexsorttitle" -> []
       _                -> [z]
transformKey _ _ x                = [x]

standardTrans :: Text -> [Text]
standardTrans z =
  case z of
       "title"          -> ["maintitle"]
       "subtitle"       -> ["mainsubtitle"]
       "titleaddon"     -> ["maintitleaddon"]
       "shorttitle"     -> []
       "sorttitle"      -> []
       "indextitle"     -> []
       "indexsorttitle" -> []
       _                -> [z]

bookTrans :: Text -> [Text]
bookTrans z =
  case z of
       "title"          -> ["booktitle"]
       "subtitle"       -> ["booksubtitle"]
       "titleaddon"     -> ["booktitleaddon"]
       "shorttitle"     -> []
       "sorttitle"      -> []
       "indextitle"     -> []
       "indexsorttitle" -> []
       _                -> [z]

resolveKey :: Lang -> Inlines -> Inlines
resolveKey lang ils = Walk.walk go ils
  where go (Str s) = Str $ resolveKey' lang s
        go x       = x

resolveKey' :: Lang -> Text -> Text
resolveKey' lang@(Lang l _) k =
  case Map.lookup l biblatexStringMap >>= Map.lookup (T.toLower k) of
    Nothing     -> k
    Just (x, _) -> either (const k) stringify $ parseLaTeX lang x

convertEnDash :: Inline -> Inline
convertEnDash (Str s) = Str (T.map (\c -> if c == '–' then '-' else c) s)
convertEnDash x       = x