module Internal.History
  ( readHistStmt
  , readHistTransfer
  , insertHistory
  , splitHistory
  )
where

import Control.Monad.Except
import Data.Csv
import Data.Foldable
import Database.Persist ((=.))
import Database.Persist.Monad hiding (get)
import Internal.Database
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
import qualified RIO.ByteString.Lazy as BL
import RIO.FilePath
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import RIO.State
import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V

-- readHistory
--   :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
--   => FilePath
--   -> [History]
--   -> m [(CommitR, [DeferredTx])]
-- readHistory root hs = do
--   let (ts, ss) = splitHistory hs
--   ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
--   ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss
--   return $ ts' ++ ss'

readHistTransfer
  :: (MonadInsertError m, MonadFinance m)
  => HistTransfer
  -> m [Tx CommitR]
readHistTransfer
  m@Transfer
    { transFrom = from
    , transTo = to
    , transCurrency = u
    , transAmounts = amts
    } =
    whenHash0 CTManual m [] $ \c -> do
      bounds <- askDBState kmStatementInterval
      let curRes = lookupCurrency u
      let go Amount {amtWhen, amtValue, amtDesc} = do
            let dayRes = liftExcept $ expandDatePat bounds amtWhen
            (days, cur) <- combineError dayRes curRes (,)
            let tx day = txPair c day from to cur amtValue amtDesc
            return $ fmap tx days
      concat <$> mapErrors go amts

readHistStmt
  :: (MonadUnliftIO m, MonadFinance m)
  => FilePath
  -> Statement
  -> m (Either CommitR [Tx CommitR])
readHistStmt root i = eitherHash CTImport i return $ \c -> do
  bs <- readImport root i
  bounds <- askDBState kmStatementInterval
  return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs

splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
  where
    go (HistTransfer x) = Left x
    go (HistStatement x) = Right x

insertHistory
  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
  => [EntryBin]
  -> m ()
insertHistory hs = do
  (toUpdate, toInsert) <- balanceTxs hs
  mapM_ updateTx toUpdate
  forM_ (groupKey commitRHash $ (\x -> (itxCommit x, x)) <$> toInsert) $
    \(c, ts) -> do
      ck <- insert c
      mapM_ (insertTx ck) ts

--------------------------------------------------------------------------------
-- low-level transaction stuff

-- TODO tags here?
txPair
  :: CommitR
  -> Day
  -> AcntID
  -> AcntID
  -> CurrencyPrec
  -> Double
  -> T.Text
  -> Tx CommitR
txPair commit day from to cur val desc =
  Tx
    { txDescr = desc
    , txDate = day
    , txCommit = commit
    , txPrimary =
        EntrySet
          { esTotalValue = -(roundPrecisionCur cur val)
          , esCurrency = cur
          , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
          , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
          }
    , txOther = []
    }
  where
    entry a =
      Entry
        { eAcnt = a
        , eValue = ()
        , eComment = ""
        , eTags = []
        }

-- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR)
-- resolveTx t@Tx {txEntries = ss} =
--   (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss

insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do
  let anyDeferred = any (isJust . feDeferred) ss
  k <- insert $ TransactionR c d e anyDeferred
  mapM_ (insertEntry k) ss

updateTx :: MonadSqlQuery m => UEBalanced -> m ()
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]

--------------------------------------------------------------------------------
-- Statements

