{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
module Buchhaltung.Add (add)
where

import           Buchhaltung.Ask
import           Buchhaltung.Common
import           Buchhaltung.ZipEdit2 as ZE
import           Buchhaltung.Zipper
import           Control.Applicative
import           Control.Arrow
import           Control.Monad.RWS.Strict
import           Data.Bits
import           Data.Char
import           Data.Decimal
import           Data.Default
import           Data.Either
import           Data.Foldable
import           Data.Function
import qualified Data.HashMap.Strict as HM
import           Data.List
import qualified Data.List.NonEmpty as E
import qualified Data.ListLike as L
import qualified Data.ListLike.String as L
import qualified Data.Map as M
import           Data.Maybe
import           Data.Monoid ((<>))
import           Data.Ord
import qualified Data.Set as S
import           Data.String
import qualified Data.Text as T
import           Data.Time.Calendar
import           Data.Time.Clock
import           Data.Time.Format
import           Formatting (sformat, (%), (%.))
import qualified Formatting as F
import qualified Formatting.ShortFormatters as F
import           Hledger hiding (at)
import           Safe
import qualified Text.Megaparsec as MP hiding (State)
import qualified Text.Megaparsec.Text as MP
import           Text.Parsec.Char
import           Text.Parsec.Combinator (eof,many1)
import           Text.Parsec.Prim (parse,try)
import           Text.Parsec.String
import           Text.Printf
import           Text.Read (readEither)

-- DONE: clear an entry without entering a new one
-- TODO: percentage entry with memory
-- TODO: other ways to find uncleared transactions (e.g. by account)
-- DONE cancel unsuccesful search (and do ot force start of transaction entry)
-- TODO: do not propose transfer accounts?
-- TODO: change (existing) titles to include account
-- TODO: insert assertions? (for geldbeutetl or automatic for hbci)
-- TODO: check assertions (gegenseitige schulden)
-- TODO: do not jump to next suggestion (only after half)
-- TODO: betrag vorschlagen mit history? oder siehen nächstes
-- TODO: möglichenkeiten der eingabe von beträgen für beide parteien gleichzeitig
-- TODO: keine kontonamen in falscher reihenfolge vorschlagen

-- DONE in 8fbbc34: BUG: discard stil marks as cleared

-- * Types

type AddT' env m = RWST (FullOptions env) () Journal (ErrorT m)


-- | Monad Transformer used to describe the 'add' program
--
-- The 'add' specific environment, that can contain a partner user

type AddOptions = FullOptions [Partner]

type AddT m = AddT' [Partner] m


data Partner = Partner
  { pUser :: User
  , partnerAccount :: AccountName
    -- ^ partner's receivable/payable account in the user's ledger
  , userAccount :: AccountName
    -- ^ user's receivable/payable account in the partner's ledger
  , partnerLedger :: FilePath
    -- ^ partner's ledger
  }
             deriving (Show, Eq)

-- | Extract partner information from the env and throw errors if there are any
-- readPartner :: (MonadReader AddOptions m, MonadError Msg m)
--             => (Partner -> a) -> m (Maybe a)
-- readPartner f = reader $ fmap f . oEnv

-- -- | Extract partner user
partners
  :: (MonadReader AddOptions m, MonadError Msg m) => m [Partner]
partners = reader oEnv

-- * Entry point

add :: AddT' [Username] IO ()
add = do
  partner <- mapM (toPartner <=< lookupUser) =<< reader oEnv
  liftIO . putStr =<< hello
  withRWST (\r s -> (r{oEnv = partner}, s)) $ do
    forever mainLoop

-- | Convert given 'Username' to 'Partner'.
toPartner :: Monad m => User -> AddT' env m Partner
toPartner part = do
  Partner part
    <$> receivablePayable True  part
    <*> receivablePayable False part
    <*> maybeThrow msg ($ name part) return (addedByOthers $ ledgers part)
  where msg = "ledgers.addedByOthers not configured for '"%F.sh%"'"


-- | Welcome message
hello :: Monad m => AddT' env m String
hello = do
  un <- readUser name
  j <- get
  return $ intercalate "\n\n" [
    "Hi "<> fshow un <> "!"
    ,"Use readline keys to edit, use tab key to complete account names."
    ,"A code (in parentheses) may be entered following transaction dates."
    ,"A comment may be entered following descriptions or amounts."
    , show ( length $ jtxns j) ++ " Transactions found"
    ]


-- | main user interaction loop
mainLoop :: AddT IO ()
mainLoop = do
  liftIO $ putStr "\n\nStarting new transaction...\n"
  (iAm, match) <- sugTrans
  let ask j = do iDa <- askDate Nothing
                 iDe <- askDescription Nothing
                 iAc <- myAskAccount j Nothing (Just "learn") (Left "Enter source account" )
                 return (nulltransaction{tdate=fst iDa, tcode=snd iDa
                                        ,tdescription=iDe}
                        ,iAc,iAm)
      useMatch t = return ( nulltransaction{tdate=tdate t,
                                            tdescription=tdescription t}
                          ,paccount p2, AA "" Nothing $ negate $ pamount p2)
        where _:(p2:_) =  tpostings t
        --                   ,paccount p3, ("",negate $ pamount p3))
        -- where p3 = fromMaybe (pos!!2) $ asum $
        --            (\x -> return x <$> extractSource "HBCI" (pcomment x)) <$> pos
        --       pos = tpostings t
  -- PROBLEM1: it's not HBCI, instead sugTrans and clearSecondPosting
  -- emphazises on the "second" posting
  (transa,iAc,iAm2) <- maybe (get >>= liftIO . ask) useMatch match
  suggs <- suggestedPostings iAc $ Just iAm2
  result <- edit myEd transa suggs moveToNextEmpty
  saveAndClear match (isJust result) =<< finishTransaction True result

