{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE IncoherentInstances        #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PatternGuards              #-}
{-# LANGUAGE ScopedTypeVariables        #-}
#if MIN_VERSION_base(4,8,0)
#define OVERLAPS {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances       #-}
#define OVERLAPS
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.CSL.Reference
-- Copyright   :  (c) Andrea Rossato
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Andrea Rossato <andrea.rossato@unitn.it>
-- Stability   :  unstable
-- Portability :  unportable
--
-- The Reference type
--
-----------------------------------------------------------------------------

module Text.CSL.Reference ( Literal(..)
                          , Value(..)
                          , ReferenceMap
                          , mkRefMap
                          , fromValue
                          , isValueSet
                          , Empty(..)
                          , Season(..)
                          , seasonToInt
                          , RefDate(..)
                          , handleLiteral
                          , toDatePart
                          , setCirca
                          , RefType(..)
                          , CNum(..)
                          , CLabel(..)
                          , Reference(..)
                          , emptyReference
                          , numericVars
                          , getReference
                          , processCites
                          , setPageFirst
                          , setNearNote
                          , parseEDTFDate
                          )
where

import Prelude
import           Control.Applicative ((<|>))
import           Control.Monad       (guard, mplus, msum)
import           Data.Aeson          hiding (Value)
import qualified Data.Aeson          as Aeson
import           Data.Aeson.Types    (Parser)
import           Data.Char           (isDigit, toLower, isPunctuation)
import           Data.Either         (lefts, rights)
import           Data.Generics       hiding (Generic)
import qualified Data.HashMap.Strict as H
import           Data.List           (find, elemIndex)
import           Data.Maybe          (fromMaybe, isNothing)
import           Data.String
import           Data.Text           (Text)
import qualified Data.Text           as T
import qualified Data.Vector         as V
import           Data.Yaml.Builder   (ToYaml (..))
import qualified Data.Yaml.Builder   as Y
import           GHC.Generics        (Generic)
import           Text.CSL.Style      hiding (Number)
import           Text.CSL.Util       (camelize, capitalize, inlinesToString,
                                      mapping', parseBool, parseInt, parseMaybeInt,
                                      parseString, readNum, safeRead, trim,
                                      uncamelize, AddYaml(..), splitStrWhen)
import           Text.Pandoc         (Inline (Str))
import qualified Text.Parsec         as P
import qualified Text.Parsec.Text    as P

newtype Literal = Literal { unLiteral :: Text }
  deriving ( Show, Read, Eq, Data, Typeable, Semigroup, Monoid, Generic )

instance AddYaml Literal
  where x &= (Literal y) = x &= y

instance FromJSON Literal where
  parseJSON v             = Literal `fmap` parseString v

instance ToJSON Literal where
  toJSON = toJSON . unLiteral

instance ToYaml Literal where
  toYaml = Y.string . unLiteral

instance IsString Literal where
  fromString = Literal . T.pack

-- | An existential type to wrap the different types a 'Reference' is
-- made of. This way we can create a map to make queries easier.
data Value = forall a . Data a => Value a

-- for debuging
instance Show Value where
    show (Value a) = gshow a

type ReferenceMap = [(Text, Value)]

mkRefMap :: Maybe Reference -> ReferenceMap
mkRefMap Nothing  = []
mkRefMap (Just r) = zip fields (gmapQ Value r)
      where fields = map (T.pack . uncamelize) . constrFields . toConstr $ r

fromValue :: Data a => Value -> Maybe a
fromValue (Value a) = cast a

isValueSet :: Value -> Bool
isValueSet val
    | Just v <- fromValue val :: Maybe Literal   = v /= mempty
    | Just v <- fromValue val :: Maybe String    = v /= mempty
    | Just v <- fromValue val :: Maybe Formatted = v /= mempty
    | Just v <- fromValue val :: Maybe [Agent]   = v /= []
    | Just v <- fromValue val :: Maybe [RefDate] = v /= []
    | Just v <- fromValue val :: Maybe Int       = v /= 0
    | Just v <- fromValue val :: Maybe CNum      = v /= 0
    | Just v <- fromValue val :: Maybe CLabel    = v /= mempty
    | Just _ <- fromValue val :: Maybe Empty     = True
    | otherwise = False

data Empty = Empty deriving ( Typeable, Data, Generic )

data Season = Spring | Summer | Autumn | Winter | RawSeason Text
     deriving (Show, Read, Eq, Typeable, Data, Generic)

instance ToYaml Season where
  toYaml Spring = toYaml (1 :: Int)
  toYaml Summer = toYaml (2 :: Int)
  toYaml Autumn = toYaml (3 :: Int)
  toYaml Winter = toYaml (4 :: Int)
  toYaml (RawSeason s) = toYaml s

seasonToInt :: Season -> Maybe Int
seasonToInt Spring = Just 1
seasonToInt Summer = Just 2
seasonToInt Autumn = Just 3
seasonToInt Winter = Just 4
seasonToInt _      = Nothing

intToSeason :: Int -> Maybe Season
intToSeason 1 = Just Spring
intToSeason 2 = Just Summer
intToSeason 3 = Just Autumn
intToSeason 4 = Just Winter
intToSeason _  = Nothing

pseudoMonthToSeason :: Int -> Maybe Season
pseudoMonthToSeason n
  | n >= 13 && n <= 16 = intToSeason (n - 12)
  | n >= 21 && n <= 24 = intToSeason (n - 20)
  | otherwise          = Nothing

-- | Parse JSON value as Maybe Season.
parseMaybeSeason :: Maybe Aeson.Value -> Parser (Maybe Season)
parseMaybeSeason Nothing = return Nothing
parseMaybeSeason (Just x) = do
  mbn <- parseMaybeInt (Just x) <|> return Nothing
  case mbn of
       Just n -> case intToSeason n of
                      Just s  -> return $ Just s
                      Nothing -> fail $ "Could not read season: " ++ show n
       Nothing -> do
         s <- parseString x
         if T.null s
            then return Nothing
            else return $ Just $ RawSeason s

data RefDate =
    RefDate { year   :: Maybe Int
            , month  :: Maybe Int
            , season :: Maybe Season
            , day    :: Maybe Int
            , other  :: Literal
            , circa  :: Bool
            } deriving ( Show, Read, Eq, Typeable, Data, Generic )

instance AddYaml RefDate where
  _ &= (RefDate Nothing Nothing Nothing Nothing o _) | o == mempty = id
  x &= y = x &= y

instance FromJSON RefDate where
  parseJSON (Array v) = handlePseudoMonths <$>
     case fromJSON (Array v) of
          Success [y]     -> RefDate <$> parseMaybeInt y <*>
                    pure Nothing <*> pure Nothing <*> pure Nothing <*>
                    pure "" <*> pure False
          Success [y,m]   -> RefDate <$> parseMaybeInt y <*> parseMaybeInt m <*>
                    pure Nothing <*> pure Nothing <*> pure "" <*> pure False
          Success [y,m,d] -> RefDate <$> parseMaybeInt y <*> parseMaybeInt m <*>
                    pure Nothing <*> parseMaybeInt d <*> pure "" <*> pure False
          Error e         -> fail $ "Could not parse RefDate: " ++ e
          _               -> fail "Could not parse RefDate"
     where handlePseudoMonths r =
              case month r >>= pseudoMonthToSeason of
                   Just s  -> r{ month = Nothing, season = Just s }
                   Nothing -> r
  parseJSON (Object v) = RefDate <$>
              (v .:? "year" >>= parseMaybeInt) <*>
              (v .:? "month" >>= parseMaybeInt) <*>
              (v .:? "season" >>= parseMaybeSeason) <*>
              (v .:? "day" >>= parseMaybeInt) <*>
              v .:? "literal" .!= "" <*>
              ((v .: "circa" >>= parseBool) <|> pure False)
  parseJSON _ = fail "Could not parse RefDate"

{-
instance ToJSON RefDate where
  toJSON refdate = object' $ [
      "year" .= year refdate
    , "month" .= month refdate
    , "season" .= season refdate
    , "day" .= day refdate
    , "literal" .= other refdate ] ++
    [ "circa" .= circa refdate | circa refdate ]
-}

instance ToYaml RefDate where
  toYaml r = mapping'
               [ "year" &= year r
               , "month" &= month r
               , "season" &= season r
               , "day" &= day r
               , "literal" &= other r
               , "circa" &= circa r
               ]

instance OVERLAPS
         FromJSON [RefDate] where
  parseJSON (Array xs) = mapM parseJSON $ V.toList xs
  parseJSON (Object v) = do
    raw' <- v .:? "raw"
    dateParts <- v .:? "date-parts"
    circa' <- (v .: "circa" >>= parseBool) <|> pure False
    season' <- v .:? "season" >>= parseMaybeSeason
    case dateParts of
         Just (Array y) | isNothing raw' ->
           case V.toList y of
              []           -> return []
              [Null]       -> return []
              [Array x]
                | V.null x -> return []
                   -- [ null ] and [ [] ] are sometimes seen. See
                   -- https://github.com/greenelab/manubot/issues/66
              ys           -> mapM (fmap (setCirca circa' .
                                maybe id setSeason season') . parseJSON) ys
         _ -> case raw' of
                  Nothing -> handleLiteral <$> parseJSON (Object v)
                  Just r  -> return $ parseRawDate r
  parseJSON x  = parseRawDate <$> parseJSON x

instance OVERLAPS
         ToJSON [RefDate] where
  toJSON = toJSONDate

toJSONDate :: [RefDate] -> Aeson.Value
toJSONDate [] = Array V.empty
toJSONDate ds = object' $
  [ "date-parts" .= dateparts | not (null dateparts) ] ++
  ["circa" .= (1 :: Int) | any circa ds] ++
  (case msum (map season ds) of
        Just (RawSeason s) -> ["season" .= s]
        _                  -> []) ++
  (case mconcat (map other ds) of
        Literal l | not (T.null l) -> ["literal" .= l]
        _                          -> [])
  where dateparts = filter (not . emptyDatePart) $ map toDatePart ds
        emptyDatePart [] = True
        emptyDatePart xs = all (== 0) xs

toDatePart :: RefDate -> [Int]
toDatePart refdate =
    case (year refdate, month refdate
           `mplus`
          ((12+) <$> (season refdate >>= seasonToInt)),
          day refdate) of
         (Just (y :: Int), Just (m :: Int), Just (d :: Int))
                                     -> [y, m, d]
         (Just y, Just m, Nothing)   -> [y, m]
         (Just y, Nothing, Nothing)  -> [y]
         _                           -> []


-- Zotero doesn't properly support date ranges, so a common
-- workaround is 2005_2007 or 2005_; support this as date range:
handleLiteral :: RefDate -> [RefDate]
handleLiteral d@(RefDate Nothing Nothing Nothing Nothing (Literal xs) b)
  = case T.splitOn "_" xs of
      [x,y] | T.all isDigit x && T.all isDigit y &&
              not (T.null x) ->
                [RefDate (safeRead x) Nothing Nothing Nothing mempty b,
                 RefDate (safeRead y) Nothing Nothing Nothing mempty b]
      _ -> [d]
handleLiteral d = [d]

setCirca :: Bool -> RefDate -> RefDate
setCirca circa' rd = rd{ circa = circa' }

setSeason :: Season -> RefDate -> RefDate
setSeason season' rd = rd{ season = Just season' }

data RefType
    = NoType
    | Article
    | ArticleMagazine
    | ArticleNewspaper
    | ArticleJournal
    | Bill
    | Book
    | Broadcast
    | Chapter
    | Dataset
    | Entry
    | EntryDictionary
    | EntryEncyclopedia
    | Figure
    | Graphic
    | Interview
    | Legislation
    | LegalCase
    | Manuscript
    | Map
    | MotionPicture
    | MusicalScore
    | Pamphlet
    | PaperConference
    | Patent
    | Post
    | PostWeblog
    | PersonalCommunication
    | Report
    | Review
    | ReviewBook
    | Song
    | Speech
    | Thesis
    | Treaty
    | Webpage
      deriving ( Read, Eq, Typeable, Data, Generic )

instance Show RefType where
    show x = map toLower . uncamelize . showConstr . toConstr $ x

instance FromJSON RefType where
  -- found in one of the test cases:
  parseJSON (String "film") = return MotionPicture
  parseJSON (String t) =
    safeRead (capitalize . T.pack . camelize $ t) <|>
    fail ("'" ++ T.unpack t ++ "' is not a valid reference type")
  parseJSON v@(Array _) =
    fmap (capitalize . T.pack . camelize . inlinesToString) (parseJSON v) >>= \t ->
      safeRead t <|>
       fail ("'" ++ T.unpack t ++ "' is not a valid reference type")
  parseJSON _ = fail "Could not parse RefType"

instance ToJSON RefType where
  toJSON reftype = toJSON (handleSpecialCases $ show reftype)

instance ToYaml RefType where
  toYaml r = Y.string (T.pack $ handleSpecialCases $ show r)

-- For some reason, CSL is inconsistent about hyphens and underscores:
handleSpecialCases :: String -> String
handleSpecialCases "motion-picture"         = "motion_picture"
handleSpecialCases "musical-score"          = "musical_score"
handleSpecialCases "personal-communication" = "personal_communication"
handleSpecialCases "legal-case"             = "legal_case"
handleSpecialCases x                        = x

newtype CNum = CNum { unCNum :: Int }
  deriving ( Show, Read, Eq, Ord, Num, Typeable, Data, Generic )

instance FromJSON CNum where
  parseJSON x = CNum `fmap` parseInt x

instance ToJSON CNum where
  toJSON (CNum n) = toJSON n

instance ToYaml CNum where
  toYaml r = Y.string (T.pack $ show $ unCNum r)

newtype CLabel = CLabel { unCLabel :: Text }
  deriving ( Show, Read, Eq, Typeable, Data, Generic, Semigroup, Monoid )

instance FromJSON CLabel where
  parseJSON x = CLabel `fmap` parseString x

instance ToJSON CLabel where
  toJSON (CLabel s) = toJSON s

instance ToYaml CLabel where
  toYaml (CLabel s) = toYaml s

-- | The 'Reference' record.
data Reference =
    Reference
    { refId                    :: Literal
    , refOtherIds              :: [Literal]
    , refType                  :: RefType

    , author                   :: [Agent]
    , editor                   :: [Agent]
    , translator               :: [Agent]
    , recipient                :: [Agent]
    , interviewer              :: [Agent]
    , composer                 :: [Agent]
    , director                 :: [Agent]
    , illustrator              :: [Agent]
    , originalAuthor           :: [Agent]
    , containerAuthor          :: [Agent]
    , collectionEditor         :: [Agent]
    , editorialDirector        :: [Agent]
    , reviewedAuthor           :: [Agent]

    , issued                   :: [RefDate]
    , eventDate                :: [RefDate]
    , accessed                 :: [RefDate]
    , container                :: [RefDate]
    , originalDate             :: [RefDate]
    , submitted                :: [RefDate]

    , title                    :: Formatted
    , titleShort               :: Formatted
    , reviewedTitle            :: Formatted
    , containerTitle           :: Formatted
    , volumeTitle              :: Formatted
    , collectionTitle          :: Formatted
    , containerTitleShort      :: Formatted
    , collectionNumber         :: Formatted --Int
    , originalTitle            :: Formatted
    , publisher                :: Formatted
    , originalPublisher        :: Formatted
    , publisherPlace           :: Formatted
    , originalPublisherPlace   :: Formatted
    , authority                :: Formatted
    , jurisdiction             :: Formatted
    , archive                  :: Formatted
    , archivePlace             :: Formatted
    , archiveLocation          :: Formatted
    , event                    :: Formatted
    , eventPlace               :: Formatted
    , page                     :: Formatted
    , pageFirst                :: Formatted
    , numberOfPages            :: Formatted
    , version                  :: Formatted
    , volume                   :: Formatted
    , numberOfVolumes          :: Formatted --Int
    , issue                    :: Formatted
    , chapterNumber            :: Formatted
    , medium                   :: Formatted
    , status                   :: Formatted
    , edition                  :: Formatted
    , section                  :: Formatted
    , source                   :: Formatted
    , genre                    :: Formatted
    , note                     :: Formatted
    , annote                   :: Formatted
    , abstract                 :: Formatted
    , keyword                  :: Formatted
    , number                   :: Formatted
    , references               :: Formatted
    , url                      :: Literal
    , doi                      :: Literal
    , isbn                     :: Literal
    , issn                     :: Literal
    , pmcid                    :: Literal
    , pmid                     :: Literal
    , callNumber               :: Literal
    , dimensions               :: Literal
    , scale                    :: Literal
    , categories               :: [Literal]
    , language                 :: Literal

    , citationNumber           :: CNum
    , firstReferenceNoteNumber :: Int
    , citationLabel            :: CLabel
    } deriving ( Eq, Show, Read, Typeable, Data, Generic )

instance FromJSON Reference where
  parseJSON (Object v') = do
     v <- parseSuppFields v' <|> return v'
     (Reference <$>
       v .:? "id" .!= "" <*>
       v .:? "other-ids" .!= [] <*>
       v .:? "type" .!= NoType <*>
       v .:? "author" .!= [] <*>
       v .:? "editor" .!= [] <*>
       v .:? "translator" .!= [] <*>
       v .:? "recipient" .!= [] <*>
       v .:? "interviewer" .!= [] <*>
       v .:? "composer" .!= [] <*>
       v .:? "director" .!= [] <*>
       v .:? "illustrator" .!= [] <*>
       v .:? "original-author" .!= [] <*>
       v .:? "container-author" .!= [] <*>
       v .:? "collection-editor" .!= [] <*>
       v .:? "editorial-director" .!= [] <*>
       v .:? "reviewed-author" .!= [] <*>
       v .:? "issued" .!= [] <*>
       v .:? "event-date" .!= [] <*>
       v .:? "accessed" .!= [] <*>
       v .:? "container" .!= [] <*>
       v .:? "original-date" .!= [] <*>
       v .:? "submitted" .!= [] <*>
       v .:? "title" .!= mempty <*>
       (v .: "shortTitle" <|> (v .:? "title-short" .!= mempty)) <*>
       v .:? "reviewed-title" .!= mempty <*>
       v .:? "container-title" .!= mempty <*>
       v .:? "volume-title" .!= mempty <*>
       v .:? "collection-title" .!= mempty <*>
       (v .: "journalAbbreviation" <|> v .:? "container-title-short" .!= mempty) <*>
       v .:? "collection-number" .!= mempty <*>
       v .:? "original-title" .!= mempty <*>
       v .:? "publisher" .!= mempty <*>
       v .:? "original-publisher" .!= mempty <*>
       v .:? "publisher-place" .!= mempty <*>
       v .:? "original-publisher-place" .!= mempty <*>
       v .:? "authority" .!= mempty <*>
       v .:? "jurisdiction" .!= mempty <*>
       v .:? "archive" .!= mempty <*>
       v .:? "archive-place" .!= mempty <*>
       v .:? "archive_location" .!= mempty <*>
       v .:? "event" .!= mempty <*>
       v .:? "event-place" .!= mempty <*>
       v .:? "page" .!= mempty <*>
       v .:? "page-first" .!= mempty <*>
       v .:? "number-of-pages" .!= mempty <*>
       v .:? "version" .!= mempty <*>
       v .:? "volume" .!= mempty <*>
       v .:? "number-of-volumes" .!= mempty <*>
       v .:? "issue" .!= mempty <*>
       v .:? "chapter-number" .!= mempty <*>
       v .:? "medium" .!= mempty <*>
       v .:? "status" .!= mempty <*>
       v .:? "edition" .!= mempty <*>
       v .:? "section" .!= mempty <*>
       v .:? "source" .!= mempty <*>
       v .:? "genre" .!= mempty <*>
       v .:? "note" .!= mempty <*>
       v .:? "annote" .!= mempty <*>
       v .:? "abstract" .!= mempty <*>
       v .:? "keyword" .!= mempty <*>
       v .:? "number" .!= mempty <*>
       v .:? "references" .!= mempty <*>
       v .:? "URL" .!= "" <*>
       v .:? "DOI" .!= "" <*>
       v .:? "ISBN" .!= "" <*>
       v .:? "ISSN" .!= "" <*>
       v .:? "PMCID" .!= "" <*>
       v .:? "PMID" .!= "" <*>
       v .:? "call-number" .!= "" <*>
       v .:? "dimensions" .!= "" <*>
       v .:? "scale" .!= "" <*>
       v .:? "categories" .!= [] <*>
       v .:? "language" .!= "" <*>
       v .:? "citation-number" .!= CNum 0 <*>
       ((v .: "first-reference-note-number" >>= parseInt) <|> return 0) <*>
       v .:? "citation-label" .!= mempty)
  parseJSON _ = fail "Could not parse Reference"

-- Syntax for adding supplementary fields in note variable
-- {:authority:Superior Court of California}{:section:A}{:original-date:1777}
-- or
-- Foo\nissued: 2016-03-20/2016-07-31\nbar
-- see http://gsl-nagoya-u.net/http/pub/citeproc-doc.html#supplementary-fields
parseSuppFields :: Aeson.Object -> Parser Aeson.Object
parseSuppFields o = do
  nt <- o .: "note"
  case P.parse noteFields "note" nt of
       Left err -> fail (show err)
       Right fs -> return $ foldr (\(k,v) x -> H.insert k v x) o fs

noteFields :: P.Parser [(Text, Aeson.Value)]
noteFields = do
  fs <- P.many (Right <$> (noteField <|> lineNoteField) <|> Left <$> regText)
  P.spaces
  let rest = T.unwords (lefts fs)
  return (("note", Aeson.String rest) : rights fs)

noteField :: P.Parser (Text, Aeson.Value)
noteField = P.try $ do
  _ <- P.char '{'
  _ <- P.char ':'
  k <- P.manyTill (P.letter <|> P.char '-') (P.char ':')
  _ <- P.skipMany (P.char ' ')
  v <- P.manyTill P.anyChar (P.char '}')
  return (T.pack k, Aeson.String (T.pack v))

lineNoteField :: P.Parser (Text, Aeson.Value)
lineNoteField = P.try $ do
  _ <- P.char '\n'
  k <- P.manyTill (P.letter <|> P.char '-') (P.char ':')
  _ <- P.skipMany (P.char ' ')
  v <- P.manyTill P.anyChar (P.char '\n' <|> '\n' <$ P.eof)
  return (T.pack k, Aeson.String (T.pack v))

regText :: P.Parser Text
regText = (T.pack <$> P.many1 (P.noneOf "\n{")) <|> (T.singleton <$> P.anyChar)

instance ToJSON Reference where
  toJSON ref = object' [
      "id" .= refId ref
    , "other-ids" .= refOtherIds ref
    , "type" .= refType ref
    , "author" .= author ref
    , "editor" .= editor ref
    , "translator" .= translator ref
    , "recipient" .= recipient ref
    , "interviewer" .= interviewer ref
    , "composer" .= composer ref
    , "director" .= director ref
    , "illustrator" .= illustrator ref
    , "original-author" .= originalAuthor ref
    , "container-author" .= containerAuthor ref
    , "collection-editor" .= collectionEditor ref
    , "editorial-director" .= editorialDirector ref
    , "reviewed-author" .= reviewedAuthor ref
    , "issued" .= issued ref
    , "event-date" .= eventDate ref
    , "accessed" .= accessed ref
    , "container" .= container ref
    , "original-date" .= originalDate ref
    , "submitted" .= submitted ref
    , "title" .= title ref
    , "title-short" .= titleShort ref
    , "reviewed-title" .= reviewedTitle ref
    , "container-title" .= containerTitle ref
    , "volume-title" .= volumeTitle ref
    , "collection-title" .= collectionTitle ref
    , "container-title-short" .= containerTitleShort ref
    , "collection-number" .= collectionNumber ref
    , "original-title" .= originalTitle ref
    , "publisher" .= publisher ref
    , "original-publisher" .= originalPublisher ref
    , "publisher-place" .= publisherPlace ref
    , "original-publisher-place" .= originalPublisherPlace ref
    , "authority" .= authority ref
    , "jurisdiction" .= jurisdiction ref
    , "archive" .= archive ref
    , "archive-place" .= archivePlace ref
    , "archive_location" .= archiveLocation ref
    , "event" .= event ref
    , "event-place" .= eventPlace ref
    , "page" .= page ref
    , "page-first" .= (if page ref == mempty then pageFirst ref else mempty)
    , "number-of-pages" .= numberOfPages ref
    , "version" .= version ref
    , "volume" .= volume ref
    , "number-of-volumes" .= numberOfVolumes ref
    , "issue" .= issue ref
    , "chapter-number" .= chapterNumber ref
    , "medium" .= medium ref
    , "status" .= status ref
    , "edition" .= edition ref
    , "section" .= section ref
    , "source" .= source ref
    , "genre" .= genre ref
    , "note" .= note ref
    , "annote" .= annote ref
    , "abstract" .= abstract ref
    , "keyword" .= keyword ref
    , "number" .= number ref
    , "references" .= references ref
    , "URL" .= url ref
    , "DOI" .= doi ref
    , "ISBN" .= isbn ref
    , "ISSN" .= issn ref
    , "PMCID" .= pmcid ref
    , "PMID" .= pmid ref
    , "call-number" .= callNumber ref
    , "dimensions" .= dimensions ref
    , "scale" .= scale ref
    , "categories" .= categories ref
    , "language" .= language ref
    , "citation-number" .= citationNumber ref
    , "first-reference-note-number" .= firstReferenceNoteNumber ref
    , "citation-label" .= citationLabel ref
    ]

instance ToYaml Reference where
  toYaml ref = mapping' [
      "id" &= refId ref
    , "other-ids" &= refOtherIds ref
    , (("type" Y..= refType ref) :)
    , "author" &= author ref
    , "editor" &= editor ref
    , "translator" &= translator ref
    , "recipient" &= recipient ref
    , "interviewer" &= interviewer ref
    , "composer" &= composer ref
    , "director" &= director ref
    , "illustrator" &= illustrator ref
    , "original-author" &= originalAuthor ref
    , "container-author" &= containerAuthor ref
    , "collection-editor" &= collectionEditor ref
    , "editorial-director" &= editorialDirector ref
    , "reviewed-author" &= reviewedAuthor ref
    , "issued" &= issued ref
    , "event-date" &= eventDate ref
    , "accessed" &= accessed ref
    , "container" &= container ref
    , "original-date" &= originalDate ref
    , "submitted" &= submitted ref
    , "title" &= title ref
    , "title-short" &= titleShort ref
    , "reviewed-title" &= reviewedTitle ref
    , "container-title" &= containerTitle ref
    , "volume-title" &= volumeTitle ref
    , "collection-title" &= collectionTitle ref
    , "container-title-short" &= containerTitleShort ref
    , "collection-number" &= collectionNumber ref
    , "original-title" &= originalTitle ref
    , "publisher" &= publisher ref
    , "original-publisher" &= originalPublisher ref
    , "publisher-place" &= publisherPlace ref
    , "original-publisher-place" &= originalPublisherPlace ref
    , "authority" &= authority ref
    , "jurisdiction" &= jurisdiction ref
    , "archive" &= archive ref
    , "archive-place" &= archivePlace ref
    , "archive_location" &= archiveLocation ref
    , "event" &= event ref
    , "event-place" &= eventPlace ref
    , "page" &= page ref
    , "page-first" &= (if page ref == mempty then pageFirst ref else mempty)
    , "number-of-pages" &= numberOfPages ref
    , "version" &= version ref
    , "volume" &= volume ref
    , "number-of-volumes" &= numberOfVolumes ref
    , "issue" &= issue ref
    , "chapter-number" &= chapterNumber ref
    , "medium" &= medium ref
    , "status" &= status ref
    , "edition" &= edition ref
    , "section" &= section ref
    , "source" &= source ref
    , "genre" &= genre ref
    , "note" &= note ref
    , "annote" &= annote ref
    , "abstract" &= abstract ref
    , "keyword" &= keyword ref
    , "number" &= number ref
    , "references" &= references ref
    , "URL" &= url ref
    , "DOI" &= doi ref
    , "ISBN" &= isbn ref
    , "ISSN" &= issn ref
    , "PMCID" &= pmcid ref
    , "PMID" &= pmid ref
    , "call-number" &= callNumber ref
    , "dimensions" &= dimensions ref
    , "scale" &= scale ref
    , "categories" &= categories ref
    , "language" &= language ref
    , if citationNumber ref == CNum 0
         then id
         else (("citation-number" Y..= citationNumber ref) :)
    , if firstReferenceNoteNumber ref == 0
         then id
         else (("first-reference-note-number" Y..=
                firstReferenceNoteNumber ref) :)
    , if citationLabel ref == mempty
         then id
         else (("citation-label" Y..= citationLabel ref) :)
    ]

