Match.hs

{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Buchhaltung.Match
where

import           Buchhaltung.Ask
import           Buchhaltung.Common
import           Buchhaltung.Importers
import           Buchhaltung.Zipper
import           Control.Arrow
import           Control.Concurrent.Async
import           Control.Lens
import           Control.Monad.RWS
import           Control.Monad.Reader
import           Data.Either
import           Data.Function
import           Data.List
import qualified Data.List.NonEmpty as N
import qualified Data.ListLike as L
import qualified Data.ListLike.String as L
import qualified Data.Map.Strict as M
import           Data.Maybe
import           Data.Ord
import qualified Data.Semigroup as S
import qualified Data.Set as S
import qualified Data.Text as T
import           Hledger.Data hiding (at)
import           System.Console.Haskeline
import           System.Exit
import           System.FilePath
import           System.Process
import qualified Text.PrettyPrint.Boxes as P
import           Text.Printf
  
type MatchT m = RWST (FullOptions FilePath) ()
                (M.Map AccountName Bool, Zipper Update) (ErrorT m)
  -- ^ R: temporaray dbacl path
  --
  --   W: Set of learned accounts
  -- 
  --   S: Zipper with all transaction that neede to be matched

match :: FullOptions FilePath -> Journal -> ErrorT IO ()
match options j = maybe (liftIO $ print "No unmatched transactions")
                  g
                  $ runReader (groupByAccount j) options
  where
    g (done, todos) = void $ runRWST (learn done >> mainLoop "")
                      options
                      (mempty, differentiate todos) :: ErrorT IO ()

-- | Apply the first matching 'Todo'
updateAccountName :: Update -> Maybe (Transaction, Transaction)
updateAccountName WithSource{ wInfo = Nothing } = Nothing
updateAccountName up =
  Just (wTx up, tPosts . ix (wIdx up) . pAcc .~ (fromJust $ wInfo up) $ wTx up)

printSource :: Source -> String
printSource = P.render . table [25,35] ["Field", "Value"] .
  (\(x,z) -> [x,z]) . unzip . M.toList . sourceToMap

mainLoop :: String -> MatchT IO ()
mainLoop msg = do
  zip <- gets $ snd
  let tx = present zip
  liftIO $ do
    putStrLn $ printSource $ wSource $ tx
    printf "Current Transaction: %d, Remaining: %d\n"
      (length $ past zip )
      $ length $ future zip
    putStr msg
  account <- myAskAccount =<< suggestAccount tx -- 
  let
    next = modify (second fwd) >> mainLoop (fwdMsg zip)
    prev = modify (second back) >> mainLoop (backMsg zip)
    fwdMsg (LZ _ []) =  "<< DONE! Use 'save' to exit >>\n\n"
    fwdMsg _ = ""
    backMsg (LZ (_ :| []) _) =  "<< This is the first transaction >>\n\n"
    backMsg _ = ""
    g "save" = void $ saveChanges Nothing $ changeTransaction
               $ mapMaybe updateAccountName $ integrate zip
    g "<" = prev
    g ">" = next
    g _   = do
      learn [(account, return tx)]
      modify $ second $ modifyPresent (fmap $ const $ Just account)
      next
  g account

histfsuf :: String
histfsuf =   "learn"

-- | Data type describing the suggested or 'default' account when
-- asking the user for account input
data Default = Default  { prefixed :: T.Text, defAcc :: AccountName }
  
suggestAccount :: Update -> MatchT IO (Maybe Default)
suggestAccount tx = do
  accs <- getAccountList $ id
  args <- dbaclProcC <$> mapM tmp accs
  text <- bayesLine tx
  bin <- readConfig cDbaclExecutable
  let
    g = if null accs || T.null text then return Nothing
        else do
      (code, output, _) <-
        liftIO $ readProcessWithExitCode bin args $ T.unpack text
      case code of
        ExitSuccess -> return Nothing
        ExitFailure x ->
          return $ Just $ Default info sa
          where sa = accs !! (x-1)
                info :: T.Text
                info = either fshow (text . lookup sa)
                  (dbacl_parse accs output)
                text Nothing = "failed\t\t"
                text (Just te) = "uncertainty: " <> T.pack te <> "\t"
  maybe g (return . Just . Default "manual:\t\t\t") $ wInfo tx
  
bayesLine :: Monad m => WithSource a -> MatchT m T.Text
bayesLine w = T.strip . T.unwords <$> getBayesFields (wSource w)

learn :: [(AccountName, NonEmpty (WithSource a))]
      -> MatchT IO ()
learn pairs = do
  accs <- liftIO . runConcurrently . sequenceA =<< mapM learn' pairs
  forM_ accs $ \(k,v) -> modify $ first $ M.insertWith const k v
  where learn' (name,txs) = do 
          bin <- readConfig cDbaclExecutable
          text <- (L.unlines . filter (not . T.null)) <$>
                    mapM bayesLine (N.toList txs)
          file <- tmp name
          let action = if T.null text then return (name, False)
                       else do
                -- let text = if text'=="" then "\n" else text' PROBLEM-bayes_fields
                L.putStrLn $ "Learning: " <> name
                -- putStrLn $ "\n\n"++ (intercalate "\n\n" $ info <$> todos)
                -- putStrLn text
                let texts = T.unpack text
                (code, out, err) <- readProcessWithExitCode bin (dbaclProc file) texts
                appendFile (file <> "_raw" ) $ texts <> "\n\n" <>
                  out <> "\n\nStd error:\n" <> err
                let success = code == ExitSuccess && null err 
                L.putStrLn $ if success then "Done:     " <> name
                             else "Failed:   " <> name <> "\nwith Code "<> fshow code <> "\n\nAnd error:\n" <> T.pack err
                return (name, success)
          return $ Concurrently $ action
accountCompletion :: [String] -> CompletionFunc IO
accountCompletion cc = completeWord Nothing
                        "" -- don't break words on whitespace, since account names
                           -- can contain spaces.
                        $ \s -> return $ map (\x -> Completion x x  False)
                                        $ filter (s `isInfixOf`) cc

type Update = WithSource (Maybe AccountName)

-- | Group all transactions with source into those that already have
--  an account (ignoring those in 'ignoredAccountsOnMatch') and those
--  that start with 'cTodoAccount'
--
-- returns `Nothing` if there are no todo transactions
groupByAccount
  :: MonadReader (Options User Config env) m =>
     Journal
     -> m (Maybe ( [(AccountName, NonEmpty (WithSource ()))]
                 , NonEmpty Update))
groupByAccount j = do
  ignored <- readUser ignoredAccountsOnMatch
  tag <- askTag
  todoFilt <- askTodoFilter
  let acc = paccount . wPosting
      f s = if todoFilt ac then Right $ fmap (const Nothing) <$> s
            else Left (ac, s)
        where ac = acc $ N.head s
  return
    -- combine all transactions with different todo accounts
    $ traverse (fmap S.sconcat . nonEmpty)
    $ first (filter $ not . isIgnored ignored . fst)
    $ partitionEithers $ fmap f
    $ N.groupBy ((==) `on` acc)
    $ sortBy (comparing acc) $ rights $ extractSource tag
    <$> jtxns j 

myAskAccount :: Maybe Default -> MatchT IO AccountName
myAskAccount acc = getAccountList (const True) >>= \accs -> do
  revAccount <- askReverseAccount
  let prompt = Right $ T.unlines
        [""
        ,maybe "" ((<> "\n\nHit 'Enter' to use the above account, or") . showdef) acc
        ,"enter one of the following: account name (in reverse notation), "<>
         "'<', '>' to navigate, or 'save'"]
      showdef (Default d a) = d <> (revAccount a) :: T.Text
  askAccount accs (defAcc <$> acc) (Just histfsuf) prompt

getAccountList :: Monad m => (Bool -> Bool) -> MatchT m [AccountName]
getAccountList f = gets $ M.keys . M.filter f . fst

tmp :: Monad m => T.Text -> MatchT m FilePath
tmp name = reader $ (</> T.unpack name) . oEnv 

-- * dbacl arguments

-- | learning
dbaclProc :: String -> [String]
dbaclProc x = [  "-g" , oneword
              , "-g" , twowords
              --,"-D" -- interessant "-D" zeigt welche features gefunden wurden  (use grep match)
              , "-d"
              -- ,"-w 1" -- use N-grams with N=2
              --  "-S" -- ignore line breaks
              , "-0" -- do not preload (this is done by -o)
              -- ,"-e", "alnum" -- alpha numeric
              , "-j" -- lowercase
              , "-l", x
              , "-o", x ++ "_online"
              ] -- category name
  where word = "(^|[^[:alpha:]])([[:alpha:]]{3,})"
        oneword = wrap $ word ++"||2"
        twowords = wrap $ word++"[^[:alpha:]]+"++word++"||24"
        wrap = id --x = "'"++x++"'"

-- | classification   
dbaclProcC :: [String] -> [String]
dbaclProcC cats = let cats' = concat $ sequence [["-c"],cats]
                 in ( cats' ++ [  -- search this file for  'debugging'
                               -- "-v" -- output name of best (dont know when useful)
                               "-n" -- neg. logaritm
                               -- , "-N" -- prob
                               -- ,"-X"
                               -- ,"-d" -- sehr hilfreich, see manual (aber nur mit weniger categorien
                               ] )