-- | Saves transaction into the designated ledgers files of each user,
-- and clears the transaction tht was matched (conditional on a 'Bool'
-- argument)
saveAndClear :: Maybe Transaction
             -- ^ matching transaction for clearing
             -> Bool -- ^ clear the matching transactions
             ->   (Maybe Transaction, [(Partner, Transaction)])
             -- ^ transactioons to be saved: ((user's,other's),
             -> AddT IO ()
saveAndClear match clearIt (userT, partnerTS)  = do
  j <- get
  let saveMine Nothing = clear j
      saveMine (Just res) = do
        -- clear the first posting, of the new transaction, if there was a
        -- match -- ReferenceA
        let newt = (if isJust match then clearNthPosting 0 else id) res
        -- add it to the user's journal (+ file)
        file <- readLedger addedByThisUser
        j' <- myJournalAddTransaction file [newt]
        infoNewTx =<< user
        -- clear the matching transactions second posting in the file
        clear j'
      clear j =  maybe (return j)
        (saveChanges . changeTransaction .
          (:[]) . clearSecondPosting) $ guard clearIt *> match
      savePartners (partner, tx) = do
        myJournalAddTransaction (partnerLedger partner) [tx]
        infoNewTx $ pUser partner
  j' <- saveMine userT
  mapM savePartners partnerTS
  put j'


clearSecondPosting :: Transaction -> (Transaction, Transaction)
clearSecondPosting t = (t, clearNthPosting 1 t)


infoNewTx = liftIO . L.putStr .
  sformat ("\nNew transaction created for '" %F.sh% "'\n") . name

-- | Split 'EditablePosting's in User's Postings and (Partner,
-- Postings, Open Balance)
split :: [EditablePosting] -> ([Posting],
                               [(Partner, E.NonEmpty Posting, MixedAmount)])
split = second (fmap h . E.groupBy (on (==) fst))
        . partitionEithers . mapMaybe f
  where
    f :: EditablePosting -> Maybe (Either Posting (Partner, Posting))
    f x = either (const Left) ((Right .) . (,)) (present $ epUser x)
          <$> epPosting x
    h :: E.NonEmpty (Partner, Posting)
      -> (Partner, E.NonEmpty Posting, MixedAmount)
    h x = (fst $ E.head x, snd <$> x, sum $ pamount . snd <$> x)

-- | generate the main and possibly the other users' transactions
finishTransaction :: (MonadIO m, MonadReader AddOptions m)
                  =>  Bool
                     -- ^ require balanced transactions
                  -> Maybe (Transaction, [EditablePosting])
                  -- ^ the transaction and postings to be combined
                  -> m (Maybe Transaction, [(Partner, Transaction)])
                  -- ^ (user's, partners') transactions
