1 {-| 2 3 A history-aware add command to help with data entry. 4 5 Note: this might not be sensible, but add has some aspirations of being 6 both user-friendly and pipeable/scriptable and for this reason 7 informational messages are mostly written to stderr rather than stdout. 8 9 -} 10 11 module Hledger.Cli.Add 12 where 13 import Control.Exception (throw) 14 import Control.Monad 15 import Control.Monad.Trans (liftIO) 16 import Data.Char (toUpper) 17 import Data.List 18 import Data.Maybe 19 import Data.Time.Calendar 20 import Safe (headMay) 21 import System.Console.Haskeline (InputT, runInputT, defaultSettings, setComplete, getInputLine) 22 import System.Console.Haskeline.Completion 23 import System.IO ( stderr, hPutStrLn, hPutStr ) 24 import System.IO.Error 25 import Text.ParserCombinators.Parsec 26 import Text.Printf 27 import qualified Data.Foldable as Foldable (find) 28 import qualified Data.Set as Set 29 30 import Hledger 31 import Prelude hiding (putStr, putStrLn, appendFile) 32 import Hledger.Utils.UTF8 (putStr, putStrLn, appendFile) 33 import Hledger.Cli.Options 34 import Hledger.Cli.Register (postingsReportAsText) 35 import Hledger.Cli.Utils 36 37 38 {- | Information used as the basis for suggested account names, amounts, 39 etc in add prompt 40 -} 41 data PostingState = PostingState { 42 psJournal :: Journal, 43 psAccept :: AccountName -> Bool, 44 psSuggestHistoricalAmount :: Bool, 45 psHistory :: Maybe [Posting]} 46 47 -- | Read transactions from the terminal, prompting for each field, 48 -- and append them to the journal file. If the journal came from stdin, this 49 -- command has no effect. 50 add :: CliOpts -> Journal -> IO () 51 add opts j 52 | f == "-" = return () 53 | otherwise = do 54 hPutStrLn stderr $ 55 "Enter one or more transactions, which will be added to your journal file.\n" 56 ++"To complete a transaction, enter . when prompted for an account.\n" 57 ++"To quit, press control-d or control-c." 58 today <- getCurrentDay 59 getAndAddTransactions j opts today 60 `catch` (\e -> unless (isEOFError e) $ ioError e) 61 where f = journalFilePath j 62 63 -- | Read a number of transactions from the command line, prompting, 64 -- validating, displaying and appending them to the journal file, until 65 -- end of input (then raise an EOF exception). Any command-line arguments 66 -- are used as the first transaction's description. 67 getAndAddTransactions :: Journal -> CliOpts -> Day -> IO () 68 getAndAddTransactions j opts defaultDate = do 69 (t, d) <- getTransaction j opts defaultDate 70 j <- journalAddTransaction j opts t 71 getAndAddTransactions j opts d 72 73 -- | Read a transaction from the command line, with history-aware prompting. 74 getTransaction :: Journal -> CliOpts -> Day 75 -> IO (Transaction,Day) 76 getTransaction j opts defaultDate = do 77 today <- getCurrentDay 78 datestr <- runInteractionDefault $ askFor "date" 79 (Just $ showDate defaultDate) 80 (Just $ \s -> null s || 81 isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s)) 82 description <- runInteractionDefault $ askFor "description" (Just "") Nothing 83 let historymatches = transactionsSimilarTo j (patterns_ $ reportopts_ opts) description 84 bestmatch | null historymatches = Nothing 85 | otherwise = Just $ snd $ head historymatches 86 bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch 87 date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr 88 accept x = x == "." || (not . null) x && 89 if no_new_accounts_ opts 90 then isJust $ Foldable.find (== x) ant 91 else True 92 where (ant,_,_,_) = groupPostings $ journalPostings j 93 getpostingsandvalidate = do 94 ps <- getPostings (PostingState j accept True bestmatchpostings) [] 95 let t = nulltransaction{tdate=date 96 ,tstatus=False 97 ,tdescription=description 98 ,tpostings=ps 99 } 100 retry msg = do 101 liftIO $ hPutStrLn stderr $ "\n" ++ msg ++ "please re-enter." 102 getpostingsandvalidate 103 either retry (return . flip (,) date) $ balanceTransaction Nothing t -- imprecise balancing 104 unless (null historymatches) 105 (liftIO $ do 106 hPutStrLn stderr "Similar transactions found, using the first for defaults:\n" 107 hPutStr stderr $ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) $ take 3 historymatches) 108 getpostingsandvalidate 109 110 -- fragile 111 -- | Read postings from the command line until . is entered, using any 112 -- provided historical postings and the journal context to guess defaults. 113 getPostings :: PostingState -> [Posting] -> IO [Posting] 114 getPostings st enteredps = do 115 let bestmatch | isNothing historicalps = Nothing 116 | n <= length ps = Just $ ps !! (n-1) 117 | otherwise = Nothing 118 where Just ps = historicalps 119 defaultaccount = maybe Nothing (Just . showacctname) bestmatch 120 account <- runInteraction j $ askFor (printf "account %d" n) defaultaccount (Just accept) 121 if account=="." 122 then return enteredps 123 else do 124 let defaultacctused = Just account == defaultaccount 125 historicalps' = if defaultacctused then historicalps else Nothing 126 bestmatch' | isNothing historicalps' = Nothing 127 | n <= length ps = Just $ ps !! (n-1) 128 | otherwise = Nothing 129 where Just ps = historicalps' 130 defaultamountstr | isJust bestmatch' && suggesthistorical = Just historicalamountstr 131 | n > 1 = Just balancingamountstr 132 | otherwise = Nothing 133 where 134 -- force a decimal point in the output in case there's a 135 -- digit group separator that would be mistaken for one 136 historicalamountstr = showMixedAmountWithPrecision maxprecisionwithpoint $ pamount $ fromJust bestmatch' 137 balancingamountstr = showMixedAmountWithPrecision maxprecisionwithpoint $ negate $ sum $ map pamount enteredrealps 138 amountstr <- runInteractionDefault $ askFor (printf "amount %d" n) defaultamountstr validateamount 139 let amount = fromparse $ runParser (someamount <|> return missingamt) ctx "" amountstr 140 amount' = fromparse $ runParser (someamount <|> return missingamt) nullctx "" amountstr 141 defaultamtused = Just (showMixedAmount amount) == defaultamountstr 142 commodityadded | c == cwithnodef = Nothing 143 | otherwise = c 144 where c = maybemixedamountcommodity amount 145 cwithnodef = maybemixedamountcommodity amount' 146 maybemixedamountcommodity = maybe Nothing (Just . commodity) . headMay . amounts 147 p = nullposting{paccount=stripbrackets account, 148 pamount=amount, 149 ptype=postingtype account} 150 st' = if defaultamtused then st 151 else st{psHistory = historicalps', 152 psSuggestHistoricalAmount = False} 153 when (isJust commodityadded) $ 154 liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (symbol $ fromJust commodityadded) 155 getPostings st' (enteredps ++ [p]) 156 where 157 j = psJournal st 158 historicalps = psHistory st 159 ctx = jContext j 160 accept = psAccept st 161 suggesthistorical = psSuggestHistoricalAmount st 162 n = length enteredps + 1 163 enteredrealps = filter isReal enteredps 164 showacctname p = showAccountName Nothing (ptype p) $ paccount p 165 postingtype ('[':_) = BalancedVirtualPosting 166 postingtype ('(':_) = VirtualPosting 167 postingtype _ = RegularPosting 168 stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse 169 validateamount = Just $ \s -> (null s && not (null enteredrealps)) 170 || isRight (runParser (someamount>>many spacenonewline>>eof) ctx "" s) 171 172 -- | Prompt for and read a string value, optionally with a default value 173 -- and a validator. A validator causes the prompt to repeat until the 174 -- input is valid. May also raise an EOF exception if control-d is pressed. 175 askFor :: String -> Maybe String -> Maybe (String -> Bool) -> InputT IO String 176 askFor prompt def validator = do 177 l <- fmap (maybe eofErr id) 178 $ getInputLine $ prompt ++ maybe "" showdef def ++ ": " 179 let input = if null l then fromMaybe l def else l 180 case validator of 181 Just valid -> if valid input 182 then return input 183 else askFor prompt def validator 184 Nothing -> return input 185 where 186 showdef s = " [" ++ s ++ "]" 187 eofErr = throw $ mkIOError eofErrorType "end of input" Nothing Nothing 188 189 -- | Append this transaction to the journal's file, and to the journal's 190 -- transaction list. 191 journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal 192 journalAddTransaction j@Journal{jtxns=ts} opts t = do 193 let f = journalFilePath j 194 appendToJournalFile f $ showTransaction t 195 when (debug_ opts) $ do 196 putStrLn $ printf "\nAdded transaction to %s:" f 197 putStrLn =<< registerFromString (show t) 198 return j{jtxns=ts++[t]} 199 200 -- | Append data to a journal file; or if the file is "-", dump it to stdout. 201 appendToJournalFile :: FilePath -> String -> IO () 202 appendToJournalFile f s = 203 if f == "-" 204 then putStr $ sep ++ s 205 else appendFile f $ sep++s 206 where 207 -- appendFile means we don't need file locking to be 208 -- multi-user-safe, but also that we can't figure out the minimal 209 -- number of newlines needed as separator 210 sep = "\n\n" 211 -- sep | null $ strip t = "" 212 -- | otherwise = replicate (2 - min 2 (length lastnls)) '\n' 213 -- where lastnls = takeWhile (=='\n') $ reverse t 214 215 -- | Convert a string of journal data into a register report. 216 registerFromString :: String -> IO String 217 registerFromString s = do 218 d <- getCurrentDay 219 j <- readJournal' s 220 return $ postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts d) j 221 where opts = defreportopts{empty_=True} 222 223 -- | Return a similarity measure, from 0 to 1, for two strings. 224 -- This is Simon White's letter pairs algorithm from 225 -- http://www.catalysoft.com/articles/StrikeAMatch.html 226 -- with a modification for short strings. 227 compareStrings :: String -> String -> Double 228 compareStrings "" "" = 1 229 compareStrings (_:[]) "" = 0 230 compareStrings "" (_:[]) = 0 231 compareStrings (a:[]) (b:[]) = if toUpper a == toUpper b then 1 else 0 232 compareStrings s1 s2 = 2.0 * fromIntegral i / fromIntegral u 233 where 234 i = length $ intersect pairs1 pairs2 235 u = length pairs1 + length pairs2 236 pairs1 = wordLetterPairs $ uppercase s1 237 pairs2 = wordLetterPairs $ uppercase s2 238 wordLetterPairs = concatMap letterPairs . words 239 letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest) 240 letterPairs _ = [] 241 242 compareDescriptions :: [Char] -> [Char] -> Double 243 compareDescriptions s t = compareStrings s' t' 244 where s' = simplify s 245 t' = simplify t 246 simplify = filter (not . (`elem` "0123456789")) 247 248 transactionsSimilarTo :: Journal -> [String] -> String -> [(Double,Transaction)] 249 transactionsSimilarTo j apats s = 250 sortBy compareRelevanceAndRecency 251 $ filter ((> threshold).fst) 252 [(compareDescriptions s $ tdescription t, t) | t <- ts] 253 where 254 compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,tdate t2) (n1,tdate t1) 255 ts = jtxns $ filterJournalTransactionsByAccount apats j 256 threshold = 0 257 258 runInteraction :: Journal -> InputT IO a -> IO a 259 runInteraction j m = do 260 let cc = completionCache j 261 runInputT (setComplete (accountCompletion cc) defaultSettings) m 262 263 runInteractionDefault :: InputT IO a -> IO a 264 runInteractionDefault m = do 265 runInputT (setComplete noCompletion defaultSettings) m 266 267 -- A precomputed list of all accounts previously entered into the journal. 268 type CompletionCache = [AccountName] 269 270 completionCache :: Journal -> CompletionCache 271 completionCache j = -- Only keep unique account names. 272 Set.toList $ Set.fromList 273 [paccount p | t <- jtxns j, p <- tpostings t] 274 275 accountCompletion :: CompletionCache -> CompletionFunc IO 276 accountCompletion cc = completeWord Nothing 277 "" -- don't break words on whitespace, since account names 278 -- can contain spaces. 279 $ \s -> return $ map simpleCompletion 280 $ filter (s `isPrefixOf`) cc