pwncash/lib/Internal/Types.hs

725 lines
18 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 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})
[ 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 "Tax" "Tax" "(./dhall/Types.dhall).Tax"
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
, SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
, SingleConstructor "Allocation" "Allocation" "(./dhall/Types.dhall).Allocation"
, 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"
, 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"
]
-------------------------------------------------------------------------------
-- lots of instances for dhall types
deriving instance Eq Currency
deriving instance Lift Currency
deriving instance Hashable Currency
deriving instance Eq Tag
deriving instance Lift Tag
deriving instance Hashable Tag
deriving instance Eq TimeUnit
deriving instance Ord TimeUnit
deriving instance Show TimeUnit
deriving instance Hashable TimeUnit
deriving instance Eq Weekday
deriving instance Ord Weekday
deriving instance Show Weekday
deriving instance Hashable Weekday
deriving instance Enum Weekday
deriving instance Eq WeekdayPat
deriving instance Ord WeekdayPat
deriving instance Show WeekdayPat
deriving instance Hashable WeekdayPat
deriving instance Show RepeatPat
deriving instance Eq RepeatPat
deriving instance Ord RepeatPat
deriving instance Hashable RepeatPat
deriving instance Show MDYPat
deriving instance Eq MDYPat
deriving instance Ord MDYPat
deriving instance Hashable MDYPat
deriving instance Eq Gregorian
deriving instance Show Gregorian
deriving instance Hashable Gregorian
deriving instance Eq GregorianM
deriving instance Show GregorianM
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 Eq ModPat
deriving instance Ord ModPat
deriving instance Show ModPat
deriving instance Hashable ModPat
deriving instance Eq CronPat
deriving instance Ord CronPat
deriving instance Show CronPat
deriving instance Hashable CronPat
deriving instance Eq DatePat
deriving instance Ord DatePat
deriving instance Show DatePat
deriving instance Hashable DatePat
deriving instance Eq Budget
deriving instance Hashable Budget
deriving instance Eq TaggedAcnt
deriving instance Hashable TaggedAcnt
deriving instance Ord TaggedAcnt
deriving instance Eq Income
deriving instance Hashable Income
deriving instance Eq Tax
deriving instance Hashable Tax
deriving instance Eq Amount
deriving instance Hashable Amount
deriving instance Eq Exchange
deriving instance Hashable Exchange
deriving instance Eq BudgetCurrency
deriving instance Hashable BudgetCurrency
deriving instance Eq Allocation
deriving instance Hashable 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)]
deriving instance Eq AmountType
deriving instance Hashable AmountType
deriving instance Eq TimeAmount
deriving instance Hashable TimeAmount
deriving instance Eq Transfer
deriving instance Hashable Transfer
deriving instance Eq ShadowTransfer
deriving instance Hashable ShadowTransfer
deriving instance Eq AcntSet
deriving instance Hashable AcntSet
deriving instance Eq ShadowMatch
deriving instance Hashable ShadowMatch
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 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
, 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 CurID = T.Text
type TagID = T.Text
data Statement
= StmtManual !Manual
| StmtImport !Import
deriving (Eq, Hashable, Generic, FromDhall)
data Split a v c t = Split
{ sAcnt :: !a
, sValue :: !v
, sCurrency :: !c
, sComment :: !T.Text
, sTags :: ![t]
}
deriving (Eq, Generic, Hashable, Show)
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
instance FromDhall ExpSplit
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
data Field k v = Field
{ fKey :: !k
, fVal :: !v
}
deriving (Show, Eq, Hashable, Generic, FromDhall, Foldable, Traversable)
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 = CTIncome | CTExpense | CTShadow | 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