finishTransaction _ Nothing = return (Nothing, [])
finishTransaction check (Just (tr,postings)) = do
  time <- liftIO getCurrentTime
  us <- user
  let
    (userP, partnerPS) = split postings

    userT = if null x then Nothing else Just $ toTP x
      where x = userP ++ concatMap userTransfer partnerPS
    userTransfer (partner, _, sum) =
      nullP (partnerAccount partner) sum

    partnerT (partner, ps, sum) = (,) partner $
      toTP $ nullP (userAccount partner) (negate sum)
      ++ E.toList ps

    toTP ps = (if check then either err id . balanceTransactionIfRequired
              else id)
              tr {tpostings = increasePrec <$> ps ,tcomment = comment}

    nullP acc am = if isReallyZeroMixedAmount am then []
                   else [nullposting{paccount = acc
                                    ,pamount = am}]

    comment = sformat ("Entered on "%F.sh%" by 'buchhaltung' user "%F.sh)
      (iso8601 time) $ name us
    err = (error.("shit, it should be balanced, check source code\n\n"++))
    increasePrec p = p{pamount = setMixedAmountPrecision maxprecisionwithpoint
                        $ pamount p}
  return $ (userT, partnerT <$> partnerPS)

iso8601 :: UTCTime -> String
iso8601 = formatTime defaultTimeLocale "%FT%TZ"

-- | add transaction to ledger file
myJournalAddTransaction :: FilePath -> [Transaction] -> AddT IO Journal
myJournalAddTransaction relative trans = do
  file <- absolute relative
  liftIO $ ensureJournalFileExists file -- creates empty journal
  j <- get
  liftIO $ L.appendFile file
    $ "\n" <> intercalateL "\n\n" trans' <> "\n"
  return j{jtxns=jtxns j ++ trans }
  where trans' = L.dropWhileEnd (=='\n') . fshow <$> trans :: [T.Text]



