ENH use rio modules everywhere and use recommended flags

app/Main.hs

@@ -2,24 +2,22 @@
 
 module Main (main) where
 
-import qualified Data.Text                  as T
-
 import Internal.Config
 import Internal.Database.Ops
 import Internal.Insert
 import Internal.Types
 import Internal.Utils
-
-import           Control.Monad.Trans.Reader
-
 import Options.Applicative
-
+import RIO
-import           System.FilePath
+import RIO.FilePath
+import qualified RIO.Text as T
 
 main :: IO ()
 main = parse =<< execParser o
   where
-    o = info (options <**> helper)
+    o =
+      info
+        (options <**> helper)
         ( fullDesc
             <> progDesc "Pwn your budget"
             <> header "pwncash - your budget, your life"
@@ -27,14 +25,16 @@ main = parse =<< execParser o
 
 data Options = Options FilePath Mode
 
-data Mode = Reset
+data Mode
+  = Reset
   | DumpCurrencies
   | DumpAccounts
   | DumpAccountKeys
   | Sync
 
 configFile :: Parser FilePath
-configFile = strOption
+configFile =
+  strOption
     ( long "config"
         <> short 'c'
         <> metavar "CONFIG"
@@ -43,7 +43,8 @@ configFile = strOption
     )
 
 options :: Parser Options
-options = getConf reset
+options =
+  getConf reset
     <|> getConf dumpCurrencies
     <|> getConf dumpAccounts
     <|> getConf dumpAccountKeys
@@ -52,21 +53,27 @@ options = getConf reset
     getConf m = Options <$> configFile <*> m
 
 reset :: Parser Mode
-reset = flag' Reset
+reset =
+  flag'
+    Reset
     ( long "reset"
         <> short 'R'
         <> help "Reset the database"
     )
 
 dumpCurrencies :: Parser Mode
-dumpCurrencies = flag' DumpCurrencies
+dumpCurrencies =
+  flag'
+    DumpCurrencies
     ( long "currencies"
         <> short 'C'
         <> help "Dump all currencies in the configuration"
     )
 
 dumpAccounts :: Parser Mode
-dumpAccounts = flag' DumpAccounts
+dumpAccounts =
+  flag'
+    DumpAccounts
     ( long "accounts"
         <> short 'A'
         <> help "Dump all accounts in the configuration"
@@ -74,14 +81,18 @@ dumpAccounts = flag' DumpAccounts
 
 -- TODO 'alias' is a better name for these
 dumpAccountKeys :: Parser Mode
-dumpAccountKeys = flag' DumpAccountKeys
+dumpAccountKeys =
+  flag'
+    DumpAccountKeys
     ( long "account_keys"
         <> short 'K'
         <> help "Dump all account keys/aliases"
     )
 
 sync :: Parser Mode
-sync = flag' Sync
+sync =
+  flag'
+    Sync
     ( long "sync"
         <> short 'S'
         <> help "Sync config to database"
@@ -109,7 +120,8 @@ runDumpAccounts c = do
   ar <- accounts <$> readConfig c
   mapM_ (\(h, f) -> printTree h $ f ar) ps
   where
-    ps = [ ("Assets", arAssets)
+    ps =
+      [ ("Assets", arAssets)
       , ("Equity", arEquity)
       , ("Expenses", arExpenses)
       , ("Income", arIncome)
@@ -129,10 +141,11 @@ runDumpAccounts c = do
 runDumpAccountKeys :: FilePath -> IO ()
 runDumpAccountKeys c = do
   ar <- accounts <$> readConfig c
-  let ks = paths2IDs
+  let ks =
-        $ fmap (double . fst)
+        paths2IDs $
-        $ concatMap (t3 . uncurry tree2Records)
+          fmap (double . fst) $
-        $ flattenAcntRoot ar
+            concatMap (t3 . uncurry tree2Records) $
+              flattenAcntRoot ar
   mapM_ (uncurry printPair) ks
   where
     printPair i p = do

budget.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.0.
+-- This file has been generated from package.yaml by hpack version 0.35.1.
 --
 -- see: https://github.com/sol/hpack
 
@@ -26,20 +26,19 @@ source-repository head
 library
   exposed-modules:
       Internal.Config
-      Internal.Types
-      Internal.Utils
-      Internal.Database.Ops
       Internal.Database.Model
+      Internal.Database.Ops
       Internal.Insert
       Internal.Statement
+      Internal.Types
+      Internal.Utils
   other-modules:
       Paths_budget
   hs-source-dirs:
       lib/
-  ghc-options: -Wall -Werror -threaded -Wpartial-fields
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
   build-depends:
       base >=4.12 && <10
-    , bytestring
     , cassava
     , conduit >=1.3.4.2
     , containers >=0.6.4.1
@@ -56,13 +55,10 @@ library
     , persistent-sqlite >=2.13.1.0
     , recursion-schemes
     , regex-tdfa
+    , rio >=0.1.21.0
     , template-haskell
     , text >=1.2.5.0
     , time >=1.9.3
-    , transformers
-    , utf8-string
-    , vector
-    , yaml
   default-language: Haskell2010
 
 executable pwncash
@@ -71,11 +67,10 @@ executable pwncash
       Paths_budget
   hs-source-dirs:
       app
-  ghc-options: -Wall -Werror -threaded -Wpartial-fields -O2
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
   build-depends:
       base >=4.12 && <10
     , budget
-    , bytestring
     , cassava
     , conduit >=1.3.4.2
     , containers >=0.6.4.1
@@ -92,11 +87,8 @@ executable pwncash
     , persistent-sqlite >=2.13.1.0
     , recursion-schemes
     , regex-tdfa
+    , rio >=0.1.21.0
     , template-haskell
     , text >=1.2.5.0
     , time >=1.9.3
-    , transformers
-    , utf8-string
-    , vector
-    , yaml
   default-language: Haskell2010

lib/Internal/Config.hs

@@ -1,76 +1,21 @@
 module Internal.Config
   ( readConfig
-  , readYaml
+  -- , readYaml
-  ) where
+  )
-
+where
-import           Control.Exception
--- import           Control.Lens
-
--- import           Data.Maybe
--- import qualified Data.Text         as T
--- import           Data.Typeable
--- import           Data.Void
-import           Data.Yaml
 
+-- import Control.Exception
+-- import Data.Yaml
 import Dhall hiding (record)
--- import qualified Dhall.Core        as DC
--- import qualified Dhall.Map         as DM
--- import           Dhall.Src
-
 import Internal.Types
 
 readConfig :: FilePath -> IO Config
 readConfig confpath = do
-  -- let subs = DM.fromList typeSubs
-  -- let settings = over substitutions (DM.union subs) defaultEvaluateSettings
-  -- unfix <$> inputFileWithSettings settings auto confpath
   unfix <$> inputFile auto confpath
 
--- typeSubs :: [(T.Text, DC.Expr Src Void)]
+-- readYaml :: FromJSON a => FilePath -> IO a
--- typeSubs = firstOrder ++ higherOrder
+-- readYaml p = do
---   where
+--   r <- decodeFileEither p
---     toVar a = fmap (\n -> (T.pack $ show n, maximum $ expected a))
+--   case r of
---       $ listToMaybe $ snd $ splitTyConApp $ typeOf a
+--     Right a -> return a
---     higherOrder =
+--     Left e -> throw e
---       [ ("ExpSplit", maximum $ expected (auto :: Decoder ExpSplit))
---       , ("ExpTx", maximum $ expected (auto :: Decoder ExpTx))
---       , ("SplitCur", maximum $ expected (auto :: Decoder SplitCur))
---       , ("SplitAcnt", maximum $ expected (auto :: Decoder SplitAcnt))
---       , ("CurID", maximum $ expected (auto :: Decoder CurID))
---       , ("AcntID", maximum $ expected (auto :: Decoder AcntID))
---       ]
---     firstOrder = catMaybes
---       [ toVar (auto :: Decoder TimeUnit)
---       , toVar (auto :: Decoder WeekdayPat)
---       , toVar (auto :: Decoder MDYPat)
---       , toVar (auto :: Decoder Gregorian)
---       , toVar (auto :: Decoder GregorianM)
---       , toVar (auto :: Decoder ModPat)
---       , toVar (auto :: Decoder CronPat)
---       , toVar (auto :: Decoder DatePat)
---       , toVar (auto :: Decoder Income)
---       , toVar (auto :: Decoder Tax)
---       , toVar (auto :: Decoder Bucket)
---       , toVar (auto :: Decoder TimeAmount)
---       , toVar (auto :: Decoder Expense)
---       , toVar (auto :: Decoder Decimal)
---       , toVar (auto :: Decoder Statement)
---       , toVar (auto :: Decoder Manual)
---       , toVar (auto :: Decoder TxOpts)
---       , toVar (auto :: Decoder ToTx)
---       , toVar (auto :: Decoder Match)
---       , toVar (auto :: Decoder MatchYMD)
---       , toVar (auto :: Decoder MatchVal)
---       , toVar (auto :: Decoder MatchDate)
---       , toVar (auto :: Decoder SplitNum)
---       , toVar (auto :: Decoder MatchDesc)
---       , toVar (auto :: Decoder MatchOther)
---       , toVar (auto :: Decoder SqlConfig)
---       ]
-
-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/Model.hs

@@ -17,18 +17,17 @@
 
 module Internal.Database.Model where
 
-import           Control.Monad.Trans.Reader
-
-import qualified Data.Map                        as M
-import qualified Data.Text                       as T
-import           Data.Time
-
 import Database.Esqueleto.Experimental
 import Database.Persist.TH
-
 import Internal.Types
+import RIO
+import qualified RIO.Map as M
+import qualified RIO.Text as T
+import RIO.Time
 
-share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+share
+  [mkPersist sqlSettings, mkMigrate "migrateAll"]
+  [persistLowerCase|
 CommitR sql=commits
     hash Int
     type ConfigType

lib/Internal/Database/Ops.hs

@@ -14,34 +14,32 @@ module Internal.Database.Ops
   , tree2Records
   , flattenAcntRoot
   , paths2IDs
-
+  )
-  ) where
+where
-
-import           Control.Monad.Logger
-import           Control.Monad.Trans.Reader
 
 import Conduit
-
+import Control.Monad.Logger
-import           Data.Bifunctor
-import           Data.Either
 import Data.Hashable
-import           Data.List                       ((\\))
-import qualified Data.List                       as L
-import qualified Data.Map                        as M
-import qualified Data.Text                       as T
-
 import Database.Esqueleto.Experimental
 import Database.Persist.Sql hiding (delete, (==.), (||.))
 import Database.Persist.Sqlite hiding (delete, (==.), (||.))
 import Database.Sqlite hiding (Config)
-
 import Internal.Database.Model
 import Internal.Types
 import Internal.Utils
+import RIO hiding (LogFunc, isNothing, on, (^.))
+import RIO.List ((\\))
+import qualified RIO.List as L
+import qualified RIO.Map as M
+import qualified RIO.Text as T
 
 migrate_ :: SqlConfig -> SqlPersistT (ResourceT (NoLoggingT IO)) () -> IO ()
-migrate_ c more = runNoLoggingT $ runResourceT
+migrate_ c more =
-          $ withSqlConn (openConnection c) (\backend ->
+  runNoLoggingT $
+    runResourceT $
+      withSqlConn
+        (openConnection c)
+        ( \backend ->
             flip runSqlConn backend $ do
               runMigration migrateAll
               more
@@ -65,7 +63,8 @@ showBalances :: MonadIO m => SqlPersistT m ()
 showBalances = do
   xs <- select $ do
     (accounts :& splits :& txs) <-
-      from $ table @AccountR
+      from
+        $ table @AccountR
           `innerJoin` table @SplitR
         `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount)
           `innerJoin` table @TransactionR
@@ -73,11 +72,14 @@ showBalances = do
     where_ $
       isNothing (txs ^. TransactionRBucket)
         &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%))
-           ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%)))
+                ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))
+            )
     groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName)
-    return ( accounts ^. AccountRFullpath
+    return
+      ( accounts ^. AccountRFullpath
       , accounts ^. AccountRName
-           , sum_ $ splits ^. SplitRValue)
+      , sum_ $ splits ^. SplitRValue
+      )
   -- TODO super stetchy table printing thingy
   liftIO $ do
     putStrLn $ T.unpack $ fmt "Account" "Balance"
@@ -91,8 +93,11 @@ showBalances = do
     toBal = maybe "???" (fmtRational 2) . unValue
 
 hashConfig :: Config -> [Int]
-hashConfig Config_ { budget = Budget { expenses = xs, income = is }
+hashConfig
-                  , statements = ss } =
+  Config_
+    { budget = Budget {expenses = xs, income = is}
+    , statements = ss
+    } =
     (hash <$> xs) ++ (hash <$> is) ++ (hash <$> ms) ++ (hash <$> ps)
     where
       (ms, ps) = partitionEithers $ fmap go ss
@@ -168,8 +173,10 @@ updateAccounts ar = do
   mapM_ insert paths
   return acntMap
 
-insertFull :: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b)
+insertFull
-  => Entity r -> ReaderT b m ()
+  :: (MonadIO m, PersistStoreWrite b, PersistRecordBackend r b)
+  => Entity r
+  -> ReaderT b m ()
 insertFull (Entity k v) = insertKey k v
 
 updateCurrencies :: MonadIO m => [Currency] -> SqlPersistT m CurrencyMap
@@ -191,20 +198,22 @@ toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash
 
 tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
-tree2Entity t parents name des = Entity (toSqlKey $ fromIntegral h)
+tree2Entity t parents name des =
-  $ AccountR name (toPath parents) des
+  Entity (toSqlKey $ fromIntegral h) $
+    AccountR name (toPath parents) des
   where
     p = AcntPath t (reverse (name : parents))
     h = hash p
     toPath = T.intercalate "/" . (atName t :) . reverse
 
-tree2Records :: AcntType -> AccountTree
+tree2Records
+  :: AcntType
+  -> AccountTree
   -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign))])
 tree2Records t = go []
   where
     go ps (Placeholder d n cs) =
-      let
+      let e = tree2Entity t (fmap snd ps) n d
-          e = tree2Entity t (fmap snd ps) n d
           k = entityKey e
           (as, aps, ms) = unzip3 $ fmap (go ((k, n) : ps)) cs
           a0 = acnt k n (fmap snd ps) d
@@ -223,7 +232,8 @@ tree2Records t = go []
     sign = accountSign t
 
 paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
-paths2IDs = uncurry zip
+paths2IDs =
+  uncurry zip
     . first trimNames
     . unzip
     . L.sortOn fst
@@ -261,9 +271,15 @@ trimNames = fmap fmt . trimAll 0
 xs !? n
   | n < 0 = Nothing
   -- Definition adapted from GHC.List
-  | otherwise = foldr (\x r k -> case k of
+  | otherwise =
+      foldr
+        ( \x r k -> case k of
             0 -> Just x
-                                   _ -> r (k-1)) (const Nothing) xs n
+            _ -> r (k - 1)
+        )
+        (const Nothing)
+        xs
+        n
 
 flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
 flattenAcntRoot AccountRoot_ {..} =
@@ -289,7 +305,8 @@ getDBState c = do
   hs <- updateHashes c
   -- TODO not sure how I feel about this, probably will change this struct alot
   -- in the future so whatever...for now
-  return $ \f -> DBState
+  return $ \f ->
+    DBState
       { kmCurrency = cm
       , kmAccount = am
       , kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c

lib/Internal/Insert.hs

@@ -5,35 +5,28 @@
 module Internal.Insert
   ( insertStatements
   , insertBudget
-  ) where
+  )
+where
 
-import           Control.Monad
-import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Class
-import           Control.Monad.Trans.Reader
-
-import           Data.Either
 import Data.Hashable
-import qualified Data.Map                   as M
-import           Data.Maybe
-import qualified Data.Text                  as T
-import           Data.Time
-
 import Database.Persist.Class
 import Database.Persist.Sql hiding (Single, Statement)
-
 import Internal.Database.Model
 import Internal.Statement
 import Internal.Types hiding (sign)
 import Internal.Utils
+import RIO hiding (to)
+import qualified RIO.Map as M
+import qualified RIO.Text as T
+import RIO.Time
 
-import           Numeric.Natural
+lookupKey :: (Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v)
-
-lookupKey :: (Show v, Ord k, Show k, MonadIO m) => M.Map k v -> k -> m (Maybe v)
 lookupKey m k = do
   let v = M.lookup k m
   when (isNothing v) $
-    liftIO $ putStrLn $ "key does not exist: " ++ show k
+    liftIO $
+      putStrLn $
+        "key does not exist: " ++ show k
   return v
 
 lookupAccount :: MonadIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign))
@@ -60,13 +53,16 @@ expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a..b]
 expandDatePat i (Mod mp) = expandModPat mp i
 
 expandModPat :: ModPat -> Bounds -> [Day]
-expandModPat ModPat { mpStart = s
+expandModPat
+  ModPat
+    { mpStart = s
     , mpBy = b
     , mpUnit = u
     , mpRepeats = r
-                    } (lower, upper) =
+    }
-  takeWhile (<= upper)
+  (lower, upper) =
-  $ (`addFun` start) . (* b')
+    takeWhile (<= upper) $
+      (`addFun` start) . (* b')
         <$> maybe id (take . fromIntegral) r [0 ..]
     where
       start = maybe lower fromGregorian' s
@@ -80,11 +76,14 @@ expandModPat ModPat { mpStart = s
 -- TODO this can be optimized to prevent filtering a bunch of dates for
 -- one/a few cron patterns
 cronPatternMatches :: CronPat -> Day -> Bool
-cronPatternMatches CronPat { cronWeekly = w
+cronPatternMatches
+  CronPat
+    { cronWeekly = w
     , cronYear = y
     , cronMonth = m
     , cronDay = d
-                           } x =
+    }
+  x =
     yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
     where
       testMaybe = maybe True
@@ -113,8 +112,8 @@ mdyPatternMatches check x p = case p of
   Single y -> errMaybe (check y) $ x == y
   Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs
   Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) ->
-    errMaybe (check s)
+    errMaybe (check s) $
-    $ s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
+      s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
   where
     errMaybe test rest = maybe rest err test
     err msg = error $ show p ++ ": " ++ msg
@@ -128,8 +127,13 @@ insertBudget Budget { income = is, expenses = es } = do
   mapM_ insertExpense es
 
 -- TODO this hashes twice (not that it really matters)
-whenHash :: Hashable a => MonadIO m => ConfigType -> a
+whenHash
-  -> (Key CommitR -> MappingT m ()) -> MappingT m ()
+  :: Hashable a
+  => MonadIO m
+  => ConfigType
+  -> a
+  -> (Key CommitR -> MappingT m ())
+  -> MappingT m ()
 whenHash t o f = do
   let h = hash o
   hs <- asks kmNewCommits
@@ -137,7 +141,9 @@ whenHash t o f = do
     f =<< lift (insert $ CommitR h t)
 
 insertIncome :: MonadIO m => Income -> MappingT m ()
-insertIncome i@Income { incCurrency = cur
+insertIncome
+  i@Income
+    { incCurrency = cur
     , incWhen = dp
     , incAccount = from
     , incTaxes = ts
@@ -153,7 +159,9 @@ insertIncome i@Income { incCurrency = cur
             lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
 
 balanceIncome :: Income -> Either T.Text [BalAllocation]
-balanceIncome Income { incGross = g
+balanceIncome
+  Income
+    { incGross = g
     , incPretax = pre
     , incTaxes = tax
     , incPosttax = post
@@ -177,8 +185,8 @@ balancePostTax bal as
   | null as = Left "no allocations to balance"
   | otherwise = case partitionEithers $ fmap hasVal as of
       ([([empty], nonmissing)], bs) ->
-        let s = bal - sumAllocations (nonmissing:bs) in
+        let s = bal - sumAllocations (nonmissing : bs)
-        if s < 0
+         in if s < 0
               then Left "allocations exceed total"
               else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs
       ([], _) -> Left "need one blank amount to balance"
@@ -195,9 +203,17 @@ balancePostTax bal as
 mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b
 mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs}
 
-allocationToTx :: MonadIO m => AcntID -> Day -> BalAllocation
+allocationToTx
+  :: MonadIO m
+  => AcntID
+  -> Day
+  -> BalAllocation
   -> MappingT m [(KeyTx, Bucket)]
-allocationToTx from day Allocation { alloPath = to
+allocationToTx
+  from
+  day
+  Allocation
+    { alloPath = to
     , alloBucket = b
     , alloCurrency = cur
     , alloAmts = as
@@ -208,13 +224,21 @@ taxToTx :: MonadIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx
 taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
   txPair day from to cur (dec2Rat v) ""
 
-transferToTx :: MonadIO m => Day -> AcntID -> AcntID -> T.Text -> BalAmount
+transferToTx
+  :: MonadIO m
+  => Day
+  -> AcntID
+  -> AcntID
+  -> T.Text
+  -> BalAmount
   -> MappingT m KeyTx
 transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
   txPair day from to cur v d
 
 insertExpense :: MonadIO m => Expense -> MappingT m ()
-insertExpense e@Expense { expFrom = from
+insertExpense
+  e@Expense
+    { expFrom = from
     , expTo = to
     , expCurrency = cur
     , expBucket = buc
@@ -224,12 +248,25 @@ insertExpense e@Expense { expFrom = from
       ts <- concat <$> mapM (timeAmountToTx from to cur) as
       lift $ mapM_ (insertTxBucket (Just buc) c) ts
 
-timeAmountToTx :: MonadIO m => AcntID -> AcntID -> T.Text -> TimeAmount
+timeAmountToTx
+  :: MonadIO m
+  => AcntID
+  -> AcntID
+  -> T.Text
+  -> TimeAmount
   -> MappingT m [KeyTx]
-timeAmountToTx from to cur TimeAmount { taWhen = dp
+timeAmountToTx
-                                      , taAmt = Amount { amtValue = v
+  from
+  to
+  cur
+  TimeAmount
+    { taWhen = dp
+    , taAmt =
+      Amount
+        { amtValue = v
         , amtDesc = d
-                                                       } } = do
+        }
+    } = do
     bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
     mapM tx $ expandDatePat bounds dp
     where
@@ -246,7 +283,9 @@ insertStatement (StmtManual m) = insertManual m
 insertStatement (StmtImport i) = insertImport i
 
 insertManual :: MonadIO m => Manual -> MappingT m ()
-insertManual m@Manual { manualDate = dp
+insertManual
+  m@Manual
+    { manualDate = dp
     , manualFrom = from
     , manualTo = to
     , manualValue = v
@@ -272,12 +311,21 @@ insertImport i = whenHash CTImport i $ \c -> do
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
-txPair :: MonadIO m => Day -> AcntID -> AcntID -> T.Text -> Rational -> T.Text
+txPair
+  :: MonadIO m
+  => Day
+  -> AcntID
+  -> AcntID
+  -> T.Text
+  -> Rational
+  -> T.Text
   -> MappingT m KeyTx
 txPair day from to cur val desc = resolveTx tx
   where
     split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
-    tx = Tx { txDescr = desc
+    tx =
+      Tx
+        { txDescr = desc
         , txDate = day
         , txTags = []
         , txSplits = [split from (-val), split to val]
@@ -296,8 +344,10 @@ resolveSplit s@Split { sAcnt = p, sCurrency = c, sValue = v } = do
   -- TODO correct sign here?
   -- TODO lenses would be nice here
   return $ case (aid, cid, sign) of
-    (Just aid', Just cid', Just sign')
+    (Just aid', Just cid', Just sign') ->
-      -> Just $ s { sAcnt = aid'
+      Just $
+        s
+          { sAcnt = aid'
           , sCurrency = cid'
           , sValue = v * fromIntegral (sign2Int sign')
           }

lib/Internal/Statement.hs

@@ -3,38 +3,29 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TupleSections #-}
 
-module Internal.Statement
+module Internal.Statement (
-  ( readImport
+    readImport,
 ) where
 
-import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Reader
-
-import           Data.Bifunctor
-import qualified Data.ByteString.Lazy       as BL
 import Data.Csv
-import           Data.Either
-import qualified Data.List                  as L
-import qualified Data.Map                   as M
-import           Data.Maybe
-import           Data.Ord
-import qualified Data.Text                  as T
-import qualified Data.Text.Encoding         as TE
-import           Data.Time
-import qualified Data.Vector                as V
-
 import Internal.Database.Model
 import Internal.Types
 import Internal.Utils
-
+import RIO
-import           Numeric.Natural
+import qualified RIO.ByteString.Lazy as BL
-
+import RIO.FilePath
-import           System.FilePath
+import qualified RIO.List as L
+import qualified RIO.Map as M
+import qualified RIO.Text as T
+import RIO.Time
+import qualified RIO.Vector as V
 
 -- TODO this probably won't scale well (pipes?)
 
 readImport :: MonadIO m => Import -> MappingT m [BalTx]
-readImport Import { impPaths = ps
+readImport
+    Import
+        { impPaths = ps
         , impMatches = ms
         , impTxOpts = ns
         , impDelim = d
@@ -46,8 +37,13 @@ readImport Import { impPaths = ps
         liftIO $ mapM_ print notfound
         return ts
 
-readImport_ :: MonadIO m => Natural -> Word -> TxOpts -> FilePath
+readImport_ ::
-  -> MappingT m [TxRecord]
+    MonadIO m =>
+    Natural ->
+    Word ->
+    TxOpts ->
+    FilePath ->
+    MappingT m [TxRecord]
 readImport_ n delim tns p = do
     dir <- asks kmConfigDir
     bs <- liftIO $ BL.readFile $ dir </> p
@@ -62,43 +58,48 @@ readImport_ n delim tns p = do
 -- blank dates but will likely want to make this more flexible
 parseTxRecord :: TxOpts -> NamedRecord -> Parser (Maybe TxRecord)
 parseTxRecord TxOpts{..} r = do
-  d <- r .: TE.encodeUtf8 toDate
+    d <- r .: T.encodeUtf8 toDate
     if d == ""
         then return Nothing
         else do
-    a <- parseRational toAmountFmt =<< r .: TE.encodeUtf8 toAmount
+            a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
-    e <- r .: TE.encodeUtf8 toDesc
+            e <- r .: T.encodeUtf8 toDesc
-    os <- M.fromList <$> mapM (\n -> (n, ) <$> r .: TE.encodeUtf8 n) toOther
+            os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
             d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
             return $ Just $ TxRecord d' a e os
 
 matchRecords :: [Match] -> [TxRecord] -> ([BalTx], [String], [Match])
-matchRecords ms rs = ( catMaybes ts
+matchRecords ms rs =
+    ( catMaybes ts
     , T.unpack <$> (es ++ bu)
-                       -- TODO record number of times each match hits for debugging
+    , -- TODO record number of times each match hits for debugging
-                     , notfound
+      notfound
     )
   where
     (matched, unmatched, notfound) = matchAll (matchPriorities ms) rs
-    (es, ts) = partitionEithers
+    (es, ts) =
-      $ fmap Just . balanceTx <$> catMaybes matched
+        partitionEithers $
+            fmap Just . balanceTx <$> catMaybes matched
     bu = fmap (\x -> T.pack $ "unmatched: " ++ show x) unmatched
 
 matchPriorities :: [Match] -> [MatchGroup]
-matchPriorities = fmap matchToGroup
+matchPriorities =
+    fmap matchToGroup
         . L.groupBy (\a b -> mPriority a == mPriority b)
         . L.sortOn (Down . mPriority)
 
 matchToGroup :: [Match] -> MatchGroup
-matchToGroup ms = uncurry MatchGroup
+matchToGroup ms =
-  $ first (L.sortOn mDate)
+    uncurry MatchGroup $
-  $ L.partition (isJust . mDate) ms
+        first (L.sortOn mDate) $
+            L.partition (isJust . mDate) ms
 
 -- TDOO could use a better struct to flatten the maybe date subtype
 data MatchGroup = MatchGroup
     { mgDate :: [Match]
     , mgNoDate :: [Match]
-  } deriving (Show)
+    }
+    deriving (Show)
 
 data Zipped a = Zipped ![a] ![a]
 
@@ -133,9 +134,10 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
     go _ [] = (Zipped bs $ cs ++ as, Nothing)
     go prev (m : ms) = case matches m x of
         Nothing -> go (m : prev) ms
-      res@(Just _)  -> let ps = reverse prev
+        res@(Just _) ->
-                           ms' = maybe ms (:ms) (matchDec m) in
+            let ps = reverse prev
-        (Zipped bs $ ps ++ ms' ++ as, res)
+                ms' = maybe ms (: ms) (matchDec m)
+             in (Zipped bs $ ps ++ ms' ++ as, res)
 
 zipperMatch' :: Zipped Match -> TxRecord -> (Zipped Match, Maybe (Maybe RawTx))
 zipperMatch' z x = go z
@@ -157,12 +159,13 @@ matchAll = go ([], [])
     go (matched, unused) gs rs = case (gs, rs) of
         (_, []) -> (matched, [], unused)
         ([], _) -> (matched, rs, unused)
-      (g:gs', _) -> let (ts, unmatched, us) = matchGroup g rs in
+        (g : gs', _) ->
-                      go (ts ++ matched, us ++ unused) gs' unmatched
+            let (ts, unmatched, us) = matchGroup g rs
+             in go (ts ++ matched, us ++ unused) gs' unmatched
 
 matchGroup :: MatchGroup -> [TxRecord] -> ([Maybe RawTx], [TxRecord], [Match])
-matchGroup MatchGroup { mgDate = ds, mgNoDate = ns } rs
+matchGroup MatchGroup{mgDate = ds, mgNoDate = ns} rs =
-  = (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
+    (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un)
   where
     (md, rest, ud) = matchDates ds rs
     (mn, unmatched, un) = matchNonDates ns rest
@@ -198,7 +201,8 @@ balanceTx t@Tx { txSplits = ss } = do
     return $ t{txSplits = bs}
 
 balanceSplits :: [RawSplit] -> Either T.Text [BalSplit]
-balanceSplits ss = fmap concat
+balanceSplits ss =
+    fmap concat
         <$> mapM (uncurry bal)
         $ groupByKey
         $ fmap (\s -> (sCurrency s, s)) ss

lib/Internal/Types.hs

@@ -17,26 +17,21 @@ module Internal.Types where
 import Data.Fix (Fix (..), foldFix)
 import Data.Functor.Foldable (embed)
 import qualified Data.Functor.Foldable.TH as TH
-import           Data.Hashable
-import           Data.Int
-import qualified Data.Map                   as M
-import qualified Data.Text                  as T
-import           Data.Time
-
 import Database.Persist.Sql hiding (In, Statement)
-
 import Dhall hiding (embed, maybe)
 import Dhall.TH
-
 import Language.Haskell.TH.Syntax (Lift)
-
+import RIO
-import           Text.Read
+import qualified RIO.Map as M
+import qualified RIO.Text as T
+import RIO.Time
 
 -------------------------------------------------------------------------------
--- | YAML CONFIG
+-- YAML CONFIG
 -------------------------------------------------------------------------------
 
-makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False })
+makeHaskellTypesWith
+    (defaultGenerateOptions{generateToDhallInstance = False})
     [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
     , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
     , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
@@ -47,7 +42,6 @@ makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False }
     , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
     , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
     , MultipleConstructors "Bucket" "(./dhall/Types.dhall).Bucket"
-
     , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
     , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
     , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
@@ -64,9 +58,10 @@ makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False }
     ]
 
 -------------------------------------------------------------------------------
--- | account tree
+-- account tree
 
-data AccountTree = Placeholder T.Text T.Text [AccountTree]
+data AccountTree
+    = Placeholder T.Text T.Text [AccountTree]
     | Account T.Text T.Text
 
 TH.makeBaseFunctor ''AccountTree
@@ -90,16 +85,17 @@ deriving instance FromDhall AccountRootF
 type AccountRoot = AccountRoot_ AccountTree
 
 -------------------------------------------------------------------------------
--- | curencies
+-- curencies
 
 deriving instance Eq Currency
+
 deriving instance Lift Currency
 deriving instance Hashable Currency
 
 type CurID = T.Text
 
 -------------------------------------------------------------------------------
--- | DHALL CONFIG
+-- DHALL CONFIG
 -------------------------------------------------------------------------------
 
 data Config_ a = Config_
@@ -119,7 +115,8 @@ type Config = Config_ AccountRoot
 unfix :: ConfigF -> Config
 unfix c@Config_{accounts = a} = c{accounts = a'}
   where
-    a' = AccountRoot_
+    a' =
+        AccountRoot_
             { arAssets = unfixTree arAssets
             , arEquity = unfixTree arEquity
             , arExpenses = unfixTree arExpenses
@@ -131,14 +128,15 @@ unfix c@Config_ { accounts = a } = c { accounts = a' }
 instance FromDhall a => FromDhall (Config_ a)
 
 -------------------------------------------------------------------------------
--- | accounts
+-- accounts
 
 type AcntID = T.Text
 
 --------------------------------------------------------------------------------
--- | Time Patterns (for assigning when budget events will happen)
+-- Time Patterns (for assigning when budget events will happen)
 
 deriving instance Eq TimeUnit
+
 deriving instance Hashable TimeUnit
 
 deriving instance Eq Weekday
@@ -167,7 +165,8 @@ deriving instance Hashable GregorianM
 instance Ord Gregorian where
     compare
         Gregorian{gYear = y, gMonth = m, gDay = d}
-    Gregorian { gYear = y', gMonth = m', gDay = d'} = compare y y'
+        Gregorian{gYear = y', gMonth = m', gDay = d'} =
+            compare y y'
                 <> compare m m'
                 <> compare d d'
 
@@ -186,7 +185,7 @@ deriving instance Eq DatePat
 deriving instance Hashable DatePat
 
 --------------------------------------------------------------------------------
--- | Budget (projecting into the future)
+-- Budget (projecting into the future)
 
 data Income = Income
     { incGross :: !Decimal
@@ -211,7 +210,8 @@ deriving instance Hashable Tax
 data Amount v = Amount
     { amtValue :: !v
     , amtDesc :: !T.Text
-  } deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
+    }
+    deriving (Functor, Foldable, Traversable, Eq, Hashable, Generic, FromDhall)
 
 data Allocation v = Allocation
     { alloPath :: !AcntID
@@ -241,9 +241,10 @@ data Expense = Expense
     deriving (Eq, Hashable, Generic, FromDhall)
 
 --------------------------------------------------------------------------------
--- | Statements (data from the past)
+-- Statements (data from the past)
 
-data Statement = StmtManual Manual
+data Statement
+    = StmtManual Manual
     | StmtImport Import
     deriving (Generic, FromDhall)
 
@@ -269,7 +270,7 @@ data Tx s = Tx
 
 type ExpTx = Tx ExpSplit
 
-instance FromDhall ExpTx where
+instance FromDhall ExpTx
 
 data Import = Import
     { impPaths :: ![FilePath]
@@ -305,8 +306,8 @@ instance Ord MatchYMD where
     compare (YMD g) (YM g') = compare (gregM g) g' <> GT
 
 gregM :: Gregorian -> GregorianM
-gregM Gregorian { gYear = y, gMonth = m}
+gregM Gregorian{gYear = y, gMonth = m} =
-  = GregorianM { gmYear = y, gmMonth = m}
+    GregorianM{gmYear = y, gmMonth = m}
 
 instance Ord MatchDate where
     compare (On d) (On d') = compare d d'
@@ -318,10 +319,12 @@ deriving instance Eq SplitNum
 deriving instance Hashable SplitNum
 deriving instance Show SplitNum
 
--- | the value of a field in split (text version)
+{- | the value of a field in split (text version)
--- can either be a raw (constant) value, a lookup from the record, or a map
+ can either be a raw (constant) value, a lookup from the record, or a map
--- between the lookup and some other value
+ between the lookup and some other value
-data SplitText t = ConstT !t
+-}
+data SplitText t
+    = ConstT !t
     | LookupT !T.Text
     | MapT (FieldMap T.Text t)
     | Map2T (FieldMap (T.Text, T.Text) t)
@@ -339,7 +342,8 @@ data Field k v = Field
 
 type FieldMap k v = Field k (M.Map k v)
 
-data MatchOther = Desc (Field T.Text T.Text)
+data MatchOther
+    = Desc (Field T.Text T.Text)
     | Val (Field T.Text MatchVal)
     deriving (Show, Eq, Hashable, Generic, FromDhall)
 
@@ -366,14 +370,15 @@ deriving instance Hashable TxOpts
 deriving instance Show TxOpts
 
 --------------------------------------------------------------------------------
--- | Specialized dhall types
+-- Specialized dhall types
 
 deriving instance Eq Decimal
+
 deriving instance Hashable Decimal
 deriving instance Show Decimal
 
 --------------------------------------------------------------------------------
--- | database cache types
+-- database cache types
 
 data ConfigHashes = ConfigHashes
     { chIncome :: ![Int]
@@ -390,15 +395,17 @@ instance PersistFieldSql ConfigType where
 
 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
+-- misc
 
-data AcntType = AssetT
+data AcntType
+    = AssetT
     | EquityT
     | ExpenseT
     | IncomeT
@@ -415,7 +422,8 @@ atName LiabilityT = "liability"
 data AcntPath = AcntPath
     { apType :: !AcntType
     , apChildren :: ![T.Text]
-  } deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
+    }
+    deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
 
 data TxRecord = TxRecord
     { trDate :: !Day
@@ -435,7 +443,7 @@ data Keyed a = Keyed
     }
     deriving (Eq, Show, Functor)
 
-data Tree a = Branch !a ![Tree a] | Leaf !a deriving Show
+data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
 
 data AcntSign = Credit | Debit
     deriving (Show)

lib/Internal/Utils.hs

@@ -4,19 +4,13 @@
 
 module Internal.Utils where
 
-import           Data.Bifunctor
-import qualified Data.Map        as M
-import           Data.Ratio
-import qualified Data.Text       as T
-import           Data.Time
-
 import GHC.Real
-
-import           Numeric.Natural
-
 import Internal.Types
-
+import RIO
-import           Text.Read
+import qualified RIO.Map as M
+import qualified RIO.Text as T
+import qualified RIO.Text.Partial as TP
+import RIO.Time
 import Text.Regex.TDFA
 
 -- when bifunctor fails...
@@ -26,15 +20,19 @@ thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
 gregTup :: Gregorian -> (Integer, Int, Int)
 gregTup g@Gregorian {..}
   | gYear > 99 = error $ show g ++ ": year must only be two digits"
-  | otherwise = ( fromIntegral gYear + 2000
+  | otherwise =
+      ( fromIntegral gYear + 2000
       , fromIntegral gMonth
-                , fromIntegral gDay)
+      , fromIntegral gDay
+      )
 
 gregMTup :: GregorianM -> (Integer, Int)
 gregMTup g@GregorianM {..}
   | gmYear > 99 = error $ show g ++ ": year must only be two digits"
-  | otherwise = ( fromIntegral gmYear + 2000
+  | otherwise =
-                , fromIntegral gmMonth)
+      ( fromIntegral gmYear + 2000
+      , fromIntegral gmMonth
+      )
 
 data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int
 
@@ -56,7 +54,8 @@ compareDate (On md) x = case fromMatchYMD md of
 compareDate (In md offset) x = case fromMatchYMD md of
   Y_ y' -> compareRange y' y
   YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
-  YMD_ y' m' d' -> let s = toModifiedJulianDay $ fromGregorian y' m' d'
+  YMD_ y' m' d' ->
+    let s = toModifiedJulianDay $ fromGregorian y' m' d'
      in compareRange s $ toModifiedJulianDay x
   where
     (y, m, _) = toGregorian x
@@ -69,7 +68,8 @@ dateMatches :: MatchDate -> Day -> Bool
 dateMatches md = (EQ ==) . compareDate md
 
 valMatches :: MatchVal -> Rational -> Bool
-valMatches MatchVal {..} x = checkMaybe (s ==) mvSign
+valMatches MatchVal {..} x =
+  checkMaybe (s ==) mvSign
     && checkMaybe (n ==) mvNum
     && checkMaybe ((d * p ==) . fromIntegral) mvDen
   where
@@ -79,16 +79,19 @@ valMatches MatchVal {..} x = checkMaybe (s ==) mvSign
 
 evalSplit :: TxRecord -> ExpSplit -> RawSplit
 evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
-  s { sAcnt = evalAcnt r a
+  s
+    { sAcnt = evalAcnt r a
     , sValue = evalExp r =<< v
-    , sCurrency = evalCurrency r c }
+    , sCurrency = evalCurrency r c
+    }
 
 evalAcnt :: TxRecord -> SplitAcnt -> T.Text
 evalAcnt TxRecord {trOther = o} s = case s of
   ConstT p -> p
   LookupT f -> read $ T.unpack $ lookupField f o
   MapT (Field f m) -> let k = lookupField f o in lookupErr "account key" k m
-  Map2T (Field (f1, f2) m) -> let k1 = lookupField f1 o
+  Map2T (Field (f1, f2) m) ->
+    let k1 = lookupField f1 o
         k2 = lookupField f2 o
      in lookupErr "account key" (k1, k2) m
 
@@ -97,7 +100,8 @@ evalCurrency TxRecord { trOther = o } s = case s of
   ConstT p -> p
   LookupT f -> lookupField f o
   MapT (Field f m) -> let k = lookupField f o in lookupErr "currency key" k m
-  Map2T (Field (f1, f2) m) -> let k1 = lookupField f1 o
+  Map2T (Field (f1, f2) m) ->
+    let k1 = lookupField f1 o
         k2 = lookupField f2 o
      in lookupErr "currency key" (k1, k2) m
 
@@ -117,7 +121,8 @@ matches Match {..} r@TxRecord {..}
   | allPass = Just $ fmap eval mTx
   | otherwise = Nothing
   where
-    allPass = checkMaybe (`dateMatches` trDate) mDate
+    allPass =
+      checkMaybe (`dateMatches` trDate) mDate
         && valMatches mVal trAmount
         && checkMaybe (=~ trDesc) mDesc
         && all (fieldMatches trOther) mOther
@@ -138,13 +143,16 @@ checkMaybe = maybe True
 
 toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> RawTx
 toTx sc sa toSplits r@TxRecord {..} =
-  Tx { txTags = []
+  Tx
+    { txTags = []
     , txDate = trDate
     , txDescr = trDesc
     , txSplits = fromSplit : fmap (evalSplit r) toSplits
     }
   where
-    fromSplit = Split { sAcnt = evalAcnt r sa
+    fromSplit =
+      Split
+        { sAcnt = evalAcnt r sa
         , sCurrency = evalCurrency r sc
         , sValue = Just trAmount
         , sComment = ""
@@ -164,9 +172,15 @@ parseRational pat s = case ms of
     readT what t = case readMaybe $ T.unpack t of
       Just d -> return $ fromInteger d
       _ -> msg $ T.unwords ["could not parse", what, t]
-    msg m = fail $ T.unpack $ T.concat [ m
+    msg m =
-                                       , "; pattern = ", pat
+      fail $
-                                       , "; query = ", s
+        T.unpack $
+          T.concat
+            [ m
+            , "; pattern = "
+            , pat
+            , "; query = "
+            , s
             ]
     readSign x
       | x == "-" = return (-1)
@@ -177,14 +191,16 @@ parseRational pat s = case ms of
       k <- readSign sign
       return (k, w)
 
+-- TODO don't use a partial function
 readRational :: MonadFail m => T.Text -> m Rational
-readRational s = case T.splitOn "." s of
+readRational s = case TP.splitOn "." s of
   [x] -> return $ fromInteger $ readT x
-  [x, y] -> let x' = readT x
+  [x, y] ->
+    let x' = readT x
         y' = readT y
         p = 10 ^ T.length y
-                k = if x' >= 0 then 1 else -1 in
+        k = if x' >= 0 then 1 else -1
-              if y' > p
+     in if y' > p
           then fail "not enough precision to parse"
           else return $ fromInteger x' + k * y' % p
   _ -> fail $ T.unpack $ T.append "malformed decimal: " s
@@ -225,8 +241,8 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
     s = if x >= 0 then "" else "-"
     x'@(n :% d) = abs x
     p = 10 ^ precision
-    n' = toInteger $ div n d
+    n' = div n d
-    d' = toInteger $ (\(a:%b) -> div a b) ((x' - fromIntegral n') * p)
+    d' = (\(a :% b) -> div a b) ((x' - fromIntegral n') * p)
     txt = T.pack . show
     pad i c z = T.append (T.replicate (i - T.length z) c) z
 

package.yaml

@@ -21,7 +21,7 @@ description:         Please see the README on GitHub at <https://github.com/ndwa
 
 dependencies:
 - base >= 4.12 && < 10
-# - rio >= 0.1.22.0
+- rio >= 0.1.21.0
 - persistent >= 2.13.3.1
 - persistent-sqlite >= 2.13.1.0
 - monad-logger >= 0.3.36
@@ -33,15 +33,10 @@ dependencies:
 - containers >= 0.6.4.1
 - ghc >= 9.0.2
 - cassava
-- bytestring
-- vector
 - regex-tdfa
-- utf8-string
-- transformers
 - esqueleto
 - template-haskell
 - hashable
-- yaml
 - optparse-applicative
 - recursion-schemes
 - data-fix
@@ -51,17 +46,14 @@ library:
   source-dirs: lib/
   ghc-options:
   - -Wall
-  - -Werror
+  - -Wcompat
-  - -threaded
+  - -Widentities
+  - -Wincomplete-record-updates
+  - -Wincomplete-uni-patterns
+  - -Wredundant-constraints
   - -Wpartial-fields
-  exposed-modules:
+  - -Werror
-  - Internal.Config
+  - -O2
-  - Internal.Types
-  - Internal.Utils
-  - Internal.Database.Ops
-  - Internal.Database.Model
-  - Internal.Insert
-  - Internal.Statement
 
 executables:
   pwncash:
@@ -69,9 +61,14 @@ executables:
     source-dirs:         app
     ghc-options:
     - -Wall
-    - -Werror
+    - -Wcompat
-    - -threaded
+    - -Widentities
+    - -Wincomplete-record-updates
+    - -Wincomplete-uni-patterns
+    - -Wredundant-constraints
     - -Wpartial-fields
+    - -Werror
     - -O2
+    - -threaded
     dependencies:
     - budget