{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module XMLParse where

import qualified Text.XML.Light as X
import qualified Text.XML.Light.Output as X
import qualified Text.XML.Light.Input as X
import Text.Regex.Posix
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.Identity
import System.Locale(defaultTimeLocale)
import Data.Time(parseTime)
import Data.List
import Data.Char(toLower)

import LedgerT
import Valuation
import Balances
import Actions
import HTML

----------------------------------------------------------------------
-- Monad for parsing XML

data Env = Env {
    celement :: X.Element, -- the element we are currently parsing
    context :: [X.Element] -- the parents of this element back to the root
}

newtype XMLParser a = XMLParser (ReaderT Env (Either String) a)
    deriving (Functor, Monad, MonadReader Env, MonadError String)

evalXMLParser :: XMLParser a -> X.Element -> Either String a
evalXMLParser (XMLParser p) el = runReaderT p (Env el [])

----------------------------------------------------------------------

templates :: [(String, XMLParser (CIO X.Element))]
templates =
    [ ("ledger_entry_table",parseEntryTable)
    , ("ledger_balance_table",parseBalanceTable)
    , ("ledger_balance_change_table",parseBalanceChangeTable)
    ]

----------------------------------------------------------------------

parseEntryTable :: XMLParser (CIO X.Element)
parseEntryTable = do
    checkTag "ledger_entry_table"
    es <- withNamedSubChild "entries" parseEntriesSource
    return (mkEntriesTable es)

parseBalanceTable :: XMLParser (CIO X.Element)
parseBalanceTable = do
    checkTag "ledger_balance_table"
    venv <- withNamedSubChild "valuation_env" parseValuationEnv
    bals <- withNamedSubChild "balances" parseBalancesSource
    showAmounts <- withOptionalNamedChild "show_commodity_amounts" True parseBool
    showValues <- withOptionalNamedChild "show_commodity_values" True parseBool
    let flags = ConvBalanceTableSettings showAmounts showValues
    return (mkBalancesTable flags venv bals)

parseBalanceChangeTable :: XMLParser (CIO X.Element)
parseBalanceChangeTable = do
    checkTag "ledger_balance_change_table"
    venv1 <- withNamedSubChild "valuation_env1" parseValuationEnv
    bals1 <- withNamedSubChild "balances1" parseBalancesSource
    venv2 <- withNamedSubChild "valuation_env2" parseValuationEnv
    bals2 <- withNamedSubChild "balances2" parseBalancesSource
    return (mkBalanceChangeTable (venv1,bals1) (venv2,bals2))

parseEntriesSource :: XMLParser EntriesSource
parseEntriesSource = parseAny "entries" [
    ("from_file",from_file),
    ("filter_by_date",filter_by_date)
    ]
  where
    from_file = do
      path <- withNamedChild "path" parseString
      return (entriesFromFile path)

    filter_by_date = do
      pred <- withNamedSubChild "predicate" parseDatePredicate
      entriesSource <- withNamedSubChild "entries" parseEntriesSource
      return (filterEntries pred entriesSource)

parseBalancesSource :: XMLParser BalancesSource
parseBalancesSource = parseAny "balances" [
    ("from_entries",from_entries),
    ("filter_by_account",filter_by_account),
    ("aggregate",aggregate)
    ]
  where
    from_entries = do
        entries <- withNamedSubChild "entries" parseEntriesSource
        t <- withNamedChild "date" parseDate
        return (balancesFromEntries t entries)

    filter_by_account = do
      pred <- withNamedSubChild "predicate" parseAccountPredicate
      balancesSource <- withNamedSubChild "balances" parseBalancesSource
      return (filterBalances pred balancesSource)

    aggregate = do
      bals <- withSingleChild parseBalancesSource
      return (aggBalances `fmap` bals)


parseValuationEnv :: XMLParser ValuationEnvSource
parseValuationEnv = parseAny "valuation env" [("from_file",from_file)]
  where
    from_file = do
        pcommod <- withNamedChild "pcommod" parseString
        t <- withNamedChild "date" parseDate
        path <- withNamedChild "path" parseString
        ndays <- withNamedChild "ndays" parseInt
        return (valuationEnvFromFile path pcommod t ndays)
    
parseDatePredicate :: XMLParser (Date -> Bool)
parseDatePredicate = parseAny "date predicate"
    [ ("eq",eq)
    , ("leq",leq)
    , ("geq",geq)
    , ("and",multiP and)
    , ("or",multiP or)
    , ("not",notP)
    ]         
  where
    eq = parseDate >>= (\t -> return (==t))
    leq = parseDate >>= (\t -> return (<=t))
    geq = parseDate >>= (\t -> return (>=t))

    notP = withSingleChild $ do
      p <- parseDatePredicate
      return (not.p)

    multiP op = do
      ps <- withEachChild parseDatePredicate
      return (\t -> op (map (\p -> p t) ps))

parseAccountPredicate :: XMLParser (AccountNameC -> Bool)
parseAccountPredicate = parseAny "account predicate"
    [ ("match", match)
    , ("and", multiP and)
    , ("or", multiP or)
    , ("not", notP)
    ]
  where
    match = do 
      pat <- parseString
      return (\a -> (intercalate ":" a) =~ pat)

    multiP op = do
      ps <- withEachChild parseAccountPredicate
      return (\t -> op (map (\p -> p t) ps))

    notP = withSingleChild $ do
      p <- parseAccountPredicate
      return (not.p)

parseDate :: XMLParser Date
parseDate = do
  el <- currentElement
  case parsedateM (X.strContent el) of
    (Just d) -> return d
    _ -> throwParseError "invalid date"
      
parseString :: XMLParser String
parseString = X.strContent `fmap` currentElement

parseInt :: XMLParser Int
parseInt = do
  el <- currentElement
  case reads (X.strContent el) of
    [(v,"")] -> return v
    _ -> throwParseError "invalid int"

parseBool :: XMLParser Bool
parseBool = do
  el <- currentElement
  case map toLower (X.strContent el) of
    ('t':_) -> return True
    ('f':_) -> return False
    _ -> throwParseError "invalid bool" 

currentElement :: XMLParser X.Element
currentElement = liftM celement ask

currentTag :: XMLParser String
currentTag = (X.qName.X.elName) `fmap` currentElement

checkTag :: String -> XMLParser ()
checkTag s = do
    tag <- currentTag
    when (tag /= s) (throwParseError $ "expected " ++ s)

withChild :: X.Element -> XMLParser a -> XMLParser a
withChild elc pa = local envf pa
  where envf (Env el ctx) = (Env elc (el:ctx))

withSingleChild :: XMLParser a -> XMLParser a
withSingleChild pa = do
    el <- currentElement
    case X.elChildren el of
      [] -> throwParseError "expected a child"
      [elc] -> withChild elc pa
      _ -> throwParseError "expected a single child"

withNamedChild :: String -> XMLParser a -> XMLParser a
withNamedChild tag pa = do
    el <- currentElement
    case X.findChild (X.blank_name{X.qName=tag}) el of
        Nothing -> throwParseError $ tag ++ " not found"
        (Just elc) -> withChild elc pa

withOptionalNamedChild :: String -> a -> XMLParser a -> XMLParser a
withOptionalNamedChild tag defv pa = do
    el <- currentElement
    case X.findChild (X.blank_name{X.qName=tag}) el of
        Nothing -> return defv
        (Just elc) -> withChild elc pa

withNamedSubChild :: String -> XMLParser a -> XMLParser a
withNamedSubChild tag pa = withNamedChild tag (withSingleChild pa)

withEachChild :: XMLParser a -> XMLParser [a]
withEachChild p = do
    el <- currentElement
    mapM (\el -> withChild el p) (X.elChildren el)

parseAny :: String -> [(String,XMLParser a)] -> XMLParser a
parseAny etype choices = do
    tag <- currentTag
    case (lookup tag choices) of
      (Just p) -> p
      Nothing -> throwParseError ("Illegal tag '" ++ tag ++ "' for " ++ etype)

throwParseError :: String -> XMLParser a
throwParseError s = do
    ctx <- ask
    throwError $ "At context " ++ ctxString ctx ++ ": " ++ s
  where
    ctxString (Env el els) = intercalate "." $ map (X.qName.X.elName) $ reverse (el:els)

parsedateM :: String -> Maybe Day
parsedateM s = firstJust [ 
     parseTime defaultTimeLocale "%Y/%m/%d" s,
     parseTime defaultTimeLocale "%Y-%m-%d" s 
     ]

firstJust ms = case dropWhile (==Nothing) ms of
    [] -> Nothing
    (md:_) -> md