clearNthPosting :: Int -> Transaction -> Transaction
clearNthPosting n t = t{tpostings=p'}
  where p' = modifyNth (\x -> x{pstatus=Cleared}) n $ tpostings t


-- * Transaction suggestions

data Asserted a = AA { aComment :: Comment
                   , aAssertion :: Maybe Amount
                   , aAmount :: a }
              deriving (Functor, Show)

instance Default AssertedAmount where
  def = AA "" Nothing $ mixed' nullamt

type AssertedAmount = Asserted MixedAmount

fromPosting :: Posting -> Asserted MixedAmount
fromPosting = AA <$> pcomment <*> pbalanceassertion <*> pamount

showAssertedAmount :: Asserted MixedAmount -> T.Text
showAssertedAmount a = showMixedAmount2 (aAmount a) <>
  maybe "" ((" = " <>) . showAmount2) (aAssertion a)


-- | Ask an amount, and return transactions matching the entered
-- amount
sugTrans :: AddT IO (AssertedAmount, Maybe Transaction)
sugTrans = sugTrans' . fmap negate =<< askAmount (Just def)
             "Enter amount (zero for any transaction)" Nothing
  where sugTrans' answ@AA{ aAmount = iAm, aAssertion = Nothing} = do
          accs <- S.fromList . HM.elems <$> askAccountMap
          user <- readUser id
          let
            f user Transaction{tpostings=p1:(p2:_)} =
              -- the first posting's account is part of the accounts
              -- automaticcaly handled by csv2ledger
              (paccount p1 `S.member` accs)
              -- the first amount of the first posting matched the entered
              -- amount in absolute values
              && (on (==) (abs.aquantity.head.amounts) iAm ( pamount p1 )
                  -- or the entered amount is zero
                  || mixed' nullamt == iAm
                  -- or the amount occurs in the comment of the second
                  || (comma.fshow.abs.aquantity.head.amounts $ iAm)
                  `L.isInfixOf` pcomment p2 )
              -- the second posting is not cleared
              && not (pstatus p2 == Cleared)
              -- doch nicht (siehe notiz vom [2013-06-02 Sun]):
              -- no transaction exists offsetting the second
              -- posting (e.g. for transactions entered, before they were
              -- paid)
              -- && fromMaybe True ( flip Set.notMember s <$>
              --     toMyP t p2{pamount=negate $ pamount p2})

              -- ignore certain accounts
              && (not $ isIgnored user $ paccount p2)
            f _ _ = False
              -- s :: S.Set MyPosting
              -- s = error "doch benutzt?" -- Set.fromList $ toMyPs =<< jtxns j
            comma = T.replace "." ","
            selectMatch :: [Transaction]
                        -> AddT IO (AssertedAmount, Maybe Transaction)
            selectMatch m = g =<< (liftIO $ choose $ show <$> m')
              where m' = take 20 $ sortBy (flip $ comparing tdate) m
                    g Manual = return (answ, Nothing)
                    g (Choose i) = return $ (answ, Just $ atNote "selectMatch" m' i)
                    g Reenter = sugTrans
          selectMatch =<< gets (filter (f user) . jtxns)
        sugTrans' a = return (a, Nothing)
-- data MyPosting = MyP {mypDay::Day, mypAcc::AccountName,mypAmt::Amount}
--                  deriving (Show)

-- toMyPs t = catMaybes [ toMyP t p  | p <- tpostings t ]

-- toMyP t p@Posting{pstatus=Uncleared} =
--   MyP (tdate t) (paccount p) <$> listToMaybe (amounts $ pamount p)
--                                                          --take only first amount
-- toMyP _ _ = Nothing


-- compareMyPs = comparing (acommodity.mypAmt) && (aquantity.mypAmt) && mypDay && mypAcc
--     where (&&) a b = a `Mo.mappend` comparing b
-- instance Ord MyPosting where
--   compare = compareMyPs
-- instance Eq MyPosting where
--   (==) =  (EQ==).:compareMyPs
-- (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
-- (.:) = (.) . (.)

data Choice = Reenter | Manual | Choose Int

-- | user input: choose one from a list of choices
choose :: [String] -- ^ choices
       -> IO Choice
choose [] = return Manual
choose m = do
  putStr $ unlines $ reverse $
    zipWith pr [1..] m
  putStr $ unlines
    [if null m then ""
      else printf "{number}: use one of the above %d transactions" len
    ,"'m': enter transaction manually"
    ,"'r': enter new amount to find existing transations"]
  either ((>> choose m) . print) return
    =<< parse (menup len)"menu parser" <$> getLine
  where pr n t = show n ++ ")\n" ++ t
        len = length m

menup :: Int -> Parser Choice
menup limit = stripP $
  try (try (char 'r' >> return Reenter)
        <|> (char 'm' >> return Manual))
  <|> do int <-pred . read <$> many1 digit
         if int < limit then return $ Choose int
           else fail "number too high"

stripP p = do r <- spaces >> p
              spaces >> eof >> return r


-- * Main editing loop

-- | combines everything into an 'EditorConf'
myEd :: EditorConf (AddT IO) EditablePosting Transaction
myEd =
  EC { getchar = Just myGetchar
     , ZE.display = dis
     , ecPrompt = const mainPrompt
     , actions = [
         ('c', ModifyAll clearTrans <> Done quiet
           ?? "Clear transaction")
         , ('n', ModifyAllM (addNewPosting False)   ?? "Add new posting")
         , ('N', ModifyAllM (addNewPosting True)
             ?? "Add new posting for next user")
         , ('r', ModifyAll (assignOpenBalance 1.0)
             ?? "Assign open balance to account")
         , ('h', ModifyAll (assignOpenBalance 2.0)
             ?? "Assign half of open balance to account")
         , ('x', Modify removeAmount   ?? "Remove current amount")
         , ('t', ModifyStateM editDescription  ?? "Edit title")
         , ('d', ModifyStateM editDate  ?? "Edit date")
           -- http://www.ledger-cli.org/3.0/doc/ledger3.html#Effective-Dates
           -- , ('D', ModifyStateM (editDate j)  ?? "Edit effective date")
         , ('e', ModifyAllM editCurAmount ?? "Edit current amount")
         , ('+', ModifyAllM
             (modifyCurAmount (\o n -> fmap (on (+) replaceMissing
                                             $ aAmount n) o) False)
             ?? "Add to amount")
         , ('j', Fwd    ?? "Move forward one item.")
         , ('k', Back   ?? "Move backward one item.")
         , ('Q', Cancel ?? "discard entry and Quit")
         , ('m', Modify setMissing ?? "set amount to 'missing'")
         , ('s', Done checkDone  ?? "Save entry")
         , ('c', Done checkDone  ?? "Save entry")
         , ('u', Modify nextNotFirst  ?? "Next user")
         , ('v', ModifyAll (assignOpenBalance (119/19)) ?? "Fill with VAT")
         , ('p', ModifyAllM
                 ((<$> liftIO askPercent) . flip assignOpenBalance)
                 ?? "Ask for percentage")
         ] ++ digitActions
     }
  where digitActions =
          [ (intToDigit n, ModifyAll (jumpTo n) ??
                  ("Edit account"++[intToDigit n])) | n <- [0..9] ]
        dis LS{userSt=tr,ctx=z} = do
          -- j <- get
          return $ L.replicate 60 '~' <> "\n\n"
            <> fromString (showTransaction tr)
            -- <> fshow (jparsedefaultcommodity j, jcommodities j, jinferredcommodities j)
            <> showEditablePosting z

mainPrompt :: (L.ListLike m item, IsString m) => m
mainPrompt =
  "\n" <> intercalateL "\n" ( intercalateL "   " <$> f) <> "\n"
  where f =
          [["[r]est ","[j]next","[u]ser ","[+]add","[t]itle","[?]Help  ","[s]ave    ","[p]%"]
          ,["[h]alf ","[k]prev","[n/N]ew","[e]dit","[d]ate ","[x]remove","[Q]discard","[v]AT"]
          ,["       ","       ","       ","[m]iss","       ","         ","[c]lear   ","      "]]

quiet :: Monad m => a -> m (Maybe a)
quiet = return . Just

-- | clear all postings
clearTrans :: Zipper EditablePosting -> Zipper EditablePosting
clearTrans = differentiate . fmap f . integrate'
  where f x  = x{epPosting=Nothing}

-- | change user of current posting, but not for the first posting
-- ReferenceA
nextNotFirst :: EditablePosting -> EditablePosting
nextNotFirst s | epNumber s > 0 = next s
               | otherwise = s

balanceTransactionIfRequired
  :: Transaction -> Either String Transaction
balanceTransactionIfRequired tx = do
  br <- mapM (balanceRequirement . ($ tx))
    [realPostings, balancedVirtualPostings]
  if not $ any required br then return tx
    else do
    when (not $ all possible br) $ throwError
      $ "Not implemented: this transaction has some postings that "
      ++ "need to be balanced while others cannot be balanced."
      ++ show br
    balanceTransaction Nothing tx

data Balancing = B { possible :: Bool
                   , required :: Bool
                   }
  deriving (Show)

-- | check, if the transaction should be passed through
-- `balanceTransaction` to infer missing amounts
balanceRequirement
  :: MonadError String m => [Posting] -> m Balancing
balanceRequirement [] = return $ B True False
balanceRequirement ps =
  if assignments > 0 then
    if length noAmount - assignments <= 1
    then return $ B False False
    else throwError $ "There cannot be more than one "
         ++ "posting with neither amount nor assertion"
  else return $ B True True
  where noAmount = filter hasAmount ps
        assignments = length $ filter
          (isJust . pbalanceassertion) noAmount

-- | Try to balance the transactions and present the final
-- transactions
checkDone :: LState EditablePosting Transaction ->
  AddT IO (Maybe  (LState EditablePosting Transaction))
checkDone st@LS{userSt = trans, ctx = postings} = do
  user <- user
  (userT, partnerT) <- finishTransaction False $ Just (trans, integrate postings)
  let
    txs :: [(User, Either String Transaction)]
    txs = second balanceTransactionIfRequired
        <$> maybeToList ((,) user <$> userT) ++ fmap (first pUser) partnerT
  res <- liftIO $ mapM g txs
  return$ if and res then Just st else Nothing
    where g (u,tx) = either (showR "ERROR" False u)
                     (showR "Balanced Transaction" True u . show) tx
          showR title ret user msg  = do
            L.putStrLn $ sformat
              ("#######  "%F.sh%":  "% (F.center 20 ' '%.F.s) %"   #######\n\n"%F.s%"\n")
              (name user) title msg
            return ret

-- * Asking (with completion)

askDescription :: Maybe T.Text -- ^ default
                  -> IO T.Text
askDescription = editLoop Right d Nothing Nothing (Left d)
  where d = "Title" :: IsString a => a

-- | uses 'dateandcodep'
askDate :: Maybe Day -- ^ default
           -> IO (Day, T.Text)
askDate def = do
  today <- getCurrentDay
  let
    defday = fromMaybe today def
    -- defday = either (error . ("cannot parse default date:\n"++) . show)
    --          (fixSmartDate today) $ (parse smartdate "" . lowercase) $ showDate today
    extract :: T.Text -> Either String (Day, T.Text)
    extract input = ("Date parsing error "++).show +++ first
                    (fixSmartDate today)
                     $ MP.runParser dateandcodep "" input
  editLoop extract "Date" (Just ((defday,""), fshow defday))
    complList (Left "Date") $ fshow <$> def
  where complList = Just ["january"
                         , "february"
                         , "march"
                         , "april"
                         , "may"
                         , "june"
                         , "july"
                         , "august"
                         , "september"
                         , "october"
                         , "november"
                         , "december"
                         , "today"
                         , "yesterday"
                         , "tomorrow"
                         , "last"
                         , "this"
                         ,"next"]

-- | HLedger's 'smartdate' and code
dateandcodep :: MP.Parser (SmartDate, T.Text)
dateandcodep = do d <- smartdate
                  c <- optional codep
                  many spacenonewline
                  MP.eof
                  return (d, maybe "" T.pack c)

myAskAccount j = askAccount completionList
  where completionList = nub $ sort [ paccount p | t <- jtxns j
                                      , p <- tpostings t]

askAmount :: Maybe AssertedAmount -- ^ default value, if "" is entered
             -> T.Text  -- ^ prompt
             -> Maybe T.Text -- ^ initial
             -> AddT IO AssertedAmount
askAmount def pr init = do
  j <- get
  liftIO $ editLoop (extract j) "Amount"
    ((id &&& showAssertedAmount) <$> def) Nothing (Left pr) init
  where
    extract :: Journal -> T.Text -> Either String AssertedAmount
    extract j input = left show $  (\a -> a { aComment = cmt })
      <$> parseAmount j am
      where (am, cmt) =  textstrip *** (textstrip . L.dropWhile (==';')) <<< L.break (==';') $ input
              :: (T.Text, T.Text)

-- -- | Parse and update an amount to equal its 'show' value
-- --
-- -- this is required to ensure, that the saved transaction equals the
-- -- edited and balanced transaction.
-- toShow :: Journal -> MixedAmount -> MixedAmount
-- toShow j (Mixed ams) = Mixed $ fmap g ams
--   where g = either (error.show) id . parseAmount j . fshow


parseAmount
  :: Journal
     -> T.Text -> Either (MP.ParseError Char MP.Dec) AssertedAmount
parseAmount j = parseWithState' j $ ((flip $ AA "") <$>
                (fmap (Mixed . pure) $ amountp MP.<|> return missingamt)
                <*> partialbalanceassertionp
                                    ) <* MP.eof

-- | (unused) overwrite upstream behavior to use defined or incurred
-- commodities
_amountp2 = MP.try leftsymbolamountp
  MP.<|> MP.try rightsymbolamountp
  MP.<|> nosymbolamountp2

nosymbolamountp2 :: Monad m => JournalStateParser m Amount
nosymbolamountp2 = do
  (q,prec,mdec,mgrps) <- lift numberp
  p <- priceamountp
  -- apply the most recently seen default commodity and style to this commodityless amount
  defcs <- getDefaultCommodityAndStyle2 <$> get
  let (c,s) = case defcs of
        Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec})
        Nothing          -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})
  return $ Amount c q p s
  MP.<?> "no-symbol amount"

