ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF split up types module to keep compile times sane

This commit is contained in:
Nathan Dwarshuis 2023-05-29 14:46:30 -04:00
parent 5dfbc3ef41
commit 02747b4678
11 changed files with 317 additions and 303 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/Main.hs
View File

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

6
budget.cabal
View File

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

12
lib/Internal/Config.hs
View File

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

2
lib/Internal/Database/Ops.hs
View File

@ -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 ((\\))

4
lib/Internal/Insert.hs
View File

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

2
lib/Internal/Statement.hs
View File

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

75
lib/Internal/Types/Database.hs Normal file
View File

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

276
lib/Internal/Types.hs → lib/Internal/Types/Dhall.hs
View File

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

226
lib/Internal/Types/Main.hs Normal file
View File

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

3
lib/Internal/TH.hs → lib/Internal/Types/TH.hs
View File

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

12
lib/Internal/Utils.hs
View File

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