pwncash/lib/Internal/Types.hs

625 lines
16 KiB
Haskell

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TemplateHaskell #-}
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"
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
, MultipleConstructors "TransferTarget" "(./dhall/Types.dhall).TransferTarget"
, 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 "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"
]
-------------------------------------------------------------------------------
-- account tree
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
-------------------------------------------------------------------------------
-- 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 Budget
deriving instance Hashable Budget
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 AmountType
deriving instance Hashable AmountType
deriving instance Eq TimeAmount
deriving instance Hashable TimeAmount
deriving instance Eq TransferTarget
deriving instance Hashable TransferTarget
deriving instance Eq Transfer
deriving instance Hashable Transfer
--------------------------------------------------------------------------------
-- Statements (data from the past)
data Statement
= StmtManual !Manual
| StmtImport !Import
deriving (Eq, Hashable, 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 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)
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)
--------------------------------------------------------------------------------
-- 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, Natural)
-- 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 PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
data InsertError
= RegexError !T.Text
| MatchValPrecisionError !Natural !Natural
| AccountError !AcntID !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