pwncash/lib/Internal/Types.hs

{-# 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"
  , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch"
  , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
  ]

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

deriving instance Eq ShadowTransfer

deriving instance Hashable ShadowTransfer

deriving instance Eq ShadowMatch

deriving instance Hashable ShadowMatch

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