612 lines
16 KiB
Haskell
612 lines
16 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DeriveLift #-}
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
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 Dhall hiding (embed, maybe)
|
|
import Dhall.TH
|
|
import Language.Haskell.TH.Syntax (Lift)
|
|
import RIO
|
|
import qualified RIO.Map as M
|
|
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 "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
|
|
, MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
|
|
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
|
, 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 "TxOpts" "TxOpts" "(./dhall/Types.dhall).TxOpts.Type"
|
|
, 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 "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
|
|
, SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
|
|
]
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- account tree
|
|
|
|
data AccountTree
|
|
= Placeholder T.Text T.Text [AccountTree]
|
|
| Account T.Text T.Text
|
|
|
|
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
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- curencies
|
|
|
|
deriving instance Eq Currency
|
|
|
|
deriving instance Lift Currency
|
|
|
|
deriving instance Hashable Currency
|
|
|
|
type CurID = T.Text
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- DHALL CONFIG
|
|
-------------------------------------------------------------------------------
|
|
|
|
data Config_ a = Config_
|
|
{ global :: !Global
|
|
, budget :: !Budget
|
|
, currencies :: ![Currency]
|
|
, statements :: ![Statement]
|
|
, accounts :: !a
|
|
, 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)
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- accounts
|
|
|
|
type AcntID = T.Text
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Time Patterns (for assigning when budget events will happen)
|
|
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Budget (projecting into the future)
|
|
|
|
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 Allocation
|
|
|
|
deriving instance Hashable Allocation
|
|
|
|
deriving instance Eq IncomeBucket
|
|
|
|
deriving instance Hashable IncomeBucket
|
|
|
|
deriving instance Show IncomeBucket
|
|
|
|
deriving instance Read IncomeBucket
|
|
|
|
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)]
|
|
|
|
instance PersistField IncomeBucket where
|
|
toPersistValue = toPersistText
|
|
|
|
fromPersistValue = fromPersistText "IncomeBucket"
|
|
|
|
instance PersistFieldSql IncomeBucket where
|
|
sqlType _ = SqlString
|
|
|
|
deriving instance Eq ExpenseBucket
|
|
|
|
deriving instance Hashable ExpenseBucket
|
|
|
|
deriving instance Show ExpenseBucket
|
|
|
|
deriving instance Read ExpenseBucket
|
|
|
|
instance PersistField ExpenseBucket where
|
|
toPersistValue = toPersistText
|
|
|
|
fromPersistValue = fromPersistText "ExpenseBucket"
|
|
|
|
instance PersistFieldSql ExpenseBucket where
|
|
sqlType _ = SqlString
|
|
|
|
deriving instance Eq TimeAmount
|
|
|
|
deriving instance Hashable TimeAmount
|
|
|
|
deriving instance Eq Transfer
|
|
|
|
deriving instance Hashable Transfer
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Statements (data from the past)
|
|
|
|
data Statement
|
|
= StmtManual !Manual
|
|
| StmtImport !Import
|
|
deriving (Generic, FromDhall)
|
|
|
|
deriving instance Eq Manual
|
|
|
|
deriving instance Hashable Manual
|
|
|
|
data Split a v c = Split
|
|
{ sAcnt :: !a
|
|
, sValue :: !v
|
|
, sCurrency :: !c
|
|
, sComment :: !T.Text
|
|
}
|
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
|
|
|
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur
|
|
|
|
data Tx s = Tx
|
|
{ txDescr :: !T.Text
|
|
, txDate :: !Day
|
|
, txTags :: ![T.Text]
|
|
, txSplits :: ![s]
|
|
}
|
|
deriving (Generic)
|
|
|
|
type ExpTx = Tx ExpSplit
|
|
|
|
instance FromDhall ExpTx
|
|
|
|
data Import = Import
|
|
{ impPaths :: ![FilePath]
|
|
, impMatches :: ![Match T.Text]
|
|
, impDelim :: !Word
|
|
, impTxOpts :: !TxOpts
|
|
, impSkipLines :: !Natural
|
|
}
|
|
deriving (Eq, Hashable, Generic, FromDhall)
|
|
|
|
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
|
|
|
|
-- 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
|
|
|
|
-- | 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)
|
|
|
|
deriving instance Eq TxOpts
|
|
|
|
deriving instance Hashable TxOpts
|
|
|
|
deriving instance Show TxOpts
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Specialized dhall types
|
|
|
|
deriving instance Eq Decimal
|
|
|
|
deriving instance Hashable Decimal
|
|
|
|
deriving instance Show Decimal
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- database cache types
|
|
|
|
data ConfigHashes = ConfigHashes
|
|
{ chIncome :: ![Int]
|
|
, chExpense :: ![Int]
|
|
, chManual :: ![Int]
|
|
, chImport :: ![Int]
|
|
}
|
|
|
|
data ConfigType = CTIncome | CTExpense | 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"
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- 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, Day)
|
|
|
|
type MaybeBounds = (Maybe Day, Maybe Day)
|
|
|
|
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
|
|
|
|
type BalSplit = Split AcntID Rational CurID
|
|
|
|
type RawTx = Tx RawSplit
|
|
|
|
type BalTx = Tx BalSplit
|
|
|
|
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
|
|
|
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
|
|
|
|
data MatchType = MatchNumeric | MatchText deriving (Show)
|
|
|
|
data SplitIDType = AcntField | CurField deriving (Show)
|
|
|
|
data LookupSuberr
|
|
= SplitIDField !SplitIDType
|
|
| SplitValField
|
|
| MatchField !MatchType
|
|
| DBKey !SplitIDType
|
|
deriving (Show)
|
|
|
|
data AllocationSuberr
|
|
= NoAllocations
|
|
| ExceededTotal
|
|
| MissingBlank
|
|
| TooManyBlanks
|
|
deriving (Show)
|
|
|
|
data InsertError
|
|
= RegexError !T.Text
|
|
| MatchValPrecisionError !Natural !Natural
|
|
| InsertIOError !T.Text
|
|
| ParseError !T.Text
|
|
| ConversionError !T.Text
|
|
| LookupError !LookupSuberr !T.Text
|
|
| BalanceError !BalanceType !CurID ![RawSplit]
|
|
| IncomeError !DatePat
|
|
| 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 MatchOtherRe = MatchOther (T.Text, Regex)
|
|
|
|
instance Show (Match (T.Text, Regex)) where
|
|
show = show . fmap fst
|