-- TODO this probably won't scale well (pipes?)
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
  let ores = compileOptions stmtTxOpts
  let cres = combineErrors $ compileMatch <$> stmtParsers
  (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
  let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
  records <- L.sort . concat <$> mapErrorsIO readStmt paths
  fromEither =<< runExceptT (matchRecords compiledMatches records)
  where
    paths = (root </>) <$> stmtPaths

readImport_
  :: MonadUnliftIO m
  => Natural
  -> Word
  -> TxOptsRe
  -> FilePath
  -> m [TxRecord]
readImport_ n delim tns p = do
  res <- tryIO $ BL.readFile p
  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
  case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
    Left m -> throwIO $ InsertException [ParseError $ T.pack m]
    Right (_, v) -> return $ catMaybes $ V.toList v
  where
    opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
    skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10

-- TODO handle this better, this maybe thing is a hack to skip lines with
-- blank dates but will likely want to make this more flexible
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
  d <- r .: T.encodeUtf8 toDate
  if d == ""
    then return Nothing
    else do
      a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
      e <- r .: T.encodeUtf8 toDesc
      os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
      d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
      return $ Just $ TxRecord d' a e os p

matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> InsertExceptT m [Tx ()]
matchRecords ms rs = do
  (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
  case (matched, unmatched, notfound) of
    (ms_, [], []) -> return ms_
    (_, us, ns) -> throwError $ InsertException [StatementError us ns]

matchPriorities :: [MatchRe] -> [MatchGroup]
matchPriorities =
  fmap matchToGroup
    . L.groupBy (\a b -> spPriority a == spPriority b)
    . L.sortOn (Down . spPriority)

matchToGroup :: [MatchRe] -> MatchGroup
matchToGroup ms =
  uncurry MatchGroup $
    first (L.sortOn spDate) $
      L.partition (isJust . spDate) ms

data MatchGroup = MatchGroup
  { mgDate :: ![MatchRe]
  , mgNoDate :: ![MatchRe]
  }
  deriving (Show)

data Zipped a = Zipped ![a] ![a]

data Unzipped a = Unzipped ![a] ![a] ![a]

initZipper :: [a] -> Zipped a
initZipper = Zipped []

resetZipper :: Zipped a -> Zipped a
resetZipper = initZipper . recoverZipper

recoverZipper :: Zipped a -> [a]
recoverZipper (Zipped as bs) = reverse as ++ bs

zipperSlice
  :: (a -> b -> Ordering)
  -> b
  -> Zipped a
  -> Either (Zipped a) (Unzipped a)
zipperSlice f x = go
  where
    go z@(Zipped _ []) = Left z
    go z@(Zipped bs (a : as)) =
      case f a x of
        GT -> go $ Zipped (a : bs) as
        EQ -> Right $ goEq (Unzipped bs [a] as)
        LT -> Left z
    goEq z@(Unzipped _ _ []) = z
    goEq z@(Unzipped bs cs (a : as)) =
      case f a x of
        GT -> goEq $ Unzipped (a : bs) cs as
        EQ -> goEq $ Unzipped bs (a : cs) as
        LT -> z

zipperMatch
  :: MonadFinance m
  => Unzipped MatchRe
  -> TxRecord
  -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
zipperMatch (Unzipped bs cs as) x = go [] cs
  where
    go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
    go prev (m : ms) = do
      res <- matches m x
      case res of
        MatchFail -> go (m : prev) ms
        skipOrPass ->
          let ps = reverse prev
              ms' = maybe ms (: ms) (matchDec m)
           in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)

zipperMatch'
  :: MonadFinance m
  => Zipped MatchRe
  -> TxRecord
  -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
zipperMatch' z x = go z
  where
    go (Zipped bs (a : as)) = do
      res <- matches a x
      case res of
        MatchFail -> go (Zipped (a : bs) as)
        skipOrPass ->
          return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
    go z' = return (z', MatchFail)

matchDec :: MatchRe -> Maybe MatchRe
matchDec m = case spTimes m of
  Just 1 -> Nothing
  Just n -> Just $ m {spTimes = Just $ n - 1}
  Nothing -> Just m

matchAll
  :: MonadFinance m
  => [MatchGroup]
  -> [TxRecord]
  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchAll = go ([], [])
  where
    go (matched, unused) gs rs = case (gs, rs) of
      (_, []) -> return (matched, [], unused)
      ([], _) -> return (matched, rs, unused)
      (g : gs', _) -> do
        (ts, unmatched, us) <- matchGroup g rs
        go (ts ++ matched, us ++ unused) gs' unmatched

matchGroup
  :: MonadFinance m
  => MatchGroup
  -> [TxRecord]
  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
  (md, rest, ud) <- matchDates ds rs
  (mn, unmatched, un) <- matchNonDates ns rest
  return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)

