1 {-| 
    2 
    3 A history-aware add command to help with data entry.
    4 
    5 -}
    6 
    7 module Commands.Add
    8 where
    9 import Prelude hiding (putStr, putStrLn, getLine, appendFile)
   10 import Ledger
   11 import Options
   12 import Commands.Register (showRegisterReport)
   13 import System.IO.UTF8
   14 import System.IO (stderr, hFlush)
   15 import System.IO.Error
   16 import Text.ParserCombinators.Parsec
   17 import Utils (ledgerFromStringWithOpts)
   18 
   19 
   20 -- | Read ledger transactions from the terminal, prompting for each field,
   21 -- and append them to the ledger file. If the ledger came from stdin, this
   22 -- command has no effect.
   23 add :: [Opt] -> [String] -> Ledger -> IO ()
   24 add opts args l
   25     | filepath (rawledger l) == "-" = return ()
   26     | otherwise = do
   27   hPutStrLn stderr
   28     "Enter one or more transactions, which will be added to your ledger file.\n\
   29     \To complete a transaction, enter . as account name. To quit, enter control-d."
   30   getAndAddTransactions l args `catch` (\e -> if isEOFError e then return () else ioError e)
   31 
   32 -- | Read a number of ledger transactions from the command line,
   33 -- prompting, validating, displaying and appending them to the ledger
   34 -- file, until end of input (then raise an EOF exception). Any
   35 -- command-line arguments are used as the first transaction's description.
   36 getAndAddTransactions :: Ledger -> [String] -> IO ()
   37 getAndAddTransactions l args = do
   38   l <- getTransaction l args >>= addTransaction l
   39   getAndAddTransactions l []
   40 
   41 -- | Read a transaction from the command line, with history-aware prompting.
   42 getTransaction :: Ledger -> [String] -> IO LedgerTransaction
   43 getTransaction l args = do
   44   today <- getCurrentDay
   45   datestr <- askFor "date" 
   46             (Just $ showDate today)
   47             (Just $ \s -> null s || 
   48              (isRight $ parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))
   49   description <- if null args 
   50                   then askFor "description" Nothing (Just $ not . null) 
   51                   else do
   52                          let description = unwords args
   53                          hPutStrLn stderr $ "description: " ++ description
   54                          return description
   55   let historymatches = transactionsSimilarTo l description
   56       bestmatch | null historymatches = Nothing
   57                 | otherwise = Just $ snd $ head $ historymatches
   58       bestmatchpostings = maybe Nothing (Just . ltpostings) bestmatch
   59       date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr
   60       getpostingsandvalidate = do
   61         ps <- getPostings bestmatchpostings []
   62         let t = nullledgertxn{ltdate=date
   63                              ,ltstatus=False
   64                              ,ltdescription=description
   65                              ,ltpostings=ps
   66                              }
   67             retry = do
   68               hPutStrLn stderr $ "\n" ++ nonzerobalanceerror ++ ". Re-enter:"
   69               getpostingsandvalidate
   70         either (const retry) return $ balanceLedgerTransaction t
   71   when (not $ null historymatches) 
   72        (do
   73          hPutStrLn stderr "Similar transactions found, using the first for defaults:\n"
   74          hPutStr stderr $ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) $ take 3 historymatches)
   75   getpostingsandvalidate
   76 
   77 -- | Read postings from the command line until . is entered, using the
   78 -- provided historical postings, if any, to guess defaults.
   79 getPostings :: Maybe [Posting] -> [Posting] -> IO [Posting]
   80 getPostings historicalps enteredps = do
   81   account <- askFor (printf "account %d" n) defaultaccount (Just $ not . null)
   82   if account=="."
   83     then return enteredps
   84     else do
   85       amountstr <- askFor (printf "amount  %d" n) defaultamount validateamount
   86       let amount = fromparse $ parse (someamount <|> return missingamt) "" amountstr
   87       let p = nullrawposting{paccount=stripbrackets account,
   88                              pamount=amount,
   89                              ptype=postingtype account}
   90       getPostings historicalps $ enteredps ++ [p]
   91     where
   92       n = length enteredps + 1
   93       realn = length enteredrealps + 1
   94       enteredrealps = filter isReal enteredps
   95       bestmatch | isNothing historicalps = Nothing
   96                 | n <= length ps = Just $ ps !! (n-1)
   97                 | otherwise = Nothing
   98                 where Just ps = historicalps
   99       defaultaccount = maybe Nothing (Just . showacctname) bestmatch
  100       showacctname p = showAccountName Nothing (ptype p) $ paccount p
  101       defaultamount = maybe balancingamount (Just . show . pamount) bestmatch
  102           where balancingamount = Just $ show $ negate $ sum $ map pamount enteredrealps
  103       postingtype ('[':_) = BalancedVirtualPosting
  104       postingtype ('(':_) = VirtualPosting
  105       postingtype _ = RegularPosting
  106       stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse
  107       validateamount = Just $ \s -> (null s && (not $ null enteredrealps))
  108                                    || (isRight $ parse (someamount>>many spacenonewline>>eof) "" s)
  109 
  110 -- | Prompt for and read a string value, optionally with a default value
  111 -- and a validator. A validator causes the prompt to repeat until the
  112 -- input is valid. May also raise an EOF exception if control-d is pressed.
  113 askFor :: String -> Maybe String -> Maybe (String -> Bool) -> IO String
  114 askFor prompt def validator = do
  115   hPutStr stderr $ prompt ++ (maybe "" showdef def) ++ ": "
  116   hFlush stderr
  117   l <- getLine
  118   let input = if null l then fromMaybe l def else l
  119   case validator of
  120     Just valid -> if valid input
  121                    then return input
  122                    else askFor prompt def validator
  123     Nothing -> return input
  124     where showdef s = " [" ++ s ++ "]"
  125 
  126 -- | Append this transaction to the ledger's file. Also, to the ledger's
  127 -- transaction list, but we don't bother updating the other fields - this
  128 -- is enough to include new transactions in the history matching.
  129 addTransaction :: Ledger -> LedgerTransaction -> IO Ledger
  130 addTransaction l t = do
  131   appendToLedgerFile l $ show t
  132   putStrLn $ printf "\nAdded transaction to %s:" (filepath $ rawledger l)
  133   putStrLn =<< registerFromString (show t)
  134   return l{rawledger=rl{ledger_txns=ts}}
  135       where rl = rawledger l
  136             ts = ledger_txns rl ++ [t]
  137 
  138 -- | Append data to the ledger's file, ensuring proper separation from any
  139 -- existing data; or if the file is "-", dump it to stdout.
  140 appendToLedgerFile :: Ledger -> String -> IO ()
  141 appendToLedgerFile l s = 
  142     if f == "-"
  143     then putStr $ sep ++ s
  144     else appendFile f $ sep++s
  145     where 
  146       f = filepath $ rawledger l
  147       -- we keep looking at the original raw text from when the ledger
  148       -- was first read, but that's good enough for now
  149       t = rawledgertext l
  150       sep | null $ strip t = ""
  151           | otherwise = replicate (2 - min 2 (length lastnls)) '\n'
  152           where lastnls = takeWhile (=='\n') $ reverse t
  153 
  154 -- | Convert a string of ledger data into a register report.
  155 registerFromString :: String -> IO String
  156 registerFromString s = do
  157   now <- getCurrentLocalTime
  158   l <- ledgerFromStringWithOpts [] [] now s
  159   return $ showRegisterReport [Empty] [] l
  160 
  161 -- | Return a similarity measure, from 0 to 1, for two strings.
  162 -- This is Simon White's letter pairs algorithm from
  163 -- http://www.catalysoft.com/articles/StrikeAMatch.html
  164 -- with a modification for short strings.
  165 compareStrings :: String -> String -> Double
  166 compareStrings "" "" = 1
  167 compareStrings (a:[]) "" = 0
  168 compareStrings "" (b:[]) = 0
  169 compareStrings (a:[]) (b:[]) = if toUpper a == toUpper b then 1 else 0
  170 compareStrings s1 s2 = 2.0 * (fromIntegral i) / (fromIntegral u)
  171     where
  172       i = length $ intersect pairs1 pairs2
  173       u = length pairs1 + length pairs2
  174       pairs1 = wordLetterPairs $ uppercase s1
  175       pairs2 = wordLetterPairs $ uppercase s2
  176 wordLetterPairs = concatMap letterPairs . words
  177 letterPairs (a:b:rest) = [a,b]:(letterPairs (b:rest))
  178 letterPairs _ = []
  179 
  180 compareLedgerDescriptions s t = compareStrings s' t'
  181     where s' = simplify s
  182           t' = simplify t
  183           simplify = filter (not . (`elem` "0123456789"))
  184 
  185 transactionsSimilarTo :: Ledger -> String -> [(Double,LedgerTransaction)]
  186 transactionsSimilarTo l s =
  187     sortBy compareRelevanceAndRecency
  188                $ filter ((> threshold).fst)
  189                $ [(compareLedgerDescriptions s $ ltdescription t, t) | t <- ts]
  190     where
  191       compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,ltdate t2) (n1,ltdate t1)
  192       ts = ledger_txns $ rawledger l
  193       threshold = 0
  194 
  195 {- doctests
  196 
  197 @
  198 $ echo "2009/13/1"|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a bad date is not accepted
  199 date : date : 
  200 @
  201 
  202 @
  203 $ echo|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a blank date is ok
  204 date : description: 
  205 @
  206 
  207 @
  208 $ printf "\n\n"|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a blank description should fail
  209 date : description: description: 
  210 @
  211 
  212 -}