pwncash/lib/Internal/Types.hs

473 lines
13 KiB
Haskell
Raw Normal View History

2022-12-11 17:51:11 -05:00
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
2022-12-14 23:59:23 -05:00
{-# LANGUAGE DerivingStrategies #-}
2022-12-11 17:51:11 -05:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
2022-12-11 17:51:11 -05:00
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Internal.Types where
import Data.Fix (Fix (..), foldFix)
import Data.Functor.Foldable (embed)
import qualified Data.Functor.Foldable.TH as TH
import Data.Hashable
import Data.Int
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Time
import Database.Persist.Sql hiding (In, Statement)
import Dhall hiding (embed, maybe)
2022-12-14 23:59:23 -05:00
import Dhall.TH
2022-12-11 17:51:11 -05:00
import Language.Haskell.TH.Syntax (Lift)
import Text.Read
-------------------------------------------------------------------------------
-- | YAML CONFIG
-------------------------------------------------------------------------------
makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False })
2022-12-14 23:59:23 -05:00
[ 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 "MatchDesc" "(./dhall/Types.dhall).MatchDesc"
, MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
, MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket"
, 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"
]
2022-12-11 18:53:54 -05:00
2022-12-11 17:51:11 -05:00
-------------------------------------------------------------------------------
-- | 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
2022-12-14 23:59:23 -05:00
deriving instance Eq Currency
deriving instance Lift Currency
deriving instance Hashable Currency
2022-12-11 17:51:11 -05:00
type CurID = T.Text
-------------------------------------------------------------------------------
-- | DHALL CONFIG
-------------------------------------------------------------------------------
data Config_ a = Config_
{ global :: !Global
, budget :: !Budget
, currencies :: ![Currency]
, statements :: ![Statement]
2022-12-14 23:59:23 -05:00
, accounts :: !a
2022-12-11 18:53:54 -05:00
, sqlConfig :: !SqlConfig
2022-12-11 17:51:11 -05:00
}
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)
2022-12-14 23:59:23 -05:00
deriving instance Eq TimeUnit
deriving instance Hashable TimeUnit
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq Weekday
deriving instance Hashable Weekday
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq WeekdayPat
deriving instance Hashable WeekdayPat
2022-12-11 17:51:11 -05:00
deriving instance Show RepeatPat
2022-12-14 23:59:23 -05:00
deriving instance Eq RepeatPat
deriving instance Hashable RepeatPat
2022-12-11 17:51:11 -05:00
deriving instance Show MDYPat
2022-12-14 23:59:23 -05:00
deriving instance Eq MDYPat
deriving instance Hashable MDYPat
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq Gregorian
deriving instance Show Gregorian
deriving instance Hashable Gregorian
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq GregorianM
deriving instance Show GregorianM
deriving instance Hashable GregorianM
2022-12-11 17:51:11 -05:00
-- 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'
2022-12-14 23:59:23 -05:00
deriving instance Eq ModPat
deriving instance Hashable ModPat
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq CronPat
deriving instance Hashable CronPat
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq DatePat
deriving instance Hashable DatePat
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- | Budget (projecting into the future)
data Income = Income
{ incGross :: !Decimal
, incCurrency :: !CurID
, incWhen :: !DatePat
, incAccount :: !AcntID
, incPretax :: ![Allocation Decimal]
, incTaxes :: ![Tax]
, incPosttax :: ![Allocation (Maybe Decimal)]
}
deriving (Eq, Hashable, Generic, FromDhall)
data Budget = Budget
{ income :: ![Income]
, expenses :: ![Expense]
}
deriving (Generic, FromDhall)
2022-12-14 23:59:23 -05:00
deriving instance Eq Tax
deriving instance Hashable Tax
2022-12-11 17:51:11 -05:00
data Amount v = Amount
{ amtValue :: !v
, amtDesc :: !T.Text
} deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
data Allocation v = Allocation
{ alloPath :: !AcntID
, alloBucket :: !Bucket
, alloAmts :: ![Amount v]
, alloCurrency :: !CurID
}
deriving (Eq, Hashable, Generic, FromDhall)
2022-12-14 23:59:23 -05:00
deriving instance Eq Bucket
deriving instance Hashable Bucket
deriving instance Show Bucket
2022-12-11 17:51:11 -05:00
data TimeAmount = TimeAmount
{ taWhen :: !DatePat
, taAmt :: Amount Decimal
}
deriving (Eq, Hashable, Generic, FromDhall)
data Expense = Expense
{ expFrom :: !AcntID
, expTo :: !AcntID
, expBucket :: !Bucket
, expAmounts :: ![TimeAmount]
, expCurrency :: !CurID
}
deriving (Eq, Hashable, Generic, FromDhall)
--------------------------------------------------------------------------------
-- | Statements (data from the past)
data Statement = StmtManual Manual
| StmtImport Import
deriving (Generic, FromDhall)
2022-12-14 23:59:23 -05:00
deriving instance Hashable Manual
2022-12-11 17:51:11 -05:00
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 where
data Import = Import
{ impPaths :: ![FilePath]
, impMatches :: ![Match]
, impDelim :: !Word
, impTxOpts :: !TxOpts
, impSkipLines :: !Natural
}
deriving (Hashable, Generic, FromDhall)
2022-12-14 23:59:23 -05:00
deriving instance Eq MatchVal
deriving instance Hashable MatchVal
deriving instance Show MatchVal
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq MatchYMD
deriving instance Hashable MatchYMD
deriving instance Show MatchYMD
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
deriving instance Eq MatchDate
deriving instance Hashable MatchDate
deriving instance Show MatchDate
2022-12-11 17:51:11 -05:00
-- 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}
2022-12-11 17:51:11 -05:00
instance Ord MatchDate where
2022-12-14 23:59:23 -05:00
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
2022-12-11 17:51:11 -05:00
-- | 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)
type FieldMap k v = Field k (M.Map k v)
2022-12-14 23:59:23 -05:00
deriving instance Eq MatchDesc
deriving instance Show MatchDesc
deriving instance Hashable MatchDesc
2022-12-11 17:51:11 -05:00
data MatchOther = Desc (Field T.Text MatchDesc)
| Val (Field T.Text MatchVal)
deriving (Show, Eq, Hashable, Generic, FromDhall)
data ToTx = ToTx
{ ttCurrency :: !SplitCur
, ttPath :: !SplitAcnt
, ttSplit :: ![ExpSplit]
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
data Match = Match
{ mDate :: Maybe MatchDate
, mVal :: MatchVal
, mDesc :: Maybe MatchDesc
, mOther :: ![MatchOther]
, mTx :: Maybe ToTx
, mTimes :: Maybe Natural
, mPriority :: !Integer
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
2022-12-14 23:59:23 -05:00
deriving instance Eq TxOpts
deriving instance Hashable TxOpts
deriving instance Show TxOpts
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- | Specialized dhall types
2022-12-14 23:59:23 -05:00
deriving instance Eq Decimal
deriving instance Hashable Decimal
deriving instance Show Decimal
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- | 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
2022-12-14 23:59:23 -05:00
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
}
deriving (Show, Eq, Ord)
2022-12-11 17:51:11 -05:00
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 RawAmount = Amount (Maybe Rational)
type BalAmount = Amount Rational
type RawAllocation = Allocation (Maybe Rational)
type BalAllocation = Allocation Rational
type RawSplit = Split AcntID (Maybe Rational) CurID
type BalSplit = Split AcntID Rational CurID
type RawTx = Tx RawSplit
type BalTx = Tx BalSplit