REF split up types module to keep compile times sane

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

budget.cabal

@@ -29,8 +29,10 @@ library
       Internal.Database.Ops
       Internal.Insert
       Internal.Statement
-      Internal.TH
+      Internal.Types.Database
-      Internal.Types
+      Internal.Types.Dhall
+      Internal.Types.Main
+      Internal.Types.TH
       Internal.Utils
   other-modules:
       Paths_budget

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

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

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

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

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"

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

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)

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

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