pwncash/lib/Internal/Types.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Internal.Types where

-- import Control.Monad.Except
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 Database.Persist.TH
import Dhall hiding (embed, maybe)
import Dhall.TH
import Internal.TH (deriveProduct)
import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
import Text.Regex.TDFA

-------------------------------------------------------------------------------
-- DHALL CONFIG
-------------------------------------------------------------------------------

makeHaskellTypesWith
  (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = 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 "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
  , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
  , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
  , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
  , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
  , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
  , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
  , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
  , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
  , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
  , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
  , SingleConstructor "TemporalScope" "TemporalScope" "(./dhall/Types.dhall).TemporalScope"
  , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat"
  , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
  , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
  , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
  , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
  , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
  , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
  , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
  , -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type"
    SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
  , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
  , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
  , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
  , SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket"
  , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
  , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
  , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
  , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
  -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
  -- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_"
  -- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_"
  -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
  -- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
  ]

deriveProduct
  ["Eq", "Show", "Generic", "FromDhall"]
  [ "Currency"
  , "Tag"
  , "TimeUnit"
  , "Weekday"
  , "WeekdayPat"
  , "RepeatPat"
  , "MDYPat"
  , "Gregorian"
  , "GregorianM"
  , "Interval"
  , "ModPat"
  , "CronPat"
  , "DatePat"
  , "TaggedAcnt"
  , "Budget"
  , "Income"
  , "ShadowTransfer"
  , "TransferMatcher"
  , "AcntSet"
  , "DateMatcher"
  , "ValMatcher"
  , "YMDMatcher"
  , "BudgetCurrency"
  , "Exchange"
  , "EntryNumGetter"
  , "TemporalScope"
  , "SqlConfig"
  , "PretaxValue"
  , "TaxValue"
  , "TaxBracket"
  , "TaxProgression"
  , "TaxMethod"
  , "PosttaxValue"
  , "BudgetTransferValue"
  , "BudgetTransferType"
  ]

-------------------------------------------------------------------------------
-- lots of instances for dhall types

deriving instance Lift Currency

deriving instance Hashable Currency

deriving instance Lift Tag

deriving instance Hashable Tag

deriving instance Ord TimeUnit

deriving instance Hashable TimeUnit

deriving instance Ord Weekday

deriving instance Hashable Weekday

deriving instance Enum Weekday

deriving instance Ord WeekdayPat

deriving instance Hashable WeekdayPat

deriving instance Ord RepeatPat

deriving instance Hashable RepeatPat

deriving instance Ord MDYPat

deriving instance Hashable MDYPat

deriving instance Hashable Gregorian

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

deriving instance Ord ModPat

deriving instance Hashable ModPat

deriving instance Ord CronPat

deriving instance Hashable CronPat

deriving instance Ord DatePat

deriving instance Hashable DatePat

type BudgetTransfer =
  Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue

deriving instance Hashable BudgetTransfer

deriving instance Generic BudgetTransfer

deriving instance FromDhall BudgetTransfer

data Budget = Budget
  { bgtLabel :: Text
  , bgtIncomes :: [Income]
  , bgtPretax :: [MultiAllocation PretaxValue]
  , bgtTax :: [MultiAllocation TaxValue]
  , bgtPosttax :: [MultiAllocation PosttaxValue]
  , bgtTransfers :: [BudgetTransfer]
  , bgtShadowTransfers :: [ShadowTransfer]
  }

deriving instance Hashable PretaxValue

deriving instance Hashable TaxBracket

deriving instance Hashable TaxProgression

deriving instance Hashable TaxMethod

deriving instance Hashable TaxValue

deriving instance Hashable PosttaxValue

deriving instance Hashable Budget

deriving instance Hashable BudgetTransferValue

deriving instance Hashable BudgetTransferType

deriving instance Hashable TaggedAcnt

deriving instance Ord TaggedAcnt

type CurID = T.Text

data Income = Income
  { incGross :: Double
  , incCurrency :: CurID
  , incWhen :: DatePat
  , incPretax :: [SingleAllocation PretaxValue]
  , incTaxes :: [SingleAllocation TaxValue]
  , incPosttax :: [SingleAllocation PosttaxValue]
  , incFrom :: TaggedAcnt
  , incToBal :: TaggedAcnt
  }

deriving instance Hashable Income

deriving instance (Ord w, Ord v) => Ord (Amount w v)

deriving instance Generic (Amount w v)

deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v)

deriving instance (Hashable v, Hashable w) => Hashable (Amount w v)

-- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v)

