app/Main.hs

@@ -204,12 +204,15 @@ runDumpAccountKeys c = do
 runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
 runSync threads c bs hs = do
   setNumCapabilities threads
+  -- putStrLn "reading config"
   config <- readConfig c
+  -- putStrLn "reading statements"
   (bs', hs') <-
     fmap (bimap concat concat . partitionEithers) $
       pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
         (Left <$> bs) ++ (Right <$> hs)
   pool <- runNoLoggingT $ mkPool $ sqlConfig config
+  putStrLn "doing other stuff"
   setNumCapabilities 1
   handle err $ sync pool root config bs' hs'
   where

dhall/Types.dhall

@@ -278,126 +278,54 @@ let DatePat =
     -}
       < Cron : CronPat.Type | Mod : ModPat.Type >
 
-let TxAmount1_ =
-      \(re : Type) ->
-        { a1Column : Text
-        , a1Fmt :
-            {-
-            Format of the amount field. Must include three fields for the
-            sign, numerator, and denominator of the amount.
-            -}
-            re
-        }
-
-let TxAmount1 =
-      { Type = TxAmount1_ Text
-      , default = { a1Column = "Amount", a1Fmt = "([-+])?([0-9\\.]+)" }
-      }
-
-let TxAmount2_ =
-      \(re : Type) ->
-        { a2Positive : Text
-        , a2Negative : Text
-        , a2Fmt :
-            {-
-            Format of the amount field. Must include two fields for the
-            numerator and denominator of the amount.
-            -}
-            re
-        }
-
-let TxAmount2 =
-      { Type = TxAmount2_ Text
-      , default =
-        { a2Positive = "Deposit"
-        , a2Negative = "Withdraw"
-        , a2Fmt = "([0-9\\.]+)"
-        }
-      }
-
-let TxAmountSpec_ =
-      \(re : Type) ->
-        < AmountSingle : TxAmount1_ re | AmountDual : TxAmount2_ re >
-
 let TxOpts_ =
-    {-
+    {- Additional metadata to use when parsing a statement -}
-    Additional metadata to use when parsing a statement
-    -}
       \(re : Type) ->
-        { toDate :
+        { Type =
-            {-
+            { toDate :
-            Column title for date
+                {-
-            -}
+                Column title for date
-            Text
+                -}
-        , toAmount :
+                Text
-            {-
+            , toAmount :
-            Column title for amount
+                {-
-            -}
+                Column title for amount
-            TxAmountSpec_ re
+                -}
-        , toDesc :
+                Text
-            {-
+            , toDesc :
-            Column title for description
+                {-
-            -}
+                Column title for description
-            Text
+                -}
-        , toOther :
+                Text
-            {-
+            , toOther :
-            Titles of other columns to include; these will be available in
+                {-
-            a map for use in downstream processing (see 'Field')
+                Titles of other columns to include; these will be available in
-            -}
+                a map for use in downstream processing (see 'Field')
-            List Text
+                -}
-        , toDateFmt :
+                List Text
-            {-
+            , toDateFmt :
-            Format of the date field as specified in the
+                {-
-            Data.Time.Format.formattime Haskell function.
+                Format of the date field as specified in the
-            -}
+                Data.Time.Format.formattime Haskell function.
-            Text
+                -}
-        , toSkipBlankDate :
+                Text
-            {-
+            , toAmountFmt :
-            Skip line if date field is a blank
+                {- Format of the amount field. Must include three fields for the
-            -}
+                sign, numerator, and denominator of the amount.
-            Bool
+                -}
-        , toSkipBlankAmount :
+                re
-            {-
+            }
-            Skip line if amount field(s) is(are) a blank
+        , default =
-            -}
+          { toDate = "Date"
-            Bool
+          , toAmount = "Amount"
-        , toSkipBlankDescription :
+          , toDesc = "Description"
-            {-
+          , toOther = [] : List Text
-            Skip line if description field is a blank
+          , toDateFmt = "%0m/%0d/%Y"
-            -}
+          , toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
-            Bool
+          }
-        , toSkipBlankOther :
-            {-
-            Skip line if any arbitrary fields are blank (these fields must also
-            be listed in 'toOther' to be considered)
-            -}
-            List Text
-        , toSkipMissingFields :
-            {-
-            Skip line if any fields are missing (this is different from blank;
-            'missing' means there is no field with name 'X', 'blank' means that
-            there is a field 'X' and its value is an empty string)
-            -}
-            Bool
         }
 
-let TxAmountSpec = TxAmountSpec_ Text
+let TxOpts = TxOpts_ Text
-
-let TxOpts =
-      { Type = TxOpts_ Text
-      , default =
-        { toDate = "Date"
-        , toAmount = TxAmountSpec.AmountSingle TxAmount1::{=}
-        , toDesc = "Description"
-        , toOther = [] : List Text
-        , toDateFmt = "%0m/%0d/%Y"
-        , toSkipBlankDate = False
-        , toSkipBlankAmount = False
-        , toSkipBlankDescription = False
-        , toSkipBlankOther = [] : List Text
-        , toSkipMissingFields = False
-        }
-      }
 
 let Field =
     {-
@@ -1056,40 +984,54 @@ let Income =
         }
       }
 