getDefaultCommodityAndStyle2
  :: Journal
  -> Maybe (CommoditySymbol,AmountStyle)
getDefaultCommodityAndStyle2
  Journal{jparsedefaultcommodity=def
         ,jcommodities=comms
         ,jinferredcommodities=inferred} =
  let mm = listToMaybe . M.toList in
    asum
    [def
    ,traverse cformat =<< mm comms
    ,mm inferred
    ]


askPercent :: IO Decimal
askPercent = editLoop extr "percent"
             (Just ((,).prep <*> fshow $ def)) Nothing (Left "Percentage") Nothing
  where
    extr :: T.Text -> Either String Decimal
    extr s = show +++ prep $ readEither $ T.unpack s
    def = -1.5 :: Decimal
    prep = (100*).recip

-- * Posting and Suggestions


-- | Type holding suggested or temporary postings
data EditablePosting = EditablePosting { epPosting :: Maybe Posting
                             , epFreq    :: Maybe Int
                             , epAccount :: AccountName
                             , epNumber  :: Int
                             , epUser :: Zipper (Either User Partner)
                             -- ^ zipper of possible user
                             }

type EditablePostings = Zipper EditablePosting

-- | construct an 'EditablePosting'
editablePosting account amt n = do
  ps <- partners
  user <- user
  return $ addPosting account amt EditablePosting
    { epAccount = account
    , epFreq=Nothing
    , epNumber=n
    , epPosting = Nothing
    , epUser = differentiate $ E.cycle $ Left user E.:| (Right <$> ps)}