deriving instance (Show w, Show v) => Show (Amount w v)

deriving instance (Eq w, Eq v) => Eq (Amount w v)

deriving instance Hashable Exchange

deriving instance Hashable BudgetCurrency

data Allocation w v = Allocation
  { alloTo :: TaggedAcnt
  , alloAmts :: [Amount w v]
  , alloCur :: CurID
  }
  deriving (Eq, Show, Generic, Hashable)

instance Bifunctor Amount where
  bimap f g a@Amount {amtWhen, amtValue} = a {amtWhen = f amtWhen, amtValue = g amtValue}

instance Bifunctor Allocation where
  bimap f g a@Allocation {alloAmts} = a {alloAmts = fmap (bimap f g) alloAmts}

deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Allocation w v)

type MultiAllocation = Allocation Interval

type SingleAllocation = Allocation ()

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

deriving instance Ord Interval

data Transfer a c w v = Transfer
  { transFrom :: a
  , transTo :: a
  , transAmounts :: [Amount w v]
  , transCurrency :: c
  }
  deriving (Eq, Show)

deriving instance Hashable ShadowTransfer

deriving instance Hashable AcntSet

deriving instance Hashable TransferMatcher

deriving instance Hashable ValMatcher

deriving instance Hashable YMDMatcher

deriving instance Hashable DateMatcher

-- TODO this just looks silly...but not sure how to simplify it
instance Ord YMDMatcher 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 DateMatcher 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 Hashable EntryNumGetter

-------------------------------------------------------------------------------
-- top level type with fixed account tree to unroll the recursion in the dhall
-- account tree type

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

data Config_ a = Config_
  { global :: !TemporalScope
  , budget :: ![Budget]
  , currencies :: ![Currency]
  , statements :: ![History]
  , accounts :: !a
  , tags :: ![Tag]
  , 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)

--------------------------------------------------------------------------------
-- dhall type overrides (since dhall can't import types with parameters...yet)

-- TODO newtypes for these?
type AcntID = T.Text

type TagID = T.Text

type HistTransfer = Transfer AcntID CurID DatePat Double

deriving instance Generic HistTransfer

deriving instance Hashable HistTransfer

deriving instance FromDhall HistTransfer

data History
  = HistTransfer !HistTransfer
  | HistStatement !Statement
  deriving (Eq, Generic, Hashable, FromDhall)

type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID

instance FromDhall EntryGetter

deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t)

deriving instance Generic (Entry a v c t)

deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t)

deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)

data Tx s = Tx
  { txDescr :: !T.Text
  , txDate :: !Day
  , txSplits :: ![s]
  }
  deriving (Generic)

type ExpTx = Tx EntryGetter

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 Statement = Statement
  { stmtPaths :: ![FilePath]
  , stmtParsers :: ![StatementParser T.Text]
  , stmtDelim :: !Word
  , stmtTxOpts :: !(TxOpts T.Text)
  , stmtSkipLines :: !Natural
  }
  deriving (Eq, Hashable, Generic, 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 EntryTextGetter 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 = EntryTextGetter CurID

type SplitAcnt = EntryTextGetter AcntID

deriving instance (Show k, Show v) => Show (Field k v)

deriving instance (Eq k, Eq v) => Eq (Field k v)

deriving instance Generic (Field k v)

deriving instance (Hashable k, Hashable v) => Hashable (Field k v)

deriving instance Foldable (Field k)

deriving instance Traversable (Field k)

deriving instance (FromDhall k, FromDhall v) => FromDhall (Field k v)

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 FieldMatcher re
  = Desc !(Field T.Text re)
  | Val !(Field T.Text ValMatcher)
  deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable)

deriving instance Show (FieldMatcher T.Text)

data TxGetter = TxGetter
  { tgCurrency :: !SplitCur
  , tgAcnt :: !SplitAcnt
  , tgEntries :: ![EntryGetter]
  }
  deriving (Eq, Generic, Hashable, Show, FromDhall)

data StatementParser re = StatementParser
  { spDate :: !(Maybe DateMatcher)
  , spVal :: !ValMatcher
  , spDesc :: !(Maybe re)
  , spOther :: ![FieldMatcher re]
  , spTx :: !(Maybe TxGetter)
  , spTimes :: !(Maybe Natural)
  , spPriority :: !Integer
  }
  deriving (Eq, Generic, Hashable, FromDhall, Functor)

deriving instance Show (StatementParser T.Text)

--------------------------------------------------------------------------------
-- DATABASE MODEL
--------------------------------------------------------------------------------