emptyReference :: Reference
emptyReference =
    Reference
    { refId               = mempty
    , refOtherIds         = mempty
    , refType             = NoType

    , author              = []
    , editor              = []
    , translator          = []
    , recipient           = []
    , interviewer         = []
    , composer            = []
    , director            = []
    , illustrator         = []
    , originalAuthor      = []
    , containerAuthor     = []
    , collectionEditor    = []
    , editorialDirector   = []
    , reviewedAuthor      = []

    , issued              = []
    , eventDate           = []
    , accessed            = []
    , container           = []
    , originalDate        = []
    , submitted           = []

    , title               = mempty
    , titleShort          = mempty
    , reviewedTitle       = mempty
    , containerTitle      = mempty
    , volumeTitle         = mempty
    , collectionTitle     = mempty
    , containerTitleShort = mempty
    , collectionNumber    = mempty
    , originalTitle       = mempty
    , publisher           = mempty
    , originalPublisher   = mempty
    , publisherPlace      = mempty
    , originalPublisherPlace = mempty
    , authority           = mempty
    , jurisdiction        = mempty
    , archive             = mempty
    , archivePlace        = mempty
    , archiveLocation     = mempty
    , event               = mempty
    , eventPlace          = mempty
    , page                = mempty
    , pageFirst           = mempty
    , numberOfPages       = mempty
    , version             = mempty
    , volume              = mempty
    , numberOfVolumes     = mempty
    , issue               = mempty
    , chapterNumber       = mempty
    , medium              = mempty
    , status              = mempty
    , edition             = mempty
    , section             = mempty
    , source              = mempty
    , genre               = mempty
    , note                = mempty
    , annote              = mempty
    , abstract            = mempty
    , keyword             = mempty
    , number              = mempty
    , references          = mempty
    , url                 = mempty
    , doi                 = mempty
    , isbn                = mempty
    , issn                = mempty
    , pmcid               = mempty
    , pmid                = mempty
    , callNumber          = mempty
    , dimensions          = mempty
    , scale               = mempty
    , categories          = mempty
    , language            = mempty

    , citationNumber           = CNum 0
    , firstReferenceNoteNumber = 0
    , citationLabel            = mempty
    }

