495 lines
13 KiB
Haskell
495 lines
13 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DeriveLift #-}
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# 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 Data.Yaml
|
|
|
|
import Database.Persist.Sql hiding (In, Statement)
|
|
|
|
import Dhall hiding (embed, maybe)
|
|
|
|
import Language.Haskell.TH.Syntax (Lift)
|
|
|
|
import Text.Read
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- | YAML CONFIG
|
|
-------------------------------------------------------------------------------
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- | 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
|
|
|
|
data Currency = Currency
|
|
{ curSymbol :: !CurID
|
|
, curFullname :: !T.Text
|
|
}
|
|
deriving (Eq, Lift, Generic, Hashable, FromDhall)
|
|
|
|
type CurID = T.Text
|
|
|
|
instance FromJSON Currency where
|
|
parseJSON = withObject "Currency" $ \o -> Currency
|
|
<$> o .: "symbol"
|
|
<*> o .: "desc"
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- | DHALL CONFIG
|
|
-------------------------------------------------------------------------------
|
|
|
|
data Config_ a = Config_
|
|
{ global :: !Global
|
|
, budget :: !Budget
|
|
, currencies :: ![Currency]
|
|
, statements :: ![Statement]
|
|
, accounts :: a
|
|
}
|
|
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)
|
|
|
|
data Global = Global
|
|
{ budgetInterval :: !Interval
|
|
, statementInterval :: !Interval
|
|
}
|
|
deriving (Generic, FromDhall)
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- | accounts
|
|
|
|
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)
|
|
|
|
type AcntID = T.Text
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Time Patterns (for assigning when budget events will happen)
|
|
|
|
data Interval = Interval
|
|
{ intStart :: Maybe Gregorian
|
|
, intEnd :: Maybe Gregorian
|
|
}
|
|
deriving (Generic, FromDhall)
|
|
|
|
data TimeUnit = Day | Week | Month | Year
|
|
deriving (Eq, Hashable, Generic, FromDhall)
|
|
|
|
data WeekdayPat = OnDay !DayOfWeek | OnDays ![DayOfWeek]
|
|
deriving (Eq, Generic, FromDhall)
|
|
|
|
instance Hashable WeekdayPat where
|
|
hashWithSalt s (OnDay d) = s `hashWithSalt` ("WPDay" :: T.Text)
|
|
`hashWithSalt` fromEnum d
|
|
hashWithSalt s (OnDays ds) = s `hashWithSalt` ("WPDays" :: T.Text)
|
|
`hashWithSalt` fromEnum <$> ds
|
|
|
|
data RepeatPat = RepeatPat
|
|
{ rpStart :: !Natural
|
|
, rpBy :: !Natural
|
|
, rpRepeats :: Maybe Natural
|
|
}
|
|
deriving (Eq, Hashable, Generic, FromDhall)
|
|
|
|
data MDYPat = Single !Natural
|
|
| Multi ![Natural]
|
|
| Repeat !RepeatPat
|
|
deriving (Eq, Hashable, Generic, FromDhall)
|
|
|
|
data Gregorian = Gregorian
|
|
{ gYear :: !Natural
|
|
, gMonth :: !Natural
|
|
, gDay :: !Natural
|
|
}
|
|
deriving (Show, Ord, Eq, Hashable, Generic, FromDhall)
|
|
|
|
data GregorianM = GregorianM
|
|
{ gmYear :: !Natural
|
|
, gmMonth :: !Natural
|
|
}
|
|
deriving (Show, Ord, Eq, Hashable, Generic, FromDhall)
|
|
|
|
data ModPat = ModPat
|
|
{ mpStart :: Maybe Gregorian
|
|
, mpBy :: !Natural
|
|
, mpUnit :: !TimeUnit
|
|
, mpRepeats :: Maybe Natural
|
|
}
|
|
deriving (Eq, Hashable, Generic, FromDhall)
|
|
|
|
data CronPat = CronPat
|
|
{ cronWeekly :: Maybe WeekdayPat
|
|
, cronYear :: Maybe MDYPat
|
|
, cronMonth :: Maybe MDYPat
|
|
, cronDay :: Maybe MDYPat
|
|
}
|
|
deriving (Eq, Hashable, Generic, FromDhall)
|
|
|
|
data DatePat = Cron !CronPat | Mod !ModPat
|
|
deriving (Eq, Hashable, Generic, FromDhall)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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)
|
|
|
|
data Tax = Tax
|
|
{ taxAcnt :: !AcntID
|
|
, taxValue :: !Decimal
|
|
}
|
|
deriving (Eq, Hashable, Generic, FromDhall)
|
|
|
|
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)
|
|
|
|
data Bucket = Fixed | Investment | Savings | Guiltless
|
|
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
|
|
|
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)
|
|
|
|
data Manual = Manual
|
|
{ manualDate :: !DatePat
|
|
, manualFrom :: !AcntID
|
|
, manualTo :: !AcntID
|
|
, manualValue :: !Decimal
|
|
, manualDesc :: !T.Text
|
|
, manualCurrency :: !CurID
|
|
}
|
|
deriving (Hashable, Generic, FromDhall)
|
|
|
|
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)
|
|
|
|
data MatchVal = MatchVal
|
|
{ mvSign :: Maybe Bool
|
|
, mvNum :: Maybe Natural
|
|
, mvDen :: Maybe Natural
|
|
, mvPrec :: !Natural
|
|
}
|
|
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
|
|
|
data MatchYMD = Y !Natural | YM !GregorianM | YMD !Gregorian
|
|
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
|
|
|
data Range a = Range
|
|
{ rStart :: !a
|
|
, rLen :: !Natural
|
|
}
|
|
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
|
|
|
data MatchDate = On !MatchYMD | In (Range MatchYMD)
|
|
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
|
|
|
-- 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 (GregorianM y m)) (YMD (Gregorian y' m' _)) = compare (y, m) (y', m') <> LT
|
|
compare (YMD (Gregorian y m _)) (YM (GregorianM y' m')) = compare (y, m) (y', m') <> GT
|
|
|
|
instance Ord MatchDate where
|
|
compare (On d) (On d') = compare d d'
|
|
compare (In (Range d r)) (In (Range d' r')) = compare d d' <> compare r r'
|
|
compare (On d) (In (Range d' _)) = compare d d' <> LT
|
|
compare (In (Range d _)) (On d') = compare d d' <> GT
|
|
|
|
data SplitNum = LookupN !T.Text
|
|
| ConstN !Decimal
|
|
| AmountN
|
|
deriving (Eq, Generic, Hashable, Show, 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)
|
|
|
|
type FieldMap k v = Field k (M.Map k v)
|
|
|
|
data MatchDesc = Re !T.Text | Exact !T.Text
|
|
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
|
|
|
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)
|
|
|
|
data TxRecord = TxRecord
|
|
{ trDate :: !Day
|
|
, trAmount :: !Rational
|
|
, trDesc :: !T.Text
|
|
, trOther :: M.Map T.Text T.Text
|
|
}
|
|
deriving (Show, Eq, Ord)
|
|
|
|
data TxOpts = TxOpts
|
|
{ toDate :: !T.Text
|
|
, toAmount :: !T.Text
|
|
, toDesc :: !T.Text
|
|
, toOther :: ![T.Text]
|
|
, toDateFmt :: !String
|
|
, toAmountFmt :: !T.Text
|
|
}
|
|
deriving (Show, Eq, Hashable, Generic, FromDhall)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Specialized dhall types
|
|
|
|
-- | hacky way to encode a rational
|
|
data Decimal = D
|
|
{ whole :: Natural
|
|
, decimal :: Natural
|
|
, precision :: Natural
|
|
, sign :: Bool
|
|
}
|
|
deriving (Generic, FromDhall, Hashable, Show, Eq)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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
|
|
|
|
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
|