798 lines
22 KiB
Haskell
798 lines
22 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Internal.Types where
|
|
|
|
import Control.Monad.Except
|
|
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 "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
|
|
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
|
|
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
|
|
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
|
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
|
|
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
|
|
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
|
|
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
|
, 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 "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"
|
|
, 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 "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"
|
|
, SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period"
|
|
, SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
|
|
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
|
|
-- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
|
|
-- , 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"
|
|
, "AcntSet"
|
|
, "DateMatcher"
|
|
, "ValMatcher"
|
|
, "YMDMatcher"
|
|
, "BudgetCurrency"
|
|
, "Exchange"
|
|
, "EntryNumGetter"
|
|
, "TemporalScope"
|
|
, "SqlConfig"
|
|
, "PretaxValue"
|
|
, "TaxValue"
|
|
, "TaxBracket"
|
|
, "TaxProgression"
|
|
, "TaxMethod"
|
|
, "PosttaxValue"
|
|
, "BudgetTransferValue"
|
|
, "BudgetTransferType"
|
|
, "Period"
|
|
, "PeriodType"
|
|
, "HourlyPeriod"
|
|
]
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- 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
|
|
|
|
type BudgetTransfer =
|
|
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
|
|
|
|
deriving instance Hashable BudgetTransfer
|
|
|
|
deriving instance Generic BudgetTransfer
|
|
|
|
deriving instance FromDhall BudgetTransfer
|
|
|
|
data Budget = Budget
|
|
{ bgtLabel :: Text
|
|
, bgtIncomes :: [Income]
|
|
, bgtPretax :: [MultiAllocation PretaxValue]
|
|
, bgtTax :: [MultiAllocation TaxValue]
|
|
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
|
, bgtTransfers :: [BudgetTransfer]
|
|
, bgtShadowTransfers :: [ShadowTransfer]
|
|
, bgtInterval :: !(Maybe Interval)
|
|
}
|
|
|
|
deriving instance Hashable PretaxValue
|
|
|
|
deriving instance Hashable TaxBracket
|
|
|
|
deriving instance Hashable TaxProgression
|
|
|
|
deriving instance Hashable TaxMethod
|
|
|
|
deriving instance Hashable TaxValue
|
|
|
|
deriving instance Hashable PosttaxValue
|
|
|
|
deriving instance Hashable Budget
|
|
|
|
deriving instance Hashable BudgetTransferValue
|
|
|
|
deriving instance Hashable BudgetTransferType
|
|
|
|
deriving instance Hashable TaggedAcnt
|
|
|
|
deriving instance Ord TaggedAcnt
|
|
|
|
type CurID = T.Text
|
|
|
|
data Income = Income
|
|
{ incGross :: Double
|
|
, incCurrency :: CurID
|
|
, incWhen :: DatePat
|
|
, incPretax :: [SingleAllocation PretaxValue]
|
|
, incTaxes :: [SingleAllocation TaxValue]
|
|
, incPosttax :: [SingleAllocation PosttaxValue]
|
|
, incFrom :: TaggedAcnt
|
|
, incToBal :: TaggedAcnt
|
|
, incPayPeriod :: !Period
|
|
}
|
|
|
|
deriving instance Hashable HourlyPeriod
|
|
|
|
deriving instance Hashable PeriodType
|
|
|
|
deriving instance Hashable Period
|
|
|
|
deriving instance Hashable Income
|
|
|
|
deriving instance (Ord w, Ord v) => Ord (Amount w v)
|
|
|
|
deriving instance Generic (Amount w v)
|
|
|
|
deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)
|
|
|
|
deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)
|
|
|
|
-- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)
|
|
|
|
deriving instance (Show w, Show v) => Show (Amount w v)
|
|
|
|
deriving instance (Eq w, Eq v) => Eq (Amount w v)
|
|
|
|
deriving instance Hashable Exchange
|
|
|
|
deriving instance Hashable BudgetCurrency
|
|
|
|
data Allocation w v = Allocation
|
|
{ alloTo :: TaggedAcnt
|
|
, alloAmts :: [Amount w v]
|
|
, alloCur :: CurID
|
|
}
|
|
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 ()
|
|
|
|
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)]
|
|
|
|
-- this is necessary since dhall will reverse the order when importing
|
|
instance Ord Interval where
|
|
compare
|
|
Interval {intStart = s0, intEnd = e0}
|
|
Interval {intStart = s1, intEnd = e1} =
|
|
compare (s0, e0) (s1, e1)
|
|
|
|
data Transfer a c w v = Transfer
|
|
{ transFrom :: a
|
|
, transTo :: a
|
|
, transAmounts :: [Amount w v]
|
|
, transCurrency :: c
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
deriving instance Hashable ShadowTransfer
|
|
|
|
deriving instance Hashable AcntSet
|
|
|
|
deriving instance Hashable TransferMatcher
|
|
|
|
deriving instance Hashable ValMatcher
|
|
|
|
deriving instance Hashable YMDMatcher
|
|
|
|
deriving instance Hashable DateMatcher
|
|
|
|
-- TODO this just looks silly...but not sure how to simplify it
|
|
instance Ord YMDMatcher 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 DateMatcher 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 EntryNumGetter
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- 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
|
|
, budget :: ![Budget]
|
|
, currencies :: ![Currency]
|
|
, statements :: ![History]
|
|
, 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
|
|
|
|
type HistTransfer = Transfer AcntID CurID DatePat Double
|
|
|
|
deriving instance Generic HistTransfer
|
|
|
|
deriving instance Hashable HistTransfer
|
|
|
|
deriving instance FromDhall HistTransfer
|
|
|
|
data History
|
|
= HistTransfer !HistTransfer
|
|
| HistStatement !Statement
|
|
deriving (Eq, Generic, Hashable, FromDhall)
|
|
|
|
type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
|
|
|
|
instance FromDhall EntryGetter
|
|
|
|
deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)
|
|
|
|
deriving instance Generic (Entry a v c t)
|
|
|
|
deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)
|
|
|
|
deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
|
|
|
|
data Tx s = Tx
|
|
{ txDescr :: !T.Text
|
|
, txDate :: !Day
|
|
, txSplits :: ![s]
|
|
}
|
|
deriving (Generic)
|
|
|
|
type ExpTx = Tx EntryGetter
|
|
|
|
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 Statement = Statement
|
|
{ stmtPaths :: ![FilePath]
|
|
, stmtParsers :: ![StatementParser T.Text]
|
|
, stmtDelim :: !Word
|
|
, stmtTxOpts :: !(TxOpts T.Text)
|
|
, stmtSkipLines :: !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 EntryTextGetter 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 = EntryTextGetter CurID
|
|
|
|
type SplitAcnt = EntryTextGetter 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 FieldMatcher re
|
|
= Desc !(Field T.Text re)
|
|
| Val !(Field T.Text ValMatcher)
|
|
deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)
|
|
|
|
deriving instance Show (FieldMatcher T.Text)
|
|
|
|
data TxGetter = TxGetter
|
|
{ tgCurrency :: !SplitCur
|
|
, tgAcnt :: !SplitAcnt
|
|
, tgEntries :: ![EntryGetter]
|
|
}
|
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
|
|
|
data StatementParser re = StatementParser
|
|
{ spDate :: !(Maybe DateMatcher)
|
|
, spVal :: !ValMatcher
|
|
, spDesc :: !(Maybe re)
|
|
, spOther :: ![FieldMatcher re]
|
|
, spTx :: !(Maybe TxGetter)
|
|
, spTimes :: !(Maybe Natural)
|
|
, spPriority :: !Integer
|
|
}
|
|
deriving (Eq, Generic, Hashable, FromDhall, Functor)
|
|
|
|
deriving instance Show (StatementParser 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
|
|
precision Int
|
|
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, Natural)
|
|
|
|
type TagMap = M.Map TagID TagRId
|
|
|
|
data DBState = DBState
|
|
{ kmCurrency :: !CurrencyMap
|
|
, kmAccount :: !AccountMap
|
|
, kmTag :: !TagMap
|
|
, kmBudgetInterval :: !Bounds
|
|
, kmStatementInterval :: !Bounds
|
|
, kmNewCommits :: ![Int]
|
|
, kmOldCommits :: ![Int]
|
|
, kmConfigDir :: !FilePath
|
|
, kmTagAll :: ![Entity TagR]
|
|
, kmAcntPaths :: ![AccountPathR]
|
|
, kmAcntsOld :: ![Entity AccountR]
|
|
, kmCurrenciesOld :: ![Entity CurrencyR]
|
|
}
|
|
|
|
type CurrencyM = Reader CurrencyMap
|
|
|
|
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
|
|
|
|
type KeyTx = Tx KeySplit
|
|
|
|
type TreeR = Tree ([T.Text], AccountRId)
|
|
|
|
type Balances = M.Map AccountRId Rational
|
|
|
|
type BalanceM = ReaderT (MVar Balances)
|
|
|
|
type MonadFinance = MonadReader DBState
|
|
|
|
askDBState :: MonadFinance m => (DBState -> a) -> m a
|
|
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 = Entry AcntID (Maybe Rational) CurID TagID
|
|
|
|
type BalSplit = Entry 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 !Day !T.Text !Rational
|
|
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
|
| BoundsError !Gregorian !(Maybe Gregorian)
|
|
| StatementError ![TxRecord] ![MatchRe]
|
|
| PeriodError !Day !Day
|
|
deriving (Show)
|
|
|
|
newtype InsertException = InsertException [InsertError]
|
|
deriving (Show, Semigroup) via [InsertError]
|
|
|
|
instance Exception InsertException
|
|
|
|
type MonadInsertError = MonadError InsertException
|
|
|
|
type InsertExceptT = ExceptT InsertException
|
|
|
|
type InsertExcept = InsertExceptT Identity
|
|
|
|
data XGregorian = XGregorian
|
|
{ xgYear :: !Int
|
|
, xgMonth :: !Int
|
|
, xgDay :: !Int
|
|
, xgDayOfWeek :: !Int
|
|
}
|
|
|
|
type MatchRe = StatementParser (T.Text, Regex)
|
|
|
|
type TxOptsRe = TxOpts (T.Text, Regex)
|
|
|
|
type FieldMatcherRe = FieldMatcher (T.Text, Regex)
|
|
|
|
instance Show (StatementParser (T.Text, Regex)) where
|
|
show = show . fmap fst
|