numericVars :: [Text]
numericVars = [ "edition", "volume", "number-of-volumes", "number", "issue", "citation-number"
              , "chapter-number", "collection-number", "number-of-pages"]

getReference :: [Reference] -> Cite -> Maybe Reference
getReference  rs c
    = case (hasId (citeId c)) `find` rs of
        Just r  -> Just $ setPageFirst r
        Nothing -> Nothing
  where hasId :: Text -> Reference -> Bool
        hasId ident r = ident `elem` (map unLiteral (refId r : refOtherIds r))

processCites :: [Reference] -> [[Cite]] -> [[(Cite, Maybe Reference)]]
processCites rs cs
    = procGr [] cs
    where
      procRef r = case filter ((==) (unLiteral $ refId r) . citeId) $ concat cs of
                    x:_ -> r { firstReferenceNoteNumber = readNum $ citeNoteNumber x}
                    []  -> r

      procGr _ [] = []
      procGr acc (x:xs) = let (a',res) = procCs acc x
                          in res : procGr ([] : a') xs

      -- process, given the accumulated history, the current group's cites
      procCs acc [] = (acc,[])
      procCs acc (c:xs) = let (a, rest) = procCs addCite xs
                              ref       = procRef <$> getReference rs c
                              c'        = c { citePosition = getCitePosition }
                          in  (a, (c', ref) : rest)
          where
            addCite = case acc of
                        []     -> [[c]]
                        (a:as) -> (c : a) : as

            -- http://docs.citationstyles.org/en/stable/specification.html#locators
            getCitePosition = fromMaybe notIbid (ibidPosition <$> prevSameCite)
                where
                    notIbid = if citeId c `elem` map citeId (concat acc)
                                 then "subsequent"
                                 else "first"

            ibidPosition x = let hasL k   = citeLocator k /= ""
                                 withIf b = if b then "ibid-with-locator" else "ibid"
                                 diffLoc  = citeLocator x /= citeLocator c
                                           || citeLabel x /= citeLabel c
                             in  case (hasL x, hasL c) of
                                   (False, cur)  -> withIf cur
                                   (True, True)  -> withIf diffLoc
                                   (True, False) -> "subsequent"

            -- x is previous cite in current group
            -- zs is the previous group
            prevSameCite = case acc of
                             []     -> Nothing
                             (a:as) -> psc a as
              where
                -- you can't have an ibid at the start of your document
                psc [] []     = Nothing

                -- a. the current cite immediately follows on another cite,
                --    within the same citation, that references the same item
                psc (x:_) _   = if citeId c == citeId x
                                   then Just x
                                   else Nothing

                -- b.  [] => the current cite is the first cite in the citation
                --     zs => and the previous citation consists of a single cite
                --           that refs the same item
                -- The spec appears to be concerned that you cannot know the
                -- correct one to match the locator against.
                -- It is a super clunky if you have [@a, 1; @a, 2] then [@a, 3],
                -- where the second citation gets "subsequent" even though there were
                -- only @a keys.
                -- This is silly. We will use the last one to match against.
                psc [] (zs:_) = case zs of
                                  [] -> Nothing
                                  (z:_) -> if all (== citeId c) (map citeId zs)
                                              then Just z
                                              else Nothing

setPageFirst :: Reference -> Reference
setPageFirst ref =
  let Formatted ils = page ref
      ils' = takeWhile (\i -> i /= Str "–" && i /= Str "-") $
              splitStrWhen isPunctuation ils
  in  if ils == ils'
         then ref
         else ref{ pageFirst = Formatted ils' }

setNearNote :: Style -> [[Cite]] -> [[Cite]]
setNearNote s cs
    = procGr [] cs
    where
      near_note   = let nn = lookup "near-note-distance" . citOptions . citation $ s
                    in maybe 5 readNum nn
      procGr _ [] = []
      procGr a (x:xs) = let (a',res) = procCs a x
                        in res : procGr a' xs

      procCs a []     = (a,[])
      procCs a (c:xs) = (a', c { nearNote = isNear} : rest)
          where
            (a', rest) = procCs (c:a) xs
            isNear     = case filter ((==) (citeId c) . citeId) a of
                           x:_ -> citeNoteNumber c /= "0" &&
                                  citeNoteNumber x /= "0" &&
                                  readNum (citeNoteNumber c) - readNum (citeNoteNumber x) <= near_note
                           _   -> False

parseRawDate :: Text -> [RefDate]
parseRawDate o =
  case P.parse rawDate "raw date" o of
       Left _   -> [RefDate Nothing Nothing Nothing Nothing (Literal o) False]
       Right ds -> ds

rawDate :: P.Parser [RefDate]
rawDate = rawDateISO <|> rawDateOld

parseEDTFDate :: Text -> [RefDate]
parseEDTFDate o =
  case handleRanges (trim o) of
       "" -> []
       o' -> case P.parse rawDateISO "date" o' of
                Left _   -> []
                Right ds -> ds
    where handleRanges s =
            case T.splitOn "/" s of
                 -- 199u EDTF format for a range
                 [x] | T.any (== 'u') x ->
                      T.map (\c -> if c == 'u' then '0' else c) x
                      <> "/" <>
                      T.map (\c -> if c == 'u' then '9' else c) x
                 [x, "open"] -> x <> "/"    -- EDTF
                 [x, "unknown"] -> x <> "/" -- EDTF
                 _  -> s

rawDateISO :: P.Parser [RefDate]
rawDateISO = do
  d1 <- isoDate
  P.option [d1] (P.char '/' >>
                  (\x -> [d1, x]) <$>
                   (  isoDate <|> return emptydate )) <* P.eof
   where emptydate = RefDate Nothing Nothing Nothing Nothing mempty False

isoDate :: P.Parser RefDate
isoDate = P.try $ do
  extyear <- P.option False (True <$ P.char 'y')  -- EDTF year > 4 digits
  -- needed for bibtex
  y <- do
    sign <- P.option "" (P.string "-")
    rest <- P.count 4 P.digit
    extended <- if extyear
                   then P.many P.digit
                   else return []
    return $ case safeRead (T.pack $ sign ++ rest ++ extended) of
                    Just x | x <= 0 -> Just (x - 1)  -- 0 = -1 AD
                    x               -> x
  m' <- P.option Nothing $ Just <$> P.try (P.char '-' >> P.many1 P.digit)
  (m,s) <- case m' >>= safeRead . T.pack of
                   Just (n::Int)
                          | n >= 1 && n <= 12  -> return (Just n, Nothing)
                          | n >= 13 && n <= 16 -> return (Nothing, pseudoMonthToSeason n)
                          | n >= 21 && n <= 24 -> return (Nothing, pseudoMonthToSeason n)
                   Nothing | isNothing m' -> return (Nothing, Nothing)
                   _ -> fail "Improper month"
  d <- P.option Nothing $ safeRead . T.pack <$> P.try (P.char '-' >> P.many1 P.digit)
  guard $ case d of
           Nothing -> True
           Just (n::Int) | n >= 1 && n <= 31 -> True
           _ -> False
  P.optional $ do
    _ <- P.char 'T'
    _ <- P.many (P.digit <|> P.char ':')
    P.optional $ (P.oneOf "+-" >> P.many1 (P.digit <|> P.char ':'))
              <|> P.string "Z"
  _ <- P.optional (P.char '?')
  c <- P.option False (True <$ P.char '~')
  return RefDate{ year = y, month = m,
                  season = s, day = d,
                  other = mempty, circa = c }

rawDateOld :: P.Parser [RefDate]
rawDateOld = do
  let months   = ["jan","feb","mar","apr","may","jun","jul","aug",
                  "sep","oct","nov","dec"]
  let seasons  = ["spr","sum","fal","win"]
  let pmonth = P.try $ do
        xs <- P.many1 P.letter <|> P.many1 P.digit
        if all isDigit xs
           then case safeRead (T.pack xs) of
                      Just (n::Int) | n >= 1 && n <= 12 -> return (Just n)
                      _ -> fail "Improper month"
           else case elemIndex (map toLower $ take 3 xs) months of
                     Nothing -> fail "Improper month"
                     Just n  -> return (Just (n+1))
  let pseason = P.try $ do
        xs <- P.many1 P.letter
        case elemIndex (map toLower $ take 3 xs) seasons of
             Just 0  -> return (Just Spring)
             Just 1  -> return (Just Summer)
             Just 2  -> return (Just Autumn)
             Just 3  -> return (Just Winter)
             _       -> fail "Improper season"
  let pday = P.try $ do
        xs <- P.many1 P.digit
        case safeRead (T.pack xs) of
             Just (n::Int) | n >= 1 && n <= 31 -> return (Just n)
             _ -> fail "Improper day"
  let pyear = safeRead . T.pack <$> P.many1 P.digit
  let sep = P.oneOf [' ','/',','] >> P.spaces
  let rangesep = P.try $ P.spaces >> P.char '-' >> P.spaces
  let refDate = RefDate Nothing Nothing Nothing Nothing mempty False
  let date = P.choice $ map P.try
                [ do s <- pseason
                     sep
                     y <- pyear
                     return refDate{ year = y, season = s }
                , do m <- pmonth
                     sep
                     d <- pday
                     sep
                     y <- pyear
                     return refDate{ year = y, month = m, day = d }
                , do m <- pmonth
                     sep
                     y <- pyear
                     return refDate{ year = y, month = m }
                , do y <- pyear
                     return refDate{ year = y }
                ]
  d1 <- date
  P.option [d1] ((\x -> [d1,x]) <$> (rangesep >> date))