-- | generate and add new 'Posting' to 'EditablePosting'
addPosting
  :: AccountName
     -> Maybe AssertedAmount -> EditablePosting -> EditablePosting
addPosting _        Nothing s = s
addPosting account (Just (AA cmt ass iam)) s =
  s{epPosting=Just nullposting
              { paccount=account
              , pcomment = cmt
              , pbalanceassertion = ass
              , pamount = iam}}

setMissing :: EditablePosting -> EditablePosting
setMissing ep = addPosting (epAccount ep)
                (Just $ missingmixedamt <$ maybe def fromPosting
                 (epPosting ep)) ep



removeAmount :: EditablePosting -> EditablePosting
removeAmount ep = ep{epPosting=Nothing}

-- | jump to a certain element in a zipper
jumpTo :: Int -> Zipper a -> Zipper a
jumpTo n z' = atNote "jumpTo" (iterate fwd . differentiate . integrate' $ z') n

editDate :: LState a Transaction -> AddT IO (LState a Transaction)
editDate s@LS{userSt=t@Transaction{tdate=d}} = liftIO $ do
   iDa <- askDate (Just d)
   return s{userSt=t{tdate=fst iDa,tcode=snd iDa}}

editDescription :: LState a Transaction -> AddT IO (LState a Transaction)
editDescription s@LS{userSt=t@Transaction{tdescription=d}} = liftIO $ do
   iDe <- askDescription (Just d)
   return s{userSt=t{tdescription=iDe}}

