module Model
( Step(..)
, MaybeStep(..)
, MatchAlgo(..)
, nextStep
, undo
, context
, suggest
) where
import Data.Function
import Data.List
import qualified Data.HashMap.Lazy as HM
import Data.Maybe
import Data.Monoid
import Data.Ord (Down(..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time hiding (parseTime)
import qualified Hledger as HL
import AmountParser
import DateParser
data Step = DateQuestion
| DescriptionQuestion Day
| AccountQuestion HL.Transaction
| AmountQuestion HL.AccountName HL.Transaction
| FinalQuestion HL.Transaction
deriving (Eq, Show)
data MaybeStep = Finished HL.Transaction
| Step Step
deriving (Eq, Show)
data MatchAlgo = Fuzzy | Substrings
deriving (Eq, Show)
nextStep :: HL.Journal -> DateFormat -> Either Text Text -> Step -> IO (Either Text MaybeStep)
nextStep journal dateFormat entryText current = case current of
DateQuestion ->
fmap (Step . DescriptionQuestion) <$> either (parseDateWithToday dateFormat)
parseHLDateWithToday
entryText
DescriptionQuestion day -> return $ Right $ Step $
AccountQuestion HL.nulltransaction { HL.tdate = day
, HL.tdescription = (fromEither entryText)
}
AccountQuestion trans
| T.null (fromEither entryText) && transactionBalanced trans
-> return $ Right $ Step $ FinalQuestion trans
| T.null (fromEither entryText)
-> return $ Left $ "Transaction not balanced! Please balance your transaction before adding it to the journal."
| otherwise -> return $ Right $ Step $
AmountQuestion (fromEither entryText) trans
AmountQuestion name trans -> case parseAmount journal (fromEither entryText) of
Left err -> return $ Left (T.pack err)
Right amount -> return $ Right $ Step $
let newPosting = post' name amount
in AccountQuestion (addPosting newPosting trans)
FinalQuestion trans
| fromEither entryText == "y" -> return $ Right $ Finished trans
| otherwise -> return $ Right $ Step $ AccountQuestion trans
undo :: Step -> Either Text Step
undo current = case current of
DateQuestion -> Left "Already at oldest step in current transaction"
DescriptionQuestion _ -> return DateQuestion
AccountQuestion trans -> return $ case HL.tpostings trans of
[] -> DescriptionQuestion (HL.tdate trans)
ps -> AmountQuestion (HL.paccount (last ps)) trans { HL.tpostings = init ps }
AmountQuestion _ trans -> Right $ AccountQuestion trans
FinalQuestion trans -> undo (AccountQuestion trans)
context :: HL.Journal -> MatchAlgo -> DateFormat -> Text -> Step -> IO [Text]
context _ _ dateFormat entryText DateQuestion = parseDateWithToday dateFormat entryText >>= \case
Left _ -> return []
Right date -> return [T.pack $ HL.showDate date]
context j matchAlgo _ entryText (DescriptionQuestion _) = return $
let descs = HL.journalDescriptions j
in sortBy (descUses j) $ filter (matches matchAlgo entryText) descs
context j matchAlgo _ entryText (AccountQuestion _) = return $
let names = HL.journalAccountNames j
in filter (matches matchAlgo entryText) names
context journal _ _ entryText (AmountQuestion _ _) = return $
maybeToList $ T.pack . HL.showMixedAmount <$> trySumAmount journal entryText
context _ _ _ _ (FinalQuestion _) = return []
suggest :: HL.Journal -> DateFormat -> Step -> IO (Maybe Text)
suggest _ dateFormat DateQuestion =
Just . printDate dateFormat . utctDay <$> getCurrentTime
suggest _ _ (DescriptionQuestion _) = return Nothing
suggest journal _ (AccountQuestion trans) = return $
if numPostings trans /= 0 && transactionBalanced trans
then Nothing
else HL.paccount <$> (suggestAccountPosting journal trans)
suggest journal _ (AmountQuestion account trans) = return $ fmap (T.pack . HL.showMixedAmount) $
if transactionBalanced trans
then HL.pamount <$> (findPostingByAcc account =<< findLastSimilar journal trans)
else Just $ negativeAmountSum trans
suggest _ _ (FinalQuestion _) = return $ Just "y"
matches :: MatchAlgo -> Text -> Text -> Bool
matches algo a b
| T.null a = False
| otherwise = matches' (T.toCaseFold a) (T.toCaseFold b)
where
matches' a' b'
| algo == Fuzzy && T.any (== ':') b' = all (`fuzzyMatch` (T.splitOn ":" b')) (T.words a')
| otherwise = all (`T.isInfixOf` b') (T.words a')
fuzzyMatch :: Text -> [Text] -> Bool
fuzzyMatch _ [] = False
fuzzyMatch query (part : partsRest) = case (T.uncons query) of
Nothing -> True
Just (c, queryRest)
| c == ':' -> fuzzyMatch queryRest partsRest
| otherwise -> fuzzyMatch query partsRest || case (T.uncons part) of
Nothing -> False
Just (c2, partRest)
| c == c2 -> fuzzyMatch queryRest (partRest : partsRest)
| otherwise -> False
post' :: HL.AccountName -> HL.MixedAmount -> HL.Posting
post' account amount = HL.nullposting { HL.paccount = account
, HL.pamount = amount
}
addPosting :: HL.Posting -> HL.Transaction -> HL.Transaction
addPosting p t = t { HL.tpostings = (HL.tpostings t) ++ [p] }
trySumAmount :: HL.Journal -> Text -> Maybe HL.MixedAmount
trySumAmount ctx = either (const Nothing) Just . parseAmount ctx
suggestNextPosting :: HL.Transaction -> HL.Transaction -> Maybe HL.Posting
suggestNextPosting current reference =
let unusedPostings = filter (`notContainedIn` curPostings) refPostings
in listToMaybe $ sortBy cmpPosting unusedPostings
where [refPostings, curPostings] = map HL.tpostings [reference, current]
notContainedIn p = not . any (((==) `on` HL.paccount) p)
cmpPosting = compare `on` (Down . HL.pamount)
suggestCorrespondingPosting :: HL.Transaction -> HL.Transaction -> Maybe HL.Posting
suggestCorrespondingPosting current reference =
let postingsEntered = length curPostings in
if postingsEntered < (length refPostings) then
Just (refPostings !! postingsEntered)
else
suggestNextPosting current reference
where [refPostings, curPostings] = map HL.tpostings [reference, current]
findLastSimilar :: HL.Journal -> HL.Transaction -> Maybe HL.Transaction
findLastSimilar journal desc =
maximumBy (compare `on` HL.tdate) <$>
listToMaybe' (filter (((==) `on` HL.tdescription) desc) $ HL.jtxns journal)
suggestAccountPosting :: HL.Journal -> HL.Transaction -> Maybe HL.Posting
suggestAccountPosting journal trans =
case findLastSimilar journal trans of
Just t -> suggestNextPosting trans t
Nothing -> (last <$> listToMaybe' (HL.jtxns journal)) >>= (suggestCorrespondingPosting trans)
findPostingByAcc :: HL.AccountName -> HL.Transaction -> Maybe HL.Posting
findPostingByAcc account = find ((==account) . HL.paccount) . HL.tpostings
listToMaybe' :: [a] -> Maybe [a]
listToMaybe' [] = Nothing
listToMaybe' ls = Just ls
numPostings :: HL.Transaction -> Int
numPostings = length . HL.tpostings
transactionBalanced :: HL.Transaction -> Bool
transactionBalanced trans =
let (rsum, _, _) = HL.transactionPostingBalances trans
in HL.isZeroMixedAmount rsum
negativeAmountSum :: HL.Transaction -> HL.MixedAmount
negativeAmountSum trans =
let (rsum, _, _) = HL.transactionPostingBalances trans
in HL.divideMixedAmount rsum (1)
descUses :: HL.Journal -> Text -> Text -> Ordering
descUses journal = compare `on` (Down . flip HM.lookup usesMap)
where usesMap = foldr (count . HL.tdescription) HM.empty $
HL.jtxns journal
count :: Text -> HM.HashMap Text (Sum Int) -> HM.HashMap Text (Sum Int)
count = HM.alter (<> Just 1)
fromEither :: Either a a -> a
fromEither = either id id