1{-|
2A history-aware add command to help with data entry.
3|-}
4
5{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}
6{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings, PackageImports, LambdaCase #-}
7{-# LANGUAGE TemplateHaskell #-}
8
9module Hledger.Cli.Commands.Add (
10   addmode
11  ,add
12  ,appendToJournalFileOrStdout
13  ,journalAddTransaction
14  ,transactionsSimilarTo
15)
16where
17
18import Prelude ()
19import "base-compat-batteries" Prelude.Compat hiding (fail)
20import Control.Exception as E
21import Control.Monad (when)
22import Control.Monad.Trans.Class
23import Control.Monad.State.Strict (evalState, evalStateT)
24import Control.Monad.Trans (liftIO)
25import Data.Char (toUpper, toLower)
26import Data.Either (isRight)
27import Data.Functor.Identity (Identity(..))
28import "base-compat-batteries" Data.List.Compat
29import qualified Data.Set as S
30import Data.Maybe
31import Data.Text (Text)
32import qualified Data.Text as T
33import Data.Time.Calendar (Day)
34import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat)
35import Safe (headDef, headMay, atMay)
36import System.Console.CmdArgs.Explicit
37import System.Console.Haskeline (runInputT, defaultSettings, setComplete)
38import System.Console.Haskeline.Completion
39import System.Console.Wizard
40import System.Console.Wizard.Haskeline
41import System.IO ( stderr, hPutStr, hPutStrLn )
42import Text.Megaparsec
43import Text.Megaparsec.Char
44import Text.Printf
45
46import Hledger
47import Hledger.Cli.CliOptions
48import Hledger.Cli.Commands.Register (postingsReportAsText)
49
50
51addmode = hledgerCommandMode
52  $(embedFileRelative "Hledger/Cli/Commands/Add.txt")
53  [flagNone ["no-new-accounts"]  (setboolopt "no-new-accounts") "don't allow creating new accounts"]
54  [generalflagsgroup2]
55  []
56  ([], Just $ argsFlag "[DATE [DESCRIPTION [ACCOUNT1 [AMOUNT1 [ACCOUNT2 [ETC...]]]]]]")
57
58-- | State used while entering transactions.
59data EntryState = EntryState {
60   esOpts               :: CliOpts           -- ^ command line options
61  ,esArgs               :: [String]          -- ^ command line arguments remaining to be used as defaults
62  ,esToday              :: Day               -- ^ today's date
63  ,esDefDate            :: Day               -- ^ the default date for next transaction
64  ,esJournal            :: Journal           -- ^ the journal we are adding to
65  ,esSimilarTransaction :: Maybe Transaction -- ^ the most similar historical txn
66  ,esPostings           :: [Posting]         -- ^ postings entered so far in the current txn
67  } deriving (Show)
68
69defEntryState = EntryState {
70   esOpts               = defcliopts
71  ,esArgs               = []
72  ,esToday              = nulldate
73  ,esDefDate            = nulldate
74  ,esJournal            = nulljournal
75  ,esSimilarTransaction = Nothing
76  ,esPostings           = []
77}
78
79data RestartTransactionException = RestartTransactionException deriving (Show)
80instance Exception RestartTransactionException
81
82-- data ShowHelpException = ShowHelpException deriving (Show)
83-- instance Exception ShowHelpException
84
85-- | Read multiple transactions from the console, prompting for each
86-- field, and append them to the journal file.  If the journal came
87-- from stdin, this command has no effect.
88add :: CliOpts -> Journal -> IO ()
89add opts j
90    | journalFilePath j == "-" = return ()
91    | otherwise = do
92        hPrintf stderr "Adding transactions to journal file %s\n" (journalFilePath j)
93        showHelp
94        today <- getCurrentDay
95        let es = defEntryState{esOpts=opts
96                              ,esArgs=listofstringopt "args" $ rawopts_ opts
97                              ,esToday=today
98                              ,esDefDate=today
99                              ,esJournal=j
100                              }
101        getAndAddTransactions es `E.catch` (\(_::UnexpectedEOF) -> putStr "")
102
103showHelp = hPutStr stderr $ unlines [
104     "Any command line arguments will be used as defaults."
105    ,"Use tab key to complete, readline keys to edit, enter to accept defaults."
106    ,"An optional (CODE) may follow transaction dates."
107    ,"An optional ; COMMENT may follow descriptions or amounts."
108    ,"If you make a mistake, enter < at any prompt to go one step backward."
109    ,"To end a transaction, enter . when prompted."
110    ,"To quit, enter . at a date prompt or press control-d or control-c."
111    ]
112
113-- | Loop reading transactions from the console, prompting, validating
114-- and appending each one to the journal file, until end of input or
115-- ctrl-c (then raise an EOF exception).  If provided, command-line
116-- arguments are used as defaults; otherwise defaults come from the
117-- most similar recent transaction in the journal.
118getAndAddTransactions :: EntryState -> IO ()
119getAndAddTransactions es@EntryState{..} = (do
120  let defaultPrevInput = PrevInput{prevDateAndCode=Nothing, prevDescAndCmnt=Nothing, prevAccount=[], prevAmountAndCmnt=[]}
121  mt <- runInputT (setComplete noCompletion defaultSettings) (System.Console.Wizard.run $ haskeline $ confirmedTransactionWizard defaultPrevInput es [])
122  case mt of
123    Nothing -> error "Could not interpret the input, restarting"  -- caught below causing a restart, I believe  -- PARTIAL:
124    Just t -> do
125      j <- if debug_ esOpts > 0
126           then do hPrintf stderr "Skipping journal add due to debug mode.\n"
127                   return esJournal
128           else do j' <- journalAddTransaction esJournal esOpts t
129                   hPrintf stderr "Saved.\n"
130                   return j'
131      hPrintf stderr "Starting the next transaction (. or ctrl-D/ctrl-C to quit)\n"
132      getAndAddTransactions es{esJournal=j, esDefDate=tdate t}
133  )
134  `E.catch` (\(_::RestartTransactionException) ->
135                 hPrintf stderr "Restarting this transaction.\n" >> getAndAddTransactions es)
136
137data TxnParams = TxnParams
138  { txnDate :: Day
139  , txnCode :: Text
140  , txnDesc :: Text
141  , txnCmnt :: Text
142  } deriving (Show)
143
144data PrevInput = PrevInput
145  { prevDateAndCode   :: Maybe String
146  , prevDescAndCmnt   :: Maybe String
147  , prevAccount       :: [String]
148  , prevAmountAndCmnt :: [String]
149  } deriving (Show)
150
151data AddingStage = EnterDateAndCode
152                 | EnterDescAndComment (Day, Text)
153                 | EnterAccount TxnParams
154                 | EnterAmountAndComment TxnParams String
155                 | EndStage Transaction
156                 | EnterNewPosting TxnParams (Maybe Posting)
157
158confirmedTransactionWizard :: PrevInput -> EntryState -> [AddingStage] -> Wizard Haskeline Transaction
159confirmedTransactionWizard prevInput es [] = confirmedTransactionWizard prevInput es [EnterDateAndCode]
160confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _) = case currentStage of
161  EnterDateAndCode -> dateAndCodeWizard prevInput es >>= \case
162    Just (date, code) -> do
163      let es' = es
164            { esArgs = drop 1 esArgs
165            , esDefDate = date
166            }
167          dateAndCodeString = formatTime defaultTimeLocale yyyymmddFormat date ++ (if T.null code then "" else " (" ++ T.unpack code ++ ")")
168          yyyymmddFormat = iso8601DateFormat Nothing
169      confirmedTransactionWizard prevInput{prevDateAndCode=Just dateAndCodeString} es' (EnterDescAndComment (date, code) : stack)
170    Nothing ->
171      confirmedTransactionWizard prevInput es stack
172
173  EnterDescAndComment (date, code) -> descriptionAndCommentWizard prevInput es >>= \case
174    Just (desc, comment) -> do
175      let mbaset = similarTransaction es desc
176          es' = es
177            { esArgs = drop 1 esArgs
178            , esPostings = []
179            , esSimilarTransaction = mbaset
180            }
181          descAndCommentString = T.unpack $ desc <> (if T.null comment then "" else "  ; " <> comment)
182          prevInput' = prevInput{prevDescAndCmnt=Just descAndCommentString}
183      when (isJust mbaset) $ liftIO $ hPrintf stderr "Using this similar transaction for defaults:\n%s" (showTransaction $ fromJust mbaset)
184      confirmedTransactionWizard prevInput' es' ((EnterNewPosting TxnParams{txnDate=date, txnCode=code, txnDesc=desc, txnCmnt=comment} Nothing) : stack)
185    Nothing ->
186      confirmedTransactionWizard prevInput es (drop 1 stack)
187
188  EnterNewPosting txnParams@TxnParams{..} posting -> case (esPostings, posting) of
189    ([], Nothing) ->
190      confirmedTransactionWizard prevInput es (EnterAccount txnParams : stack)
191    (_, Just _) ->
192      confirmedTransactionWizard prevInput es (EnterAccount txnParams : stack)
193    (_, Nothing) -> do
194      let t = nulltransaction{tdate=txnDate
195                             ,tstatus=Unmarked
196                             ,tcode=txnCode
197                             ,tdescription=txnDesc
198                             ,tcomment=txnCmnt
199                             ,tpostings=esPostings
200                             }
201      case balanceTransaction Nothing t of -- imprecise balancing (?)
202        Right t' ->
203          confirmedTransactionWizard prevInput es (EndStage t' : stack)
204        Left err -> do
205          liftIO (hPutStrLn stderr $ "\n" ++ (capitalize err) ++ "please re-enter.")
206          let notFirstEnterPost stage = case stage of
207                EnterNewPosting _ Nothing -> False
208                _ -> True
209          confirmedTransactionWizard prevInput es{esPostings=[]} (dropWhile notFirstEnterPost stack)
210
211  EnterAccount txnParams -> accountWizard prevInput es >>= \case
212    Just account
213      | account `elem` [".", ""] ->
214          case (esPostings, postingsBalanced esPostings) of
215            ([],_)    -> liftIO (hPutStrLn stderr "Please enter some postings first.") >> confirmedTransactionWizard prevInput es stack
216            (_,False) -> liftIO (hPutStrLn stderr "Please enter more postings to balance the transaction.") >> confirmedTransactionWizard prevInput es stack
217            (_,True)  -> confirmedTransactionWizard prevInput es (EnterNewPosting txnParams Nothing : stack)
218      | otherwise -> do
219          let prevAccount' = replaceNthOrAppend (length esPostings) account (prevAccount prevInput)
220          confirmedTransactionWizard prevInput{prevAccount=prevAccount'} es{esArgs=drop 1 esArgs} (EnterAmountAndComment txnParams account : stack)
221    Nothing -> do
222      let notPrevAmountAndNotEnterDesc stage = case stage of
223            EnterAmountAndComment _ _ -> False
224            EnterDescAndComment _ -> False
225            _ -> True
226      confirmedTransactionWizard prevInput es{esPostings=init esPostings} (dropWhile notPrevAmountAndNotEnterDesc stack)
227
228  EnterAmountAndComment txnParams account -> amountAndCommentWizard prevInput es >>= \case
229    Just (amount, comment) -> do
230      let posting = nullposting{paccount=T.pack $ stripbrackets account
231                               ,pamount=Mixed [amount]
232                               ,pcomment=comment
233                               ,ptype=accountNamePostingType $ T.pack account
234                               }
235          amountAndCommentString = showAmount amount ++ (if T.null comment then "" else "  ;" ++ T.unpack comment)
236          prevAmountAndCmnt' = replaceNthOrAppend (length esPostings) amountAndCommentString (prevAmountAndCmnt prevInput)
237          es' = es{esPostings=esPostings++[posting], esArgs=drop 2 esArgs}
238      confirmedTransactionWizard prevInput{prevAmountAndCmnt=prevAmountAndCmnt'} es' (EnterNewPosting txnParams (Just posting) : stack)
239    Nothing -> confirmedTransactionWizard prevInput es (drop 1 stack)
240
241  EndStage t -> do
242    output $ showTransaction t
243    y <- let def = "y" in
244         retryMsg "Please enter y or n." $
245          parser ((fmap (\c -> if c == '<' then Nothing else Just c)) . headMay . map toLower . strip) $
246          defaultTo' def $ nonEmpty $
247          line $ green $ printf "Save this transaction to the journal ?%s: " (showDefault def)
248    case y of
249      Just 'y' -> return t
250      Just _   -> throw RestartTransactionException
251      Nothing  -> confirmedTransactionWizard prevInput es (drop 2 stack)
252  where
253    replaceNthOrAppend n newElem xs = take n xs ++ [newElem] ++ drop (n + 1) xs
254
255-- Identify the closest recent match for this description in past transactions.
256similarTransaction :: EntryState -> Text -> Maybe Transaction
257similarTransaction EntryState{..} desc =
258  let q = queryFromOptsOnly esToday $ reportopts_ esOpts
259      historymatches = transactionsSimilarTo esJournal q desc
260      bestmatch | null historymatches = Nothing
261                | otherwise           = Just $ snd $ head historymatches
262  in bestmatch
263
264dateAndCodeWizard PrevInput{..} EntryState{..} = do
265  let def = headDef (showDate esDefDate) esArgs
266  retryMsg "A valid hledger smart date is required. Eg: 2014/2/14, 14, yesterday." $
267   parser (parseSmartDateAndCode esToday) $
268   withCompletion (dateCompleter def) $
269   defaultTo' def $ nonEmpty $
270   maybeExit $
271   -- maybeShowHelp $
272   linePrewritten (green $ printf "Date%s: " (showDefault def)) (fromMaybe "" prevDateAndCode) ""
273    where
274      parseSmartDateAndCode refdate s = if s == "<" then return Nothing else either (const Nothing) (\(d,c) -> return $ Just (fixSmartDate refdate d, c)) edc
275          where
276            edc = runParser (dateandcodep <* eof) "" $ T.pack $ lowercase s
277            dateandcodep :: SimpleTextParser (SmartDate, Text)
278            dateandcodep = do
279                d <- smartdate
280                c <- optional codep
281                skipNonNewlineSpaces
282                eof
283                return (d, fromMaybe "" c)
284      -- defday = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) defdate
285      -- datestr = showDate $ fixSmartDate defday smtdate
286
287descriptionAndCommentWizard PrevInput{..} EntryState{..} = do
288  let def = headDef "" esArgs
289  s <- withCompletion (descriptionCompleter esJournal def) $
290       defaultTo' def $ nonEmpty $
291       linePrewritten (green $ printf "Description%s: " (showDefault def)) (fromMaybe "" prevDescAndCmnt) ""
292  if s == "<"
293    then return Nothing
294    else do
295      let (desc,comment) = (T.pack $ strip a, T.pack $ strip $ dropWhile (==';') b) where (a,b) = break (==';') s
296      return $ Just (desc, comment)
297
298postingsBalanced :: [Posting] -> Bool
299postingsBalanced ps = isRight $ balanceTransaction Nothing nulltransaction{tpostings=ps}
300
301accountWizard PrevInput{..} EntryState{..} = do
302  let pnum = length esPostings + 1
303      historicalp = fmap ((!! (pnum - 1)) . (++ (repeat nullposting)) . tpostings) esSimilarTransaction
304      historicalacct = case historicalp of Just p  -> showAccountName Nothing (ptype p) (paccount p)
305                                           Nothing -> ""
306      def = headDef historicalacct esArgs
307      endmsg | canfinish && null def = " (or . or enter to finish this transaction)"
308             | canfinish             = " (or . to finish this transaction)"
309             | otherwise             = ""
310  retryMsg "A valid hledger account name is required. Eg: assets:cash, expenses:food:eating out." $
311   parser (parseAccountOrDotOrNull def canfinish) $
312   withCompletion (accountCompleter esJournal def) $
313   defaultTo' def $ -- nonEmpty $
314   linePrewritten (green $ printf "Account %d%s%s: " pnum (endmsg::String) (showDefault def)) (fromMaybe "" $ prevAccount `atMay` length esPostings) ""
315    where
316      canfinish = not (null esPostings) && postingsBalanced esPostings
317      parseAccountOrDotOrNull :: String -> Bool -> String -> Maybe (Maybe String)
318      parseAccountOrDotOrNull _  _ "<"       = dbg1 $ Just Nothing
319      parseAccountOrDotOrNull _  _ "."       = dbg1 $ Just $ Just "." -- . always signals end of txn
320      parseAccountOrDotOrNull "" True ""     = dbg1 $ Just $ Just ""  -- when there's no default and txn is balanced, "" also signals end of txn
321      parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just $ Just def -- when there's a default, "" means use that
322      parseAccountOrDotOrNull _ _ s          = dbg1 $ fmap (Just . T.unpack) $
323        either (const Nothing) validateAccount $
324          flip evalState esJournal $ runParserT (accountnamep <* eof) "" (T.pack s) -- otherwise, try to parse the input as an accountname
325        where
326          validateAccount :: Text -> Maybe Text
327          validateAccount t | no_new_accounts_ esOpts && notElem t (journalAccountNamesDeclaredOrImplied esJournal) = Nothing
328                            | otherwise = Just t
329      dbg1 = id -- strace
330
331amountAndCommentWizard PrevInput{..} EntryState{..} = do
332  let pnum = length esPostings + 1
333      (mhistoricalp,followedhistoricalsofar) =
334          case esSimilarTransaction of
335            Nothing                        -> (Nothing,False)
336            Just Transaction{tpostings=ps} -> (if length ps >= pnum then Just (ps !! (pnum-1)) else Nothing
337                                              ,all (\(a,b) -> pamount a == pamount b) $ zip esPostings ps)
338      def = case (esArgs, mhistoricalp, followedhistoricalsofar) of
339              (d:_,_,_)                                             -> d
340              (_,Just hp,True)                                      -> showamt $ pamount hp
341              _  | pnum > 1 && not (mixedAmountLooksZero balancingamt) -> showamt balancingamtfirstcommodity
342              _                                                     -> ""
343  retryMsg "A valid hledger amount is required. Eg: 1, $2, 3 EUR, \"4 red apples\"." $
344   parser parseAmountAndComment $
345   withCompletion (amountCompleter def) $
346   defaultTo' def $ nonEmpty $
347   linePrewritten (green $ printf "Amount  %d%s: " pnum (showDefault def)) (fromMaybe "" $ prevAmountAndCmnt `atMay` length esPostings) ""
348    where
349      parseAmountAndComment s = if s == "<" then return Nothing else either (const Nothing) (return . Just) $
350                                runParser
351                                  (evalStateT (amountandcommentp <* eof) nodefcommodityj)
352                                  ""
353                                  (T.pack s)
354      nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing}
355      amountandcommentp :: JournalParser Identity (Amount, Text)
356      amountandcommentp = do
357        a <- amountp
358        lift skipNonNewlineSpaces
359        c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle)
360        -- eof
361        return (a,c)
362      balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings
363      balancingamtfirstcommodity = Mixed $ take 1 $ amounts balancingamt
364      showamt =
365        showMixedAmountWithPrecision
366                  -- what should this be ?
367                  -- 1 maxprecision (show all decimal places or none) ?
368                  -- 2 maxprecisionwithpoint (show all decimal places or .0 - avoids some but not all confusion with thousands separators) ?
369                  -- 3 canonical precision for this commodity in the journal ?
370                  -- 4 maximum precision entered so far in this transaction ?
371                  -- 5 3 or 4, whichever would show the most decimal places ?
372                  -- I think 1 or 4, whichever would show the most decimal places
373                  NaturalPrecision
374  --
375  -- let -- (amt,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amtcmt
376      -- a           = fromparse $ runParser (amountp <|> return missingamt) (jparsestate esJournal) "" amt
377  --     awithoutjps = fromparse $ runParser (amountp <|> return missingamt) mempty              "" amt
378  --     defamtaccepted = Just (showAmount a) == mdefamt
379  --     es2 = if defamtaccepted then es1 else es1{esHistoricalPostings=Nothing}
380  --     mdefaultcommodityapplied = if acommodity a == acommodity awithoutjps then Nothing else Just $ acommodity a
381  -- when (isJust mdefaultcommodityapplied) $
382  --      liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust mdefaultcommodityapplied)
383
384maybeExit = parser (\s -> if s=="." then throw UnexpectedEOF else Just s)
385
386-- maybeShowHelp :: Wizard Haskeline String -> Wizard Haskeline String
387-- maybeShowHelp wizard = maybe (liftIO showHelp >> wizard) return $
388--                        parser (\s -> if s=="?" then Nothing else Just s) wizard
389
390-- Completion helpers
391
392dateCompleter :: String -> CompletionFunc IO
393dateCompleter = completer ["today","tomorrow","yesterday"]
394
395descriptionCompleter :: Journal -> String -> CompletionFunc IO
396descriptionCompleter j = completer (map T.unpack $ journalDescriptions j)
397
398accountCompleter :: Journal -> String -> CompletionFunc IO
399accountCompleter j = completer (map T.unpack $ journalAccountNamesDeclaredOrImplied j)
400
401amountCompleter :: String -> CompletionFunc IO
402amountCompleter = completer []
403
404-- | Generate a haskeline completion function from the given
405-- completions and default, that case insensitively completes with
406-- prefix matches, or infix matches above a minimum length, or
407-- completes the null string with the default.
408completer :: [String] -> String -> CompletionFunc IO
409completer completions def = completeWord Nothing "" completionsFor
410    where
411      simpleCompletion' s = (simpleCompletion s){isFinished=False}
412      completionsFor "" = return [simpleCompletion' def]
413      completionsFor i  = return (map simpleCompletion' ciprefixmatches)
414          where
415            ciprefixmatches = [c | c <- completions, i `isPrefixOf` c]
416            -- mixed-case completions require haskeline > 0.7.1.2
417            -- ciprefixmatches = [c | c <- completions, lowercase i `isPrefixOf` lowercase c]
418
419--------------------------------------------------------------------------------
420
421-- utilities
422
423defaultTo' = flip defaultTo
424
425withCompletion f = withSettings (setComplete f defaultSettings)
426
427green s = "\ESC[1;32m\STX"++s++"\ESC[0m\STX"
428
429showDefault "" = ""
430showDefault s = " [" ++ s ++ "]"
431
432-- | Append this transaction to the journal's file and transaction list.
433journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal
434journalAddTransaction j@Journal{jtxns=ts} opts t = do
435  let f = journalFilePath j
436  appendToJournalFileOrStdout f $ showTransaction t
437    -- unelided shows all amounts explicitly, in case there's a price, cf #283
438  when (debug_ opts > 0) $ do
439    putStrLn $ printf "\nAdded transaction to %s:" f
440    putStrLn =<< registerFromString (showTransaction t)
441  return j{jtxns=ts++[t]}
442
443-- | Append a string, typically one or more transactions, to a journal
444-- file, or if the file is "-", dump it to stdout.  Tries to avoid
445-- excess whitespace.
446--
447-- XXX This writes unix line endings (\n), some at least,
448-- even if the file uses dos line endings (\r\n), which could leave
449-- mixed line endings in the file. See also writeFileWithBackupIfChanged.
450--
451appendToJournalFileOrStdout :: FilePath -> String -> IO ()
452appendToJournalFileOrStdout f s
453  | f == "-"  = putStr s'
454  | otherwise = appendFile f s'
455  where s' = "\n" ++ ensureOneNewlineTerminated s
456
457-- | Replace a string's 0 or more terminating newlines with exactly one.
458ensureOneNewlineTerminated :: String -> String
459ensureOneNewlineTerminated = (++"\n") . reverse . dropWhile (=='\n') . reverse
460
461-- | Convert a string of journal data into a register report.
462registerFromString :: String -> IO String
463registerFromString s = do
464  d <- getCurrentDay
465  j <- readJournal' $ T.pack s
466  return $ postingsReportAsText opts $ postingsReport ropts (queryFromOpts d ropts) j
467      where
468        ropts = defreportopts{empty_=True}
469        opts = defcliopts{reportopts_=ropts}
470
471capitalize :: String -> String
472capitalize "" = ""
473capitalize (c:cs) = toUpper c : cs
474
475-- | Find the most similar and recent transactions matching the given
476-- transaction description and report query.  Transactions are listed
477-- with their "relevancy" score, most relevant first.
478transactionsSimilarTo :: Journal -> Query -> Text -> [(Double,Transaction)]
479transactionsSimilarTo j q desc =
480    sortBy compareRelevanceAndRecency
481               $ filter ((> threshold).fst)
482               [(compareDescriptions desc $ tdescription t, t) | t <- ts]
483    where
484      compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,tdate t2) (n1,tdate t1)
485      ts = filter (q `matchesTransaction`) $ jtxns j
486      threshold = 0
487
488-- | Return a similarity measure, from 0 to 1, for two transaction
489-- descriptions.  This is like compareStrings, but first strips out
490-- any numbers, to improve accuracy eg when there are bank transaction
491-- ids from imported data.
492compareDescriptions :: Text -> Text -> Double
493compareDescriptions s t = compareStrings s' t'
494    where s' = simplify $ T.unpack s
495          t' = simplify $ T.unpack t
496          simplify = filter (not . (`elem` ("0123456789" :: String)))
497
498-- | Return a similarity measure, from 0 to 1, for two strings.  This
499-- was based on Simon White's string similarity algorithm
500-- (http://www.catalysoft.com/articles/StrikeAMatch.html), later found
501-- to be https://en.wikipedia.org/wiki/S%C3%B8rensen%E2%80%93Dice_coefficient,
502-- modified to handle short strings better.
503-- Todo: check out http://nlp.fi.muni.cz/raslan/2008/raslan08.pdf#page=14 .
504compareStrings :: String -> String -> Double
505compareStrings "" "" = 1
506compareStrings [_] "" = 0
507compareStrings "" [_] = 0
508compareStrings [a] [b] = if toUpper a == toUpper b then 1 else 0
509compareStrings s1 s2 = 2 * commonpairs / totalpairs
510    where
511      pairs1      = S.fromList $ wordLetterPairs $ uppercase s1
512      pairs2      = S.fromList $ wordLetterPairs $ uppercase s2
513      commonpairs = fromIntegral $ S.size $ S.intersection pairs1 pairs2
514      totalpairs  = fromIntegral $ S.size pairs1 + S.size pairs2
515
516wordLetterPairs = concatMap letterPairs . words
517
518letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest)
519letterPairs _ = []
520