-- | edit the amount of the selected posting
editCurAmount :: EditablePostings -> AddT IO EditablePostings
editCurAmount = modifyCurAmount (const id) True

-- | modfiy current amount by asking for a new amount, that is
-- combined with the old to get a new amount (e.g. with (+))
modifyCurAmount ::(AssertedAmount -> AssertedAmount -> AssertedAmount)
               -- ^ oldAmout -> enteredAmount -> newAmount
               -> Bool  -- ^ Show old amound
               -> EditablePostings -> AddT IO EditablePostings
modifyCurAmount new showO z@LZ{past=(s@EditablePosting{epAccount=ac} E.:| ps)} = do
  iAm <- askAmount olda ("Amount for " <> ac) solda
  return $ moveToNextEmpty z
    { past = addPosting ac
      (Just $ maybe iAm (flip new iAm) olda) s E.:| ps }
    where olda = fromPosting <$> epPosting s
          solda = guard showO *> fmap showAssertedAmount olda

replaceMissing :: MixedAmount -> MixedAmount
replaceMissing amt | normaliseMixedAmount amt == missingmixedamt = nullmixedamt
                   | True = amt



-- | Hardcoded default number of suggested accounts
defNumSuggestedAccounts :: Int
defNumSuggestedAccounts = 20


-- | retrieve a number of suggested contra postings for a given
-- account, sort frequency of that contra account for the given
-- account.
--
-- duplicate each posting for both users, but only if the
-- other user's account is present in the suggestions.
suggestedPostings :: MonadIO m
                  => AccountName
                  -> Maybe AssertedAmount
                  -> AddT m (E.NonEmpty EditablePosting)
suggestedPostings account am = do
  j <- get
  filterPref <- maybe id (\x -> filter $ not . L.isPrefixOf (x <> ":") . epAccount)
                <$> readUser accountPrefixOthers
  nP <- succ . length <$> partners
  let
    toEp l = editablePosting (head l) Nothing 0
      >>= \x -> return $ x{epFreq=Just $ length l}
    matches = concatMap tail $ filter filt $
              ((paccount<$>) . tpostings) <$> jtxns j
  sugaccounts <- sortBy (flip $ comparing epFreq)
                 <$> mapM toEp (group $ sort matches)
  let
    s = filterPref sugaccounts
    transformed :: [EditablePosting]
    transformed = if length sugaccounts == length s then s
                  else do x <- s
                          take nP $ iterate next x
  firstP <- editablePosting account am 0 -- ReferenceA
  num <- fromMaybe defNumSuggestedAccounts <$>
    readUser numSuggestedAccounts
  return $ (E.:|) firstP $ take (pred num) $
    zipWith (\n p -> p{epNumber=n}) [1..] transformed
  where
    filt x = account == head x && not ( null x )

-- | change posting's user to the next user
next :: EditablePosting -> EditablePosting
next s = s{epUser = fwd $ epUser s}

roundP :: EditablePosting -> EditablePosting
roundP p = p{epPosting = r1 <$> epPosting p}
  where r1 p = p{pamount = normalizeMixedAmountWith g $ pamount p}
        g a = roundTo (fromIntegral $ asprecision $ astyle a) $ aquantity a



-- | assign the 'Transaction''s open balance to an empty 'EditablePosting'
assignOpenBalance :: Decimal -> EditablePostings -> EditablePostings
assignOpenBalance c old@LZ{past=(pr@EditablePosting{epAccount=sac} E.:| ps)} =
  moveToNextEmpty $ old{past= roundP (newp $ epPosting pr) E.:| ps}
  where balance = divideMixedAmount (totalBalance all) c
        all = integrate old
        newp Nothing = addPosting sac (Just $ AA "" Nothing balance) pr
        newp (Just op) = pr{epPosting = Just op{pamount= balance + pamount op }}

