pwncash/lib/Internal/Types.hs

764 lines
21 KiB
Haskell
Raw Normal View History

{-# LANGUAGE DeriveAnyClass #-}
2023-02-26 18:57:40 -05:00
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
2023-02-26 18:57:40 -05:00
{-# LANGUAGE UndecidableInstances #-}
2022-12-11 17:51:11 -05:00
module Internal.Types where
import Data.Fix (Fix (..), foldFix)
import Data.Functor.Foldable (embed)
import qualified Data.Functor.Foldable.TH as TH
2023-02-01 23:02:07 -05:00
import Database.Persist.Sql hiding (Desc, In, Statement)
2023-02-26 18:57:40 -05:00
import Database.Persist.TH
import Dhall hiding (embed, maybe)
import Dhall.TH
2023-04-17 00:34:09 -04:00
import Internal.TH (deriveProduct)
import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
2023-02-25 22:56:23 -05:00
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
2023-02-01 23:02:07 -05:00
import Text.Regex.TDFA
2022-12-11 17:51:11 -05:00
-------------------------------------------------------------------------------
-- DHALL CONFIG
2022-12-11 17:51:11 -05:00
-------------------------------------------------------------------------------
makeHaskellTypesWith
2023-04-17 00:34:09 -04:00
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
, MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat"
, MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat"
, MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
, MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
2023-02-26 12:03:35 -05:00
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
2023-02-26 22:53:12 -05:00
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
, SingleConstructor "TemporalScope" "TemporalScope" "(./dhall/Types.dhall).TemporalScope"
, SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
, SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
2023-02-13 19:57:39 -05:00
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
2023-04-17 00:34:09 -04:00
, -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
, SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
, SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
2023-04-17 00:34:09 -04:00
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
-- , SingleConstructor "MatchOther" "MatchOther" "(./dhall/Types.dhall).MatchOther_"
-- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
]
deriveProduct
["Eq", "Show", "Generic", "FromDhall"]
[ "Currency"
, "Tag"
, "TimeUnit"
, "Weekday"
, "WeekdayPat"
, "RepeatPat"
, "MDYPat"
, "Gregorian"
, "GregorianM"
, "Interval"
, "ModPat"
, "CronPat"
, "DatePat"
, "TaggedAcnt"
, "Budget"
, "Income"
, "ShadowTransfer"
, "TransferMatcher"
2023-04-17 00:34:09 -04:00
, "AcntSet"
, "DateMatcher"
, "ValMatcher"
, "YMDMatcher"
2023-04-17 00:34:09 -04:00
, "Decimal"
, "BudgetCurrency"
, "Exchange"
, "EntryNumGetter"
, "TemporalScope"
2023-04-17 00:34:09 -04:00
, "SqlConfig"
, "PretaxValue"
, "TaxValue"
, "TaxBracket"
, "TaxProgression"
, "TaxMethod"
, "PosttaxValue"
, "BudgetTransferValue"
, "BudgetTransferType"
]
2022-12-11 18:53:54 -05:00
2022-12-11 17:51:11 -05:00
-------------------------------------------------------------------------------
2023-02-26 18:57:40 -05:00
-- lots of instances for dhall types
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Lift Currency
2022-12-14 23:59:23 -05:00
deriving instance Hashable Currency
2022-12-11 17:51:11 -05:00
2023-02-26 22:53:12 -05:00
deriving instance Lift Tag
deriving instance Hashable Tag
deriving instance Ord TimeUnit
2022-12-14 23:59:23 -05:00
deriving instance Hashable TimeUnit
2022-12-11 17:51:11 -05:00
deriving instance Ord Weekday
2022-12-14 23:59:23 -05:00
deriving instance Hashable Weekday
2022-12-11 17:51:11 -05:00
2023-02-02 23:18:36 -05:00
deriving instance Enum Weekday
deriving instance Ord WeekdayPat
2022-12-14 23:59:23 -05:00
deriving instance Hashable WeekdayPat
2022-12-11 17:51:11 -05:00
deriving instance Ord RepeatPat
2022-12-14 23:59:23 -05:00
deriving instance Hashable RepeatPat
2022-12-11 17:51:11 -05:00
deriving instance Ord MDYPat
2022-12-14 23:59:23 -05:00
deriving instance Hashable MDYPat
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Hashable Gregorian
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Hashable GregorianM
2022-12-11 17:51:11 -05:00
-- Dhall.TH rearranges my fields :(
instance Ord Gregorian where
compare
Gregorian {gYear = y, gMonth = m, gDay = d}
Gregorian {gYear = y', gMonth = m', gDay = d'} =
compare y y'
<> compare m m'
<> compare d d'
instance Ord GregorianM where
compare
GregorianM {gmYear = y, gmMonth = m}
GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
deriving instance Hashable Interval
deriving instance Ord ModPat
2022-12-14 23:59:23 -05:00
deriving instance Hashable ModPat
2022-12-11 17:51:11 -05:00
deriving instance Ord CronPat
2022-12-14 23:59:23 -05:00
deriving instance Hashable CronPat
2022-12-11 17:51:11 -05:00
deriving instance Ord DatePat
2022-12-14 23:59:23 -05:00
deriving instance Hashable DatePat
2022-12-11 17:51:11 -05:00
type BudgetTransfer =
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
data Budget = Budget
{ budgetLabel :: Text
, incomes :: [Income]
, pretax :: [MultiAllocation PretaxValue]
, tax :: [MultiAllocation TaxValue]
, posttax :: [MultiAllocation PosttaxValue]
, transfers :: [BudgetTransfer]
, shadowTransfers :: [ShadowTransfer]
}
deriving instance Hashable PretaxValue
deriving instance Hashable TaxBracket
deriving instance Hashable TaxProgression
deriving instance Hashable TaxMethod
deriving instance Hashable TaxValue
deriving instance Hashable PosttaxValue
2023-02-05 18:45:56 -05:00
deriving instance Hashable Budget
deriving instance Hashable BudgetTransferValue
deriving instance Hashable BudgetTransferType
2023-02-26 22:53:12 -05:00
deriving instance Hashable TaggedAcnt
deriving instance Ord TaggedAcnt
type CurID = T.Text
data Income = Income
{ incGross :: Decimal
, incCurrency :: CurID
, incWhen :: DatePat
, incPretax :: [SingleAllocation PretaxValue]
, incTaxes :: [SingleAllocation TaxValue]
, incPosttax :: [SingleAllocation PosttaxValue]
, incFrom :: TaggedAcnt
, incToBal :: TaggedAcnt
}
deriving instance Hashable Income
deriving instance (Ord w, Ord v) => Ord (Amount w v)
deriving instance Generic (Amount w v)
deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
deriving instance (Generic w, Generic v, Hashable w, Hashable v) => Hashable (Amount w v)
deriving instance (Show w, Show v) => Show (Amount w v)
deriving instance (Eq w, Eq v) => Eq (Amount w v)
2022-12-11 17:51:11 -05:00
2023-02-26 12:03:35 -05:00
deriving instance Hashable Exchange
deriving instance Hashable BudgetCurrency
data Allocation w v = Allocation
{ alloTo :: TaggedAcnt
, alloAmts :: [Amount w v]
, alloCur :: CurID
}
2023-04-17 00:34:09 -04:00
deriving (Eq, Show, Generic, Hashable)
instance Bifunctor Amount where
bimap f g a@Amount {amtWhen, amtValue} = a {amtWhen = f amtWhen, amtValue = g amtValue}
instance Bifunctor Allocation where
bimap f g a@Allocation {alloAmts} = a {alloAmts = fmap (bimap f g) alloAmts}
deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Allocation w v)
type MultiAllocation = Allocation Interval
type SingleAllocation = Allocation ()
2023-01-30 21:47:17 -05:00
toPersistText :: Show a => a -> PersistValue
toPersistText = PersistText . T.pack . show
fromPersistText :: Read a => T.Text -> PersistValue -> Either T.Text a
fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
Just v -> Right v
Nothing -> Left $ T.unwords ["error when reading", what, "from text:", t]
fromPersistText what x =
Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
2023-04-17 00:34:09 -04:00
deriving instance Ord Interval
data Transfer a c w v = Transfer
{ transFrom :: a
, transTo :: a
, transAmounts :: [Amount w v]
, transCurrency :: c
}
deriving (Eq, Show, Generic, FromDhall)
deriving instance
(Generic w, Generic v, Hashable a, Hashable c, Hashable w, Hashable v)
=> Hashable (Transfer a c w v)
2022-12-11 17:51:11 -05:00
2023-02-13 19:57:39 -05:00
deriving instance Hashable ShadowTransfer
deriving instance Hashable AcntSet
deriving instance Hashable TransferMatcher
2023-02-13 19:57:39 -05:00
deriving instance Hashable ValMatcher
2023-02-26 18:57:40 -05:00
deriving instance Hashable YMDMatcher
2023-02-26 18:57:40 -05:00
deriving instance Hashable DateMatcher
2023-02-26 18:57:40 -05:00
deriving instance Ord Decimal
2023-02-26 18:57:40 -05:00
deriving instance Hashable Decimal
-- TODO this just looks silly...but not sure how to simplify it
instance Ord YMDMatcher where
2023-02-26 18:57:40 -05:00
compare (Y y) (Y y') = compare y y'
compare (YM g) (YM g') = compare g g'
compare (YMD g) (YMD g') = compare g g'
compare (Y y) (YM g) = compare y (gmYear g) <> LT
compare (Y y) (YMD g) = compare y (gYear g) <> LT
compare (YM g) (Y y') = compare (gmYear g) y' <> GT
compare (YMD g) (Y y') = compare (gYear g) y' <> GT
compare (YM g) (YMD g') = compare g (gregM g') <> LT
compare (YMD g) (YM g') = compare (gregM g) g' <> GT
gregM :: Gregorian -> GregorianM
gregM Gregorian {gYear = y, gMonth = m} =
GregorianM {gmYear = y, gmMonth = m}
instance Ord DateMatcher where
2023-02-26 18:57:40 -05:00
compare (On d) (On d') = compare d d'
compare (In d r) (In d' r') = compare d d' <> compare r r'
compare (On d) (In d' _) = compare d d' <> LT
compare (In d _) (On d') = compare d d' <> GT
deriving instance Hashable EntryNumGetter
2023-02-26 18:57:40 -05:00
-------------------------------------------------------------------------------
-- top level type with fixed account tree to unroll the recursion in the dhall
-- account tree type
data AccountTree
= Placeholder T.Text T.Text [AccountTree]
| Account T.Text T.Text
deriving (Eq, Generic, Hashable)
TH.makeBaseFunctor ''AccountTree
deriving instance Generic (AccountTreeF a)
deriving instance FromDhall a => FromDhall (AccountTreeF a)
data AccountRoot_ a = AccountRoot_
{ arAssets :: ![a]
, arEquity :: ![a]
, arExpenses :: ![a]
, arIncome :: ![a]
, arLiabilities :: ![a]
}
deriving (Generic)
type AccountRootF = AccountRoot_ (Fix AccountTreeF)
deriving instance FromDhall AccountRootF
type AccountRoot = AccountRoot_ AccountTree
data Config_ a = Config_
{ global :: !TemporalScope
2023-02-26 18:57:40 -05:00
, budget :: ![Budget]
, currencies :: ![Currency]
, statements :: ![History]
2023-02-26 18:57:40 -05:00
, accounts :: !a
2023-02-26 22:53:12 -05:00
, tags :: ![Tag]
2023-02-26 18:57:40 -05:00
, sqlConfig :: !SqlConfig
}
deriving (Generic)
type ConfigF = Config_ AccountRootF
type Config = Config_ AccountRoot
unfix :: ConfigF -> Config
unfix c@Config_ {accounts = a} = c {accounts = a'}
where
a' =
AccountRoot_
{ arAssets = unfixTree arAssets
, arEquity = unfixTree arEquity
, arExpenses = unfixTree arExpenses
, arIncome = unfixTree arIncome
, arLiabilities = unfixTree arLiabilities
}
unfixTree f = foldFix embed <$> f a
instance FromDhall a => FromDhall (Config_ a)
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
2023-02-26 18:57:40 -05:00
-- dhall type overrides (since dhall can't import types with parameters...yet)
2023-02-26 22:53:12 -05:00
-- TODO newtypes for these?
2023-02-26 18:57:40 -05:00
type AcntID = T.Text
2023-02-26 22:53:12 -05:00
type TagID = T.Text
type HistTransfer = Transfer AcntID CurID DatePat Decimal
data History
= HistTransfer !HistTransfer
| HistStatement !Statement
2023-02-05 18:45:56 -05:00
deriving (Eq, Hashable, Generic, FromDhall)
2022-12-11 17:51:11 -05:00
type ExpSplit = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
2022-12-11 17:51:11 -05:00
2023-02-26 22:53:12 -05:00
instance FromDhall ExpSplit
2022-12-11 17:51:11 -05:00
deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
2023-04-17 00:34:09 -04:00
deriving instance Generic (Entry a v c t)
2023-04-17 00:34:09 -04:00
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
2023-04-17 00:34:09 -04:00
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
2023-04-17 00:34:09 -04:00
2022-12-11 17:51:11 -05:00
data Tx s = Tx
{ txDescr :: !T.Text
, txDate :: !Day
, txSplits :: ![s]
}
deriving (Generic)
2022-12-11 17:51:11 -05:00
type ExpTx = Tx ExpSplit
instance FromDhall ExpTx
2022-12-11 17:51:11 -05:00
data TxOpts re = TxOpts
{ toDate :: !T.Text
, toAmount :: !T.Text
, toDesc :: !T.Text
, toOther :: ![T.Text]
, toDateFmt :: !T.Text
, toAmountFmt :: !re
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
data Statement = Statement
{ impPaths :: ![FilePath]
2023-02-01 23:02:07 -05:00
, impMatches :: ![Match T.Text]
, impDelim :: !Word
, impTxOpts :: !(TxOpts T.Text)
, impSkipLines :: !Natural
}
deriving (Eq, Hashable, Generic, FromDhall)
2022-12-11 17:51:11 -05:00
-- | the value of a field in split (text version)
-- can either be a raw (constant) value, a lookup from the record, or a map
-- between the lookup and some other value
data SplitText t
= ConstT !t
| LookupT !T.Text
2023-01-30 22:57:42 -05:00
| MapT !(FieldMap T.Text t)
| Map2T !(FieldMap (T.Text, T.Text) t)
deriving (Eq, Generic, Hashable, Show, FromDhall)
2022-12-11 17:51:11 -05:00
type SplitCur = SplitText CurID
type SplitAcnt = SplitText AcntID
2023-04-17 00:34:09 -04:00
deriving instance (Show k, Show v) => Show (Field k v)
deriving instance (Eq k, Eq v) => Eq (Field k v)
deriving instance Generic (Field k v)
deriving instance (Hashable k, Hashable v) => Hashable (Field k v)
deriving instance Foldable (Field k)
deriving instance Traversable (Field k)
deriving instance (FromDhall k, FromDhall v) => FromDhall (Field k v)
2023-02-01 23:02:07 -05:00
instance Functor (Field f) where
fmap f (Field k v) = Field k $ f v
2022-12-11 17:51:11 -05:00
type FieldMap k v = Field k (M.Map k v)
2023-02-01 23:02:07 -05:00
data MatchOther re
= Desc !(Field T.Text re)
| Val !(Field T.Text ValMatcher)
2023-02-01 23:02:07 -05:00
deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
deriving instance Show (MatchOther T.Text)
2022-12-11 17:51:11 -05:00
data ToTx = ToTx
{ ttCurrency :: !SplitCur
, ttPath :: !SplitAcnt
, ttSplit :: ![ExpSplit]
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
2022-12-11 17:51:11 -05:00
2023-02-01 23:02:07 -05:00
data Match re = Match
{ mDate :: !(Maybe DateMatcher)
, mVal :: !ValMatcher
2023-02-01 23:02:07 -05:00
, mDesc :: !(Maybe re)
, mOther :: ![MatchOther re]
2023-01-30 22:57:42 -05:00
, mTx :: !(Maybe ToTx)
, mTimes :: !(Maybe Natural)
, mPriority :: !Integer
}
2023-02-01 23:02:07 -05:00
deriving (Eq, Generic, Hashable, FromDhall, Functor)
deriving instance Show (Match T.Text)
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
2023-02-26 18:57:40 -05:00
-- DATABASE MODEL
--------------------------------------------------------------------------------
2022-12-11 17:51:11 -05:00
2023-02-26 18:57:40 -05:00
share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
CommitR sql=commits
hash Int
type ConfigType
deriving Show Eq
CurrencyR sql=currencies
symbol T.Text
fullname T.Text
deriving Show Eq
2023-02-26 22:53:12 -05:00
TagR sql=tags
symbol T.Text
fullname T.Text
deriving Show Eq
2023-02-26 18:57:40 -05:00
AccountR sql=accounts
name T.Text
fullpath T.Text
desc T.Text
deriving Show Eq
AccountPathR sql=account_paths
parent AccountRId OnDeleteCascade
child AccountRId OnDeleteCascade
depth Int
deriving Show Eq
TransactionR sql=transactions
commit CommitRId OnDeleteCascade
date Day
description T.Text
deriving Show Eq
SplitR sql=splits
transaction TransactionRId OnDeleteCascade
currency CurrencyRId OnDeleteCascade
account AccountRId OnDeleteCascade
memo T.Text
value Rational
deriving Show Eq
2023-02-26 22:53:12 -05:00
TagRelationR sql=tag_relations
split SplitRId OnDeleteCascade
tag TagRId OnDeleteCascade
2023-02-26 18:57:40 -05:00
BudgetLabelR sql=budget_labels
split SplitRId OnDeleteCascade
budgetName T.Text
deriving Show Eq
|]
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- database cache types
2022-12-11 17:51:11 -05:00
data ConfigHashes = ConfigHashes
{ chIncome :: ![Int]
, chExpense :: ![Int]
, chManual :: ![Int]
, chImport :: ![Int]
}
2022-12-11 17:51:11 -05:00
data ConfigType = CTBudget | CTManual | CTImport
deriving (Eq, Show, Read, Enum)
2022-12-11 17:51:11 -05:00
instance PersistFieldSql ConfigType where
sqlType _ = SqlString
2022-12-11 17:51:11 -05:00
instance PersistField ConfigType where
toPersistValue = PersistText . T.pack . show
-- TODO these error messages *might* be good enough?
fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "wrong type"
2022-12-11 17:51:11 -05:00
2023-02-26 18:57:40 -05:00
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
type CurrencyMap = M.Map CurID CurrencyRId
2023-02-26 22:53:12 -05:00
type TagMap = M.Map TagID TagRId
2023-02-26 18:57:40 -05:00
data DBState = DBState
{ kmCurrency :: !CurrencyMap
, kmAccount :: !AccountMap
2023-02-26 22:53:12 -05:00
, kmTag :: !TagMap
2023-02-26 18:57:40 -05:00
, kmBudgetInterval :: !Bounds
, kmStatementInterval :: !Bounds
, kmNewCommits :: ![Int]
, kmConfigDir :: !FilePath
}
type MappingT m = ReaderT DBState (SqlPersistT m)
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
2023-02-26 18:57:40 -05:00
type KeyTx = Tx KeySplit
type TreeR = Tree ([T.Text], AccountRId)
type Balances = M.Map AccountRId Rational
type BalanceM m = ReaderT (MVar Balances) m
class MonadUnliftIO m => MonadFinance m where
askDBState :: (DBState -> a) -> m a
instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where
askDBState = asks
class MonadUnliftIO m => MonadBalance m where
askBalances :: m (MVar Balances)
withBalances :: (Balances -> m a) -> m a
withBalances f = do
bs <- askBalances
withMVar bs f
modifyBalances :: (Balances -> m (Balances, a)) -> m a
modifyBalances f = do
bs <- askBalances
modifyMVar bs f
lookupBalance :: AccountRId -> m Rational
lookupBalance i = withBalances $ return . fromMaybe 0 . M.lookup i
addBalance :: AccountRId -> Rational -> m ()
addBalance i v =
modifyBalances $ return . (,()) . M.alter (Just . maybe v (v +)) i
2022-12-11 17:51:11 -05:00
-------------------------------------------------------------------------------
-- misc
2022-12-11 17:51:11 -05:00
data AcntType
= AssetT
| EquityT
| ExpenseT
| IncomeT
| LiabilityT
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
2022-12-14 23:59:23 -05:00
atName :: AcntType -> T.Text
atName AssetT = "asset"
atName EquityT = "equity"
atName ExpenseT = "expense"
atName IncomeT = "income"
2022-12-14 23:59:23 -05:00
atName LiabilityT = "liability"
data AcntPath = AcntPath
{ apType :: !AcntType
, apChildren :: ![T.Text]
}
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
2022-12-14 23:59:23 -05:00
data TxRecord = TxRecord
{ trDate :: !Day
, trAmount :: !Rational
, trDesc :: !T.Text
, trOther :: !(M.Map T.Text T.Text)
2023-01-30 22:57:42 -05:00
, trFile :: !FilePath
}
deriving (Show, Eq, Ord)
2022-12-14 23:59:23 -05:00
type Bounds = (Day, Natural)
2022-12-11 17:51:11 -05:00
data Keyed a = Keyed
{ kKey :: !Int64
, kVal :: !a
}
deriving (Eq, Show, Functor)
2022-12-11 17:51:11 -05:00
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
2022-12-11 17:51:11 -05:00
data AcntSign = Credit | Debit
deriving (Show)
2022-12-11 17:51:11 -05:00
sign2Int :: AcntSign -> Int
sign2Int Debit = 1
2022-12-11 17:51:11 -05:00
sign2Int Credit = 1
accountSign :: AcntType -> AcntSign
accountSign AssetT = Debit
accountSign ExpenseT = Debit
accountSign IncomeT = Credit
2022-12-11 17:51:11 -05:00
accountSign LiabilityT = Credit
accountSign EquityT = Credit
2022-12-11 17:51:11 -05:00
type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
2022-12-11 17:51:11 -05:00
type BalSplit = Entry AcntID Rational CurID TagID
2022-12-11 17:51:11 -05:00
type RawTx = Tx RawSplit
2022-12-11 17:51:11 -05:00
type BalTx = Tx BalSplit
2023-01-30 22:57:42 -05:00
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
2023-01-07 23:42:04 -05:00
2023-02-26 18:57:40 -05:00
--------------------------------------------------------------------------------
-- exception types
2023-01-24 23:24:41 -05:00
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
2023-01-07 23:42:04 -05:00
2023-01-27 23:33:34 -05:00
data MatchType = MatchNumeric | MatchText deriving (Show)
2023-02-26 22:53:12 -05:00
data SplitIDType = AcntField | CurField | TagField deriving (Show)
2023-01-27 23:33:34 -05:00
data LookupSuberr
2023-01-30 22:57:42 -05:00
= SplitIDField !SplitIDType
2023-01-27 23:33:34 -05:00
| SplitValField
2023-01-30 22:57:42 -05:00
| MatchField !MatchType
| DBKey !SplitIDType
2023-01-27 23:33:34 -05:00
deriving (Show)
2023-01-25 23:04:54 -05:00
2023-01-27 20:31:13 -05:00
data AllocationSuberr
= NoAllocations
| ExceededTotal
| MissingBlank
| TooManyBlanks
deriving (Show)
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
2023-01-24 23:24:41 -05:00
data InsertError
2023-01-30 22:57:42 -05:00
= RegexError !T.Text
| MatchValPrecisionError !Natural !Natural
2023-02-25 22:56:23 -05:00
| AccountError !AcntID !(NE.NonEmpty AcntType)
2023-01-30 22:57:42 -05:00
| InsertIOError !T.Text
| ParseError !T.Text
| ConversionError !T.Text
2023-01-30 22:57:42 -05:00
| LookupError !LookupSuberr !T.Text
| BalanceError !BalanceType !CurID ![RawSplit]
| IncomeError !Day !T.Text !Rational
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| BoundsError !Gregorian !(Maybe Gregorian)
2023-02-01 23:02:07 -05:00
| StatementError ![TxRecord] ![MatchRe]
2023-01-24 23:24:41 -05:00
deriving (Show)
2023-01-07 23:42:04 -05:00
2023-01-24 23:24:41 -05:00
newtype InsertException = InsertException [InsertError] deriving (Show)
2023-01-07 23:42:04 -05:00
instance Exception InsertException
2023-01-24 23:24:41 -05:00
type EitherErr = Either InsertError
2023-01-26 23:41:45 -05:00
type EitherErrs = Either [InsertError]
data XGregorian = XGregorian
{ xgYear :: !Int
, xgMonth :: !Int
, xgDay :: !Int
, xgDayOfWeek :: !Int
}
2023-02-01 23:02:07 -05:00
type MatchRe = Match (T.Text, Regex)
type TxOptsRe = TxOpts (T.Text, Regex)
2023-02-01 23:02:07 -05:00
type MatchOtherRe = MatchOther (T.Text, Regex)
instance Show (Match (T.Text, Regex)) where
show = show . fmap fst