752 lines
20 KiB
Haskell
752 lines
20 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Internal.Types where
|
|
|
|
import Data.Fix (Fix (..), foldFix)
|
|
import Data.Functor.Foldable (embed)
|
|
import qualified Data.Functor.Foldable.TH as TH
|
|
import Database.Persist.Sql hiding (Desc, In, Statement)
|
|
import Database.Persist.TH
|
|
import Dhall hiding (embed, maybe)
|
|
import Dhall.TH
|
|
import Internal.TH (deriveProduct)
|
|
import Language.Haskell.TH.Syntax (Lift)
|
|
import RIO
|
|
import qualified RIO.Map as M
|
|
import qualified RIO.NonEmpty as NE
|
|
import qualified RIO.Text as T
|
|
import RIO.Time
|
|
import Text.Regex.TDFA
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- DHALL CONFIG
|
|
-------------------------------------------------------------------------------
|
|
|
|
makeHaskellTypesWith
|
|
(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 "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
|
|
, MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
|
|
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
|
|
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
|
|
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
|
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
|
, 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 "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
|
|
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
|
|
, SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
|
|
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
|
|
, -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
|
|
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
|
|
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
|
|
, SingleConstructor "Split" "Split" "(./dhall/Types.dhall).Split"
|
|
-- , 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"
|
|
, "ShadowMatch"
|
|
, "AcntSet"
|
|
, "MatchDate"
|
|
, "MatchVal"
|
|
, "MatchYMD"
|
|
, "Decimal"
|
|
, "Transfer"
|
|
, "BudgetCurrency"
|
|
, "Manual"
|
|
, "Exchange"
|
|
, "Amount"
|
|
, "AmountType"
|
|
, "SplitNum"
|
|
, "Global"
|
|
, "SqlConfig"
|
|
]
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- lots of instances for dhall types
|
|
|
|
deriving instance Lift Currency
|
|
|
|
deriving instance Hashable Currency
|
|
|
|
deriving instance Lift Tag
|
|
|
|
deriving instance Hashable Tag
|
|
|
|
deriving instance Ord TimeUnit
|
|
|
|
deriving instance Hashable TimeUnit
|
|
|
|
deriving instance Ord Weekday
|
|
|
|
deriving instance Hashable Weekday
|
|
|
|
deriving instance Enum Weekday
|
|
|
|
deriving instance Ord WeekdayPat
|
|
|
|
deriving instance Hashable WeekdayPat
|
|
|
|
deriving instance Ord RepeatPat
|
|
|
|
deriving instance Hashable RepeatPat
|
|
|
|
deriving instance Ord MDYPat
|
|
|
|
deriving instance Hashable MDYPat
|
|
|
|
deriving instance Hashable Gregorian
|
|
|
|
deriving instance Hashable GregorianM
|
|
|
|
-- 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
|
|
|
|
deriving instance Hashable ModPat
|
|
|
|
deriving instance Ord CronPat
|
|
|
|
deriving instance Hashable CronPat
|
|
|
|
deriving instance Ord DatePat
|
|
|
|
deriving instance Hashable DatePat
|
|
|
|
data Budget = Budget
|
|
{ budgetLabel :: Text
|
|
, incomes :: [Income]
|
|
, pretax :: [IntervalAllocation]
|
|
, tax :: [IntervalAllocation]
|
|
, posttax :: [IntervalAllocation]
|
|
, transfers :: [Transfer]
|
|
, shadowTransfers :: [ShadowTransfer]
|
|
}
|
|
|
|
deriving instance Hashable Budget
|
|
|
|
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 Hashable Income
|
|
|
|
deriving instance Ord Amount
|
|
|
|
deriving instance Hashable Amount
|
|
|
|
deriving instance Hashable Exchange
|
|
|
|
deriving instance Hashable BudgetCurrency
|
|
|
|
data Allocation_ a = Allocation_
|
|
{ alloTo :: TaggedAcnt
|
|
, alloAmts :: [a]
|
|
, alloCur :: BudgetCurrency
|
|
}
|
|
deriving (Eq, Show, Generic, Hashable)
|
|
|
|
deriving instance FromDhall a => FromDhall (Allocation_ a)
|
|
|
|
type Allocation = Allocation_ Amount
|
|
|
|
type IntervalAllocation = Allocation_ IntervalAmount
|
|
|
|
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)]
|
|
|
|
deriving instance Ord AmountType
|
|
|
|
deriving instance Hashable AmountType
|
|
|
|
-- data TimeAmount a = TimeAmount
|
|
-- { taWhen :: a
|
|
-- , taAmt :: Amount
|
|
-- , taAmtType :: AmountType
|
|
-- }
|
|
-- deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
|
|
|
|
deriving instance Show a => Show (TimeAmount a)
|
|
|
|
deriving instance Eq a => Eq (TimeAmount a)
|
|
|
|
deriving instance Ord a => Ord (TimeAmount a)
|
|
|
|
deriving instance Functor TimeAmount
|
|
|
|
deriving instance Foldable TimeAmount
|
|
|
|
deriving instance Traversable TimeAmount
|
|
|
|
deriving instance Generic (TimeAmount a)
|
|
|
|
deriving instance Hashable a => Hashable (TimeAmount a)
|
|
|
|
deriving instance FromDhall a => FromDhall (TimeAmount a)
|
|
|
|
type DateAmount = TimeAmount DatePat
|
|
|
|
type IntervalAmount = TimeAmount Interval
|
|
|
|
deriving instance Ord Interval
|
|
|
|
data Transfer = Transfer
|
|
{ transFrom :: TaggedAcnt
|
|
, transTo :: TaggedAcnt
|
|
, transAmounts :: [DateAmount]
|
|
, transCurrency :: BudgetCurrency
|
|
}
|
|
|
|
deriving instance Hashable Transfer
|
|
|
|
deriving instance Hashable ShadowTransfer
|
|
|
|
deriving instance Hashable AcntSet
|
|
|
|
deriving instance Hashable ShadowMatch
|
|
|
|
deriving instance Hashable MatchVal
|
|
|
|
deriving instance Hashable MatchYMD
|
|
|
|
deriving instance Hashable MatchDate
|
|
|
|
deriving instance Ord Decimal
|
|
|
|
deriving instance Hashable 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 Hashable SplitNum
|
|
|
|
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
|
|
, tags :: ![Tag]
|
|
, 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)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- dhall type overrides (since dhall can't import types with parameters...yet)
|
|
|
|
-- TODO newtypes for these?
|
|
type AcntID = T.Text
|
|
|
|
type TagID = T.Text
|
|
|
|
data Statement
|
|
= StmtManual !Manual
|
|
| StmtImport !Import
|
|
deriving (Eq, Hashable, Generic, FromDhall)
|
|
|
|
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
|
|
|
|
instance FromDhall ExpSplit
|
|
|
|
deriving instance (Show a, Show c, Show v, Show t) => Show (Split a v c t)
|
|
|
|
deriving instance Generic (Split a v c t)
|
|
|
|
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Split a v c t)
|
|
|
|
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Split a v c t)
|
|
|
|
data Tx s = Tx
|
|
{ txDescr :: !T.Text
|
|
, txDate :: !Day
|
|
, txSplits :: ![s]
|
|
}
|
|
deriving (Generic)
|
|
|
|
type ExpTx = Tx ExpSplit
|
|
|
|
instance FromDhall ExpTx
|
|
|
|
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 Import = Import
|
|
{ impPaths :: ![FilePath]
|
|
, impMatches :: ![Match T.Text]
|
|
, impDelim :: !Word
|
|
, impTxOpts :: !(TxOpts T.Text)
|
|
, impSkipLines :: !Natural
|
|
}
|
|
deriving (Eq, Hashable, Generic, FromDhall)
|
|
|
|
-- | 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
|
|
| MapT !(FieldMap T.Text t)
|
|
| Map2T !(FieldMap (T.Text, T.Text) t)
|
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
|
|
|
type SplitCur = SplitText CurID
|
|
|
|
type SplitAcnt = SplitText AcntID
|
|
|
|
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)
|
|
|
|
instance Functor (Field f) where
|
|
fmap f (Field k v) = Field k $ f v
|
|
|
|
type FieldMap k v = Field k (M.Map k v)
|
|
|
|
data MatchOther re
|
|
= Desc !(Field T.Text re)
|
|
| Val !(Field T.Text MatchVal)
|
|
deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
|
|
|
|
deriving instance Show (MatchOther T.Text)
|
|
|
|
data ToTx = ToTx
|
|
{ ttCurrency :: !SplitCur
|
|
, ttPath :: !SplitAcnt
|
|
, ttSplit :: ![ExpSplit]
|
|
}
|
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
|
|
|
data Match re = Match
|
|
{ mDate :: !(Maybe MatchDate)
|
|
, mVal :: !MatchVal
|
|
, mDesc :: !(Maybe re)
|
|
, mOther :: ![MatchOther re]
|
|
, mTx :: !(Maybe ToTx)
|
|
, mTimes :: !(Maybe Natural)
|
|
, mPriority :: !Integer
|
|
}
|
|
deriving (Eq, Generic, Hashable, FromDhall, Functor)
|
|
|
|
deriving instance Show (Match T.Text)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- DATABASE MODEL
|
|
--------------------------------------------------------------------------------
|
|
|
|
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
|
|
TagR sql=tags
|
|
symbol T.Text
|
|
fullname T.Text
|
|
deriving Show Eq
|
|
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
|
|
TagRelationR sql=tag_relations
|
|
split SplitRId OnDeleteCascade
|
|
tag TagRId OnDeleteCascade
|
|
BudgetLabelR sql=budget_labels
|
|
split SplitRId OnDeleteCascade
|
|
budgetName T.Text
|
|
deriving Show Eq
|
|
|]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- database cache types
|
|
|
|
data ConfigHashes = ConfigHashes
|
|
{ chIncome :: ![Int]
|
|
, chExpense :: ![Int]
|
|
, chManual :: ![Int]
|
|
, chImport :: ![Int]
|
|
}
|
|
|
|
data ConfigType = CTBudget | CTManual | CTImport
|
|
deriving (Eq, Show, Read, Enum)
|
|
|
|
instance PersistFieldSql ConfigType where
|
|
sqlType _ = SqlString
|
|
|
|
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"
|
|
|
|
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
|
|
|
type CurrencyMap = M.Map CurID CurrencyRId
|
|
|
|
type TagMap = M.Map TagID TagRId
|
|
|
|
data DBState = DBState
|
|
{ kmCurrency :: !CurrencyMap
|
|
, kmAccount :: !AccountMap
|
|
, kmTag :: !TagMap
|
|
, kmBudgetInterval :: !Bounds
|
|
, kmStatementInterval :: !Bounds
|
|
, kmNewCommits :: ![Int]
|
|
, kmConfigDir :: !FilePath
|
|
}
|
|
|
|
type MappingT m = ReaderT DBState (SqlPersistT m)
|
|
|
|
type KeySplit = Split AccountRId Rational CurrencyRId TagRId
|
|
|
|
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
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- misc
|
|
|
|
data AcntType
|
|
= AssetT
|
|
| EquityT
|
|
| ExpenseT
|
|
| IncomeT
|
|
| LiabilityT
|
|
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
|
|
|
|
atName :: AcntType -> T.Text
|
|
atName AssetT = "asset"
|
|
atName EquityT = "equity"
|
|
atName ExpenseT = "expense"
|
|
atName IncomeT = "income"
|
|
atName LiabilityT = "liability"
|
|
|
|
data AcntPath = AcntPath
|
|
{ apType :: !AcntType
|
|
, apChildren :: ![T.Text]
|
|
}
|
|
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
|
|
|
|
data TxRecord = TxRecord
|
|
{ trDate :: !Day
|
|
, trAmount :: !Rational
|
|
, trDesc :: !T.Text
|
|
, trOther :: !(M.Map T.Text T.Text)
|
|
, trFile :: !FilePath
|
|
}
|
|
deriving (Show, Eq, Ord)
|
|
|
|
type Bounds = (Day, Natural)
|
|
|
|
data Keyed a = Keyed
|
|
{ kKey :: !Int64
|
|
, kVal :: !a
|
|
}
|
|
deriving (Eq, Show, Functor)
|
|
|
|
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
|
|
|
|
data AcntSign = Credit | Debit
|
|
deriving (Show)
|
|
|
|
sign2Int :: AcntSign -> Int
|
|
sign2Int Debit = 1
|
|
sign2Int Credit = 1
|
|
|
|
accountSign :: AcntType -> AcntSign
|
|
accountSign AssetT = Debit
|
|
accountSign ExpenseT = Debit
|
|
accountSign IncomeT = Credit
|
|
accountSign LiabilityT = Credit
|
|
accountSign EquityT = Credit
|
|
|
|
type RawSplit = Split AcntID (Maybe Rational) CurID TagID
|
|
|
|
type BalSplit = Split AcntID Rational CurID TagID
|
|
|
|
type RawTx = Tx RawSplit
|
|
|
|
type BalTx = Tx BalSplit
|
|
|
|
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- exception types
|
|
|
|
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
|
|
|
|
data MatchType = MatchNumeric | MatchText deriving (Show)
|
|
|
|
data SplitIDType = AcntField | CurField | TagField deriving (Show)
|
|
|
|
data LookupSuberr
|
|
= SplitIDField !SplitIDType
|
|
| SplitValField
|
|
| MatchField !MatchType
|
|
| DBKey !SplitIDType
|
|
deriving (Show)
|
|
|
|
data AllocationSuberr
|
|
= NoAllocations
|
|
| ExceededTotal
|
|
| MissingBlank
|
|
| TooManyBlanks
|
|
deriving (Show)
|
|
|
|
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
|
|
|
|
data InsertError
|
|
= RegexError !T.Text
|
|
| MatchValPrecisionError !Natural !Natural
|
|
| AccountError !AcntID !(NE.NonEmpty AcntType)
|
|
| InsertIOError !T.Text
|
|
| ParseError !T.Text
|
|
| ConversionError !T.Text
|
|
| LookupError !LookupSuberr !T.Text
|
|
| BalanceError !BalanceType !CurID ![RawSplit]
|
|
| IncomeError !DatePat
|
|
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
|
| BoundsError !Gregorian !(Maybe Gregorian)
|
|
| StatementError ![TxRecord] ![MatchRe]
|
|
deriving (Show)
|
|
|
|
newtype InsertException = InsertException [InsertError] deriving (Show)
|
|
|
|
instance Exception InsertException
|
|
|
|
type EitherErr = Either InsertError
|
|
|
|
type EitherErrs = Either [InsertError]
|
|
|
|
data XGregorian = XGregorian
|
|
{ xgYear :: !Int
|
|
, xgMonth :: !Int
|
|
, xgDay :: !Int
|
|
, xgDayOfWeek :: !Int
|
|
}
|
|
|
|
type MatchRe = Match (T.Text, Regex)
|
|
|
|
type TxOptsRe = TxOpts (T.Text, Regex)
|
|
|
|
type MatchOtherRe = MatchOther (T.Text, Regex)
|
|
|
|
instance Show (Match (T.Text, Regex)) where
|
|
show = show . fmap fst
|