showEditablePosting :: EditablePostings -> T.Text
showEditablePosting LZ{past= pr E.:| ps ,future=fut} =
  renderTable (replicate 4 AlignCenter,replicate 4 AlignLeft,
               [ "Account",  "Amount", "Assertion", "Frequency"])
  [ let mark = if marked then "->" else "  " :: String
    in [
        sformat (F.d % "," %F.sh% " " %F.s% " " %F.st)
         (epNumber x) (either name (name.pUser) $ present $ epUser x) mark
         $ epAccount x
       ,maybe "" (showMissing . pamount) $ epPosting x
       ,maybe "" (("= " <>) . showAmount2)
        $ pbalanceassertion =<< epPosting x
       ,maybe "" fshow $ epFreq x
       ] | (marked,x) <- postings ]
  $ Just ["Open Balance",balance,""]
  where balance = showMixedAmount2 $ totalBalance $ snd <$> postings
        postings = reverse ((,) True pr : mark ps) ++ mark fut
        mark = ((,) False <$>)
        showMissing amt | normaliseMixedAmount amt == missingmixedamt = "missing"
                        | True = showMixedAmount2 amt

totalBalance :: [EditablePosting] -> MixedAmount
totalBalance = negate . sum . fmap pamount . mapMaybe epPosting

showAmount2 :: Amount -> T.Text
showAmount2 = showMixedAmount2 . mixed'

showMixedAmount2 :: MixedAmount -> T.Text
showMixedAmount2 amt = T.pack $ showMixedAmountWithPrecision maxprecisionwithpoint amt

-- | ask for new account (display old as default) and use existing
-- posting, if same account without a posting/amount already exists or
-- append.
addNewPosting :: Bool -- ^ for next partner
              -> EditablePostings -> AddT IO EditablePostings
addNewPosting forNext old' = do
  j <- get
  let postings = integrate old'
      nextP = (if forNext then fwd else id)
        $ epUser $ present old'
  account <- liftIO $ myAskAccount j
    (Just $ epAccount $ present old') Nothing $ Left "Account"
  new <- editablePosting account Nothing $ length postings
  let loop (ep:eps) done =
        if isNothing (epPosting ep)
           && epAccount ep == account
           && on (==) present nextP (epUser ep)
        then LZ (addPosting account Nothing ep E.:| done) eps
        else loop eps (ep:done)
      loop [] done = LZ (new E.:| done) []
  return $ modifyPresent (\x -> x{epUser = nextP}) $ loop postings []


-- | move the focus to the next empty posting
moveToNextEmpty :: EditablePostings -> EditablePostings
moveToNextEmpty z = fromMaybe z $ find f zs
  where zs =  take (length postings) $ iterate wrapFwd z
        postings = integrate' z
        f = isNothing . epPosting . E.head . past
        wrapFwd x = if null $ future x then differentiate postings
                    else fwd x


-- * Pretty Table Printer

-- a type for fill functions
data Align = AlignLeft | AlignRight | AlignCenter

-- functions that fill a string (s) to a given width (n) by adding pad
-- character (c) to align left, right, or center
fillLeft c n s = s <> L.replicate (n - L.length s) c
fillRight c n s = L.replicate (n - L.length s) c <> s
fillCenter c n s = L.replicate l c <> s <> L.replicate r c
    where x = n - L.length s
          l = x `div` 2
          r = x - l

-- converts a list of items into a table according to a list
-- of column descriptors
renderTable :: ([Align],[Align],[T.Text])
            -> [[T.Text]]
            -> Maybe [T.Text]
            -> T.Text
renderTable (headerAlign,rowAlign,header) rows footer =
    let widths = [maximum $ map L.length col |
                  col <- transpose $ (header : rows) ++ maybeToList footer]
                 :: [Int]
        separator = intercalateL "-+-" [L.replicate width '-' | width <- widths]
        fillCols fill cols = intercalateL " | " $
                             zipWith3 (($).) fill widths cols
    in
        L.unlines ( fillCols headerFill header
                  : separator
                  : map (fillCols rowFill) rows
                  ++ maybe []
                  (\x ->  [separator, fillCols rowFill x]) footer)
  where toFiller AlignLeft = fillLeft ' '
        toFiller AlignRight = fillRight ' '
        toFiller AlignCenter = fillCenter ' '
        headerFill = toFiller <$> headerAlign
        rowFill = toFiller <$> rowAlign