{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Citeproc.Element
  ( pLocale
  , pDate
  , Attributes(..)
  , lookupAttribute
  , ElementParser
  , runElementParser
  , parseFailure
  , getChildren
  , allChildren
  , getAttributes
  , getNameAttributes
  , getFormatting
  , getTextContent
  )
where
import Citeproc.Types
import Data.Maybe (fromMaybe)
import Control.Monad (foldM)
import qualified Data.Map as M
import qualified Text.XML as X
import Data.Text (Text)
import qualified Data.Text as T
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Class (lift)

newtype Attributes = Attributes (M.Map Text Text)
  deriving (Show, Semigroup, Monoid, Eq)

lookupAttribute :: Text -> Attributes -> Maybe Text
lookupAttribute key (Attributes kvs) = M.lookup key kvs

type ElementParser = ReaderT (M.Map X.Name Text) (Except CiteprocError)

runElementParser :: ElementParser a -> Either CiteprocError a
runElementParser p = runExcept (runReaderT p mempty)

parseFailure :: String -> ElementParser a
parseFailure s = lift $ throwE (CiteprocParseError $ T.pack s)

getChildren :: Text -> X.Element -> [X.Element]
getChildren name el = [e | X.NodeElement e <- X.elementNodes el
                         , X.nameLocalName (X.elementName e) == name]

allChildren :: X.Element -> [X.Element]
allChildren el = [e | X.NodeElement e <- X.elementNodes el]

getAttributes :: X.Element -> Attributes
getAttributes =
  Attributes . M.mapKeys X.nameLocalName . X.elementAttributes

-- Like getAttributes but incorporates inheritable attributes.
getNameAttributes :: X.Element -> ElementParser Attributes
getNameAttributes node = do
  nameattr <- ask
  let xattr = X.elementAttributes node <> nameattr
  return $ Attributes $ M.mapKeys X.nameLocalName xattr

getFormatting :: Attributes -> Formatting
getFormatting attr =
   Formatting
     { formatLang = Nothing
     , formatFontStyle =
          case lookupAttribute "font-style" attr of
            Just "italic"  -> Just ItalicFont
            Just "oblique" -> Just ObliqueFont
            Just "normal"  -> Just NormalFont
            _              -> Nothing
      , formatFontVariant =
          case lookupAttribute "font-variant" attr of
            Just "small-caps" -> Just SmallCapsVariant
            Just "normal"     -> Just NormalVariant
            _                 -> Nothing
      , formatFontWeight =
          case lookupAttribute "font-weight" attr of
            Just "bold"   -> Just BoldWeight
            Just "light"  -> Just LightWeight
            Just "normal" -> Just NormalWeight
            _             -> Nothing
      , formatTextDecoration =
          case lookupAttribute "text-decoration" attr of
            Just "underline" -> Just UnderlineDecoration
            Just "none"      -> Just NoDecoration
            _                -> Nothing
      , formatVerticalAlign =
          case lookupAttribute "vertical-align" attr of
            Just "sup"       -> Just SupAlign
            Just "sub"       -> Just SubAlign
            Just "baseline"  -> Just BaselineAlign
            _                -> Nothing
      , formatPrefix = lookupAttribute "prefix" attr
      , formatSuffix = lookupAttribute "suffix" attr
      , formatDisplay =
          case lookupAttribute "display" attr of
            Just "block"        -> Just DisplayBlock
            Just "left-margin"  -> Just DisplayLeftMargin
            Just "right-inline" -> Just DisplayRightInline
            Just "indent"       -> Just DisplayIndent
            _                   -> Nothing
      , formatTextCase =
          case lookupAttribute "text-case" attr of
            Just "lowercase"        -> Just Lowercase
            Just "uppercase"        -> Just Uppercase
            Just "capitalize-first" -> Just CapitalizeFirst
            Just "capitalize-all"   -> Just CapitalizeAll
            Just "sentence"         -> Just SentenceCase
            Just "title"            -> Just TitleCase
            _                       -> Nothing
      , formatDelimiter = lookupAttribute "delimiter" attr
      , formatStripPeriods =
          lookupAttribute "strip-periods" attr == Just "true"
      , formatQuotes =
          lookupAttribute "quotes" attr == Just "true"
      , formatAffixesInside = False -- should be true for layout only
      }


getTextContent :: X.Element -> Text
getTextContent e = mconcat [t | X.NodeContent t <- X.elementNodes e]

pLocale :: X.Element -> ElementParser Locale
pLocale node = do
  let attr = getAttributes node
  lang <- case lookupAttribute "lang" attr of
            Nothing -> return Nothing
            Just l  -> either parseFailure (return . Just) $ parseLang l
  let styleOpts = mconcat . map getAttributes $
                      getChildren "style-options" node
  let addDateElt e m =
        case e of
          Element (EDate _ dateType _ _) _ -> M.insert dateType e m
          _ -> error "pDate returned an element other than EDate"
  dateElts <- foldr addDateElt mempty <$> mapM pDate (getChildren "date" node)
  let termNodes = concatMap (getChildren "term") (getChildren "terms" node)
  terms <- foldM parseTerm mempty termNodes
  return $
    Locale
    { localeLanguage               = lang
    , localePunctuationInQuote     = (== "true") <$>
               lookupAttribute "punctuation-in-quote" styleOpts
    , localeLimitDayOrdinalsToDay1 = (== "true") <$>
               lookupAttribute "limit-day-ordinals-to-day-1" styleOpts
    , localeDate                   = dateElts
    , localeTerms                  = terms
    }

parseTerm :: M.Map Text [(Term, Text)]
          -> X.Element
          -> ElementParser (M.Map Text [(Term, Text)])
parseTerm m node = do
  let attr = getAttributes node
  name <- case lookupAttribute "name" attr of
                Just n   -> return n
                Nothing  -> parseFailure "Text node has no name attribute"
  let single = mconcat $ map getTextContent $ getChildren "single" node
  let multiple = mconcat $ map getTextContent $ getChildren "multiple" node
  let txt = getTextContent node
  let form = case lookupAttribute "form" attr of
               Just "short"      -> Short
               Just "verb"       -> Verb
               Just "verb-short" -> VerbShort
               Just "symbol"     -> Symbol
               _                 -> Long
  let gender = case lookupAttribute "gender" attr of
                 Just "masculine"  -> Just Masculine
                 Just "feminine"   -> Just Feminine
                 _                 -> Nothing
  let genderForm = case lookupAttribute "gender-form" attr of
                     Just "masculine"  -> Just Masculine
                     Just "feminine"   -> Just Feminine
                     _                 -> Nothing
  let match = case lookupAttribute "match" attr of
                     Just "last-digit"      -> Just LastDigit
                     Just "last-two-digits" -> Just LastTwoDigits
                     Just "whole-number"    -> Just WholeNumber
                     _                      -> Nothing
  let term = Term
        { termName          = name
        , termForm          = form
        , termNumber        = Nothing
        , termGender        = gender
        , termGenderForm    = genderForm
        , termMatch         = match
        }
  let addToList x Nothing   = Just [x]
      addToList x (Just xs) = Just (x:xs)
  if T.null single
     then return $ M.alter (addToList (term, txt)) (termName term) m
     else do
       let term_single = term{ termNumber = Just Singular }
       let term_plural = term{ termNumber = Just Plural }
       return $ M.alter
          (addToList (term_single, single) .
           addToList (term_plural, multiple)) (termName term) m

pDate :: X.Element -> ElementParser (Element a)
pDate node = do
  let attr = getAttributes node
  let formatting = getFormatting attr
  let form = lookupAttribute "form" attr
  let var = toVariable $ fromMaybe mempty $ lookupAttribute "variable" attr
  let showDateParts = case lookupAttribute "date-parts" attr of
                        Just "year-month-day" -> Just YearMonthDay
                        Just "year-month"     -> Just YearMonth
                        Just "year"           -> Just Year
                        _                     -> Nothing

  dps <- mapM parseDatePartElement (getChildren "date-part" node)
  let dateType = case form of
                      Just "numeric" -> LocalizedNumeric
                      Just "text"    -> LocalizedText
                      _              -> NonLocalized
  return $ Element (EDate var dateType showDateParts dps) formatting

parseDatePartElement :: X.Element -> ElementParser DP
parseDatePartElement node = do
  let attr = getAttributes node
  let formatting = getFormatting attr
  let name = case lookupAttribute "name" attr of
               Just "day"   -> DPDay
               Just "month" -> DPMonth
               _            -> DPYear
  let form = case lookupAttribute "form" attr of
               Just "numeric"                -> DPNumeric
               Just "numeric-leading-zeros"  -> DPNumericLeadingZeros
               Just "ordinal"                -> DPOrdinal
               Just "long"                   -> DPLong
               Just "short"                  -> DPShort
               _ | name == DPDay             -> DPNumeric
                 | otherwise                 -> DPLong
  let rangeDelim = fromMaybe "–" $ lookupAttribute "range-delimiter" attr
  return $ DP name form rangeDelim formatting