{-# LANGUAGE StrictData #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Citeproc.Eval
  ( evalStyle )
where
import Citeproc.Types
import Citeproc.Style (mergeLocales)
import Data.Semigroup
import Control.Monad.Trans.RWS.CPS
import Data.Containers.ListUtils (nubOrdOn, nubOrd)
import Safe (headMay, headDef, lastMay, initSafe, tailSafe, maximumMay)
import Data.Maybe
import Control.Monad (foldM, zipWithM, when, unless)
import qualified Data.Map as M
import qualified Data.Set as Set
import Data.Coerce (coerce)
import Data.List (find, intersperse, sortOn, groupBy, foldl', transpose,
                  sort, (\\))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Char (isSpace, isPunctuation, isDigit, isUpper, isLower, isLetter,
                  ord, chr)
import Text.Printf (printf)
import Control.Applicative
import Data.Generics.Uniplate.Operations (universe, transform)

-- import Debug.Trace (traceShowId)
-- import Text.Show.Pretty (ppShow)
-- ppTrace :: Show a => a -> a
-- ppTrace x = trace (ppShow x) x

data Context a =
  Context
  { contextLocale              :: Locale
  , contextAbbreviations       :: Maybe Abbreviations
  , contextStyleOptions        :: StyleOptions
  , contextLocator             :: Maybe Text
  , contextLabel               :: Maybe Text
  , contextPosition            :: [Position]
  , contextInSubstitute        :: Bool
  , contextInSortKey           :: Bool
  , contextSubstituteNamesForm :: Maybe NamesFormat
  }
  deriving (Show)

-- used internally for group elements, which
-- are skipped if (a) the group calls a variable
-- but (b) all of the variables called are empty.
data VarCount =
  VarCount
  { variablesAccessed :: Int
  , variablesNonempty :: Int
  } deriving (Show)

data EvalState a =
  EvalState
  { stateVarCount       :: VarCount
  , stateLastCitedMap   :: M.Map ItemId (Int, Maybe Int, Int,
                                          Bool, Maybe Text, Maybe Text)
                        -- (citegroup, noteNum, posInGroup,
                        --      aloneInCitation, label, locator)
  , stateRefMap         :: ReferenceMap a
  , stateReference      :: Reference a
  , stateUsedYearSuffix :: Bool
  } deriving (Show)


type Eval a = RWS (Context a) (Set.Set Text) (EvalState a)

updateVarCount :: Int -> Int -> Eval a ()
updateVarCount total' nonempty' =
  modify $ \st ->
    let VarCount total nonempty = stateVarCount st
     in st{ stateVarCount =
              VarCount (total + total') (nonempty + nonempty') }

evalStyle  :: CiteprocOutput a
           => Style a          -- ^ Parsed CSL style.
           -> Maybe Lang       -- ^ Override style default locale.
           -> [Reference a]    -- ^ List of references (bibliographic data).
           -> [Citation a]     -- ^ List of citations.
           -> ([Output a], [(Text, Output a)], [Text])
                       -- ^ (citations, (id, bibentry) pairs, warnings)
evalStyle style mblang refs citations =
  (citationOs, bibliographyOs, Set.toList warnings)
 where
  ((citationOs, bibliographyOs), warnings) = evalRWS go
     Context
      { contextLocale              = mergeLocales mblang style
      , contextAbbreviations       = styleAbbreviations style
      , contextStyleOptions        = styleOptions style
      , contextLocator             = Nothing
      , contextLabel               = Nothing
      , contextPosition            = []
      , contextInSubstitute        = False
      , contextInSortKey           = False
      , contextSubstituteNamesForm = Nothing
      }
      EvalState
      { stateVarCount = VarCount 0 0
      , stateLastCitedMap = mempty
      , stateRefMap = makeReferenceMap refs
      , stateReference = Reference mempty mempty Nothing mempty
      , stateUsedYearSuffix = False
      }

  assignCitationNumbers sortedIds =
    modify $ \st ->
              st{ stateRefMap = ReferenceMap $ foldl'
                     (\m (citeId, num) ->
                         M.adjust (\ref ->
                           ref{ referenceVariables =
                                 M.insert "citation-number"
                                    (NumVal num) .
                                 M.alter (addIfMissing (citationLabel ref))
                                    "citation-label"
                                 $ referenceVariables ref
                              }) citeId m)
                     (unReferenceMap (stateRefMap st))
                     (zip sortedIds [1..]) }

  addIfMissing x Nothing  = Just x
  addIfMissing _ (Just x) = Just x

  go = do
      -- list of citationItemIds that are actually cited
      let citationOrder = M.fromList $ reverse $ zip
            (concatMap (map citationItemId . citationItems) citations)
            [(1 :: Int)..]
      let citeIds = M.keysSet citationOrder
      let sortedCiteIds = sortOn (`M.lookup` citationOrder)
                                  (map referenceId refs)
      assignCitationNumbers sortedCiteIds
      -- sorting of bibliography, insertion of citation-number
      (bibCitations, bibSortKeyMap) <-
        case styleBibliography style of
          Nothing -> return ([], mempty)
          Just biblayout -> do
            bibSortKeyMap <- M.fromList
                      <$> mapM
                          ((\citeId ->
                             (citeId,) <$> evalSortKeys biblayout citeId)
                             . referenceId)
                          refs
            let sortedIds =
                  if null (layoutSortKeys biblayout)
                     then sortedCiteIds
                     else sortOn (`M.lookup` bibSortKeyMap)
                            (map referenceId refs)
            assignCitationNumbers $
              case layoutSortKeys biblayout of
                (SortKeyVariable Descending "citation-number":_)
                  -> reverse sortedIds
                (SortKeyMacro Descending
                  (Element (ENumber "citation-number" _) _:_) : _)
                  -> reverse sortedIds
                (SortKeyMacro Descending
                  (Element (EText (TextVariable _ "citation-number")) _:_): _)
                  -> reverse sortedIds
                _ -> sortedIds
            let bibCitations = map (\ident ->
                  Citation (Just $ unItemId ident) Nothing
                   [CitationItem ident Nothing Nothing
                      NormalCite Nothing Nothing]) sortedIds
            return (bibCitations, bibSortKeyMap)
      -- styling of citations
      sortKeyMap <-
        foldM (\m citeId -> do
                  sk <- evalSortKeys (styleCitation style) citeId
                  return $ M.insert citeId sk m)
               M.empty
               citeIds
      -- We can't just sort all the citations, because
      -- this can make a hash out of prefixes and suffixes.
      -- See e.g. pandoc-citeproc issue #292.
      -- we need to first break into groups so that any
      -- suffix ends a group and any prefix begins a group;
      -- then sort the groups; then combine again:
      let canGroup i1 i2
           =   isNothing (citationItemSuffix i1) &&
               isNothing (citationItemPrefix i2)
      let sortCitationItems citation' =
            citation'{ citationItems =
                          concatMap
                           (sortOn
                             (\citeItem ->
                              M.lookup (citationItemId citeItem)
                                       sortKeyMap))
                        $ groupBy canGroup
                        $ citationItems citation' }
      let citCitations = map sortCitationItems citations
      let layoutOpts = layoutOptions $ styleCitation style
      cs <- disambiguateCitations style bibSortKeyMap citCitations
      let mbcgDelim =
            case styleCiteGroupDelimiter (styleOptions style) of
              Just x -> Just x
              Nothing
                -- grouping is activated whenever there is
                -- collapsing; this is the default
                -- cite-group-delimiter
                | isJust (layoutCollapse layoutOpts) -> Just ", "
                | otherwise -> Nothing
      let cs' = case mbcgDelim of
                   Nothing -> cs
                   Just citeGroupDelim -> map
                      (groupAndCollapseCitations citeGroupDelim
                       (layoutYearSuffixDelimiter layoutOpts)
                       (layoutAfterCollapseDelimiter layoutOpts)
                       (layoutCollapse layoutOpts))
                      cs

      let removeNamesIfSuppressAuthor
           (Tagged (TagItem SuppressAuthor cid') x)
             = Tagged (TagItem SuppressAuthor cid') (transform removeNames x)
          removeNamesIfSuppressAuthor x = x

      -- we need to do this after disambiguation and collapsing
      let handleSuppressAuthors = transform removeNamesIfSuppressAuthor

      let isNoteCitation = styleIsNoteStyle (styleOptions style)

      -- if we have an author-only citation at the beginning
      -- separate it out:
      let handleAuthorOnly formattedCit =
            case formattedCit of
              Formatted f
                (x@(Tagged (TagItem AuthorOnly _) _):xs)
                  | isNoteCitation
                    -> formatted mempty
                        (x : [InNote (formatted f xs) | not (null xs)])
                  | otherwise
                    -> formatted mempty
                        (x :
                         if null xs
                            then []
                            else [Literal (fromText " "),
                                  formatted f xs])
              Formatted f
                (Formatted f'
                  (x@(Tagged (TagItem AuthorOnly _) _):xs) : ys)
                  | isNoteCitation
                    -> formatted mempty
                        (Formatted f'{ formatPrefix = Nothing
                                     , formatSuffix = Nothing } [x] :
                         if null xs && null ys
                            then []
                            else [InNote (formatted f
                                           (formatted f' xs : ys))])
                  | otherwise
                    -> Formatted mempty
                        (Formatted f'{ formatPrefix = Nothing
                                     , formatSuffix = Nothing } [x] :
                         if null xs && null ys
                            then []
                            else [Literal (fromText " "),
                                  formatted f (formatted f' xs : ys)])
              _ | isNoteCitation -> InNote formattedCit
                | otherwise      -> formattedCit

      let cs'' = map (handleSuppressAuthors . handleAuthorOnly) cs'

      -- styling of bibliography (this needs to go here to take account
      -- of year suffixes added in disambiguation)
      bs <- case styleBibliography style of
               Just biblayout
                 -> mapM (evalLayout True biblayout) (zip [1..] bibCitations)
                    >>= \bs ->
                      case styleSubsequentAuthorSubstitute
                            (styleOptions style) of
                        Nothing -> return bs
                        Just subs -> subsequentAuthorSubstitutes subs bs
               Nothing -> return []
      return (cs'', case styleBibliography style of
                     Nothing -> []
                     Just _  ->
                       zip (map (fromMaybe "" . citationId) bibCitations) bs)

subsequentAuthorSubstitutes :: CiteprocOutput a
                            => SubsequentAuthorSubstitute
                            -> [Output a]
                            -> Eval a [Output a]
subsequentAuthorSubstitutes (SubsequentAuthorSubstitute t rule) =
  return . groupCitesByNames
 where
  groupCitesByNames [] = []
  groupCitesByNames (x:xs) =
    let xnames = fromMaybe ([],NullOutput) $ getNames x
        samenames = replaceMatch rule (fromText t) xnames xs
        rest = drop (length samenames) xs
    in  (x : samenames) ++ groupCitesByNames rest
  getNames (Formatted _ (x:_)) =
    case [(ns,r) | (Tagged (TagNames _ _ ns) r) <- universe x] of
      ((ns,r) : _) -> Just (ns,r)
      []           -> Nothing
  getNames _ = Nothing

replaceMatch :: CiteprocOutput a
             => SubsequentAuthorSubstituteRule
             -> a
             -> ([Name], Output a)
             -> [Output a]
             -> [Output a]
replaceMatch _ _ _ [] = []
replaceMatch rule replacement (names, raw) (z:zs) =
  case go z of
    Nothing -> []
    Just z' -> z' : replaceMatch rule replacement (names, raw) zs
 where
  go (Tagged t@TagItem{} y) =
    Tagged t <$> go y
  go (Formatted f (y:ys)) =
    Formatted f . (: ys) <$> go y
  go y@(Tagged (TagNames _ _ ns) r) =
    case (if null names then CompleteAll else rule) of
        CompleteAll ->
          if ns == names && (not (null names) || r == raw)
             then Just $ replaceAll y
             else Nothing
        CompleteEach ->
          if ns == names
             then Just $ transform replaceEach y
             else Nothing
        PartialEach ->
          case numberOfMatches ns names of
            num | num >= 1 -> Just $ transform (replaceFirst num) y
            _ -> Nothing
        PartialFirst ->
          case numberOfMatches ns names of
            num | num >= (1 :: Int) -> Just $ transform (replaceFirst 1) y
            _ -> Nothing
  go _ = Nothing
  replaceAll (Tagged (TagNames t' nf ns') x)
     = Tagged (TagNames t' nf ns') $
       -- removeName will leave label "ed."
       -- which we want, but it will also leave the substituted
       -- title when there is no name, which we do not want.
       -- So, if ns' is null, then we just remove everything.
       if null ns'
          then Literal replacement
          else
            case transform removeName x of
              Formatted f' xs -> Formatted f' (Literal replacement : xs)
              _               -> Literal replacement
  replaceAll x = x
  removeName (Tagged (TagName _) _) = NullOutput
  removeName x = x
  replaceEach (Tagged (TagName n) _)
    | n `elem` names
     = Tagged (TagName n) (Literal replacement)
  replaceEach x = x
  replaceFirst num x@(Tagged (TagNames _ _ ns') _)
    -- a kludge to get this to type-check!
    | True = foldr (transform . replaceName) x $ take num ns'
    | False = Literal replacement
  replaceFirst _num x = x
  replaceName name (Tagged (TagName n) _)
    | n == name = Tagged (TagName n) (Literal replacement)
  replaceName _ x = x
  numberOfMatches (a:as) (b:bs)
    | a == b    = 1 + numberOfMatches as bs
    | otherwise = 0
  numberOfMatches _ _ = 0

data DisambData =
  DisambData
  { ddItem       :: ItemId
  , ddNames      :: [Name]
  , ddDates      :: [Date]
  } deriving (Eq, Ord, Show)

disambiguateCitations :: CiteprocOutput a
                      => Style a
                      -> M.Map ItemId [SortKeyValue]
                      -> [Citation a]
                      -> Eval a [Output a]
disambiguateCitations style bibSortKeyMap citations = do
  refs <- unReferenceMap <$> gets stateRefMap
  let refIds = M.keys refs
  let citeIds = Set.fromList $
                   concatMap (map citationItemId . citationItems) citations
  let ghostCitations = [Citation Nothing Nothing
                          [CitationItem ident Nothing Nothing
                            NormalCite Nothing Nothing]
                       | ident <- refIds
                       , not (ident `Set.member` citeIds)]
  allCites <- withRWST (\ctx st -> (ctx,
                                    st { stateLastCitedMap = mempty })) $
               mapM (evalLayout False (styleCitation style))
                            (zip [1..] (citations ++ ghostCitations))

  styleOpts <- asks contextStyleOptions
  let strategy = styleDisambiguation styleOpts
  let allNameGroups = [ns | Tagged (TagNames _ _ ns) _ <-
                              concatMap universe allCites]
  let allNames = nubOrd $ concat allNameGroups
  let primaryNames = nubOrd $ concatMap (take 1) allNameGroups
  allCites' <-
    case disambiguateAddGivenNames strategy of
         Nothing     -> return allCites
         Just ByCite -> return allCites -- do this later
         Just rule   -> do -- disambiguate names, not just citations
           let relevantNames =
                 case rule of
                   PrimaryNameWithInitials -> primaryNames
                   PrimaryName -> primaryNames
                   _ -> allNames
           let familyNames = nubOrd $ mapMaybe nameFamily relevantNames
           let grps = map (\name ->
                             [v | v <- relevantNames
                                , nameFamily v == Just name])
                          familyNames
           let toHint names name =
                  if any (initialsMatch name) (filter (/= name) names)
                     then
                       case rule of
                         AllNamesWithInitials    -> Nothing
                         PrimaryNameWithInitials -> Nothing
                         PrimaryName             -> Just AddGivenNameIfPrimary
                         _                       -> Just AddGivenName
                     else
                       case rule of
                         PrimaryNameWithInitials -> Just AddInitialsIfPrimary
                         PrimaryName             -> Just AddInitialsIfPrimary
                         _                       -> Just AddInitials
           let namesMap = mconcat $ map
                  (\names -> if length names > 1
                                 then foldr
                                    (\name ->
                                        case toHint names name of
                                          Just x -> M.insert name x
                                          Nothing -> id)
                                    mempty
                                    names
                                 else mempty) grps
           -- use this same names map for every citation
           modify $ \st ->
              st{ stateRefMap = ReferenceMap $
                   foldr
                     (M.adjust (alterReferenceDisambiguation
                       (\d -> d{ disambNameMap = namesMap })))
                     (unReferenceMap $ stateRefMap st)
                     refIds }
           -- redo citations
           withRWST (\ctx st -> (ctx,
                                 st { stateLastCitedMap = mempty })) $
             mapM (evalLayout False (styleCitation style))
                   (zip [1..] (citations ++ ghostCitations))

  case getAmbiguities allCites' of
    []          -> return $ take (length citations) allCites'
    ambiguities -> do
      analyzeAmbiguities bibSortKeyMap strategy (map snd ambiguities)
      withRWST (\ctx st -> (ctx,
                            st { stateLastCitedMap = mempty })) $
        mapM (evalLayout False (styleCitation style)) (zip [1..] citations)

 where
  analyzeAmbiguities :: M.Map ItemId [SortKeyValue]
                     -> DisambiguationStrategy
                     -> [[DisambData]]
                     -> Eval a ()
  analyzeAmbiguities bibSortKeyMap' strategy ambiguities = do
    -- add names to et al.
    as1 <- if disambiguateAddNames strategy
              then mapM (tryAddNames (disambiguateAddGivenNames strategy))
                       ambiguities
              else return ambiguities
    as2 <- case disambiguateAddGivenNames strategy of
             Just ByCite -> mapM tryAddGivenNames as1
             _           -> return as1
    as3 <- if disambiguateAddYearSuffix strategy
              then do
                addYearSuffixes bibSortKeyMap' as2
                return []
              else return as2
    mapM_ tryDisambiguateCondition as3

  isDisambiguated :: Maybe GivenNameDisambiguationRule
                  -> Int -- et al min
                  -> [DisambData]
                  -> DisambData
                  -> Bool
  isDisambiguated mbrule etAlMin xs x =
    all (\y -> x == y || disambiguatedName y /= disambiguatedName x) xs
   where
    disambiguatedName = nameParts . take etAlMin . ddNames
    nameParts =
      case mbrule of
        Just AllNames -> id
        Just AllNamesWithInitials ->
             map (\name -> name{ nameGiven = initialize True False ""
                                              <$> nameGiven name })
        Just PrimaryName ->
          \case
            [] -> []
            (z:zs) -> z : map (\name -> name{ nameGiven = Nothing }) zs
        Just PrimaryNameWithInitials ->
          \case
            [] -> []
            (z:zs) -> z{ nameGiven = initialize True False "" <$> nameGiven z } :
                       map (\name -> name{ nameGiven = Nothing }) zs
        Just ByCite -> id -- hints will be added later
        _ -> map (\name -> name{ nameGiven = Nothing })

  tryAddNames mbrule bs = (case mbrule of
                            Just ByCite -> bs <$ tryAddGivenNames bs
                            _ -> return bs) >>= go 1
                          -- if ByCite, we want to make sure that
                          -- tryAddGivenNames is still applied, as
                          -- calculation of "add names" assumes this.
   where
     maxnames = fromMaybe 0 . maximumMay . map (length . ddNames)
     go n as
       | n > maxnames as = return as
       | otherwise = do
           let ds = filter (isDisambiguated mbrule n as) as
           if null ds
              then go (n + 1) as
              else do
                modify $ \st ->
                  st{ stateRefMap = ReferenceMap
                        $ foldr (setEtAlNames (Just n) . ddItem)
                          (unReferenceMap $ stateRefMap st) as }
                go (n + 1) (as \\ ds)

  tryAddGivenNames :: [DisambData]
                   -> Eval a [DisambData]
  tryAddGivenNames as = do
    let correspondingNames =
           map (zip (map ddItem as)) $ transpose $ map ddNames as
        go [] _ = return []
        go (as' :: [DisambData]) (ns :: [(ItemId, Name)]) = do
          hintedIds <- Set.fromList . catMaybes <$>
                          mapM (addNameHint (map snd ns)) ns
          return $ filter (\x -> ddItem x `Set.notMember` hintedIds) as'
    foldM go as correspondingNames

  addYearSuffixes bibSortKeyMap' as = do
    let allitems = concat as
    let companions a =
          sortOn
          (\it -> M.lookup (ddItem it) bibSortKeyMap')
          (concat [ x | x <- as, a `elem` x ])
    let groups = Set.map companions $ Set.fromList allitems
    let addYearSuffix item suff =
          modify $ \st ->
            st{ stateRefMap = ReferenceMap
                 $ setYearSuffix suff item
                 $ unReferenceMap
                 $ stateRefMap st }
    mapM_ (\xs -> zipWithM addYearSuffix (map ddItem xs) [1..]) groups

  tryDisambiguateCondition as =
    case as of
      [] -> return ()
      xs -> modify $ \st ->
              st{ stateRefMap = ReferenceMap
                  $ foldr (setDisambCondition True . ddItem)
                    (unReferenceMap (stateRefMap st))
                    xs }

  alterReferenceDisambiguation f r =
        r{ referenceDisambiguation = f <$>
             case referenceDisambiguation r of
               Nothing -> Just
                 DisambiguationData
                   { disambYearSuffix  = Nothing
                   , disambNameMap     = mempty
                   , disambEtAlNames   = Nothing
                   , disambCondition   = False
                 }
               Just x  -> Just x }

  initialsMatch x y =
    case (nameGiven x, nameGiven y) of
      (Just x', Just y') ->
        initialize True False "" x' == initialize True False "" y'
      _ -> False

  addNameHint names (item, name) = do
    let familyMatches = [n | n <- names
                           , n /= name
                           , nameFamily n == nameFamily name]
    case familyMatches of
      [] -> return Nothing
      _  -> do
        let hint = if any (initialsMatch name) familyMatches
                      then AddGivenName
                      else AddInitials
        modify $ \st ->
          st{ stateRefMap = ReferenceMap
              $ setNameHint hint name item
              $ unReferenceMap (stateRefMap st) }
        return $ Just item

  setNameHint hint name = M.adjust
         (alterReferenceDisambiguation
           (\d -> d{ disambNameMap =
                       M.insert name hint
                       (disambNameMap d) }))

  setEtAlNames x = M.adjust
         (alterReferenceDisambiguation
           (\d -> d{ disambEtAlNames = x }))

  setYearSuffix x = M.adjust
         (alterReferenceDisambiguation
           (\d -> d{ disambYearSuffix = Just x }))

  setDisambCondition x = M.adjust
         (alterReferenceDisambiguation
           (\d -> d{ disambCondition = x }))

  getAmbiguities cs =
        filter ((> 1) . length . snd)
        $ mapMaybe
             (\zs ->
                 case zs of
                   ("",_):_ -> Nothing  -- no printed form of citation
                   (t, _):_ -> Just (t, map toDisambData $
                                         nubOrdOn fst $ map snd zs)
                   []       -> Nothing)
        $ groupBy (\(x,_) (y,_) -> x == y)
        $ sortOn fst
        [let (tags, texts) = unzip $ takeNamesOrDate (universe x) in
             (T.unwords texts, (iid, (getNames tags, getDates tags)))
        | (Tagged (TagItem ty iid) x) <- concatMap universe cs,
                  ty /= AuthorOnly]

  toDisambData (id', (ns', ds')) = DisambData id' ns' ds'

  -- take names, date, or citation-label (which also gets year suffix).
  takeNamesOrDate :: CiteprocOutput a => [Output a] -> [(Tag, Text)]
  takeNamesOrDate (Tagged t@TagNames{} x : xs) =
    (t, outputToText x) : takeNamesOrDate xs
  takeNamesOrDate (Tagged t@TagDate{} x : xs) =
    (t, outputToText x) : takeNamesOrDate xs
  takeNamesOrDate (Tagged t@TagCitationLabel x : xs) =
    (t, outputToText x) : takeNamesOrDate xs
  takeNamesOrDate (_ : xs) =
    takeNamesOrDate xs
  takeNamesOrDate [] = []

  getNames :: [Tag] -> [Name]
  getNames (TagNames _ _ ns : xs) = ns ++ getNames xs
  getNames (_ : xs)               = getNames xs
  getNames []                     = []

  getDates :: [Tag] -> [Date]
  getDates (TagDate d : xs)     = d : getDates xs
  getDates (_ : xs)             = getDates xs
  getDates []                   = []



groupAndCollapseCitations :: CiteprocOutput a
                          => Text
                          -> Maybe Text
                          -> Maybe Text
                          -> Maybe Collapsing
                          -> Output a
                          -> Output a
groupAndCollapseCitations citeGroupDelim yearSuffixDelim afterCollapseDelim
  collapsing (Formatted f xs) =
   case collapsing of
      Just CollapseCitationNumber ->
        Formatted f{ formatDelimiter = Nothing } $
            foldr collapseRange []
                  (groupSuccessive isAdjacentCitationNumber xs)
      Just collapseType ->
          Formatted f{ formatDelimiter = Nothing } $
            foldr (collapseGroup collapseType) [] (groupWith sameNames xs)
      Nothing ->
          Formatted f $
             map (Formatted mempty{ formatDelimiter = Just citeGroupDelim })
                 (groupWith sameNames xs)
 where
  --   Note that we cannot assume we've sorted by name,
  --   so we can't just use Data.ListgroupBy
  groupWith _ [] = []
  groupWith isMatched (z:zs) =
    (z : filter (isMatched z) zs) :
         groupWith isMatched (filter (not . isMatched z) zs)
  collapseRange ys zs
    | length ys >= 3
    , Just yhead <- headMay ys
    , Just ylast <- lastMay ys
      = Formatted mempty{ formatDelimiter = Just $ T.singleton enDash }
                  [yhead, ylast] :
                  if null zs
                     then []
                     else maybe NullOutput literal afterCollapseDelim : zs
  collapseRange ys zs =
    Formatted mempty{ formatDelimiter = formatDelimiter f } ys :
      if null zs
         then []
         else maybe NullOutput literal (formatDelimiter f) : zs
  collapseGroup _ [] zs = zs
  collapseGroup collapseType (y:ys) zs =
    let ys' = y : map (transform removeNames) ys
        ws = collapseYearSuffix collapseType ys'
        noCollapse = ws == y:ys
        noYearSuffixCollapse = ws == ys'
        hasLocator u = not $ null [x | x@(Tagged TagLocator _) <- universe u]
        -- https://github.com/citation-style-language/test-suite/issues/36 :
        flippedAfterCollapseDelim = collapseType == CollapseYear
        addCGDelim u [] = [u]
        addCGDelim u us =
          Formatted mempty{ formatSuffix =
                              if noCollapse || noYearSuffixCollapse &&
                                 not (flippedAfterCollapseDelim &&
                                      hasLocator u)
                                 then Just citeGroupDelim
                                 else afterCollapseDelim <|>
                                      formatDelimiter f } [u] : us
     in Formatted mempty{ formatDelimiter = Nothing
                        , formatSuffix =
                            if null zs
                               then Nothing
                               else if noCollapse &&
                                          not flippedAfterCollapseDelim
                                       then formatDelimiter f
                                       else afterCollapseDelim <|>
                                            formatDelimiter f }
                               (foldr addCGDelim [] ws) : zs
  collapseRanges = map rangifyGroup . groupSuccessive isSuccessive
  isSuccessive x y
    = case ([c | Tagged (TagYearSuffix c) _ <- universe x],
            [d | Tagged (TagYearSuffix d) _ <- universe y]) of
        ([c],[d]) -> d == c + 1
        _   -> False
  rangifyGroup zs
    | length zs >= 3
    , Just zhead <- headMay zs
    , Just zlast <- lastMay zs
    = Formatted mempty{ formatDelimiter = Just (T.singleton enDash) }
                [zhead, zlast]
  rangifyGroup [z] = z
  rangifyGroup zs = Formatted mempty{ formatDelimiter = yearSuffixDelim
                                    } zs
  yearSuffixGroup _ [x] = x
  yearSuffixGroup useRanges zs  =
    Formatted mempty{ formatDelimiter = yearSuffixDelim }
      $ if useRanges then collapseRanges zs else zs
  collapseYearSuffix CollapseYearSuffix zs =
    reverse $ yearSuffixGroup False cur : items
   where
     (cur, items) = foldl' (goYearSuffix False) ([], []) zs
  collapseYearSuffix CollapseYearSuffixRanged zs =
    reverse $ yearSuffixGroup True cur : items
   where
     (cur, items) = foldl' (goYearSuffix True) ([], []) zs
  collapseYearSuffix _ zs = zs
  getDates x = [d | Tagged (TagDate d) _ <- universe x]
  getYears x = [map (\case
                        DateParts (y:_) -> Just y
                        _               -> Nothing) (dateParts d)
                | d <- getDates x
                , isNothing (dateLiteral d)]
  goYearSuffix useRanges (cur, items) item =
    case cur of
      []     -> ([item], items)
      (z:zs)
        | getYears z == getYears item
          -> (z:zs ++ [x | x@(Tagged (TagYearSuffix _) _) <- universe item],
              items)
        | otherwise -> ([item], yearSuffixGroup useRanges (z:zs) : items)

  isAdjacentCitationNumber
     (Tagged (TagItem _ _)
       (Formatted _f1 [Tagged (TagCitationNumber n1) _xs1]))
     (Tagged (TagItem _ _)
       (Formatted _f2 [Tagged (TagCitationNumber n2) _xs2]))
    = n2 == n1 + 1
  isAdjacentCitationNumber
     (Tagged (TagItem _ _) (Tagged (TagCitationNumber n1) _xs1))
     (Tagged (TagItem _ _) (Tagged (TagCitationNumber n2) _xs2))
    = n2 == n1 + 1
  isAdjacentCitationNumber _ _ = False
  sameNames x y =
    case (extractTags x, extractTags y) of
      (Just (Tagged (TagNames t1 _nf1 ns1) ws1),
       Just (Tagged (TagNames t2 _nf2 ns2) ws2))
        -> t1 == t2 && (if ns1 == ns2
                           then not (null ns1) || ws1 == ws2
                           else ws1 == ws2)
      -- case where it's just a date with no name or anything;
      -- we treat this as same name e.g. (1955a,b)
      (Just (Tagged TagDate{} _), Just (Tagged TagDate{} _))
        -> True
          -- case where title is substituted
      _ -> False
  extractTags x =
    let items = [y | y@(Tagged (TagItem ty _) _) <- universe x
                   , ty /= AuthorOnly]
        names = [y | y@(Tagged TagNames{} _) <- concatMap universe items]
        dates = [y | y@(Tagged TagDate{} _) <- concatMap universe items]
    in  if null items
           then Nothing
           else listToMaybe names <|> listToMaybe dates
groupAndCollapseCitations _ _ _ _ x = x

takeSeq :: Show a => (a -> a -> Bool) -> [a] -> ([a], [a])
takeSeq isAdjacent (x1 : x2 : rest)
  | isAdjacent x1 x2 = (x1:ys, zs)
  where (ys, zs) = takeSeq isAdjacent (x2:rest)
takeSeq _ (y:ys) = ([y], ys)
takeSeq _ []     = ([], [])

groupSuccessive :: Show a => (a -> a -> Bool) -> [a] -> [[a]]
groupSuccessive isAdjacent zs =
  case takeSeq isAdjacent zs of
    ([],_)  -> []
    (xs,ys) -> xs : groupSuccessive isAdjacent ys


evalSortKeys :: CiteprocOutput a
             => Layout a
             -> ItemId
             -> Eval a [SortKeyValue]
evalSortKeys layout citeId =
  withRWST (\ctx st -> (ctx{ contextInSortKey = True }, st)) $
    mapM (evalSortKey citeId) (layoutSortKeys layout)

evalSortKey :: CiteprocOutput a
            => ItemId
            -> SortKey a
            -> Eval a SortKeyValue
evalSortKey citeId (SortKeyMacro sortdir elts) = do
  refmap <- gets stateRefMap
  case lookupReference citeId refmap of
    Nothing  -> return $ SortKeyValue (sortdir, Nothing)
    Just ref -> do
        k <- normalizeSortKey . toText .
              renderOutput defaultCiteprocOptions . grouped
              <$> withRWS newContext (mconcat <$> mapM eElement elts)
        return $ SortKeyValue (sortdir, Just k)
     where
      newContext oldContext s =
        (oldContext, s{ stateReference = ref })
evalSortKey citeId (SortKeyVariable sortdir var) = do
  refmap <- gets stateRefMap
  SortKeyValue . (sortdir,) <$>
    case lookupReference citeId refmap >>= lookupVariable var of
      Nothing           -> return Nothing
      Just (TextVal t)  -> return $ Just $ normalizeSortKey t
      Just (NumVal  i)  -> return $ Just [T.pack $ printf "%09d" i]
      Just (FancyVal x) -> return $ Just $ normalizeSortKey $ toText x
      Just (NamesVal ns) ->
        Just . normalizeSortKey . mconcat . intersperse "," . map T.unwords
             <$> mapM getNamePartSortOrder ns
      Just (DateVal d)  -> return $ Just [T.toLower $ dateToText d]

normalizeSortKey :: Text -> [Text]
normalizeSortKey =
  filter (not . T.null) .
  T.words .
  T.map (\c -> if isPunctuation c ||
                  c == 'ʾ' || c == 'ʿ' -- ayn/hamza in transliterated arabic
                  then ' '
                  else c) .
  T.filter (/= '-')

-- Note!  This prints negative (BC) dates as -(999,999,999 + y)
-- so they sort properly. Do not use out of context of sort keys.
dateToText :: Date -> Text
dateToText = mconcat . map (T.pack . go . coerce) . dateParts
 where
  go :: [Int] -> String
  go [] = ""
  go [y] = toYear y
  go [y,m] = toYear y <> printf "%02d" m
  go (y:m:d:_) = toYear y <> printf "%02d" m <> printf "%02d" d
  toYear :: Int -> String
  toYear y
    | y < 0     = printf "-%09d" (999999999 + y)
    | otherwise = printf "0%09d" y


evalLayout :: CiteprocOutput a
            => Bool
            -> Layout a
            -> (Int, Citation a)
            -> Eval a (Output a)
evalLayout isBibliography layout (citationGroupNumber, citation) = do
  -- this is a hack to ensure that "ibid" detection will work
  -- correctly in a citation starting with an author-only:
  -- the combination AuthorOnly [SuppressAuthor] should not
  -- count against a later Ibid citation.
  let positions = case citationItems citation of
                    (c:_) | citationItemType c == AuthorOnly -> [0..]
                    _ -> [1..]
  items <- mapM evalItem (zip positions (citationItems citation))

  styleOpts <- asks contextStyleOptions
  let isNote = styleIsNoteStyle styleOpts

  -- see display_SecondFieldAlignMigratePunctuation.txt
  let moveSuffixInsideDisplay zs =
        case (lastMay zs, formatSuffix formatting) of
          (Just (Tagged (TagItem ct id') (Formatted f ys)), Just _) ->
            (\ys' -> initSafe zs ++
                      [Tagged (TagItem ct id') (Formatted f ys')]) <$>
                        moveSuffixInsideDisplay ys
          (Just (Formatted f ys), Just suff)
            | isJust (formatDisplay f) ->
                Just $ initSafe zs ++
                     [Formatted f{ formatSuffix = Just
                          (fromMaybe "" (formatSuffix f) <> suff) } ys]
            | otherwise -> (\ys' -> initSafe zs ++ [Formatted f ys']) <$>
                             moveSuffixInsideDisplay ys
          _ -> Nothing
  let items' = if isNote
                  then capitalizeInitialTerm items
                  else items
  return $
    case moveSuffixInsideDisplay items' of
      Nothing      -> formatted formatting items'
      Just items'' -> formatted formatting{ formatSuffix = Nothing } items''
 where
  formatting = layoutFormatting layout

  mbNoteNumber = citationNoteNumber citation
  secondFieldAlign (x:xs) =
    formatted mempty{ formatDisplay = Just DisplayLeftMargin } [x]
    : [formatted mempty{ formatDisplay = Just DisplayRightInline } xs]
  secondFieldAlign [] = []

  evalItem (positionInCitation :: Int, item) = do
    refmap <- gets stateRefMap
    position <- if isBibliography
                   then return []
                   else getPosition item
                         citationGroupNumber
                         mbNoteNumber
                         positionInCitation

    let addLangToFormatting lang (Formatted f xs) =
          Formatted f{ formatLang = Just lang } xs
        addLangToFormatting _ x = x

    xs <- case lookupReference (citationItemId item) refmap of
            Just ref -> withRWST
              (\ctx st ->
               (ctx{ contextLocator = citationItemLocator item
                   , contextLabel = citationItemLabel item
                   , contextPosition = position
                   },
                st{ stateReference = ref
                  , stateUsedYearSuffix = False }))
                $ do xs <- mconcat <$> mapM eElement (layoutElements layout)
                     let mblang = parseLang <$>
                                  (lookupVariable "language" ref
                                    >>= valToText)
                     return $
                       case mblang of
                         Nothing   -> xs
                         Just lang -> map
                             (transform (addLangToFormatting lang)) xs
            Nothing -> do
              warn $ "citation " <> unItemId (citationItemId item) <>
                     " not found"
              return [Literal $ addFontWeight BoldWeight
                 $ fromText $ unItemId (citationItemId item) <> "?"]

    styleOpts <- asks contextStyleOptions
    let isNote = styleIsNoteStyle styleOpts

    -- we only update the map in the citations section
    unless isBibliography $ do
      lastCitedMap <- gets stateLastCitedMap
      let notenum = NumVal $ fromMaybe citationGroupNumber mbNoteNumber
      case M.lookup (citationItemId item) lastCitedMap of
        Nothing | isNote -> -- first citation
          modify $ \st ->
            st{ stateRefMap = ReferenceMap $
                    M.adjust (\ref -> ref{ referenceVariables =
                      M.insert "first-reference-note-number" notenum
                                 (referenceVariables ref)})
                      (citationItemId item)
                   (unReferenceMap $ stateRefMap st) }
        _  -> return ()

      unless (citationItemType item == AuthorOnly) $
        modify $ \st ->
          st{ stateLastCitedMap =
            M.insert (citationItemId item)
              (citationGroupNumber, mbNoteNumber, positionInCitation,
               case citationItems citation of
                  [_]   -> True
                  [x,y] -> citationItemId x == citationItemId y
                          && citationItemType x == AuthorOnly
                          && citationItemType y == SuppressAuthor
                  _     -> False,
               citationItemLabel item,
               citationItemLocator item)
            lastCitedMap }

    return $
          maybe id (\pref x -> grouped [Literal pref, x])
                (citationItemPrefix item)
        . maybe id (\suff x -> grouped [x, Literal suff])
                   (citationItemSuffix item)
        . (\x -> case x of
                   NullOutput -> x
                   _          -> Tagged (TagItem (citationItemType item)
                                                  (citationItemId item)) x)
        . formatted mempty
        . (if citationItemType item == AuthorOnly
              then filter isNames . concatMap universe
              else id)
        . (case citationItemPrefix item of
             Just t | isNote
                    , ". " `T.isSuffixOf` (toText t)
                    , T.count " " (toText t) > 1 -- exclude single word
                                 -> capitalizeInitialTerm
             _                   -> id)
        . (if isBibliography
              then
                case styleSecondFieldAlign styleOpts of
                  Just SecondFieldAlignFlush  -> secondFieldAlign
                  Just SecondFieldAlignMargin -> secondFieldAlign -- TODO?
                  Nothing -> id
              else id)
        $ xs


isNames :: Output a -> Bool
isNames (Tagged TagNames{} _) = True
isNames _ = False


removeNames :: Output a -> Output a
removeNames (Tagged TagNames{} _) = NullOutput
removeNames x = x

capitalizeInitialTerm :: [Output a] -> [Output a]
capitalizeInitialTerm [] = []
capitalizeInitialTerm (z:zs) = go z : zs
 where
  go (Tagged TagTerm x) =
    Tagged TagTerm
      (formatted mempty{ formatTextCase = Just CapitalizeFirst } [x])
  go (Formatted f xs) = Formatted f (capitalizeInitialTerm xs)
  go (Tagged tg x) = Tagged tg (go x)
  go x = x

getPosition :: CitationItem a -> Int -> Maybe Int -> Int -> Eval a [Position]
getPosition item groupNum mbNoteNum posInGroup = do
  lastCitedMap <- gets stateLastCitedMap
  case M.lookup (citationItemId item) lastCitedMap of
    Nothing -> return [FirstPosition]
    Just (prevGroupNum, mbPrevNoteNum,
           prevPosInGroup, prevAloneInGroup, prevLabel, prevLoc) -> do
      isNote <- asks (styleIsNoteStyle . contextStyleOptions)
      nearNoteDistance <- fromMaybe 5 <$>
                           asks (styleNearNoteDistance . contextStyleOptions)
      let noteNum = fromMaybe groupNum mbNoteNum
      let prevNoteNum = fromMaybe prevGroupNum mbPrevNoteNum
      return $
        (if isNote && noteNum - prevNoteNum < nearNoteDistance
            then (NearNote :)
            else id) .
        (if (groupNum == prevGroupNum &&
             posInGroup == prevPosInGroup + 1) ||
            (groupNum == prevGroupNum + 1 &&
              (((-) <$> mbNoteNum <*> mbPrevNoteNum) <= Just 1) &&
             posInGroup == 1 &&
             prevAloneInGroup)
             then case (prevLoc, citationItemLocator item) of
                    (Nothing, Just _)  -> (IbidWithLocator :) . (Ibid :)
                    (Nothing, Nothing) -> (Ibid :)
                    (Just _, Nothing)   -> id
                    (Just l1, Just l2)
                      | l1 == l2
                      , citationItemLabel item == prevLabel -> (Ibid :)
                      | otherwise -> (IbidWithLocator :) . (Ibid :)
             else id)
        $ [Subsequent]

eElement :: CiteprocOutput a => Element a -> Eval a [Output a]
eElement (Element etype formatting) =
  case etype of
    EText textType ->
      (:[]) <$> withFormatting formatting (eText textType)
    ENumber var nform ->
      (:[]) <$> withFormatting formatting (eNumber var nform)
    EGroup isMacro els ->
      (:[]) <$> eGroup isMacro formatting els
    EChoose chooseParts -> eChoose chooseParts
    ELabel var termform pluralize ->
      (:[]) <$> eLabel var termform pluralize formatting
    EDate var dateType mbShowDateParts dps ->
      (:[]) <$> eDate var dateType mbShowDateParts dps formatting
    ENames vars namesFormat subst ->
      (:[]) <$> eNames vars namesFormat subst formatting

withFormatting :: CiteprocOutput a
               => Formatting -> Eval a (Output a) -> Eval a (Output a)
withFormatting (Formatting Nothing Nothing Nothing Nothing Nothing Nothing
                           Nothing Nothing Nothing Nothing Nothing
                           False False False) p
                          = p
withFormatting formatting p = do
  -- Title case conversion only affects English-language items.
  lang <- asks (localeLanguage . contextLocale)
  ref <- gets stateReference
  let reflang = case M.lookup "language" (referenceVariables ref) of
                  Just (TextVal t)  -> Just $ parseLang t
                  Just (FancyVal x) -> Just $ parseLang $ toText x
                  _                 -> Nothing
  let mainLangIsEn Nothing = False
      mainLangIsEn (Just l) = langLanguage l == "en"
  let isEnglish = case reflang of
                    Just l  -> mainLangIsEn (Just l)
                    Nothing -> mainLangIsEn lang
  let formatting' = if formatTextCase formatting == Just TitleCase &&
                       not isEnglish
                       then formatting{ formatTextCase = Nothing }
                       else formatting
  res <- p
  return $ formatted formatting' [res]

lookupTerm :: Term -> Eval a [(Term, Text)]
lookupTerm term = do
  terms <- asks (localeTerms . contextLocale)
  case M.lookup (termName term) terms of
     Just ts -> return $ [(term',t)
                         | (term',t) <- ts
                         , term <= term'
                         ]
     Nothing -> return []

lookupTerm' :: CiteprocOutput a => Term -> Eval a (Output a)
lookupTerm' term = lookupTerm term >>= f
 where
   f []  =
     --  “verb-short” first falls back to “verb”, “symbol”
     --  first falls back to “short”, and “verb” and “short”
     --  both fall back to “long”.
     case termForm term of
       VerbShort -> lookupTerm' term{ termForm = Verb }
       Symbol    -> lookupTerm' term{ termForm = Short }
       Verb      -> lookupTerm' term{ termForm = Long }
       Short     -> lookupTerm' term{ termForm = Long }
       _         -> return NullOutput
   f xs  = case xs of
             []        -> return NullOutput
             ((_,t):_) -> return $
                            if T.null t
                               then NullOutput
                               else Literal $ fromText t

pageRange :: CiteprocOutput a => Text -> Eval a (Output a)
pageRange x = do
  pageDelim <- lookupTerm'
                  emptyTerm{ termName = "page-range-delimiter" }
  mbPageRangeFormat <- asks (stylePageRangeFormat . contextStyleOptions)
  let ranges = map T.strip $ T.groupBy
               (\c d -> not (c == ',' || c == '&' || d == ',' || d == '&'))
               x
  return $ formatted mempty{ formatDelimiter = Just " " }
         $ map (formatPageRange mbPageRangeFormat
            (case pageDelim of
               NullOutput -> literal $ T.singleton enDash
               delim      -> delim)) ranges

enDash :: Char
enDash = '\x2013'

formatPageRange :: CiteprocOutput a
                => Maybe PageRangeFormat
                -> Output a
                -> Text
                -> Output a
formatPageRange _ _ "&" = literal "&"
formatPageRange _ _ "," = literal ","
formatPageRange mbPageRangeFormat delim t =
  let isDash '-' = True
      isDash '\x2013' = True
      isDash _ = False
      rangeParts = if "\\-" `T.isInfixOf` t
                      then [T.replace "\\-" "-" t]
                      else map T.strip $ T.split isDash t
      inRange pref xs
        | T.null pref = grouped (intersperse delim (map literal xs))
        | otherwise = grouped
            (literal pref : intersperse delim (map literal xs))
      changedDigits xs ys =
        length $ filter not $ zipWith (==) (xs ++ repeat ' ') ys
      minimal threshold pref x y =
        case T.commonPrefixes x y of
             Just (_comm, _erstx, resty) ->
                 if T.length resty < threshold && T.length y >= threshold
                    then inRange pref [x, T.takeEnd threshold y]
                    else inRange pref [x, resty]
             Nothing -> inRange pref [x, y]
   in case rangeParts of
        []     -> NullOutput
        [w]    -> literal w
        [w,v]
          | Nothing <- mbPageRangeFormat -> inRange mempty [w,v]
          | Just fmt <- mbPageRangeFormat -> do
            let wPrefix = T.dropWhileEnd isDigit w
            let vPrefix = T.dropWhileEnd isDigit v
            if wPrefix == vPrefix
               then do
                 let pref = wPrefix
                 let x = T.drop (T.length wPrefix) w
                 let y = T.drop (T.length vPrefix) v
                 let xlen = T.length x
                 let ylen = T.length y
                 let y'   = if ylen < xlen
                               then T.take (xlen - ylen) x <> y
                               else y
                 case fmt of
                   PageRangeChicago
                       | xlen < 3  -> inRange pref [x, y']
                       | "00" `T.isSuffixOf` x -> inRange pref [x, y']
                       | T.take 1 (T.takeEnd 2 x) == "0"
                         -> minimal 1 pref x y'
                       | xlen == 4
                       , changedDigits (T.unpack x) (T.unpack y') >= 3
                         -> inRange pref [x, y']
                       | otherwise -> minimal 2 pref x y'
                   PageRangeExpanded ->
                       inRange mempty [pref <> x, pref <> y']
                   PageRangeMinimal -> minimal 1 pref x y'
                   PageRangeMinimalTwo -> minimal 2 pref x y'
               else inRange mempty [w,v]
        _ -> literal t

eText :: CiteprocOutput a => TextType -> Eval a (Output a)
eText (TextVariable varForm v) = do
  ref <- gets stateReference
  inSubstitute <- asks contextInSubstitute
  -- Note: we do book keeping on how many variables
  -- have been accessed and how many are nonempty,
  -- in order to properly handle the group element,
  -- which is implicitly conditional.
  case v of
    "id"   -> do
      updateVarCount 1 1
      return $ Literal $ fromText $ coerce $ referenceId ref
    "type" -> do
      updateVarCount 1 1
      return $ Literal $ fromText  $ referenceType ref
    "locator" -> do
        let handleAmpersands (Just t) | T.any (=='&') t = do
              ts <- lookupTerm emptyTerm { termName = "and"
                                         , termForm = Symbol }
              case ts of
                (_,x):_ -> return (Just $ T.replace "&" x t)
                []      -> return (Just t)
            handleAmpersands x = return x

        mbv <- asks contextLocator >>= handleAmpersands
        mbl <- asks contextLabel
        case mbv of
          Just x | isNothing mbl || mbl == Just "page" -> do
                      updateVarCount 1 1
                      Tagged TagLocator <$> pageRange x
                 | otherwise -> do
                      updateVarCount 1 1
                      return $ Tagged TagLocator $
                                formatPageRange Nothing
                                (literal $ T.singleton enDash) x
          Nothing -> NullOutput <$ updateVarCount 1 0

    "year-suffix" -> do
        disamb <- gets (referenceDisambiguation . stateReference)
        case disamb >>= disambYearSuffix of
          Just x ->
            -- we don't update var count here; this doesn't
            -- count as a variable
            return $ Tagged (TagYearSuffix x)
                            (Literal (fromText (showYearSuffix x)))
          Nothing -> return NullOutput

    "citation-number" -> do
        mbv <- askVariable v
        case mbv of
          Just (NumVal x)  -> return $
                              Tagged (TagCitationNumber x) $
                              Literal $ fromText (T.pack (show x))
          _ -> do
            warn $ "citation-number not defined for " <>
                      coerce (referenceId ref)
            return NullOutput

    "citation-label" -> do  -- these need year suffix too
        mbv <- askVariable v
        mbsuff <- getYearSuffix
        case mbv of
          Just (TextVal t)  -> return $
                                Tagged TagCitationLabel $
                                  grouped $
                                  Literal (fromText t)
                                  : maybe [] (:[]) mbsuff
          Just (FancyVal x) -> return $
                                 Tagged TagCitationLabel $
                                  grouped $
                                  Literal x
                                  : maybeToList mbsuff
          _ -> do
            warn $ "citation-label of unknown type for " <>
                      coerce (referenceId ref)
            return NullOutput

    _ -> do
        mbv <- if varForm == ShortForm
                  then do
                    mbval <- (<|>) <$> askVariable (v <> "-short")
                                   <*> askVariable v
                    case mbval of
                      Nothing -> return Nothing
                      Just val -> do
                        mbAbbrevs <- asks contextAbbreviations
                        return $ Just $ fromMaybe val
                               $ mbAbbrevs >>= lookupAbbreviation v val
                  else askVariable v
        res <- case mbv of
                 Just (TextVal x)
                   | v == "page" -> pageRange x
                   | otherwise   -> return $ Literal $ fromText x
                 Just (FancyVal x)
                   | v == "page" -> pageRange (toText x)
                   | otherwise   -> return $ Literal x
                 Just (NumVal x) -> return $ Literal
                                           $ fromText (T.pack (show x))
                 _ -> return NullOutput
        when inSubstitute $
          modify $ \st -> -- delete variable so it isn't used again...
              st{ stateReference =
                  let Reference id' type' d' m' = stateReference st
                   in Reference id' type' d' (M.delete v m') }
        return res
eText (TextMacro name) = do
  warn $ "encountered unexpanded macro " <> name
  return NullOutput
eText (TextValue t) = return $ Literal $ fromText t
eText (TextTerm term) = do
  t' <- lookupTerm' term
  t'' <- if termName term == "no date"
            then do
              mbsuff <- getYearSuffix
              case mbsuff of
                Nothing  -> return t'
                Just suff -> return $ grouped [t', suff]
            else return t'
  return $ Tagged TagTerm t''


-- Numbers with prefixes or suffixes are never ordinalized
-- or rendered in roman numerals (e.g. “2E” remains “2E).
-- Numbers without affixes are individually transformed
-- (“2, 3” can become “2nd, 3rd”, “second, third” or “ii, iii”).
-- So, first we split on punctuation and spaces:
splitNums :: Text -> [Val a]
splitNums = map go . T.groupBy sameClass
 where
  go t = case readAsInt t of
           Just i  -> NumVal i
           Nothing -> TextVal $ if t == "-"
                                   then T.singleton enDash
                                   else t
  sameClass c d = (isSepPunct c || isSpace c) ==
                  (isSepPunct d || isSpace d)

--- punctuation that separates pages in a range
isSepPunct :: Char -> Bool
isSepPunct ',' = True
isSepPunct ';' = True
isSepPunct '-' = True
isSepPunct '\x2013' = True
isSepPunct _   = False

eLabel :: CiteprocOutput a
       => Variable
       -> TermForm
       -> Pluralize
       -> Formatting
       -> Eval a (Output a)
eLabel var termform pluralize formatting = do
  ref <- gets stateReference
  let getTerm :: CiteprocOutput a
              => Text -> Val a -> Eval a (Output a)
      getTerm termname x = do
        let determinePlural t
             | var == "number-of-volumes"
             , t /= "1" && t /= "0"      = Plural
             | "\\-" `T.isInfixOf` t     = Singular
             | length (splitNums t) > 1  = Plural
               -- see label_CollapsedPageNumberPluralDetection.txt
             | otherwise                 = Singular
        let number = case pluralize of
                         AlwaysPluralize     -> Plural
                         NeverPluralize      -> Singular
                         ContextualPluralize ->
                          case x of
                            TextVal t   -> determinePlural t
                            FancyVal w  -> determinePlural (toText w)
                            NamesVal ns -> if length ns > 1
                                              then Plural
                                              else Singular
                            _ -> Singular
        let term = emptyTerm{ termName = termname
                            , termForm = termform
                            , termNumber = Just number }
        lookupTerm' term
  locator <- asks contextLocator
  label <- asks contextLabel
  let var' = if var == "editortranslator" then "editor" else var
  term' <- case (var, locator, label) of
             ("locator", Just loc, Just lab) -> getTerm lab (TextVal loc)
             ("locator", Just loc, Nothing)
                | beginsWithSpace loc -> return NullOutput
                | ". " `T.isPrefixOf` (T.dropWhile isLetter loc)
                                         -> return NullOutput
                | otherwise              -> getTerm "page" (TextVal loc)
             ("page", Just loc, _) ->
               getTerm "page" (TextVal loc)
             _ -> case lookupVariable var' ref of
                         Nothing -> return NullOutput
                         Just x  -> getTerm (fromVariable var) x

  return $
    case formatSuffix formatting of
      Just suff
        | "." `T.isPrefixOf` suff
          -> case term' of
               Literal x
                 | "." `T.isSuffixOf` (toText x)
                 , not (formatStripPeriods formatting)
                 -> formatted
                     formatting{ formatSuffix =
                        if T.length suff <= 1
                           then Nothing
                           else Just (T.drop 1 suff) }
                     [term']
               _ -> formatted formatting [term']
      _ -> formatted formatting [term']

eDate :: CiteprocOutput a
       => Variable
       -> DateType
       -> Maybe ShowDateParts
       -> [DP]
       -> Formatting
       -> Eval a (Output a)
eDate var dateType mbShowDateParts dps formatting
  | var == mempty = do
    warn "skipping date element with no variable attribute set"
    return NullOutput
  | otherwise = do
    datevar <- askVariable var
    localeDateElt <- M.lookup dateType <$> asks (localeDate . contextLocale)
    let addOverride newdps olddp accum =
          case find ((== dpName olddp) . dpName) newdps of
            Just x  -> x{ dpFormatting =
                            dpFormatting olddp <> dpFormatting x } : accum
            Nothing -> olddp : accum
    let useDatePart dp =
          case mbShowDateParts of
            Just Year      -> dpName dp == DPYear
            Just YearMonth -> dpName dp == DPYear || dpName dp == DPMonth
            _              -> True
    let (dps', formatting') =
          case localeDateElt of
            Just (Element (EDate _ _ _ edps) f)
              -> (filter useDatePart $ foldr (addOverride dps) [] edps,
                   formatting <> f)
            _ -> (filter useDatePart dps, formatting)
    case datevar of
      Nothing ->
        -- warn $ "date element for empty variable " <> var
        return NullOutput
      Just (DateVal date) ->
        case dateLiteral date of
          Just t -> return $ formatted formatting' [Literal $ fromText t]
          Nothing -> do
            let dateparts = case dateSeason date of
                              Just i  ->
                                case dateParts date of
                                  [DateParts [y]] ->
                                    [DateParts [y, 12 + i]] -- pseudo-mo
                                  xs    -> xs
                              Nothing -> dateParts date
            xs <- formatDateParts dps'
                    $ case dateparts of
                        [] -> (DateParts [], Nothing)
                        [d] -> (d, Nothing)
                        (d:e:_) -> (d, Just e)
            when (all (== NullOutput) xs) $
              -- back off on the claim to nonemptiness
              -- when the only match are in date parts that
              -- we aren't printing; see
              -- group_SuppressTermWhenNoOutputFromPartialDate.txt
              updateVarCount 0 (-1)

            yearSuffix <- getYearSuffix
            return $ Tagged (TagDate date) $ formatted formatting'
                      (xs ++ maybeToList yearSuffix)
      Just _ -> do
        warn $ "date element for variable with non-date value " <>
                fromVariable var
        return NullOutput


getYearSuffix :: CiteprocOutput a => Eval a (Maybe (Output a))
getYearSuffix = do
  disamb <- gets (referenceDisambiguation . stateReference)
  sopts <- asks contextStyleOptions
  -- we only want year suffix on first occurence of year
  -- in a reference:
  usedYearSuffix <- gets stateUsedYearSuffix
  case disamb >>= disambYearSuffix of
    Just c
      | not (styleUsesYearSuffixVariable sopts)
      , not usedYearSuffix
      -> do
        modify $ \st -> st{ stateUsedYearSuffix = True }
        return $ Just $ Tagged (TagYearSuffix c)
                         (Literal (fromText (showYearSuffix c)))
      | otherwise -> return Nothing
    Nothing  -> return Nothing



formatDateParts :: CiteprocOutput a
          => [DP] -> (DateParts, Maybe DateParts) -> Eval a [Output a]
formatDateParts dpSpecs (date, mbNextDate) = do
  let (yr,mo,da) = bindDateParts date
  case mbNextDate of
    Nothing -> mapM (eDP (yr,mo,da)) dpSpecs
    Just nextDate -> do
      let (nextyr,nextmo,nextda) = bindDateParts nextDate
      let isOpenRange = nextyr == Just 0 &&
                        isNothing nextmo &&
                        isNothing nextda
      -- figure out where the range goes:
      -- first to differ out of the items selected by dpSpecs, in order y->m->d
      let dpToNs DPYear  = (yr, nextyr)
          dpToNs DPMonth = (mo, nextmo)
          dpToNs DPDay   = (da, nextda)
      let areSame = takeWhile (uncurry (==) . dpToNs) $
                      sort $ map dpName dpSpecs
      let (sames1, rest) = span (\dp -> dpName dp `elem` areSame) dpSpecs
      let (diffs, sames2) = span (\dp -> dpName dp `notElem` areSame) rest
      let cleanup = filter (/= NullOutput)
      sames1' <- cleanup <$> mapM (eDP (yr,mo,da)) sames1
      diffsLeft' <- cleanup <$> mapM (eDP (yr,mo,da)) diffs
      diffsRight' <- cleanup <$> mapM (eDP (nextyr,nextmo,nextda)) diffs
      sames2' <- cleanup <$> mapM (eDP (yr,mo,da)) sames2
      let rangeDelim = case sortOn dpName diffs of
                              []     -> Nothing
                              (dp:_) -> Just $ dpRangeDelimiter dp
      let toRange xs ys =
            case lastMay xs of
              Just xlast ->
                   initSafe xs ++
                     [Formatted mempty{ formatDelimiter = rangeDelim }
                     [xlast, headDef (Literal mempty) ys]] ++
                   tailSafe ys
              _ -> xs ++ ys

      return $
        if isOpenRange
           then [Formatted mempty{ formatSuffix = rangeDelim }
                    (removeLastSuffix $ sames1' ++ diffsLeft')]
           else removeLastSuffix $
                 sames1' ++
                 toRange (removeLastSuffix diffsLeft')
                         (removeFirstPrefix diffsRight') ++
                 sames2'

removeFirstPrefix :: [Output a] -> [Output a]
removeFirstPrefix (Formatted f xs : rest) =
  Formatted f{ formatPrefix = Nothing } xs : rest
removeFirstPrefix xs = xs

removeLastSuffix :: [Output a] -> [Output a]
removeLastSuffix [] = []
removeLastSuffix [Formatted f xs] =
  [Formatted f{ formatSuffix = Nothing } xs ]
removeLastSuffix (x:xs) = x : removeLastSuffix xs

eDP :: CiteprocOutput a
    => (Maybe Int, Maybe Int, Maybe Int) ->  DP -> Eval a (Output a)
eDP (yr,mo,da) dp = do
  let mbn = case dpName dp of
               DPDay   -> da
               DPMonth -> mo
               DPYear  -> yr
  case mbn of
    Nothing -> return NullOutput
    Just 0 | dpName dp == DPYear
            -> return $ Literal mempty -- open date range
    Just n  -> do
      let litStr = return . Literal . fromText . T.pack
      suffix <- case dpName dp of
                  DPYear
                    | n < 0
                      -> (:[]) <$> lookupTerm' emptyTerm{ termName = "bc" }
                    | n > 0
                    , n < 1000
                      -> (:[]) <$> lookupTerm' emptyTerm{ termName = "ad" }
                    | otherwise -> return []
                  _ -> return []
      let n' = case dpName dp of
                 DPYear -> abs n
                 _      -> n
      formatted (dpFormatting dp) . (:suffix) <$>
          case dpForm dp of
            DPNumeric             -> litStr (show n')
            DPNumericLeadingZeros -> litStr (printf "%02d" n')
            DPOrdinal             -> do
              locale <- asks contextLocale
              if localeLimitDayOrdinalsToDay1 locale == Just True && n' /= 1
                 then litStr (show n')
                 else evalNumber NumberOrdinal Nothing (NumVal n')
            form -> do
              let termForMonth s = emptyTerm{ termName = T.pack s
                                            , termForm = if form == DPShort
                                                            then Short
                                                            else Long }

              case dpName dp of
                DPMonth | n <= 0 -> return NullOutput
                        | n <= 12 ->
                  lookupTerm' $ termForMonth (printf "month-%02d" n)
                        | n <= 16 -> -- season pseudo-month
                  lookupTerm' $ termForMonth (printf "season-%02d" (n - 12))
                        | n <= 20 -> -- season pseudo-month
                  lookupTerm' $ termForMonth (printf "season-%02d" (n - 16))
                        | otherwise -> -- season pseudo-month
                  lookupTerm' $ termForMonth (printf "season-%02d" (n - 20))
                _                 -> litStr (show n')


bindDateParts :: DateParts -> (Maybe Int, Maybe Int, Maybe Int)
bindDateParts date =
      case date of
        DateParts (y:m:d:_) -> (Just y,Just m,Just d)
        DateParts [y,m]     -> (Just y,Just m,Nothing)
        DateParts [y]       -> (Just y,Nothing,Nothing)
        _                   -> (Nothing,Nothing,Nothing)

eNames :: CiteprocOutput a
        => [Variable]
        -> NamesFormat
        -> [Element a]
        -> Formatting
        -> Eval a (Output a)
eNames vars namesFormat' subst formatting = do
  substituteNamesForm <- asks contextSubstituteNamesForm
  inSortKey <- asks contextInSortKey
  let namesFormat =
        case substituteNamesForm of
          Nothing -> namesFormat'
          Just subs ->
            NamesFormat
            { namesLabel           =
                if inSortKey -- see test/csl/sort_DropNameLabelInSort.txt
                   -- though this doesn't seem to be in the spec
                   then Nothing
                   else namesLabel namesFormat' <|> namesLabel subs
            , namesEtAl            = namesEtAl namesFormat' <|>
                                       namesEtAl subs
            , namesName            = namesName namesFormat' <|>
                                       namesName subs
            , namesLabelBeforeName =
                if isJust (namesName namesFormat') &&
                   isJust (namesLabel namesFormat')
                   then namesLabelBeforeName namesFormat'
                   else namesLabelBeforeName subs
            }

  vars' <- if "editor" `elem` vars && "translator" `elem` vars
              then do
                ed <- askVariable "editor"
                tr <- askVariable "translator"
                let termform =
                      case namesLabel namesFormat of
                        Just (termform', _, _) -> termform'
                        _ -> Long
                mbterm <- lookupTerm'
                            emptyTerm{ termName = "editortranslator"
                                     , termForm = termform }
                if ed == tr && mbterm /= NullOutput
                   then return $ "editortranslator" :
                        [v | v <- vars
                           , v /= "editor"
                           , v /= "translator"]
                   else return vars
              else return vars
  inSubstitute <- asks contextInSubstitute
  let (nameFormat, nameFormatting) =
        fromMaybe (defaultNameFormat, mempty) $ namesName namesFormat
  rawContribs <- mapM (\var -> (var,) <$>
                       askVariable
                       (if var == "editortranslator"
                           then "editor"
                           else var)) vars'
  if all (isNothing . snd) rawContribs
     then
       case subst of
         els@(_:_) | not inSubstitute -> do
           res <- withRWST
                  (\ctx st -> (ctx{ contextInSubstitute = True
                                  , contextSubstituteNamesForm =
                                      Just namesFormat },
                               st)) $ eSubstitute els
           return $
             case res of
               (Tagged TagNames{} _:_) -> formatted formatting res
               -- important to have title (or whatever) tagged as
               -- substituting for Names, for purposes of
               -- disambiguation:
               _ -> formatted formatting
                    [Tagged (TagNames "" namesFormat []) $ grouped res]
         _ -> return NullOutput
     else do
        xs <- mapM (formatNames namesFormat nameFormat nameFormatting)
               rawContribs
        when inSubstitute $
          modify $ \st ->  -- delete variables so they aren't used again...
              st{ stateReference =
                  let Reference id' type' d' m' = stateReference st
                   in Reference id' type' d' (foldr M.delete m'
                                         [v | (v, Just _) <- rawContribs ])}

        return $
          case nameForm nameFormat of
             CountName -> Literal $ fromText $ T.pack $ show $ length
               [name
                 | Tagged (TagName name) _ <- concatMap universe xs]
             _ -> formatted formatting xs

eSubstitute :: CiteprocOutput a
            => [Element a]
            -> Eval a [Output a]
eSubstitute els =
  case els of
    [] -> return []
    (e:es) -> do
      res <- eElement e
      case filter (/= NullOutput) res of
        [] -> eSubstitute es
        xs -> return xs

formatNames :: CiteprocOutput a
            => NamesFormat
            -> NameFormat
            -> Formatting
            -> (Variable, Maybe (Val a))
            -> Eval a (Output a)
formatNames namesFormat nameFormat formatting (var, Just (NamesVal names)) =
  do
  inSortKey <- asks contextInSortKey
  disamb <- gets (referenceDisambiguation . stateReference)
  names' <- zipWithM (formatName nameFormat formatting) [1..] names
  let delim' = fromMaybe (nameDelimiter nameFormat) $
                 formatDelimiter formatting
  let delim = case (beginsWithSpace <$> formatSuffix formatting,
                    endsWithSpace <$> formatPrefix formatting) of
                    (Just True, Just True) -> T.strip delim'
                    (Just True, _)         -> T.stripStart delim'
                    (_, Just True)         -> T.stripEnd delim'
                    _                      -> delim'
  let numnames = length names'
  label <- case namesLabel namesFormat of
             Just (termform, pluralize, lf) | not inSortKey ->
               (:[]) <$> eLabel var termform pluralize lf
             _ -> return []
  mbAndTerm <- case nameAndStyle nameFormat of
                  Just Symbol -> do
                    ts <- lookupTerm emptyTerm { termName = "and"
                                               , termForm = Symbol }
                    case ts of
                      (_,x):_ -> return $ Just x
                      []      -> return $ Just "&"
                  Just _ -> fmap snd . listToMaybe <$>
                              lookupTerm emptyTerm { termName = "and"
                                                   , termForm = Long }
                  Nothing -> return Nothing
  let etAlUseLast = nameEtAlUseLast nameFormat
  let etAlThreshold = case nameEtAlMin nameFormat of
                        Just x | numnames >= x
                          -> case (disamb >>= disambEtAlNames,
                                    nameEtAlUseFirst nameFormat) of
                               (Just n, Just m) -> Just (max m n)
                               (_, y) -> y
                        _ -> Nothing
  let beforeLastDelim =
        case mbAndTerm of
          Nothing -> delim
          Just _ ->
             case nameDelimiterPrecedesLast nameFormat of
                PrecedesContextual
                  | numnames > 2          -> delim
                  | otherwise             -> ""
                PrecedesAfterInvertedName
                  -> case nameAsSortOrder nameFormat of
                       Just NameAsSortOrderAll -> delim
                       Just NameAsSortOrderFirst
                         | numnames < 3        -> delim
                       _                       -> ""
                PrecedesAlways            -> delim
                PrecedesNever             -> ""
  let andPreSpace =
        if T.null beforeLastDelim
           then case formatSuffix formatting of
                  Just t | endsWithSpace t -> ""
                  _ -> " "
           else
             if endsWithSpace beforeLastDelim
                then ""
                else " "
  let andPostSpace = case formatPrefix formatting of
                       Just t | beginsWithSpace t -> ""
                       _ -> " "
  let mbAndDelim = case mbAndTerm of
                         Nothing -> Nothing
                         Just t  -> Just (andPreSpace <> t <> andPostSpace)
  let etAlPreSpace = case formatSuffix formatting of
                       Just t | endsWithSpace t -> ""
                       _ -> " "
  let beforeEtAl =
        case nameDelimiterPrecedesEtAl nameFormat of
            PrecedesContextual
              | numnames > 2
              , etAlThreshold > Just 1 -> delim
              | otherwise              -> etAlPreSpace
            PrecedesAfterInvertedName
                  -> case nameAsSortOrder nameFormat of
                       Just NameAsSortOrderAll  -> delim
                       Just NameAsSortOrderFirst
                         | etAlThreshold < Just 2 -> delim
                       _                          -> etAlPreSpace
            PrecedesAlways            -> delim
            PrecedesNever             -> etAlPreSpace
  etAl <- case namesEtAl namesFormat of
                Just (term, f) -> withFormatting f{
                    formatPrefix = removeDoubleSpaces <$>
                      Just beforeEtAl <> formatPrefix f } $
                 lookupTerm' emptyTerm{ termName = term }
                Nothing
                  | etAlUseLast ->
                    return $
                      Formatted mempty{ formatPrefix = Just beforeEtAl }
                        [literal "\x2026 "] -- ellipses
                  | otherwise   ->
                      Formatted mempty{ formatPrefix = Just beforeEtAl }
                      . (:[]) <$> lookupTerm' emptyTerm{ termName = "et-al" }
  let addNameAndDelim name idx
       | etAlThreshold == Just 0 = NullOutput
       | idx == 1    = name
       | idx == numnames
       , etAlUseLast
       , maybe False (idx - 1 >=) etAlThreshold
         = name
       | maybe False (idx - 1 >) etAlThreshold = NullOutput
       | maybe False (idx - 1 ==) etAlThreshold =
         if inSortKey
            then NullOutput
            else etAl
       | inSortKey = name
       | idx == numnames
         = formatted mempty{ formatPrefix =
                       Just (beforeLastDelim <> fromMaybe "" mbAndDelim) }
            [name]
       | otherwise = formatted mempty{ formatPrefix = Just delim } [name]
  let names'' = zipWith addNameAndDelim names' [1..]
  -- we set delimiter to Nothing because we're handling delim
  -- manually, to allow for things like "and" and no final comma
  return $ Tagged (TagNames var namesFormat names)
         $ grouped $
           if namesLabelBeforeName namesFormat
              then label ++ names''
              else names'' ++ label

formatNames _ _ _ (var, Just _) = do
  warn $ "ignoring non-name value for variable " <> fromVariable var
  return NullOutput
formatNames _ _ _ (_, Nothing) = return NullOutput

formatName :: CiteprocOutput a
           => NameFormat -> Formatting -> Int -> Name -> Eval a (Output a)
formatName nameFormat formatting order name = do
  disamb <- gets (referenceDisambiguation . stateReference)
  let nameFormat' =
        case disambNameMap <$> disamb >>= M.lookup name of
          Nothing -> nameFormat
          Just AddInitials
            -> nameFormat{ nameForm = LongName }
          Just AddInitialsIfPrimary
            | order == 1  -> nameFormat{ nameForm = LongName }
            | otherwise -> nameFormat
          Just AddGivenName ->
            nameFormat{ nameForm = LongName
                      , nameInitialize = False
                      }
          Just AddGivenNameIfPrimary
            | order == 1 ->
               nameFormat{ nameForm = LongName
                         , nameInitialize = False
                         }
            | otherwise -> nameFormat
  Tagged (TagName name) <$>
    case nameLiteral name of
      Just t  -> return $ formatted formatting
                        $ maybe [literal t]
                          (\f -> [Formatted f [literal t]])
                          (nameFamilyFormatting nameFormat)
      Nothing -> getDisplayName nameFormat' formatting order name


getNamePartSortOrder :: Name -> Eval a [Text]
getNamePartSortOrder name = do
  demoteNonDroppingParticle <-
    asks (styleDemoteNonDroppingParticle . contextStyleOptions)
  map (fromMaybe mempty) <$>
    case nameLiteral name of
      Nothing
        | isByzantineName name
           -> return $
                   case demoteNonDroppingParticle of
                     DemoteNever ->
                           [nameNonDroppingParticle name <> nameFamily name,
                            nameDroppingParticle name,
                            nameGiven name,
                            nameSuffix name]
                     _ ->  [nameFamily name,
                            nameDroppingParticle name <>
                              nameNonDroppingParticle name,
                            nameGiven name,
                            nameSuffix name]
        | otherwise
           -> return [nameFamily name,
                      nameGiven name]
      Just n -> return [Just n]

literal :: CiteprocOutput a => Text -> Output a
literal = Literal . fromText

showYearSuffix :: Int -> Text
showYearSuffix x
  | x < 27    = T.singleton $ chr $ ord 'a' + (x - 1)
  | otherwise =
      let x' = x - 1
       in T.pack [chr (ord 'a' - 1 + (x' `div` 26)),
                  chr (ord 'a' + (x' `mod` 26))]

initialize :: Bool       -- ^ initialize
           -> Bool       -- ^ with hyphen
           -> Text       -- ^ initialize with (suffix)
           -> Text
           -> Text
initialize makeInitials useHyphen initializeWith =
   T.strip . T.replace " -" "-" . mconcat . map initializeWord . splitWords
  where
   -- Left values are already initials
   -- Right values are not
   splitWords =
     reverse . (\(ws,cs) ->
                  case cs of
                    [] -> ws
                    [d] -> Left (T.singleton d) : ws
                    _   -> Right (T.pack (reverse cs)) : ws) .
     T.foldl'
     (\(ws, cs) c ->
       case c of
         '.' | null cs   -> (ws, [])
             | otherwise -> (Left (T.pack (reverse cs)) : ws, [])
         '-' | null cs   -> (ws, ['-'])
             | otherwise -> (Right (T.pack (reverse cs)) : ws, ['-'])
         ' ' -> case cs of
                  []  -> (ws, cs)
                  [d] -> (Left (T.singleton d) : ws, [])
                  _   -> (Right (T.pack (reverse cs)) : ws, [])
         _   -> (ws, c:cs))
     ([], mempty)
   addSuffix t
     | T.null t  = mempty
     | otherwise = t <> initializeWith
   toInitial t =
       case T.uncons t of
         Just ('-', t') ->
           case T.uncons t' of
             Just (c, _)
               | isUpper c
               , useHyphen -> "-" <> T.toUpper (T.singleton c)
               | isUpper c -> T.toUpper (T.singleton c)
             _ -> mempty  -- e.g. Ji-ping -> J. not J.-p.
         Just (c, t')
           | isUpper c ->
             case T.uncons t' of
               Just (d, t'')
                 | isUpper d  -- see test/csl/name_LongAbbreviation.txt
                 , not (T.null t'')
                 , T.all isLower t''
                 -> T.singleton c <> T.toLower (T.singleton d)
               _ -> T.singleton c
         _ -> t
   initializeWord (Left t) -- Left values already initialized
     = addSuffix t
   initializeWord (Right t) -- Right values not already initialized
     | T.all isLower t = if endsWithSpace initializeWith
                            then t <> " "
                            else " " <> t <> " "
     | makeInitials    = (addSuffix . toInitial) t
     | otherwise       = t <> " "

getDisplayName :: CiteprocOutput a
               => NameFormat -> Formatting -> Int -> Name -> Eval a (Output a)
getDisplayName nameFormat formatting order name = do
  inSortKey <- asks contextInSortKey
  demoteNonDroppingParticle <-
    asks (styleDemoteNonDroppingParticle . contextStyleOptions)
  initializeWithHyphen <-
    asks (styleInitializeWithHyphen . contextStyleOptions)
  let initialize' =
        case nameFamily name of
          Nothing -> id
          Just _ ->
            case nameInitializeWith nameFormat of
              Just initializeWith ->
                initialize
                (nameInitialize nameFormat)
                initializeWithHyphen
                initializeWith
              Nothing -> id
  let separator = nameSortSeparator nameFormat
  let x <+> NullOutput = x
      NullOutput <+> x = x
      Literal x <+> y =
        case T.unsnoc (toText x) of
          Just (_, c) | c == '’' || c == '\'' || c == '-' || c == '\x2013' ->
               formatted mempty [Literal x, y]
          _ | isByzantineName name ->
               formatted mempty{ formatDelimiter = Just " " } [Literal x, y]
            | otherwise -> formatted mempty [Literal x, y]
      Formatted f x <+> y =
        formatted mempty{ formatDelimiter =
                            case formatSuffix f of
                              Just t | endsWithSpace t -> Nothing
                              _ -> Just " " } [formatted f x, y]
      Tagged _ x <+> y = x <+> y
      InNote x <+> y = x <+> y
  let x <:> NullOutput = x
      NullOutput <:> x = x
      Literal x <:> y =
        formatted mempty{ formatDelimiter = Just separator } [Literal x, y]
      Formatted f x <:> y = formatted
        (mempty{ formatDelimiter = Just separator }) [Formatted f x, y]
      Tagged _ x <:> y = x <:> y
      InNote x <:> y = x <:> y

  let familyAffixes = formatted
          (case nameFamilyFormatting nameFormat of
             Nothing -> mempty
             Just f  -> mempty{ formatSuffix = formatSuffix f
                              , formatPrefix = formatPrefix f })
  let givenAffixes = formatted
          (case nameGivenFormatting nameFormat of
             Nothing -> mempty
             Just f  -> mempty{ formatSuffix = formatSuffix f
                              , formatPrefix = formatPrefix f })
  let familyFormatting = formatted
          (case nameFamilyFormatting nameFormat of
             Nothing -> mempty
             Just f  -> f{ formatSuffix = Nothing
                         , formatPrefix = Nothing })
  let givenFormatting = formatted
          (case nameGivenFormatting nameFormat of
             Nothing -> mempty
             Just f  -> f{ formatSuffix = Nothing
                         , formatPrefix = Nothing })
  let nonDroppingParticle =
        maybe NullOutput (familyFormatting . (:[]) . literal) $
          nameNonDroppingParticle name
  let droppingParticle =
        maybe NullOutput (givenFormatting . (:[]) . literal) $
          nameDroppingParticle name
  let given =
        maybe NullOutput (givenFormatting . (:[]) . literal . initialize') $
          nameGiven name
  let family =
        maybe NullOutput (familyFormatting . (:[]) . literal) $
          nameFamily name
  let suffix = maybe NullOutput literal $ nameSuffix name
  let useSortOrder = inSortKey ||
                     case nameAsSortOrder nameFormat of
                       Just NameAsSortOrderAll -> True
                       Just NameAsSortOrderFirst -> order == 1
                       _ -> False
  return $ formatted formatting . (:[]) $
    if isByzantineName name
       then
         case nameForm nameFormat of
              LongName
                | demoteNonDroppingParticle == DemoteNever ||
                  demoteNonDroppingParticle == DemoteSortOnly
                , useSortOrder->
                      familyAffixes
                      [ nonDroppingParticle <+>
                        family ] <:>
                      givenAffixes
                      [ given <+>
                        droppingParticle ] <:>
                      suffix
                | demoteNonDroppingParticle == DemoteDisplayAndSort
                , useSortOrder->
                      familyAffixes
                      [ family ] <:>
                      givenAffixes
                      [ given <+>
                        droppingParticle <+>
                        nonDroppingParticle ] <:>
                      suffix
                | nameCommaSuffix name ->
                      givenAffixes
                      [ given ] <+>
                      familyAffixes
                      [ droppingParticle <+>
                        nonDroppingParticle <+>
                        family <:>
                        suffix ]
                | otherwise ->
                      givenAffixes
                      [ given ] <+>
                      familyAffixes
                      [ droppingParticle <+>
                        nonDroppingParticle <+>
                        family <+>
                        suffix ]
              ShortName ->
                      familyAffixes
                      [ nonDroppingParticle <+>
                        family ]
              CountName -> NullOutput
       else
         case nameForm nameFormat of
              LongName  -> grouped
                [ familyAffixes
                  [ family ]
                , givenAffixes
                  [ given ] ]
              ShortName -> familyAffixes
                             [ family ]
              CountName -> NullOutput


eGroup :: CiteprocOutput a
          => Bool -> Formatting -> [Element a] -> Eval a (Output a)
eGroup isMacro formatting els = do
  -- A group is suppressed if it directly or indirectly
  -- calls at least one variable but all of the variables
  -- it calls are empty.
  VarCount oldVars oldNonempty <- gets stateVarCount
  xs <- mconcat <$> mapM eElement els
  VarCount newVars newNonempty <- gets stateVarCount
  -- see
  -- https://github.com/citation-style-language/documentation/blob/master/specification.rst#group
  -- "When a cs:group contains a child cs:macro, if the cs:macro is
  -- non-empty, it is treated as a non-empty variable for the purposes of
  -- determining suppression of the outer cs:group."
  when (isMacro && not (all (== NullOutput) xs)) $
    updateVarCount 1 1
  return $ if oldVars == newVars || newNonempty > oldNonempty
              then formatted formatting xs
              else NullOutput

eChoose :: CiteprocOutput a
        => [(Match, [Condition], [Element a])] -> Eval a [Output a]
eChoose [] = return []
eChoose ((match, conditions, els):rest) = do
  ref <- gets stateReference
  label <- asks contextLabel
  let disambiguate = maybe False
                      disambCondition (referenceDisambiguation ref)
  positions <- asks contextPosition
  hasLocator <- isJust <$> asks contextLocator
  let isNumeric t = all
        (\chunk -> T.any isDigit chunk && not (T.any isSpace chunk)) $
        T.split (\c -> c == ',' || c == '-' || c == '&')
         (T.replace ", " "," . T.replace "& " "&" . T.replace ", " "," $ t)
  let testCondition cond =
        case cond of
           HasVariable "locator" -> hasLocator
           HasVariable t ->
             case lookupVariable t ref of
               Just (TextVal x)   -> x /= mempty
               Just (FancyVal x)  -> toText x /= mempty
               Just (NamesVal xs) -> not (null xs)
               Just _             -> True
               Nothing            -> False
           HasType t -> lookupVariable "type" ref == Just (TextVal t)
           IsUncertainDate t -> case lookupVariable t ref of
                                  Just (DateVal d) -> dateCirca d
                                  _                -> False
           IsNumeric t -> case lookupVariable t ref of
                            Just (NumVal _)   -> True
                            Just (TextVal x)  -> isNumeric x
                            Just (FancyVal x) -> isNumeric (toText x)
                            _                 -> False
           HasLocatorType t -> case label of
                                 Just "sub verbo" -> t == "sub-verbo"
                                 Just x -> toVariable x == t
                                 Nothing -> t == "page"
           HasPosition pos -> pos `elem` positions
           WouldDisambiguate -> disambiguate
  let matched = (case match of
                   MatchAll  -> all testCondition
                   MatchAny  -> any testCondition
                   MatchNone -> not . any testCondition) conditions
  if matched
     then mconcat <$> mapM eElement els
     else eChoose rest


eNumber :: CiteprocOutput a => Variable -> NumberForm -> Eval a (Output a)
eNumber var nform = do
  mbv <- askVariable var
  varTerms <- lookupTerm emptyTerm { termName = fromVariable var }
  let mbGender = case varTerms of
                   [] -> Nothing
                   ((t,_):_) -> termGender t
  let nparts = case mbv of
                 Just x@NumVal{}   -> [x]
                 Just (FancyVal x) -> splitNums (toText x)
                 Just (TextVal t)  -> splitNums t
                 _                 -> []
  grouped <$> mapM (evalNumber nform mbGender) nparts

evalNumber :: CiteprocOutput a
           => NumberForm -> Maybe TermGender -> Val a -> Eval a (Output a)
evalNumber form mbGender (NumVal i) = do
  let numterm s x = emptyTerm { termName = T.pack $ printf s x
                              , termGenderForm = mbGender }
  let dectext = T.pack (show i)
  let twomatch = numterm "ordinal-%02d" (i `mod` 100)
  let onematch = numterm "ordinal-%02d" (i `mod` 10)
  let fallback = emptyTerm { termName = "ordinal" }
  case form of
    NumberNumeric -> return $ Literal $ fromText dectext
    NumberOrdinal -> do
      res <- (if i > 99
                 then filter (\(t,_) -> termMatch t /= Just WholeNumber)
                 else id) <$> lookupTerm twomatch
      case res of
        ((_,suff):_) ->
          return $ Literal $ fromText (dectext <> suff)
        [] -> do -- not an exact match
          res' <- (if i > 10
                      then filter (\(t,_) ->
                             isNothing (termMatch t) ||
                             termMatch t == Just LastDigit)
                      else id) <$> lookupTerm onematch
          case res' of
            ((_,suff):_) ->
              return $ Literal $ fromText (dectext <> suff)
            [] -> do
              res'' <- lookupTerm fallback
              case res'' of
                ((_,suff):_) ->
                  return $ Literal $ fromText (dectext <> suff)
                [] -> do
                  warn $ "no ordinal suffix found for " <> dectext
                  return $ Literal $ fromText (T.pack (show i))
    NumberLongOrdinal
      | i >= 1
      , i <= 10 -> do
        res <- lookupTerm (numterm "long-ordinal-%02d" i)
        case res of
          ((_,t):_) -> return $ Literal $ fromText t
          []        -> evalNumber NumberOrdinal mbGender (NumVal i)
      | otherwise -> evalNumber NumberOrdinal mbGender (NumVal i)
    NumberRoman -> return $ Literal $ fromText $ toRomanNumeral i
evalNumber _ _ (TextVal t) = return $ Literal $ fromText t
evalNumber _ _ (FancyVal t) = return $ Literal t
evalNumber _ _ _ = return NullOutput


warn :: Text -> Eval a ()
warn t = tell $ Set.singleton t

-- | Convert number < 4000 to lowercase roman numeral.
toRomanNumeral :: Int -> Text
toRomanNumeral x
  | x >= 4000 || x < 0 = T.pack (show x)
  | x >= 1000 = "m" <> toRomanNumeral (x - 1000)
  | x >= 900  = "cm" <> toRomanNumeral (x - 900)
  | x >= 500  = "d" <> toRomanNumeral (x - 500)
  | x >= 400  = "cd" <> toRomanNumeral (x - 400)
  | x >= 100  = "c" <> toRomanNumeral (x - 100)
  | x >= 90   = "xc" <> toRomanNumeral (x - 90)
  | x >= 50   = "l"  <> toRomanNumeral (x - 50)
  | x >= 40   = "xl" <> toRomanNumeral (x - 40)
  | x >= 10   = "x" <> toRomanNumeral (x - 10)
  | x == 9    = "ix"
  | x >= 5    = "v" <> toRomanNumeral (x - 5)
  | x == 4    = "iv"
  | x >= 1    = "i" <> toRomanNumeral (x - 1)
  | x == 0    = ""
  | otherwise = T.pack (show x)

-- Gets variable while updating var count.
askVariable :: CiteprocOutput a => Variable -> Eval a (Maybe (Val a))
askVariable "page-first" = do
  res <- askVariable "page"
  case res of
    Just (TextVal t)  ->
      return $ Just $ TextVal $ T.takeWhile (not . isSepPunct) t
    Just (FancyVal x) ->
      return $ Just $ TextVal $ T.takeWhile (not . isSepPunct) $ toText x
    Just (NumVal n)   -> return $ Just $ NumVal n
    _                 -> return Nothing
askVariable v = do
  ref <- gets stateReference
  case lookupVariable v ref of
    Just x -> do
      updateVarCount 1 1
      return $ Just x
    Nothing -> do
      updateVarCount 1 0
      return Nothing

citationLabel :: Reference a -> Val a
citationLabel ref = TextVal trigraph
 where
  trigraph = namepart <> datepart
  datepart = case datevars of
               [] -> ""
               (var:_) -> case M.lookup var varmap of
                            Just (DateVal d) -> getYear d
                            _ -> ""
  namepart = if "author" `elem` namevars
                then getNames "author"
                else case namevars of
                       (n:_) -> getNames n
                       _     -> "Xyz"
  varmap = referenceVariables ref
  vars = M.keys varmap
  namevars = [v | v <- vars, variableType v == NameVariable]
  datevars = [v | v <- vars, variableType v == DateVariable]
  getNames var = case M.lookup var varmap of
                   Just (NamesVal ns) ->
                     let x = case length ns of
                               1  -> 4
                               n | n >= 4 -> 1
                                 | otherwise -> 2
                     in mconcat $
                        map (T.take x . fromMaybe "" .  nameFamily)
                        (take 4 ns)
                   _ -> ""
  getYear d = case dateParts d of
                (DateParts (x:_):_) -> T.pack $ printf "%02d"
                                              $ x `mod` 100
                _ -> ""

removeDoubleSpaces :: Text -> Text
removeDoubleSpaces = T.replace "  " " "

endsWithSpace :: Text -> Bool
endsWithSpace t = not (T.null t) && isSpace (T.last t)

beginsWithSpace :: Text -> Bool
beginsWithSpace t = not (T.null t) && isSpace (T.head t)