share
  [mkPersist sqlSettings, mkMigrate "migrateAll"]
  [persistLowerCase|
CommitR sql=commits
    hash Int
    type ConfigType
    deriving Show Eq
CurrencyR sql=currencies
    symbol T.Text
    fullname T.Text
    precision Int
    deriving Show Eq
TagR sql=tags
    symbol T.Text
    fullname T.Text
    deriving Show Eq
AccountR sql=accounts
    name T.Text
    fullpath T.Text
    desc T.Text
    deriving Show Eq
AccountPathR sql=account_paths
    parent AccountRId OnDeleteCascade
    child AccountRId OnDeleteCascade
    depth Int
    deriving Show Eq
TransactionR sql=transactions
    commit CommitRId OnDeleteCascade
    date Day
    description T.Text
    deriving Show Eq
SplitR sql=splits
    transaction TransactionRId OnDeleteCascade
    currency CurrencyRId OnDeleteCascade
    account AccountRId OnDeleteCascade
    memo T.Text
    value Rational
    deriving Show Eq
TagRelationR sql=tag_relations
    split SplitRId OnDeleteCascade
    tag TagRId OnDeleteCascade
BudgetLabelR sql=budget_labels
    split SplitRId OnDeleteCascade
    budgetName T.Text
    deriving Show Eq
|]

--------------------------------------------------------------------------------
-- database cache types

data ConfigHashes = ConfigHashes
  { chIncome :: ![Int]
  , chExpense :: ![Int]
  , chManual :: ![Int]
  , chImport :: ![Int]
  }

data ConfigType = CTBudget | 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"

type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)

type CurrencyMap = M.Map CurID (CurrencyRId, Natural)

type TagMap = M.Map TagID TagRId

data DBState = DBState
  { kmCurrency :: !CurrencyMap
  , kmAccount :: !AccountMap
  , kmTag :: !TagMap
  , kmBudgetInterval :: !Bounds
  , kmStatementInterval :: !Bounds
  , kmNewCommits :: ![Int]
  , kmConfigDir :: !FilePath
  }

type CurrencyM = Reader CurrencyMap

type MappingT m = ReaderT DBState (SqlPersistT m)

type KeySplit = Entry AccountRId Rational CurrencyRId TagRId

type KeyTx = Tx KeySplit

type TreeR = Tree ([T.Text], AccountRId)

type Balances = M.Map AccountRId Rational

type BalanceM m = ReaderT (MVar Balances) m

class MonadUnliftIO m => MonadFinance m where
  askDBState :: (DBState -> a) -> m a

instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where
  askDBState = asks

class MonadUnliftIO m => MonadBalance m where
  askBalances :: m (MVar Balances)

  withBalances :: (Balances -> m a) -> m a
  withBalances f = do
    bs <- askBalances
    withMVar bs f

  modifyBalances :: (Balances -> m (Balances, a)) -> m a
  modifyBalances f = do
    bs <- askBalances
    modifyMVar bs f

  lookupBalance :: AccountRId -> m Rational
  lookupBalance i = withBalances $ return . fromMaybe 0 . M.lookup i

  addBalance :: AccountRId -> Rational -> m ()
  addBalance i v =
    modifyBalances $ return . (,()) . M.alter (Just . maybe v (v +)) i

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

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 = Entry AcntID (Maybe Rational) CurID TagID

type BalSplit = Entry AcntID Rational CurID TagID

type RawTx = Tx RawSplit

type BalTx = Tx BalSplit

data MatchRes a = MatchPass !a | MatchFail | MatchSkip

--------------------------------------------------------------------------------
-- exception types

data BalanceType = TooFewSplits | NotOneBlank deriving (Show)

data MatchType = MatchNumeric | MatchText deriving (Show)

data SplitIDType = AcntField | CurField | TagField 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 !(NE.NonEmpty AcntType)
  | InsertIOError !T.Text
  | ParseError !T.Text
  | ConversionError !T.Text
  | LookupError !LookupSuberr !T.Text
  | BalanceError !BalanceType !CurID ![RawSplit]
  | IncomeError !Day !T.Text !Rational
  | 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]

-- type InsertExceptT m = ExceptT [InsertError] m

-- type InsertExcept = InsertExceptT Identity

data XGregorian = XGregorian
  { xgYear :: !Int
  , xgMonth :: !Int
  , xgDay :: !Int
  , xgDayOfWeek :: !Int
  }

type MatchRe = StatementParser (T.Text, Regex)

type TxOptsRe = TxOpts (T.Text, Regex)

type FieldMatcherRe = FieldMatcher (T.Text, Regex)

instance Show (StatementParser (T.Text, Regex)) where
  show = show . fmap fst