pwncash/lib/Internal/Types.hs

{-# 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       #-}

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)
import           Dhall.TH

import           Language.Haskell.TH.Syntax (Lift)

import           Text.Read

-------------------------------------------------------------------------------
-- | YAML 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 "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"
  ]

-------------------------------------------------------------------------------
-- | 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 Hashable TimeUnit

deriving instance Eq Weekday
deriving instance Hashable Weekday

deriving instance Eq WeekdayPat
deriving instance Hashable WeekdayPat

deriving instance Show RepeatPat
deriving instance Eq RepeatPat
deriving instance Hashable RepeatPat

deriving instance Show MDYPat
deriving instance Eq 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 Hashable ModPat

deriving instance Eq CronPat
deriving instance Hashable CronPat

deriving instance Eq DatePat
deriving instance Hashable DatePat

--------------------------------------------------------------------------------
-- | 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)

deriving instance Eq Tax
deriving instance Hashable Tax

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)

deriving instance Eq Bucket
deriving instance Hashable Bucket
deriving instance Show Bucket

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)

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 where

data Import = Import
  { impPaths     :: ![FilePath]
  , impMatches   :: ![Match]
  , impDelim     :: !Word
  , impTxOpts    :: !TxOpts
  , impSkipLines :: !Natural
  }
  deriving (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)

type FieldMap k v = Field k (M.Map k v)

data MatchOther = Desc (Field T.Text T.Text)
  | 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 Text
  , mOther    :: ![MatchOther]
  , mTx       :: Maybe ToTx
  , mTimes    :: Maybe Natural
  , mPriority :: !Integer
  }
  deriving (Eq, Generic, Hashable, Show, FromDhall)

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
  }
  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 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