-let AcntMatcher_ =
+let AcntSet =
     {-
-    Regex pattern by which matching account ids will be identified
+    A list of account IDs represented as a set.
     -}
-      \(re : Type) ->
+      { Type =
-        { Type = { amPat : re, amInvert : Bool }, default.amInvert = False }
+          { asList : List AcntID
+          , asInclude :
+              {-
+              If true, tests for account membership in this set will return
+              true if the account is in the set. Invert this behavior otherwise.
+              -}
+              Bool
+          }
+      , default = { asList = [] : List AcntID, asInclude = False }
+      }
 
-let AcntMatcher = AcntMatcher_ Text
+let TransferMatcher =
-
-let TransferMatcher_ =
     {-
     Means to match a transfer (which will be used to "clone" it in some
     fashion)
     -}
-      \(re : Type) ->
+      { Type =
-        { tmFrom : Optional (AcntMatcher_ re).Type
+          { tmFrom :
-        , tmTo : Optional (AcntMatcher_ re).Type
+              {-
-        , tmDate :
+              List of accounts (which may be empty) to match with the
-            {-
+              starting account in a transfer.
-            If given, means to match the date of a transfer.
+              -}
-            -}
+              AcntSet.Type
-            Optional DateMatcher
+          , tmTo :
-        , tmVal :
+              {-
-            {-
+              List of accounts (which may be empty) to match with the
-            If given, means to match the value of a transfer.
+              ending account in a transfer.
-            -}
+              -}
-            ValMatcher.Type
+              AcntSet.Type
-        }
+          , tmDate :
-
+              {-
-let TransferMatcher =
+              If given, means to match the date of a transfer.
-      { Type = TransferMatcher_ Text
+              -}
+              Optional DateMatcher
+          , tmVal :
+              {-
+              If given, means to match the value of a transfer.
+              -}
+              ValMatcher.Type
+          }
       , default =
-        { tmFrom = None AcntMatcher.Type
+        { tmFrom = AcntSet.default
-        , tmTo = None AcntMatcher.Type
+        , tmTo = AcntSet.default
         , tmDate = None DateMatcher
         , tmVal = ValMatcher.default
         }
@@ -1206,9 +1148,9 @@ in  { CurID
     , Budget
     , Allocation
     , Amount
-    , TransferMatcher_
     , TransferMatcher
     , ShadowTransfer
+    , AcntSet
     , TaggedAcnt
     , AccountTree
     , Account
@@ -1235,13 +1177,4 @@ in  { CurID
     , TransferAmount
     , MultiAlloAmount
     , SingleAlloAmount
-    , AcntMatcher_
-    , AcntMatcher
-    , TxAmountSpec
-    , TxAmountSpec_
-    , TxAmount1_
-    , TxAmount2_
-    , TxAmount1
-    , TxAmount2
-    , BudgetTransfer
     }

lib/Internal/Budget.hs

@@ -38,8 +38,9 @@ readBudget
           (intAllos, _) <- combineError intAlloRes acntRes (,)
           let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes
           let res2 = expandTransfers c budgetSpan bgtTransfers
-          combineErrorM (concat <$> res1) res2 $ \is ts ->
+          txs <- combineError (concat <$> res1) res2 (++)
-            addShadowTransfers bgtShadowTransfers (is ++ ts)
+          shadow <- addShadowTransfers bgtShadowTransfers txs
+          return $ txs ++ shadow
     where
       c = CommitR (CommitHash $ hash b) CTBudget
       acntRes = mapErrors isNotIncomeAcnt alloAcnts
@@ -145,7 +146,7 @@ readIncome
         let allos = allo2Trans <$> (pre ++ tax ++ post)
         let primary =
               EntrySet
-                { esTotalValue = -gross
+                { esTotalValue = gross
                 , esCurrency = cpID cp
                 , esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
                 , esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
@@ -345,31 +346,26 @@ fromShadow
   -> ShadowTransfer
   -> m (Maybe ShadowEntrySet)
 fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
-  combineErrorM curRes mRes $ \cur compiled -> do
+  combineErrorM curRes shaRes $ \cur sha -> do
-    res <- liftExcept $ shadowMatches compiled tx
     let es = entryPair stFrom stTo cur stDesc stRatio ()
-    return $ if not res then Nothing else Just es
+    return $ if not sha then Nothing else Just es
   where
-    curRes = lookupCurrencyKey stCurrency
+    curRes = lookupCurrencyKey (CurID stCurrency)
-    mRes = liftExcept $ compileMatch stMatch
+    shaRes = liftExcept $ shadowMatches stMatch tx
 
-shadowMatches :: TransferMatcherRe -> Tx CommitR -> AppExcept Bool
+shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
 shadowMatches
-  TransferMatcher_ {tmFrom, tmTo, tmDate, tmVal}
+  TransferMatcher {tmFrom, tmTo, tmDate, tmVal}
   Tx {txPrimary, txMeta = TxMeta {txmDate}} =
     do
-      -- ASSUME these will never fail and thus I don't need to worry about
-      -- stacking the errors
-      fromRes <- acntMatches fa tmFrom
-      toRes <- acntMatches ta tmTo
       -- NOTE this will only match against the primary entry set since those
       -- are what are guaranteed to exist from a transfer
       valRes <- case txPrimary of
         Left es -> valMatches tmVal $ toRational $ esTotalValue es
         Right _ -> return True
       return $
-        fromRes
+        memberMaybe fa tmFrom
-          && toRes
+          && memberMaybe ta tmTo
           && maybe True (`dateMatches` txmDate) tmDate
           && valRes
     where
@@ -378,22 +374,8 @@ shadowMatches
       getAcntFrom = getAcnt esFrom
       getAcntTo = getAcnt esTo
       getAcnt f = eAcnt . hesPrimary . f
-      acntMatches (AcntID a) = maybe (return True) (match' a)
+      memberMaybe x AcntSet {asList, asInclude} =
-      match' a AcntMatcher_ {amPat, amInvert} =
+        (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
-        (if amInvert then not else id) <$> matchMaybe a amPat
-
-compileMatch :: TransferMatcher_ T.Text -> AppExcept TransferMatcherRe
-compileMatch m@TransferMatcher_ {tmTo, tmFrom} =
-  combineError tres fres $ \t f -> m {tmTo = t, tmFrom = f}
-  where
-    go a@AcntMatcher_ {amPat} = do
-      (_, p) <- compileRegex False amPat
-      return $ a {amPat = p}
-    tres = mapM go tmTo
-    fres = mapM go tmFrom
-
--- memberMaybe x AcntSet {asList, asInclude} =
---   (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
 
 --------------------------------------------------------------------------------
 -- random

lib/Internal/Database.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ImplicitPrelude #-}
+
 module Internal.Database
   ( runDB
   , readDB
@@ -22,7 +24,6 @@ import Control.Monad.IO.Rerunnable
 import Control.Monad.Logger
 import Data.Decimal
 import Data.Hashable
-import qualified Data.Text.IO as TI
 import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
 import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
@@ -39,11 +40,12 @@ import Database.Persist.Sqlite hiding
   , (==.)
   , (||.)
   )
+-- import GHC.Err
 import Internal.Budget
 import Internal.History
 import Internal.Types.Main
 import Internal.Utils
-import RIO hiding (LogFunc, isNothing, logDebug, on, (^.))
+import RIO hiding (LogFunc, isNothing, on, (^.))
 import qualified RIO.List as L
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as NE
@@ -73,7 +75,15 @@ sync pool root c bs hs = do
       b <- liftIOExceptT $ readBudgetCRUD budgets
       h <- readHistoryCRUD root history
       return (b, h)
-  liftIO $ TI.putStr $ formatBuildPlan history budgets
+  -- liftIO $ print $ length $ coCreate budgets
+  liftIO $ print $ length $ fst $ coCreate history
+  liftIO $ print $ bimap length length $ coCreate history
+  liftIO $ print $ length $ coRead history
+  liftIO $ print $ length $ coUpdate history
+  liftIO $ print $ (\(DeleteTxs e a b c' d) -> (length e, length a, length b, length c', length d)) $ coDelete history
+  -- liftIO $ print $ length $ M.elems $ tsAccountMap txState
+  -- liftIO $ print $ length $ M.elems $ tsCurrencyMap txState
+  -- liftIO $ print $ length $ M.elems $ tsTagMap txState
 
   -- Update the DB.
   runSqlQueryT pool $ withTransaction $ flip runReaderT txState $ do
@@ -88,35 +98,6 @@ sync pool root c bs hs = do
     -- thrown error should be caught despite possibly needing to be rerun
     rerunnableIO $ fromEither res
 
-formatBuildPlan :: PreHistoryCRUD -> PreBudgetCRUD -> T.Text
-formatBuildPlan
-  CRUDOps {coCreate = hc, coRead = hr, coUpdate = hu, coDelete = hd}
-  CRUDOps {coCreate = bc, coDelete = bd} =
-    T.unlines $ "Build plan:" : (T.append "  " <$> ht ++ [""] ++ bt)
-    where
-      ht =
-        [ T.append "History transfers to create: " $ tshow hCt
-        , T.append "History statements to create: " $ tshow hCs
-        , T.append "History entries to read: " $ tshow $ length hr
-        , T.append "History entry sets to update: " $ tshow $ length hu
-        ]
-          ++ formatDel "History" hd
-      bt =
-        T.append "Budgets to create: " (tshow $ bgtLabel <$> bc)
-          : formatDel "Budget" bd
-      toDel what thing n = T.unwords [what, thing, "to delete:", tshow n]
-      formatDel what (DeleteTxs e a b c' d) =
-        [ f "commits" e
-        , f "transactions" a
-        , f "entry sets" b
-        , f "entries" c'
-        , f "tag relations" d
-        ]
-        where
-          f :: T.Text -> [a] -> T.Text
-          f thing = toDel what thing . length
-      (hCt, hCs) = bimap length length hc
-
 runDB
   :: MonadUnliftIO m
   => SqlConfig

lib/Internal/History.hs

@@ -23,6 +23,7 @@ import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
 import Text.Regex.TDFA hiding (matchAll)
+import Text.Regex.TDFA.Text
 
 readHistoryCRUD
   :: (MonadUnliftIO m, MonadFinance m)
@@ -32,7 +33,7 @@ readHistoryCRUD
 readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
   -- TODO multithread this for some extra fun :)
 
-  ss' <- mapErrorsIO (readHistStmt root) ss
+  ss' <- mapM (readHistStmt root) ss
   fromEitherM $ runExceptT $ do
     let sRes = mapErrors (ExceptT . return) ss'
     let tRes = mapErrors readHistTransfer ts
@@ -112,93 +113,39 @@ readImport_ n delim tns p = do
 -- TODO handle this better, this maybe thing is a hack to skip lines with
 -- blank dates but will likely want to make this more flexible
 parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
-parseTxRecord
+parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
-  p
+  d <- r .: T.encodeUtf8 toDate
-  TxOpts
+  if d == ""
-    { toDate
+    then return Nothing
-    , toDesc
+    else do
-    , toAmount
+      a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
-    , toOther
+      e <- r .: T.encodeUtf8 toDesc
-    , toDateFmt
+      os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
-    , toSkipBlankDate
+      d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
-    , toSkipBlankAmount
+      return $ Just $ TxRecord d' a e os p
-    , toSkipBlankDescription
-    , toSkipBlankOther
-    , toSkipMissingFields
-    }
-  r =
-    do
-      -- TODO this is confusing as hell
-      --
-      -- try and parse all fields; if a parse fails, either trip an error
-      -- or return a Nothing if we want to deliberately skip missing fields
-      d <- getField toDate
-      e <- getField toDesc
-      os <-
-        fmap M.fromList . sequence
-          <$> mapM (\n -> fmap (n,) <$> getField n) toOther
-      (af, ax) <- case toAmount of
-        -- the amount column is extra confusing because it can either be one
-        -- or two columns, so keep track of this with a maybe
-        AmountSingle TxAmount1 {a1Column, a1Fmt} -> do
-          f <- getField a1Column
-          return (a1Fmt, Right <$> f)
-        AmountDual TxAmount2 {a2Positive, a2Negative, a2Fmt} -> do
-          f1 <- getField a2Positive
-          f2 <- getField a2Negative
-          return $ (a2Fmt,) $ case (f1, f2) of
-            (Just a, Just b) -> Just $ Left (a, b)
-            _ -> Nothing
-      case (d, e, os, ax) of
-        -- If all lookups were successful, check that none of the fields are
-        -- blank, and if they are return nothing to skip this line
-        (Just d', Just e', Just os', Just ax') ->
-          if (toSkipBlankDate && d' == "")
-            || (toSkipBlankDescription && e' == "")
-            || (toSkipBlankAmount && (ax' == Right "" || ax' == Left ("", "")))
-            || elem "" (mapMaybe (`M.lookup` os') toSkipBlankOther)
-            then return Nothing
-            else -- if we are skipping nothing, proceed to parse the date and amount
-            -- columns
-            do
-              a <- case ax' of
-                Right a -> parseDecimal True af a
-                Left ("", a) -> ((-1) *) <$> parseDecimal False af a
-                Left (a, _) -> parseDecimal False af a
-              d'' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d'
-              return $ Just $ TxRecord d'' a e' os' p
-        -- if no lookups succeeded, return nothing to skip this line. Note that
-        -- a parse fail will trigger a failure error further up, so that case
-        -- is already dealt with implicitly
-        _ -> return Nothing
-    where
-      getField :: FromField a => T.Text -> Parser (Maybe a)
-      getField f = case runParser $ r .: T.encodeUtf8 f of
-        Left err -> if toSkipMissingFields then return Nothing else fail err
-        Right x -> return $ Just x
 
-matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()]
+matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
     (ms_, [], []) -> return ms_
     (_, us, ns) -> throwError $ AppException [StatementError us ns]
 
-matchPriorities :: [StatementParserRe] -> [MatchGroup]
+matchPriorities :: [MatchRe] -> [MatchGroup]
 matchPriorities =
   fmap matchToGroup
     . L.groupBy (\a b -> spPriority a == spPriority b)
     . L.sortOn (Down . spPriority)
 
-matchToGroup :: [StatementParserRe] -> MatchGroup
+matchToGroup :: [MatchRe] -> MatchGroup
 matchToGroup ms =
   uncurry MatchGroup $
     first (L.sortOn spDate) $
       L.partition (isJust . spDate) ms
 
 data MatchGroup = MatchGroup
-  { mgDate :: ![StatementParserRe]
+  { mgDate :: ![MatchRe]
-  , mgNoDate :: ![StatementParserRe]
+  , mgNoDate :: ![MatchRe]
   }
   deriving (Show)
 
@@ -237,9 +184,9 @@ zipperSlice f x = go
 
 zipperMatch
   :: MonadFinance m
-  => Unzipped StatementParserRe
+  => Unzipped MatchRe
   -> TxRecord
-  -> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
+  -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
     go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@@ -254,9 +201,9 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
 
 zipperMatch'
   :: MonadFinance m
-  => Zipped StatementParserRe
+  => Zipped MatchRe
   -> TxRecord
-  -> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
+  -> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
 zipperMatch' z x = go z
   where
     go (Zipped bs (a : as)) = do
@@ -267,7 +214,7 @@ zipperMatch' z x = go z
           return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
     go z' = return (z', MatchFail)
 
-matchDec :: StatementParserRe -> Maybe StatementParserRe
+matchDec :: MatchRe -> Maybe MatchRe
 matchDec m = case spTimes m of
   Just 1 -> Nothing
   Just n -> Just $ m {spTimes = Just $ n - 1}
@@ -277,7 +224,7 @@ matchAll
   :: MonadFinance m
   => [MatchGroup]
   -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
@@ -291,7 +238,7 @@ matchGroup
   :: MonadFinance m
   => MatchGroup
   -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
   (md, rest, ud) <- matchDates ds rs
   (mn, unmatched, un) <- matchNonDates ns rest
@@ -299,9 +246,9 @@ matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
 
 matchDates
   :: MonadFinance m
-  => [StatementParserRe]
+  => [MatchRe]
   -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -324,9 +271,9 @@ matchDates ms = go ([], [], initZipper ms)
 
 matchNonDates
   :: MonadFinance m
-  => [StatementParserRe]
+  => [MatchRe]
   -> [TxRecord]
-  -> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
+  -> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -343,11 +290,7 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
-matches
+matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ()))
-  :: MonadFinance m
-  => StatementParserRe
-  -> TxRecord
-  -> AppExceptT m (MatchRes (Tx ()))
 matches
   StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@@ -522,17 +465,11 @@ readRational s = case T.split (== '.') s of
     err = throwError $ AppException [ConversionError s False]
 
 compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
-compileOptions = mapM (compileRegex True)
+compileOptions o@TxOpts {toAmountFmt = pat} = do
+  re <- compileRegex True pat
+  return $ o {toAmountFmt = re}
 
--- compileOptions o@TxOpts {toAmount = pat} = case pat of
+compileMatch :: StatementParser T.Text -> AppExcept MatchRe
---   AmountSingle (TxAmount1 {a1Fmt}) -> do
---     re <- compileRegex True a1Fmt
---     return $ o {toAmountFmt = re}
---   AmountDual (TxAmount2 {a2Fmt}) -> do
---     re <- compileRegex True a2Fmt
---     return $ o {toAmountFmt = re}
-
-compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe
 compileMatch m@StatementParser {spDesc, spOther} = do
   combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
   where
@@ -540,15 +477,42 @@ compileMatch m@StatementParser {spDesc, spOther} = do
     dres = mapM go spDesc
     ores = combineErrors $ fmap (mapM go) spOther
 
-parseDecimal :: MonadFail m => Bool -> (T.Text, Regex) -> T.Text -> m Decimal
+compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
-parseDecimal wantSign (pat, re) s = case (wantSign, matchGroupsMaybe s re) of
+compileRegex groups pat = case res of
-  (True, [sign, num]) -> do
+  Right re -> return (pat, re)
-    k <- readSign sign
+  Left _ -> throwError $ AppException [RegexError pat]
-    x <- readNum num
+  where
-    return $ k * x
+    res =
-  (False, [num]) -> readNum num
+      compile
+        (blankCompOpt {newSyntax = True})
+        (blankExecOpt {captureGroups = groups})
+        pat
+
+matchMaybe :: T.Text -> Regex -> AppExcept Bool
+matchMaybe q re = case execute re q of
+  Right res -> return $ isJust res
+  Left _ -> throwError $ AppException [RegexError "this should not happen"]
+
+matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
+matchGroupsMaybe q re = case regexec re q of
+  Right Nothing -> []
+  Right (Just (_, _, _, xs)) -> xs
+  -- this should never fail as regexec always returns Right
+  Left _ -> []
+
+parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
+parseDecimal (pat, re) s = case matchGroupsMaybe s re of
+  [sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
+  [sign, x, y] -> do
+    d <- readT "decimal" y
+    let p = T.length y
+    (k, w) <- readWhole sign x
+    return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
   _ -> msg "malformed decimal"
   where
+    readT what t = case readMaybe $ T.unpack t of
+      Just d -> return $ fromInteger d
+      _ -> msg $ T.unwords ["could not parse", what, singleQuote t]
     msg :: MonadFail m => T.Text -> m a
     msg m =
       fail $
@@ -558,10 +522,7 @@ parseDecimal wantSign (pat, re) s = case (wantSign, matchGroupsMaybe s re) of
       | x == "-" = return (-1)
       | x == "+" || x == "" = return 1
       | otherwise = msg $ T.append "invalid sign: " x
-    readNum x =
+    readWhole sign x = do
-      maybe
+      w <- readT "whole number" x
-        (msg $ T.unwords ["could not parse", singleQuote x])
+      k <- readSign sign
-        return
+      return (k, w)
-        $ readMaybe
-        $ T.unpack
-        $ T.filter (/= ',') x

lib/Internal/Types/Database.hs

@@ -102,7 +102,7 @@ newtype EntryIndex = EntryIndex {unEntryIndex :: Int}
   deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
 
 newtype TxDesc = TxDesc {unTxDesc :: T.Text}
-  deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField, IsString)
+  deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField)
 
 newtype Precision = Precision {unPrecision :: Word8}
   deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)

lib/Internal/Types/Dhall.hs

@@ -49,16 +49,17 @@ makeHaskellTypesWith
   , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
   , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
   , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
-  , SingleConstructor "TxAmount1" "TxAmount1" "(./dhall/Types.dhall).TxAmount1_"
-  , SingleConstructor "TxAmount2" "TxAmount2" "(./dhall/Types.dhall).TxAmount2_"
   , SingleConstructor
       "Amount"
       "Amount"
       "\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
   , SingleConstructor
-      "AcntMatcher_"
+      "TxOpts"
-      "AcntMatcher_"
+      "TxOpts"
-      "\\(re : Type) -> ((./dhall/Types.dhall).AcntMatcher_ re).Type"
+      "\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type"
+  , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
+  , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
+  , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
   , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
   , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
   , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
@@ -87,7 +88,11 @@ deriveProduct
   , "CronPat"
   , "DatePat"
   , "TaggedAcnt"
+  , "Budget"
   , "Income"
+  , "ShadowTransfer"
+  , "TransferMatcher"
+  , "AcntSet"
   , "DateMatcher"
   , "ValMatcher"
   , "YMDMatcher"
@@ -186,33 +191,15 @@ newtype BudgetName = BudgetName {unBudgetName :: T.Text}
   deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
 
 data Budget = Budget
-  { bgtLabel :: !BudgetName
+  { bgtLabel :: BudgetName
-  , bgtIncomes :: ![Income]
+  , bgtIncomes :: [Income]
-  , bgtPretax :: ![MultiAllocation PretaxValue]
+  , bgtPretax :: [MultiAllocation PretaxValue]
-  , bgtTax :: ![MultiAllocation TaxValue]
+  , bgtTax :: [MultiAllocation TaxValue]
-  , bgtPosttax :: ![MultiAllocation PosttaxValue]
+  , bgtPosttax :: [MultiAllocation PosttaxValue]
-  , bgtTransfers :: ![PairedTransfer]
+  , bgtTransfers :: [PairedTransfer]
-  , bgtShadowTransfers :: ![ShadowTransfer]
+  , bgtShadowTransfers :: [ShadowTransfer]
   , bgtInterval :: !(Maybe Interval)
   }
-  deriving (Generic, Hashable, FromDhall)
-
-data ShadowTransfer = ShadowTransfer
-  { stFrom :: !TaggedAcnt
-  , stTo :: !TaggedAcnt
-  , stCurrency :: !CurID
-  , stDesc :: !Text
-  , stMatch :: !(TransferMatcher_ Text)
-  , stRatio :: !Double
-  }
-  deriving (Generic, Hashable, FromDhall)
-
-data TransferMatcher_ re = TransferMatcher_
-  { tmFrom :: !(Maybe (AcntMatcher_ re))
-  , tmTo :: !(Maybe (AcntMatcher_ re))
-  , tmDate :: !(Maybe DateMatcher)
-  , tmVal :: !ValMatcher
-  }
 
 deriving instance Hashable PretaxValue
 
@@ -226,6 +213,8 @@ deriving instance Hashable TaxValue
 
 deriving instance Hashable PosttaxValue
 
+deriving instance Hashable Budget
+
 deriving instance Hashable TransferValue
 
 deriving instance Hashable TransferType
@@ -325,17 +314,11 @@ data Transfer a c w v = Transfer
   }
   deriving (Eq, Show)
 
-deriving instance Generic (TransferMatcher_ Text)
+deriving instance Hashable ShadowTransfer
 
-deriving instance Hashable (TransferMatcher_ Text)
+deriving instance Hashable AcntSet
 
-deriving instance FromDhall (TransferMatcher_ Text)
+deriving instance Hashable TransferMatcher
-
-deriving instance Generic (AcntMatcher_ Text)
-
-deriving instance Hashable (AcntMatcher_ Text)
-
-deriving instance FromDhall (AcntMatcher_ Text)
 
 deriving instance Hashable ValMatcher
 
@@ -466,44 +449,12 @@ deriving instance Eq a => Eq (TxOpts a)
 
 deriving instance Generic (TxOpts a)
 
-deriving instance Hashable (TxOpts T.Text)
+deriving instance Hashable a => Hashable (TxOpts a)
 
-deriving instance FromDhall (TxOpts T.Text)
+deriving instance FromDhall a => FromDhall (TxOpts a)
 
 deriving instance Show a => Show (TxOpts a)
 
-deriving instance Eq re => Eq (TxAmount1 re)
-
-deriving instance Eq re => Eq (TxAmount2 re)
-
-deriving instance Show re => Show (TxAmount1 re)
-
-deriving instance Show re => Show (TxAmount2 re)
-
-deriving instance Generic (TxAmount1 T.Text)
-
-deriving instance Generic (TxAmount2 T.Text)
-
-deriving instance Hashable (TxAmount1 T.Text)
-
-deriving instance Hashable (TxAmount2 T.Text)
-
-deriving instance FromDhall (TxAmount1 T.Text)
-
-deriving instance FromDhall (TxAmount2 T.Text)
-
-deriving instance Functor TxAmount1
-
-deriving instance Functor TxAmount2
-
-deriving instance Foldable TxAmount1
-
-deriving instance Foldable TxAmount2
-
-deriving instance Traversable TxAmount1
-
-deriving instance Traversable TxAmount2
-
 data Statement = Statement
   { stmtPaths :: ![FilePath]
   , stmtParsers :: ![StatementParser T.Text]
@@ -513,29 +464,6 @@ data Statement = Statement
   }
   deriving (Eq, Hashable, Generic, FromDhall, Show)
 
-data TxAmountSpec re = AmountSingle (TxAmount1 re) | AmountDual (TxAmount2 re)
-  deriving (Eq, Show, Functor, Foldable, Traversable)
-
-deriving instance Generic (TxAmountSpec T.Text)
-
-deriving instance FromDhall (TxAmountSpec T.Text)
-
-deriving instance Hashable (TxAmountSpec T.Text)
-
-data TxOpts re = TxOpts
-  { toDate :: !T.Text
-  , toAmount :: !(TxAmountSpec re)
-  , toDesc :: !T.Text
-  , toOther :: ![T.Text]
-  , toDateFmt :: !T.Text
-  , toSkipBlankDate :: !Bool
-  , toSkipBlankAmount :: !Bool
-  , toSkipBlankDescription :: !Bool
-  , toSkipBlankOther :: ![Text]
-  , toSkipMissingFields :: !Bool
-  }
-  deriving (Functor, Foldable, Traversable)
-
 -- | the value of a field in entry (text version)
 -- can either be a raw (constant) value, a lookup from the record, or a map
 -- between the lookup and some other value

lib/Internal/Types/Main.hs

@@ -306,7 +306,7 @@ data AppError
   | LookupError !LookupSuberr !T.Text
   | DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | DaySpanError !Gregorian !(Maybe Gregorian)
-  | StatementError ![TxRecord] ![StatementParserRe]
+  | StatementError ![TxRecord] ![MatchRe]
   | PeriodError !Day !Day
   | LinkError !EntryIndex !EntryIndex
   | DBError !DBSubError
@@ -323,9 +323,7 @@ type AppExceptT = ExceptT AppException
 
 type AppExcept = AppExceptT Identity
 
-type StatementParserRe = StatementParser (T.Text, Regex)
+type MatchRe = StatementParser (T.Text, Regex)
-
-type TransferMatcherRe = TransferMatcher_ Regex
 
 type TxOptsRe = TxOpts (T.Text, Regex)
 

lib/Internal/Utils.hs

@@ -51,9 +51,6 @@ module Internal.Utils
   , keyVals
   , realFracToDecimalP
   , roundToP
-  , compileRegex
-  , matchMaybe
-  , matchGroupsMaybe
   )
 where
 
@@ -72,8 +69,6 @@ import RIO.State
 import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
-import Text.Regex.TDFA hiding (matchAll)
-import Text.Regex.TDFA.Text
 
 --------------------------------------------------------------------------------
 -- intervals
@@ -130,7 +125,7 @@ expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
 
 expandMDYPat :: Natural -> Natural -> MDYPat -> AppExcept [Natural]
 expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
-expandMDYPat lower upper (Multi xs) = return $ dropWhile (< lower) $ takeWhile (<= upper) xs
+expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
 expandMDYPat lower upper (After x) = return [max lower x .. upper]
 expandMDYPat lower upper (Before x) = return [lower .. min upper x]
 expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
@@ -499,7 +494,7 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
       , ("description", doubleQuote $ unTxDesc e)
       ]
 
-showMatch :: StatementParserRe -> T.Text
+showMatch :: MatchRe -> T.Text
 showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
   T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
   where
@@ -698,12 +693,14 @@ rebalanceTotalEntrySet
     , utTotalValue
     } =
     do
-      (fval, fs, tpairs) <- rebalanceDebit utCurrency utFromRO utFromUnk
+      (fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
       let f0val = utTotalValue - fval
-      modify $ mapAdd_ (f0Acnt, utCurrency) f0val
+      modify $ mapAdd_ (f0Acnt, bc) f0val
       let tsLinked = tpairs ++ (unlink f0val <$> f0links)
-      ts <- rebalanceCredit utCurrency utTotalValue utTo0 utToUnk utToRO tsLinked
+      ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
       return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
+    where
+      bc = utCurrency
 
 rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceFullEntrySet
@@ -717,13 +714,14 @@ rebalanceFullEntrySet
     , utCurrency
     } =
     do
-      (ftot, fs, tpairs) <- rebalanceDebit utCurrency rs ls
+      (ftot, fs, tpairs) <- rebalanceDebit bc rs ls
-      ts <- rebalanceCredit utCurrency ftot utTo0 utToUnk utToRO tpairs
+      ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
       return (fs ++ ts)
     where
       (rs, ls) = case utFrom0 of
         Left x -> (x : utFromRO, utFromUnk)
         Right x -> (utFromRO, x : utFromUnk)
+      bc = utCurrency
 
 rebalanceDebit
   :: BCKey
@@ -757,7 +755,7 @@ rebalanceCredit
   -> [UE_RO]
   -> [UEBalanced]
   -> State EntryBals [UEBalanced]
-rebalanceCredit k tot t0@UpdateEntry {ueAcnt = t0Acnt} us rs bs = do
+rebalanceCredit k tot t0 us rs bs = do
   (tval, ts) <-
     fmap (second catMaybes) $
       sumM goTo $
@@ -765,9 +763,7 @@ rebalanceCredit k tot t0@UpdateEntry {ueAcnt = t0Acnt} us rs bs = do
           (UETLinked <$> bs)
             ++ (UETUnk <$> us)
             ++ (UETReadOnly <$> rs)
-  let t0val = -(tot + tval)
+  return (t0 {ueValue = StaticValue (-(tot + tval))} : ts)
-  modify $ mapAdd_ (t0Acnt, k) t0val
-  return (t0 {ueValue = StaticValue t0val} : ts)
   where
     idx = projectUET ueIndex ueIndex ueIndex
     goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e
@@ -1041,26 +1037,3 @@ realFracToDecimalP p = realFracToDecimal (unPrecision p)
 
 roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i
 roundToP p = roundTo (unPrecision p)
-
-compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
-compileRegex groups pat = case res of
-  Right re -> return (pat, re)
-  Left _ -> throwError $ AppException [RegexError pat]
-  where
-    res =
-      compile
-        (blankCompOpt {newSyntax = True})
-        (blankExecOpt {captureGroups = groups})
-        pat
-
-matchMaybe :: T.Text -> Regex -> AppExcept Bool
-matchMaybe q re = case execute re q of
-  Right res -> return $ isJust res
-  Left _ -> throwError $ AppException [RegexError "this should not happen"]
-
-matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
-matchGroupsMaybe q re = case regexec re q of
-  Right Nothing -> []
-  Right (Just (_, _, _, xs)) -> xs
-  -- this should never fail as regexec always returns Right
-  Left _ -> []