FIX counter error

app/Main.hs

@@ -1,8 +1,8 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Main (main) where
 
+import qualified Data.Text.IO as TI
 import Internal.Config
 import Internal.Database.Ops
 import Internal.Insert
@@ -157,12 +157,16 @@ runDumpAccountKeys c = do
 runSync :: MonadUnliftIO m => FilePath -> m ()
 runSync c = do
   config <- readConfig c
-  migrate_ (sqlConfig config) $ do
+  handle err $ migrate_ (sqlConfig config) $ do
     s <- getDBState config
     flip runReaderT (s $ takeDirectory c) $ do
       es1 <- insertBudget $ budget config
       es2 <- insertStatements config
       let es = es1 ++ es2
       unless (null es) $ throwIO $ InsertException es
+  where
+    err (InsertException es) = do
+      liftIO $ mapM_ TI.putStrLn $ concatMap showError es
+      exitFailure
 
 -- showBalances

lib/Internal/Config.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
 module Internal.Config
   ( readConfig
   -- , readYaml

lib/Internal/Database/Model.hs

@@ -14,6 +14,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Database.Model where
 

lib/Internal/Database/Ops.hs

@@ -4,11 +4,12 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Database.Ops
   ( migrate_
   , nukeTables
-  , showBalances
+  -- , showBalances
   , updateHashes
   , getDBState
   , tree2Records
@@ -24,6 +25,7 @@ import Database.Esqueleto.Experimental
 import Database.Persist.Sql hiding (delete, (==.), (||.))
 import Database.Persist.Sqlite hiding (delete, (==.), (||.))
 import Database.Sqlite hiding (Config)
+import GHC.Err
 import Internal.Database.Model
 import Internal.Types
 import Internal.Utils
@@ -64,38 +66,38 @@ nukeTables = do
   deleteWhere ([] :: [Filter AccountR])
   deleteWhere ([] :: [Filter TransactionR])
 
-showBalances :: MonadUnliftIO m => SqlPersistT m ()
+-- showBalances :: MonadUnliftIO m => SqlPersistT m ()
-showBalances = do
+-- showBalances = do
-  xs <- select $ do
+--   xs <- select $ do
-    (accounts :& splits :& txs) <-
+--     (accounts :& splits :& txs) <-
-      from
+--       from
-        $ table @AccountR
+--         $ table @AccountR
-          `innerJoin` table @SplitR
+--           `innerJoin` table @SplitR
-        `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount)
+--         `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount)
-          `innerJoin` table @TransactionR
+--           `innerJoin` table @TransactionR
-        `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId)
+--         `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId)
-    where_ $
+--     where_ $
-      isNothing (txs ^. TransactionRBucket)
+--       isNothing (txs ^. TransactionRBucket)
-        &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%))
+--         &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%))
-                ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))
+--                 ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))
-            )
+--             )
-    groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName)
+--     groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName)
-    return
+--     return
-      ( accounts ^. AccountRFullpath
+--       ( accounts ^. AccountRFullpath
-      , accounts ^. AccountRName
+--       , accounts ^. AccountRName
-      , sum_ $ splits ^. SplitRValue
+--       , sum_ $ splits ^. SplitRValue
-      )
+--       )
-  -- TODO super stetchy table printing thingy
+--   -- TODO super stetchy table printing thingy
-  liftIO $ do
+--   liftIO $ do
-    putStrLn $ T.unpack $ fmt "Account" "Balance"
+--     putStrLn $ T.unpack $ fmt "Account" "Balance"
-    putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-")
+--     putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-")
-    mapM_ (putStrLn . T.unpack . fmtBalance) xs
+--     mapM_ (putStrLn . T.unpack . fmtBalance) xs
-  where
+--   where
-    fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal)
+--     fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal)
-    fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"]
+--     fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"]
-    pad n xs = T.append xs $ T.replicate (n - T.length xs) " "
+--     pad n xs = T.append xs $ T.replicate (n - T.length xs) " "
-    toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
+--     toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
-    toBal = maybe "???" (fmtRational 2) . unValue
+--     toBal = maybe "???" (fmtRational 2) . unValue
 
 hashConfig :: Config -> [Int]
 hashConfig
@@ -220,7 +222,7 @@ tree2Records t = go []
     go ps (Placeholder d n cs) =
       let e = tree2Entity t (fmap snd ps) n d
           k = entityKey e
-          (as, aps, ms) = unzip3 $ fmap (go ((k, n) : ps)) cs
+          (as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs
           a0 = acnt k n (fmap snd ps) d
           paths = expand k $ fmap fst ps
        in (a0 : concat as, paths ++ concat aps, concat ms)
@@ -240,7 +242,7 @@ paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
 paths2IDs =
   uncurry zip
     . first trimNames
-    . unzip
+    . L.unzip
     . L.sortOn fst
     . fmap (first pathList)
   where
@@ -301,7 +303,7 @@ indexAcntRoot r =
   , M.fromList $ paths2IDs $ concat ms
   )
   where
-    (ars, aprs, ms) = unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
+    (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
 
 getDBState
   :: MonadUnliftIO m

lib/Internal/Insert.hs

@@ -54,14 +54,13 @@ cronPatternMatches
     , cronDay = d
     }
   x =
-    yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
+    yMaybe y' y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
     where
       testMaybe = maybe True
-      yMaybe z = testMaybe (mdyPatternMatches testYear (fromIntegral z))
+      yMaybe z = testMaybe (mdyPatternMatches (fromIntegral z))
-      mdMaybe z = testMaybe (mdyPatternMatches (const Nothing) (fromIntegral z))
+      mdMaybe z = testMaybe (mdyPatternMatches (fromIntegral z))
       wdMaybe z = testMaybe (`weekdayPatternMatches` z)
       (y', m', d') = toGregorian x
-      testYear z = if z > 99 then Just "year must be 2 digits" else Nothing
 
 dayOfWeek_ :: Day -> Weekday
 dayOfWeek_ d = case dayOfWeek d of
@@ -77,16 +76,12 @@ weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool
 weekdayPatternMatches (OnDay x) = (== x)
 weekdayPatternMatches (OnDays xs) = (`elem` xs)
 
-mdyPatternMatches :: (Natural -> Maybe String) -> Natural -> MDYPat -> Bool
+mdyPatternMatches :: Natural -> MDYPat -> Bool
-mdyPatternMatches check x p = case p of
+mdyPatternMatches x p = case p of
-  Single y -> errMaybe (check y) $ x == y
+  Single y -> x == y
-  Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs
+  Multi xs -> x `elem` xs
   Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) ->
-    errMaybe (check s) $
     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
 
 --------------------------------------------------------------------------------
 -- budget
@@ -261,8 +256,6 @@ timeAmountToTx
 insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError]
 insertStatements conf = concat <$> mapM insertStatement (statements conf)
 
--- unless (null es) $ throwIO $ InsertException es
-
 insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
 insertStatement (StmtManual m) = insertManual m
 insertStatement (StmtImport i) = insertImport i

lib/Internal/Statement.hs

@@ -147,7 +147,7 @@ zipperMatch' z x = go z
 
 matchDec :: Match -> Maybe Match
 matchDec m = case mTimes m of
-  Just 0 -> Nothing
+  Just 1 -> Nothing
   Just n -> Just $ m {mTimes = Just $ n - 1}
   Nothing -> Just m