content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE NoMonomorphismRestriction #-}
  {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
  module Buchhaltung.Uniques
  where
  
  import           Buchhaltung.Common
  import           Control.Arrow hiding (loop)
  import           Control.Monad.RWS.Strict
  import           Control.Monad.Trans.Cont
  import           Data.Function
  import           Data.List
  import qualified Data.ListLike as L
  import qualified Data.ListLike.String as L
  import qualified Data.Map as M
  import           Data.Ord
  import qualified Data.Text as T
  import qualified Data.Text.IO as T
  import qualified Data.Text.Lazy as TL
  import           Data.Time.Calendar
  import           Debug.Trace
  import           Formatting as F
  import qualified Formatting.ShortFormatters as F
  import           Hledger.Data
  import           System.IO
  import           Text.EditDistance
  import qualified Text.PrettyPrint.Boxes as P
  import           Text.Printf
  
  -- | The monad stack
  type M r m = ContT r (RWST () () (M.Map KeyIx (Aged Entry)) m)
    
  data Aged a = Aged { getAge :: Age
                     , unAged :: a
                     }
    deriving Show
  
  data Age = Old | New
    deriving (Show, Eq)
  
  -- | the key that is used to compare transactions. The Int is a
  -- counter, to ensure there are no actual duplicates in the
  -- map and to be able to update entries.
  --
  -- Duplicates are then found by extraction of a key range using
  -- 'M.split'. See 'findDuplicates'.
  type Key = ([(CommoditySymbol,Quantity)], AccountName, Day)
  type KeyIx = (Key, Int) 
  
  
  -- | Takes a list of new entries, removes duplicates or updates
  -- existing transactions and adds new entries.
  addNewEntriesToJournal :: (MonadIO m, MonadReader (Options user Config env) m)
         => [FilledEntry]
            -- ^ new candidates including entries already existing in
            -- journal possible duplicates
         -> Journal
         -> m [Entry]
  addNewEntriesToJournal newTxs journal = do
    tag <- askTag
    let toKeyVal i tx = ((deriveKey tx, i)
                        , Aged Old $ ImportedEntry tx () $
                          wSource <$> extractSource tag tx)
    fmap (fmap unAged . M.elems . fst)
      <$> execRWST (evalContT $ callCC $ \exit -> zipWithM_
                     (loop exit $ length newTxs) [1..] newTxs)
      () $ M.fromList $ zipWith toKeyVal [1..] $ jtxns journal
  
  -- | Derive a key from a transaction and an index
  deriveKey :: Transaction -> Key
  deriveKey tx = (compAmount $ pamount p, paccount p, tdate tx)
    where compAmount (Mixed am) = sort $ fmap (acommodity &&& aquantity) am
          p = head $ tpostings tx
  
  -- | loop through all existing possible duplicates of a new
  -- transaction
  loop :: (MonadIO m, MonadReader (Options user Config env) m)
       => (() -> M r m ())
       -> Int -> Int -> FilledEntry -> M r m ()
  loop exit totalTx iTx new = do
    let msg = format ("Transaction: "%F.d%" of "%F.d%" new\n") iTx totalTx
    dups <- findFuzzy $ ieT new
    checkOrAsk exit new msg
      $ sortBy (flip $ comparing snd) $ (id &&& distance) <$> dups
      where distance (_, y) =
              -- careful: the negate is fmapped over the Maybe value
              -- which changes the relative order between Nothing and
              -- Justs.
              negate . on
              (restrictedDamerauLevenshteinDistance defaultEditCosts)
              (TL.unpack . json)  (ieSource new)
              <$> (eitherToMaybe $ ieSource $ unAged y)
  
  eitherToMaybe :: Either b a -> Maybe a
  eitherToMaybe = either (const Nothing) Just
  
  -- | Find all duplicates for a given key
  findDuplicates :: Monad m => Key -> M r m [(KeyIx,Aged Entry)]
  findDuplicates key@(ams,acc,day) = lift $ gets $ \old ->
     let later = snd $ M.split (key,0) old in
     M.toList $ fst $ M.split ((ams,acc,addDays 1 day),0) later
  
  findFuzzy :: Monad m => Transaction -> M r m [(KeyIx,Aged Entry)]
  findFuzzy = fmap concat . mapM (findDuplicates . deriveKey) . alternatives
    where alternatives x = [x] ++ conditionalDateShift x
          conditionalDateShift tx = if paccount (head (tpostings tx)) == "Aktiva:Konten:Comdirect:Visa"
            then map (\s -> tx { tdate = addDays s $ tdate tx }) [-1,1]
            else []
  
  -- | check single new entry against a list of conflict
  -- candidates, and insert new entry (if list is empty), or keep old
  -- entry (if identical to new one), or ask weither to modify old entry
  -- or insert new entry.
  checkOrAsk :: (MonadIO m, MonadReader (Options user Config env) m)
             => (() -> M r m ())
             -> FilledEntry
             -> TL.Text -- ^ message
             -> [((KeyIx, Aged Entry), Maybe Int)] -> M r m ()
  checkOrAsk _ new _ []  = do
    newIx <- gets $ \old -> M.size old + 1
    modify $ uncurry M.insert $ ((deriveKey $ ieT new, newIx), Aged New $ fromFilled new)
    liftIO $ T.putStrLn "\nSaved new transaction.\n"
  checkOrAsk exit new msg (( (oldKey, oldEntry), cost):remaining) = do
    if getAge oldEntry == Old && cost == Just 0
      then return () -- do nothing, i.e. use old unchanged
      else if False && cost > Just ( - 98)
              && on (==) (tdate.ieT) (unAged oldEntry) (fromFilled new)
           then do
        -- liftIO $ do print (fst new) >> print (oldKey)
        --             print (tdate.ieT.snd $ new) >> print (tdate.ieT $ oldEntry)
        --             print (ieSource.snd $ new) >> print (ieSource $ oldEntry)
      overwriteOldSource
      else do
      let question = (answer =<<) . liftIO $ do
            L.putStr $ L.unlines
              [ prettyPrint cost new oldEntry msg $ length remaining
              , "Yes, they are duplicates. Update the source [y]"
              , "No, " <> (if null remaining then "Save as new transaction"
                           else "Show next duplicate") <> " [n]"
              , "Skip this new transaction [q]"
              , "Skip this and all remaining transactions [Q]"
              , "Your answer:" ]
            hSetBuffering stdin NoBuffering
            getChar <* putStrLn ""
          answer 'y' = overwriteOldSource
          answer 'n' = checkOrAsk exit new msg remaining
          answer 'q' = return ()
          answer 'Q' = exit ()
          answer _   = question
      question
    where
      overwriteOldSource = lift $ do
            tag <- lift $ askTag
            modify $ M.adjust (applyChanges tag new (deriveKey $ ieT new) $ fst oldKey) oldKey
            liftIO $ T.putStrLn "\nUpdated duplicate's source.\n"
  
  prettyPrint :: Maybe Int -> FilledEntry -> Aged Entry -> TL.Text -- ^ Message
              -> Int -- ^ Remaining
              -> T.Text
  prettyPrint cost new (Aged age old) msg remain =
        let union2 = f . second unzip . unzip . M.toList $ M.mergeWithKey g
              (fmap $ flip (,) "<empty>") (fmap $ (,) "<empty>")
              (either (const mempty) sourceToMap $ oldSource)
              $ sourceToMap $ ieSource new
            g _ x y | x == y = Just $ (x, "")
                    | True   = Just $ (x, y)
            f (k,(old,new)) = T.pack $ P.render
              $ table [20, 25, 25] header [k, old, new]
            oldName Old = "Old"
            oldName New = "Imported earlier"
            header = ["Field", oldName age, "New"]
            oldSource = ieSource old
            showError (Left x) = [""
                                 ,"Error retrieving old transaction's source:"
                                 , T.pack x]
            showError (Right _) = []
            def _ Nothing = "n.a."
            def f (Just x) = f x
          in
          L.unlines $
          [ union2 ]
          ++ [ sformat
               ("changes: "%F.s%"/"%F.s%"\n"%F.t%"Remaining existing duplicates: "%F.d)
               (def (show . negate) cost)
               (def (show . TL.length . json) $ eitherToMaybe $ ieSource old)
               msg
               remain
             ]
          ++ showError oldSource
  
  
  applyChanges :: ImportTag -> FilledEntry -> Key -- ^ new key
               -> Key -- ^ old key
               -> Aged Entry -> Aged Entry
  applyChanges tag newEntry (ams2,acc2,day2) (ams1, acc1, _) oldEntry =
    if (ams2,acc2) /= (ams1,acc1) then
      error $ unlines ["Change not supported: "
                      , show newEntry
                      , show oldEntry]
   else Aged New $ (unAged oldEntry){
      ieT= (injectSource tag (ieSource newEntry)
             $ ieT $ unAged oldEntry){tdate = day2} }
  