matchDates
  :: MonadFinance m
  => [MatchRe]
  -> [TxRecord]
  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchDates ms = go ([], [], initZipper ms)
  where
    go (matched, unmatched, z) [] =
      return
        ( catMaybes matched
        , reverse unmatched
        , recoverZipper z
        )
    go (matched, unmatched, z) (r : rs) =
      case zipperSlice findDate r z of
        Left zipped -> go (matched, r : unmatched, zipped) rs
        Right unzipped -> do
          (z', res) <- zipperMatch unzipped r
          let (m, u) = case res of
                (MatchPass p) -> (Just p : matched, unmatched)
                MatchSkip -> (Nothing : matched, unmatched)
                MatchFail -> (matched, r : unmatched)
          go (m, u, z') rs
    findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m

matchNonDates
  :: MonadFinance m
  => [MatchRe]
  -> [TxRecord]
  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchNonDates ms = go ([], [], initZipper ms)
  where
    go (matched, unmatched, z) [] =
      return
        ( catMaybes matched
        , reverse unmatched
        , recoverZipper z
        )
    go (matched, unmatched, z) (r : rs) = do
      (z', res) <- zipperMatch' z r
      let (m, u) = case res of
            MatchPass p -> (Just p : matched, unmatched)
            MatchSkip -> (Nothing : matched, unmatched)
            MatchFail -> (matched, r : unmatched)
       in go (m, u, resetZipper z') rs

balanceTxs
  :: (MonadInsertError m, MonadFinance m)
  => [EntryBin]
  -> m ([UEBalanced], [InsertTx])
balanceTxs ebs =
  first concat . partitionEithers . catMaybes
    <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
  where
    go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
    go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
      modify $ mapAdd_ (reAcnt, reCurrency) reValue
      return Nothing
    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) =
      let res0 = balanceEntrySet (\_ _ v -> return v) txPrimary
          resN = mapErrors (balanceEntrySet primaryBalance) txOther
       in combineError res0 resN $ \e es ->
            -- TODO repacking a Tx into almost the same record seems stupid
            Just $
              Right $
                InsertTx
                  { itxDescr = txDescr
                  , itxDate = txDate
                  , itxEntries = concat $ e : es
                  , itxCommit = txCommit
                  }
    primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v

binDate :: EntryBin -> Day
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
binDate (ToRead ReadEntry {reDate}) = reDate
binDate (ToInsert Tx {txDate}) = txDate

type EntryBals = M.Map (AccountRId, CurrencyRId) Rational

data UpdateEntryType a
  = UET_ReadOnly UE_RO
  | UET_Unk UEUnk
  | UET_Linked a

-- TODO make sure new values are rounded properly here
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceEntrySet
  UpdateEntrySet
    { utFrom0
    , utTo0
    , utPairs
    , utFromUnk
    , utToUnk
    , utFromRO
    , utToRO
    , utCurrency
    , utToUnkLink0
    , utTotalValue
    } =
    do
      (f0val, (tpairs, fs)) <-
        fmap (second partitionEithers) $
          foldM goFrom (utTotalValue, []) $
            L.sortOn idx $
              (UET_ReadOnly <$> utFromRO)
                ++ (UET_Unk <$> utFromUnk)
                ++ (UET_Linked <$> utPairs)
      let f0 = utFrom0 {ueValue = StaticValue f0val}
      let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
      (t0val, tsUnk) <-
        fmap (second catMaybes) $
          foldM goTo (-utTotalValue, []) $
            L.sortOn idx2 $
              (UET_Linked <$> (tpairs ++ tsLink0))
                ++ (UET_Unk <$> utToUnk)
                ++ (UET_ReadOnly <$> utToRO)
      let t0 = utTo0 {ueValue = StaticValue t0val}
      return (f0 : fs ++ (t0 : tsUnk))
    where
      project f _ _ (UET_ReadOnly e) = f e
      project _ f _ (UET_Unk e) = f e
      project _ _ f (UET_Linked p) = f p
      idx = project ueIndex ueIndex (ueIndex . fst)
      idx2 = project ueIndex ueIndex ueIndex
      -- TODO the sum accumulator thing is kinda awkward
      goFrom (tot, es) (UET_ReadOnly e) = do
        v <- updateFixed e
        return (tot - v, es)
      goFrom (tot, esPrev) (UET_Unk e) = do
        v <- updateUnknown e
        return (tot - v, Right e {ueValue = StaticValue v} : esPrev)
      goFrom (tot, esPrev) (UET_Linked (e0, es)) = do
        v <- updateUnknown e0
        let e0' = Right $ e0 {ueValue = StaticValue v}
        let es' = fmap (Left . unlink (-v)) es
        return (tot - v, (e0' : es') ++ esPrev)
      goTo (tot, esPrev) (UET_ReadOnly e) = do
        v <- updateFixed e
        return (tot - v, esPrev)
      goTo (tot, esPrev) (UET_Linked e) = do
        v <- updateFixed e
        return (tot - v, Just e : esPrev)
      goTo (tot, esPrev) (UET_Unk e) = do
        v <- updateUnknown e
        return (tot - v, Just e {ueValue = StaticValue v} : esPrev)
      updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
      updateFixed e = do
        let v = unStaticValue $ ueValue e
        modify $ mapAdd_ (ueAcnt e, utCurrency) v
        return v
      updateUnknown e = do
        let key = (ueAcnt e, utCurrency)
        curBal <- gets (M.findWithDefault 0 key)
        let v = case ueValue e of
              EVPercent p -> p * curBal
              EVBalance p -> p - curBal
        modify $ mapAdd_ key v
        return v
      unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}

balanceEntrySet
  :: (MonadInsertError m, MonadFinance m)
  => (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational)
  -> DeferredEntrySet v
  -> StateT EntryBals m [KeyEntry]
balanceEntrySet
  findTot
  EntrySet
    { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
    , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
    , esTotalValue
    } =
    do
      -- 1. Resolve tag and accout ids in primary entries since we (might) need
      --    them later to calculate the total value of the transaction.
      let f0res = resolveAcntAndTags f0
      let t0res = resolveAcntAndTags t0
      combineErrorM f0res t0res $ \f0' t0' -> do
        -- 2. Compute total value of transaction using the primary debit entry
        tot <- liftInnerS $ findTot f0' curID esTotalValue

        -- 3. Balance all debit entries (including primary). Note the negative
        --    indices, which will signify them to be debit entries when updated
        --    later.
        let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
        fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1))

        -- 4. Build an array of debit values be linked as desired in credit entries
        let fv = V.fromList $ fmap (eValue . feEntry) fs'

        -- 4. Balance credit entries (including primary) analogously.
        let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
        ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
        return $ fs' ++ ts'

