From 02747b4678dbed1c71caebc5c49be46ee7314d21 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 14:46:30 -0400 Subject: [PATCH] REF split up types module to keep compile times sane --- app/Main.hs | 2 +- budget.cabal | 6 +- lib/Internal/Config.hs | 12 +- lib/Internal/Database/Ops.hs | 2 +- lib/Internal/Insert.hs | 4 +- lib/Internal/Statement.hs | 2 +- lib/Internal/Types/Database.hs | 75 ++++++ lib/Internal/{Types.hs => Types/Dhall.hs} | 276 +--------------------- lib/Internal/Types/Main.hs | 226 ++++++++++++++++++ lib/Internal/{ => Types}/TH.hs | 3 +- lib/Internal/Utils.hs | 12 +- 11 files changed, 317 insertions(+), 303 deletions(-) create mode 100644 lib/Internal/Types/Database.hs rename lib/Internal/{Types.hs => Types/Dhall.hs} (69%) create mode 100644 lib/Internal/Types/Main.hs rename lib/Internal/{ => Types}/TH.hs (73%) diff --git a/app/Main.hs b/app/Main.hs index 8142e30..8710d96 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,7 +11,7 @@ import Database.Persist.Monad import Internal.Config import Internal.Database.Ops import Internal.Insert -import Internal.Types +import Internal.Types.Main import Internal.Utils import Options.Applicative import RIO diff --git a/budget.cabal b/budget.cabal index c3ae77e..e80aa97 100644 --- a/budget.cabal +++ b/budget.cabal @@ -29,8 +29,10 @@ library Internal.Database.Ops Internal.Insert Internal.Statement - Internal.TH - Internal.Types + Internal.Types.Database + Internal.Types.Dhall + Internal.Types.Main + Internal.Types.TH Internal.Utils other-modules: Paths_budget diff --git a/lib/Internal/Config.hs b/lib/Internal/Config.hs index 30a07c7..93df85b 100644 --- a/lib/Internal/Config.hs +++ b/lib/Internal/Config.hs @@ -1,21 +1,11 @@ module Internal.Config ( readConfig - -- , readYaml ) where --- import Control.Exception --- import Data.Yaml import Dhall hiding (record) -import Internal.Types +import Internal.Types.Main import RIO readConfig :: MonadUnliftIO m => FilePath -> m Config readConfig confpath = liftIO $ unfix <$> inputFile auto confpath - --- readYaml :: FromJSON a => FilePath -> IO a --- readYaml p = do --- r <- decodeFileEither p --- case r of --- Right a -> return a --- Left e -> throw e diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 182f6f0..0e6acef 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -29,7 +29,7 @@ import Database.Persist.Sqlite hiding , (||.) ) import GHC.Err -import Internal.Types +import Internal.Types.Main import Internal.Utils import RIO hiding (LogFunc, isNothing, on, (^.)) import RIO.List ((\\)) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 6f06a70..bf4a6f6 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -11,7 +11,7 @@ import Control.Monad.Except import Data.Hashable import Database.Persist.Monad import Internal.Statement -import Internal.Types +import Internal.Types.Main import Internal.Utils import RIO hiding (to) import qualified RIO.List as L @@ -222,7 +222,6 @@ fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, st then Nothing else Just $ - -- TODO does this actually share the same metadata as the "parent" tx? FlatTransfer { ftMeta = ftMeta tx , ftWhen = ftWhen tx @@ -391,6 +390,7 @@ workingDays wds start end daysFull = fromIntegral (length wds') * nFull daysTail = fromIntegral $ length $ takeWhile (< nPart) wds' in return $ fromIntegral $ daysFull + daysTail + -- TODO make an error here that says something to the effect of "Period must be positive" | otherwise = throwError $ InsertException undefined where interval = diffDays end start diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index e7a325e..cf09dcb 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -8,7 +8,7 @@ where import Control.Monad.Error.Class import Control.Monad.Except import Data.Csv -import Internal.Types +import Internal.Types.Main import Internal.Utils import RIO import qualified RIO.ByteString.Lazy as BL diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs new file mode 100644 index 0000000..9e82ca6 --- /dev/null +++ b/lib/Internal/Types/Database.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Types corresponding to the database model +module Internal.Types.Database where + +import Database.Persist.Sql hiding (Desc, In, Statement) +import Database.Persist.TH +import RIO +import qualified RIO.Text as T +import RIO.Time + +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 +|] + +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" diff --git a/lib/Internal/Types.hs b/lib/Internal/Types/Dhall.hs similarity index 69% rename from lib/Internal/Types.hs rename to lib/Internal/Types/Dhall.hs index ab12036..9a96a14 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types/Dhall.hs @@ -4,29 +4,24 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -module Internal.Types where +-- | Types corresponding to the configuration tree (written in Dhall) +module Internal.Types.Dhall 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 Internal.Types.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" @@ -528,270 +523,5 @@ data StatementParser re = StatementParser 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] - , kmOldCommits :: ![Int] - , kmConfigDir :: !FilePath - , kmTagAll :: ![Entity TagR] - , kmAcntPaths :: ![AccountPathR] - , kmAcntsOld :: ![Entity AccountR] - , kmCurrenciesOld :: ![Entity CurrencyR] - } - -type CurrencyM = Reader CurrencyMap - -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 = ReaderT (MVar Balances) - -type MonadFinance = MonadReader DBState - -askDBState :: MonadFinance m => (DBState -> a) -> m a -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] - | PeriodError !Day !Day - deriving (Show) - -newtype InsertException = InsertException [InsertError] - deriving (Show, Semigroup) via [InsertError] - -instance Exception InsertException - -type MonadInsertError = MonadError InsertException - -type InsertExceptT = ExceptT InsertException - -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 diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs new file mode 100644 index 0000000..94b354f --- /dev/null +++ b/lib/Internal/Types/Main.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Other types used throughout the program; kept in its own module to prevent +-- circular imports +module Internal.Types.Main + ( module Internal.Types.Main + , module Internal.Types.Dhall + , module Internal.Types.Database + ) +where + +import Control.Monad.Except +import Database.Persist.Sql hiding (Desc, In, Statement) +import Dhall hiding (embed, maybe) +import Internal.Types.Database +import Internal.Types.Dhall +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 + +-------------------------------------------------------------------------------- +-- database cache types + +data ConfigHashes = ConfigHashes + { chIncome :: ![Int] + , chExpense :: ![Int] + , chManual :: ![Int] + , chImport :: ![Int] + } + +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] + , kmOldCommits :: ![Int] + , kmConfigDir :: !FilePath + , kmTagAll :: ![Entity TagR] + , kmAcntPaths :: ![AccountPathR] + , kmAcntsOld :: ![Entity AccountR] + , kmCurrenciesOld :: ![Entity CurrencyR] + } + +type CurrencyM = Reader CurrencyMap + +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 = ReaderT (MVar Balances) + +type MonadFinance = MonadReader DBState + +askDBState :: MonadFinance m => (DBState -> a) -> m a +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) + +-- TODO pick a better name for this (something like DayInterval or something) +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] + | PeriodError !Day !Day + deriving (Show) + +newtype InsertException = InsertException [InsertError] + deriving (Show, Semigroup) via [InsertError] + +instance Exception InsertException + +type MonadInsertError = MonadError InsertException + +type InsertExceptT = ExceptT InsertException + +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) diff --git a/lib/Internal/TH.hs b/lib/Internal/Types/TH.hs similarity index 73% rename from lib/Internal/TH.hs rename to lib/Internal/Types/TH.hs index 51c0ce1..d9b0b26 100644 --- a/lib/Internal/TH.hs +++ b/lib/Internal/Types/TH.hs @@ -1,4 +1,5 @@ -module Internal.TH where +-- | Helper functions so I don't need to write lots of dhall instances +module Internal.Types.TH where import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName) import RIO diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index e5723f9..a1d268b 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -27,15 +27,6 @@ module Internal.Utils , combineErrorIOM3 , collectErrorsIO , mapErrorsIO - -- , leftToMaybe - -- , concatEithers2 - -- , concatEithers3 - -- , concatEither3 - -- , concatEither2 - -- , concatEitherL - -- , concatEithersL - -- , concatEither2M - -- , concatEithers2M , parseRational , showError , unlessLeft_ @@ -51,7 +42,6 @@ module Internal.Utils , sndOf3 , thdOf3 , xGregToDay - -- , plural , compileMatch , compileOptions , dateMatches @@ -66,7 +56,7 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Time.Format.ISO8601 import GHC.Real -import Internal.Types +import Internal.Types.Main import RIO import qualified RIO.List as L import qualified RIO.Map as M