pwncash/lib/Internal/Types.hs

818 lines
20 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
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
(defaultGenerateOptions {generateToDhallInstance = 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 "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
2023-02-12 16:23:32 -05:00
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
2023-02-26 12:03:35 -05:00
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
2023-02-26 22:53:12 -05:00
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
, SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global"
, 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 "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
, -- , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
-- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-- , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
2023-02-26 22:53:12 -05:00
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
2023-02-25 22:56:23 -05:00
, SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
2023-02-13 19:57:39 -05:00
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
]
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 Eq Currency
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 Eq Tag
deriving instance Lift Tag
deriving instance Hashable Tag
2022-12-14 23:59:23 -05:00
deriving instance Eq TimeUnit
deriving instance Ord TimeUnit
deriving instance Show TimeUnit
2022-12-14 23:59:23 -05:00
deriving instance Hashable TimeUnit
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq Weekday
deriving instance Ord Weekday
deriving instance Show 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
2022-12-14 23:59:23 -05:00
deriving instance Eq WeekdayPat
deriving instance Ord WeekdayPat
deriving instance Show WeekdayPat
2022-12-14 23:59:23 -05:00
deriving instance Hashable WeekdayPat
2022-12-11 17:51:11 -05:00
deriving instance Show RepeatPat
2022-12-14 23:59:23 -05:00
deriving instance Eq RepeatPat
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 Show MDYPat
2022-12-14 23:59:23 -05:00
deriving instance Eq MDYPat
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 Eq Gregorian
2022-12-14 23:59:23 -05:00
deriving instance Show Gregorian
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 Eq GregorianM
2022-12-14 23:59:23 -05:00
deriving instance Show GregorianM
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 Eq Interval
deriving instance Ord Interval
deriving instance Hashable Interval
2022-12-14 23:59:23 -05:00
deriving instance Eq ModPat
deriving instance Ord ModPat
deriving instance Show ModPat
2022-12-14 23:59:23 -05:00
deriving instance Hashable ModPat
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq CronPat
deriving instance Ord CronPat
deriving instance Show CronPat
2022-12-14 23:59:23 -05:00
deriving instance Hashable CronPat
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq DatePat
deriving instance Ord DatePat
deriving instance Show DatePat
2022-12-14 23:59:23 -05:00
deriving instance Hashable DatePat
2022-12-11 17:51:11 -05:00
data Budget = Budget
{ budgetLabel :: Text
, incomes :: [Income]
, pretax :: [IntervalAllocation]
, tax :: [IntervalAllocation]
, posttax :: [IntervalAllocation]
, transfers :: [Transfer]
, shadowTransfers :: [ShadowTransfer]
}
2023-02-05 18:45:56 -05:00
deriving instance Eq Budget
deriving instance Generic Budget
2023-02-05 18:45:56 -05:00
deriving instance Hashable Budget
deriving instance FromDhall Budget
2023-02-26 22:53:12 -05:00
deriving instance Eq TaggedAcnt
deriving instance Hashable TaggedAcnt
deriving instance Ord TaggedAcnt
type CurID = T.Text
data Income = Income
{ incGross :: Decimal
, incCurrency :: CurID
, incWhen :: DatePat
, incPretax :: [Allocation]
, incTaxes :: [Allocation]
, incPosttax :: [Allocation]
, incFrom :: TaggedAcnt
, incToBal :: TaggedAcnt
}
deriving instance Eq Income
2022-12-11 17:51:11 -05:00
deriving instance Generic Income
2022-12-11 17:51:11 -05:00
deriving instance Hashable Income
deriving instance FromDhall Income
2022-12-11 17:51:11 -05:00
deriving instance Eq Amount
2022-12-11 17:51:11 -05:00
deriving instance Ord Amount
deriving instance Hashable Amount
2022-12-11 17:51:11 -05:00
2023-02-26 12:03:35 -05:00
deriving instance Eq Exchange
deriving instance Hashable Exchange
deriving instance Eq BudgetCurrency
deriving instance Hashable BudgetCurrency
data Allocation_ a = Allocation_
{ alloTo :: TaggedAcnt
, alloAmts :: [a]
, alloCur :: BudgetCurrency
}
type Allocation = Allocation_ Amount
deriving instance Eq Allocation
deriving instance Generic Allocation
deriving instance Hashable Allocation
deriving instance FromDhall Allocation
type IntervalAllocation = Allocation_ IntervalAmount
deriving instance Eq IntervalAllocation
deriving instance Generic IntervalAllocation
deriving instance Hashable IntervalAllocation
deriving instance FromDhall IntervalAllocation
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-02-12 16:23:32 -05:00
deriving instance Eq AmountType
deriving instance Ord AmountType
2023-02-12 16:23:32 -05:00
deriving instance Hashable AmountType
data TimeAmount a = TimeAmount
{ taWhen :: a
, taAmt :: Amount
, taAmtType :: AmountType
}
deriving (Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
type DateAmount = TimeAmount DatePat
-- deriving instance Eq DateAmount
-- deriving instance Generic DateAmount
-- deriving instance Hashable DateAmount
-- deriving instance FromDhall DateAmount
type IntervalAmount = TimeAmount Interval
-- deriving instance Eq IntervalAmount
-- deriving instance Ord IntervalAmount
-- deriving instance Generic IntervalAmount
-- deriving instance Hashable IntervalAmount
-- deriving instance FromDhall IntervalAmount
data Transfer = Transfer
{ transFrom :: TaggedAcnt
, transTo :: TaggedAcnt
, transAmounts :: [DateAmount]
, transCurrency :: BudgetCurrency
}
2023-01-30 21:12:08 -05:00
deriving instance Eq Transfer
deriving instance Generic Transfer
2023-01-30 21:12:08 -05:00
deriving instance Hashable Transfer
2022-12-11 17:51:11 -05:00
deriving instance FromDhall Transfer
2023-02-13 19:57:39 -05:00
deriving instance Eq ShadowTransfer
deriving instance Hashable ShadowTransfer
deriving instance Eq AcntSet
deriving instance Hashable AcntSet
2023-02-13 19:57:39 -05:00
deriving instance Eq ShadowMatch
deriving instance Hashable ShadowMatch
2023-02-26 18:57:40 -05:00
deriving instance Eq MatchVal
deriving instance Hashable MatchVal
deriving instance Show MatchVal
deriving instance Eq MatchYMD
deriving instance Hashable MatchYMD
deriving instance Show MatchYMD
deriving instance Eq MatchDate
deriving instance Hashable MatchDate
deriving instance Show MatchDate
deriving instance Eq Decimal
deriving instance Ord Decimal
2023-02-26 18:57:40 -05:00
deriving instance Hashable Decimal
deriving instance Show Decimal
-- TODO this just looks silly...but not sure how to simplify it
instance Ord MatchYMD where
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 MatchDate where
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 Eq SplitNum
deriving instance Hashable SplitNum
deriving instance Show SplitNum
deriving instance Eq Manual
deriving instance Hashable Manual
-------------------------------------------------------------------------------
-- 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 :: !Global
, budget :: ![Budget]
, currencies :: ![Currency]
, statements :: ![Statement]
, 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
data Statement
2023-01-30 22:57:42 -05:00
= StmtManual !Manual
| StmtImport !Import
2023-02-05 18:45:56 -05:00
deriving (Eq, Hashable, Generic, FromDhall)
2022-12-11 17:51:11 -05:00
2023-02-26 22:53:12 -05:00
data Split a v c t = Split
{ sAcnt :: !a
, sValue :: !v
, sCurrency :: !c
, sComment :: !T.Text
2023-02-26 22:53:12 -05:00
, sTags :: ![t]
}
2023-02-26 22:53:12 -05:00
deriving (Eq, Generic, Hashable, Show)
type ExpSplit = Split SplitAcnt (Maybe SplitNum) 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
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)
2022-12-11 17:51:11 -05:00
data Import = Import
{ 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
data Field k v = Field
{ fKey :: !k
, fVal :: !v
}
2023-02-01 23:02:07 -05:00
deriving (Show, Eq, Hashable, Generic, FromDhall, Foldable, Traversable)
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)
2023-01-30 22:57:42 -05:00
| Val !(Field T.Text MatchVal)
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
2023-01-30 22:57:42 -05:00
{ mDate :: !(Maybe MatchDate)
, mVal :: !MatchVal
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)
2023-02-26 22:53:12 -05:00
type KeySplit = Split 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
2023-02-26 22:53:12 -05:00
type RawSplit = Split AcntID (Maybe Rational) CurID TagID
2022-12-11 17:51:11 -05:00
2023-02-26 22:53:12 -05:00
type BalSplit = Split 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 !DatePat
| 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