doEntries
  :: (MonadInsertError m)
  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
  -> CurrencyRId
  -> Rational
  -> Entry AccountRId AcntSign TagRId
  -> [Entry AcntID v TagID]
  -> NonEmpty Int
  -> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
doEntries f curID tot e es (i0 :| iN) = do
  es' <- mapErrors (uncurry f) $ zip iN es
  let e0val = tot - entrySum es'
  -- TODO not dry
  let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack
  modify (mapAdd_ (eAcnt e, curID) tot)
  let e' =
        InsertEntry
          { feEntry = e {eValue = s * e0val}
          , feCurrency = curID
          , feDeferred = Nothing
          , feIndex = i0
          }
  return $ e' : es'
  where
    entrySum = sum . fmap (eValue . feEntry)

liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
liftInnerS = mapStateT (return . runIdentity)

balanceLinked
  :: MonadInsertError m
  => Vector Rational
  -> CurrencyRId
  -> Natural
  -> AccountRId
  -> LinkDeferred Rational
  -> StateT EntryBals m (Rational, Maybe DBDeferred)
balanceLinked from curID precision acntID lg = case lg of
  (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
    let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
    case res of
      Just v -> return (v, Just $ EntryLinked lngIndex $ toRational lngScale)
      -- TODO this error would be much more informative if I had access to the
      -- file from which it came
      Nothing -> throwError undefined
  (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
  where
    go s = roundPrecision precision . (* s) . fromRational

balanceDeferred
  :: CurrencyRId
  -> AccountRId
  -> EntryValue Rational
  -> State EntryBals (Rational, Maybe DBDeferred)
balanceDeferred curID acntID (EntryValue t v) = do
  newval <- findBalance acntID curID t v
  let d = case t of
        TFixed -> Nothing
        TBalance -> Just $ EntryBalance v
        TPercent -> Just $ EntryPercent v
  return (newval, d)

balanceEntry
  :: (MonadInsertError m, MonadFinance m)
  => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
  -> CurrencyRId
  -> Int
  -> Entry AcntID v TagID
  -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
  let acntRes = lookupAccount eAcnt
  let tagRes = mapErrors lookupTag eTags
  combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
    let s = fromIntegral $ sign2Int sign
    (newVal, deferred) <- f acntID eValue
    modify (mapAdd_ (acntID, curID) newVal)
    return $
      InsertEntry
        { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
        , feCurrency = curID
        , feDeferred = deferred
        , feIndex = idx
        }

resolveAcntAndTags
  :: (MonadInsertError m, MonadFinance m)
  => Entry AcntID v TagID
  -> m (Entry AccountRId AcntSign TagRId)
resolveAcntAndTags e@Entry {eAcnt, eTags} = do
  let acntRes = lookupAccount eAcnt
  let tagRes = mapErrors lookupTag eTags
  -- TODO total hack, store account sign in the value field so I don't need to
  -- make seperate tuple pair thing to haul it around. Weird, but it works.
  combineError acntRes tagRes $
    \(acntID, sign, _) tags -> e {eAcnt = acntID, eTags = tags, eValue = sign}

findBalance
  :: AccountRId
  -> CurrencyRId
  -> TransferType
  -> Rational
  -> State EntryBals Rational
findBalance acnt cur t v = do
  curBal <- gets (M.findWithDefault 0 (acnt, cur))
  return $ case t of
    TBalance -> v - curBal
    TPercent -> v * curBal
    TFixed -> v

-- -- reimplementation from future version :/
-- mapAccumM
--   :: Monad m
--   => (s -> a -> m (s, b))
--   -> s
--   -> [a]
--   -> m (s, [b])
-- mapAccumM f s xs = foldrM go (s, []) xs
--   where
--     go x (s', acc) = second (: acc) <$> f s' x