FIX update bugs

app/Main.hs

@@ -8,6 +8,7 @@ import Control.Monad.IO.Rerunnable
 import Control.Monad.Logger
 import Control.Monad.Reader
 import Data.Bitraversable
+-- import Data.Hashable
 import qualified Data.Text.IO as TI
 import qualified Database.Esqueleto.Experimental as E
 import Database.Persist.Monad
@@ -20,7 +21,7 @@ import Internal.Utils
 import Options.Applicative
 import RIO
 import RIO.FilePath
-import qualified RIO.Map as M
+-- import qualified RIO.Map as M
 import qualified RIO.Text as T
 
 main :: IO ()
@@ -233,7 +234,7 @@ runSync threads c bs hs = do
         -- TODO for some mysterious reason using multithreading just for this
         -- little bit slows the program down by several seconds
         -- lift $ setNumCapabilities threads
-        (liftIO . print) =<< askDBState (M.keys . csAccountMap)
+        -- (liftIO . print) =<< askDBState (M.keys . csAccountMap)
         -- (liftIO . print) =<< askDBState (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts)
         (CRUDOps hSs _ _ _) <- askDBState csHistStmts
         hSs' <- mapErrorsIO (readHistStmt root) hSs
@@ -247,12 +248,19 @@ runSync threads c bs hs = do
         bTs' <- liftIOExceptT $ mapErrors readBudget bTs
         -- lift $ print $ length $ lefts bTs
         return $ concat $ hSs' ++ hTs' ++ bTs'
-    -- print $ length $ kmNewCommits state
+    print $ length $ coCreate $ csBudgets state
-    -- print $ length $ duOldCommits updates
+    print $ length $ coCreate $ csHistTrans state
-    -- print $ length $ duNewTagIds updates
+    print $ length $ coCreate $ csHistStmts state
-    -- print $ length $ duNewAcntPaths updates
+    print $ length $ coUpdate $ csBudgets state
-    -- print $ length $ duNewAcntIds updates
+    print $ length $ coUpdate $ csHistTrans state
-    -- print $ length $ duNewCurrencyIds updates
+    print $ length $ coUpdate $ csHistStmts state
+    print $ length $ coRead $ csBudgets state
+    print $ length $ coRead $ csHistTrans state
+    print $ length $ coRead $ csHistStmts state
+    print $ coDelete $ csBudgets state
+    print $ coDelete $ csHistTrans state
+    print $ coDelete $ csHistStmts state
+    -- print $ fmap hash $ coCreate $ csHistStmts state
 
     -- Update the DB.
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do

lib/Internal/Budget.hs

@@ -49,7 +49,7 @@ readBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
       getSpan = do
-        globalSpan <- askDBState csBudgetScope
+        globalSpan <- askDBState (unBSpan . csBudgetScope)
         case bgtInterval of
           Nothing -> return $ Just globalSpan
           Just bi -> do

lib/Internal/Database.hs

@@ -22,7 +22,7 @@ import Control.Monad.Except
 import Control.Monad.Logger
 import Data.Decimal
 import Data.Hashable
-import Database.Esqueleto.Experimental ((:&) (..), (==.), (^.))
+import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
 import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
 import Database.Persist.Monad
@@ -42,11 +42,10 @@ import GHC.Err
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (LogFunc, isNothing, on, (^.))
-import qualified RIO.HashSet as HS
 import qualified RIO.List as L
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as NE
--- import qualified RIO.Set as S
+import qualified RIO.Set as S
 import qualified RIO.Text as T
 
 runDB
@@ -126,67 +125,66 @@ readConfigState
   -> [History]
   -> m ConfigState
 readConfigState c bs hs = do
-  curAcnts <- readCurrentIds AccountRId
+  (acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
-  curTags <- readCurrentIds TagRId
+  (pathsIns, _, pathsDel) <- diff newPaths
-  curCurs <- readCurrentIds CurrencyRId
+  (curs2Ins, cursRem, curs2Del) <- diff newCurs
-  curPaths <- readCurrentIds AccountPathRId
+  (tags2Ins, tagsRem, tags2Del) <- diff newTags
-  let (acnts2Ins, acntsRem, acnts2Del) = diff newAcnts curAcnts
-  let (pathsIns, _, pathsDel) = diff newPaths curPaths
-  let (curs2Ins, cursRem, curs2Del) = diff newCurs curCurs
-  let (tags2Ins, tagsRem, tags2Del) = diff newTags curTags
   let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
   let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
   let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
-  let fromMap f = HS.fromList . fmap (fromIntegral . E.fromSqlKey . f) . M.elems
+  let fromMap f = S.fromList . fmap f . M.elems
   let existing =
         ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
 
   (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
-  (bChanged, hChanged) <- readScopeChanged $ scope c
+  -- TODO refine this test to include the whole db (with data already mixed
-  bgt <- makeTxCRUD existing bs curBgts bChanged
+  -- in this algorithm)
-  hTrans <- makeTxCRUD existing ts curHistTrs hChanged
+  let bsRes = BudgetSpan <$> resolveScope budgetInterval
-  hStmt <- makeTxCRUD existing ss curHistSts hChanged
+  let hsRes = HistorySpan <$> resolveScope statementInterval
+  combineErrorM bsRes hsRes $ \bscope hscope -> do
+    let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
+    (bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
+    bgt <- makeTxCRUD existing bs curBgts bChanged
+    hTrans <- makeTxCRUD existing ts curHistTrs hChanged
+    hStmt <- makeTxCRUD existing ss curHistSts hChanged
 
-  let bsRes = resolveScope budgetInterval
+    return $
-  let hsRes = resolveScope statementInterval
+      ConfigState
-  combineError bsRes hsRes $ \b h ->
+        { csCurrencies = CRUDOps curs2Ins () () curs2Del
-    ConfigState
+        , csTags = CRUDOps tags2Ins () () tags2Del
-      { csCurrencies = CRUDOps curs2Ins () () curs2Del
+        , csAccounts = CRUDOps acnts2Ins () () acnts2Del
-      , csTags = CRUDOps tags2Ins () () tags2Del
+        , csPaths = CRUDOps pathsIns () () pathsDel
-      , csAccounts = CRUDOps acnts2Ins () () acnts2Del
+        , csBudgets = bgt
-      , csPaths = CRUDOps pathsIns () () pathsDel
+        , csHistTrans = hTrans
-      , csBudgets = bgt
+        , csHistStmts = hStmt
-      , csHistTrans = hTrans
+        , csAccountMap = amap
-      , csHistStmts = hStmt
+        , csCurrencyMap = cmap
-      , csAccountMap = amap
+        , csTagMap = tmap
-      , csCurrencyMap = cmap
+        , csBudgetScope = bscope
-      , csTagMap = tmap
+        , csHistoryScope = hscope
-      , csBudgetScope = b
+        }
-      , csHistoryScope = h
-      }
   where
     (ts, ss) = splitHistory hs
-    diff :: Eq (Key a) => [Entity a] -> [Key a] -> ([Entity a], [(Entity a, Key a)], [Key a])
+    diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
-    diff = setDiffWith (\a b -> E.entityKey a == b)
     (newAcnts, newPaths) = indexAcntRoot $ accounts c
     newTags = tag2Record <$> tags c
     newCurs = currency2Record <$> currencies c
     resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
 
-readScopeChanged :: (MonadInsertError m, MonadSqlQuery m) => TemporalScope -> m (Bool, Bool)
+readScopeChanged
-readScopeChanged s = do
+  :: (MonadInsertError m, MonadSqlQuery m)
+  => Bool
+  -> BudgetSpan
+  -> HistorySpan
+  -> m (Bool, Bool)
+readScopeChanged dbempty bscope hscope = do
   rs <- dumpTbl
   case rs of
-    [] -> return (True, True)
+    [] -> if dbempty then return (True, True) else throwError undefined
     [r] -> do
-      let (ConfigStateR hsh bsh) = E.entityVal r
+      let (ConfigStateR h b) = E.entityVal r
-      return
+      return (bscope /= b, hscope /= h)
-        ( hashScope budgetInterval == bsh
-        , hashScope statementInterval == hsh
-        )
     _ -> throwError undefined
-  where
-    hashScope f = hash $ f s
 
 makeTxCRUD
   :: (MonadInsertError m, MonadSqlQuery m, Hashable a)
@@ -202,13 +200,13 @@ makeTxCRUD
           DeleteTxs
       )
 makeTxCRUD existing newThings curThings scopeChanged = do
-  let (toDelHashes, overlap, toIns) = setDiffWith go curThings newThings
+  let (toDelHashes, overlap, toIns) =
+        setDiffWith (\a b -> hash b == a) curThings newThings
   -- Check the overlap for rows with accounts/tags/currencies that
   -- won't exist on the next update. Those with invalid IDs will be set aside
   -- to delete and reinsert (which may also fail) later
-  (toInsRetry, noRetry) <- readInvalidIds existing overlap
+  (noRetry, toInsRetry) <- readInvalidIds existing overlap
-  let toDelAllHashes = toDelHashes ++ (fst <$> toInsRetry)
+  let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
-  let toInsAll = (snd <$> toInsRetry) ++ toIns
   -- If we are inserting or deleting something or the scope changed, pull out
   -- the remainder of the entries to update/read as we are (re)inserting other
   -- stuff (this is necessary because a given transaction may depend on the
@@ -218,8 +216,6 @@ makeTxCRUD existing newThings curThings scopeChanged = do
     _ -> readUpdates noRetry
   toDelAll <- readTxIds toDelAllHashes
   return $ CRUDOps toInsAll toRead toUpdate toDelAll
-  where
-    go a b = hash b == a
 
 readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs
 readTxIds cs = do
@@ -270,10 +266,10 @@ currency2Record :: Currency -> Entity CurrencyR
 currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
   Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
 
-readCurrentIds :: PersistEntity a => MonadSqlQuery m => EntityField a (Key a) -> m [Key a]
+readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
-readCurrentIds f = fmap (E.unValue <$>) $ selectE $ do
+readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
   rs <- E.from E.table
-  return (rs ^. f)
+  return (rs ^. E.persistIdField)
 
 readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int])
 readCurrentCommits = do
@@ -286,8 +282,8 @@ readCurrentCommits = do
       let y = E.unValue x
        in case E.unValue t of
             CTBudget -> (y : bs, ts, hs)
-            CTTransfer -> (bs, y : ts, hs)
+            CTHistoryTransfer -> (bs, y : ts, hs)
-            CTHistory -> (bs, ts, y : hs)
+            CTHistoryStatement -> (bs, ts, y : hs)
 
 -- hashConfig :: [Budget] -> [History] -> [Int]
 -- hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
@@ -311,13 +307,16 @@ setDiffWith f = go [] []
   where
     go inA inBoth [] bs = (inA, inBoth, bs)
     go inA inBoth as [] = (as ++ inA, inBoth, [])
-    go inA inBoth (a : as) bs = case inB a bs of
+    go inA inBoth (a : as) bs =
-      Just (b, bs') -> go inA ((a, b) : inBoth) as bs'
+      let (res, bs') = findDelete (f a) bs
-      Nothing -> go (a : inA) inBoth as bs
+       in case res of
-    inB _ [] = Nothing
+            Nothing -> go (a : inA) inBoth as bs
-    inB a (b : bs)
+            Just b -> go inA ((a, b) : inBoth) as bs'
-      | f a b = Just (b, bs)
+
-      | otherwise = inB a bs
+findDelete :: (a -> Bool) -> [a] -> (Maybe a, [a])
+findDelete f xs = case break f xs of
+  (ys, []) -> (Nothing, ys)
+  (ys, z : zs) -> (Just z, ys ++ zs)
 
 -- getDBHashes :: MonadSqlQuery m => m [Int]
 -- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
@@ -594,23 +593,24 @@ updateDBState = do
   deleteTxs =<< asks (coDelete . csBudgets)
   deleteTxs =<< asks (coDelete . csHistTrans)
   deleteTxs =<< asks (coDelete . csHistStmts)
-
+  b <- asks csBudgetScope
--- updateHashes u
+  h <- asks csHistoryScope
--- updateTags u
+  repsertE (E.toSqlKey 1) $ ConfigStateR h b
--- updateAccounts u
--- updateCurrencies u
 
 deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
 deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
 
+repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
+repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
+
 selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
 selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
 
 deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
-deleteKeyE q = unsafeLiftSql "esqueleto-select" (E.deleteKey q)
+deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
 
 insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
-insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
+insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
 
 -- whenHash
 --   :: (Hashable a, MonadFinance m, MonadSqlQuery m)
@@ -661,7 +661,7 @@ insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
 --   hs <- askDBState kmNewCommits
 --   if h `elem` hs then Just . (c,) <$> f else return Nothing
 
-readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([(Int, a)], [Int])
+readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)])
 readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
   rs <- selectE $ do
     (commits :& _ :& entrysets :& entries :& tags) <-
@@ -673,28 +673,28 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
         `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
           `E.innerJoin` E.table
         `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
-          `E.innerJoin` E.table
+          `E.leftJoin` E.table
-        `E.on` (\(_ :& _ :& _ :& e :& r) -> e ^. EntryRId ==. r ^. TagRelationREntry)
+        `E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry)
     E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
     return
       ( commits ^. CommitRHash
       , entrysets ^. EntrySetRCurrency
       , entries ^. EntryRAccount
-      , tags ^. TagRelationRTag
+      , tags ?. TagRelationRTag
       )
   -- TODO there are faster ways to do this; may/may not matter
-  let cs = go ecCurrencies (\(i, c, _, _) -> (i, c)) rs
+  let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
-  let as = go ecAccounts (\(i, _, a, _) -> (i, a)) rs
+  let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
-  let ts = go ecTags (\(i, _, _, t) -> (i, t)) rs
+  let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
-  let valid = (cs `HS.intersection` as) `HS.intersection` ts
+  let valid = (cs `S.intersection` as) `S.intersection` ts
-  return $ second (fst <$>) $ L.partition ((`HS.member` valid) . fst) xs
+  let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
+  return (a0, [])
   where
-    go existing f =
+    go existing =
-      HS.fromList
+      S.fromList
         . fmap (E.unValue . fst)
-        . L.filter (all (`HS.member` existing) . fmap (fromIntegral . E.fromSqlKey . E.unValue) . snd)
+        . L.filter (all (`S.member` existing) . snd)
         . groupKey id
-        . fmap f
 
 readUpdates
   :: (MonadInsertError m, MonadSqlQuery m)

lib/Internal/History.hs

@@ -41,10 +41,10 @@ readHistTransfer
   => PairedTransfer
   -> m [Tx CommitR]
 readHistTransfer ht = do
-  bounds <- askDBState csHistoryScope
+  bounds <- askDBState (unHSpan . csHistoryScope)
   expandTransfer c historyName bounds ht
   where
-    c = CommitR (hash ht) CTTransfer
+    c = CommitR (hash ht) CTHistoryTransfer
 
 --------------------------------------------------------------------------------
 -- Statements
@@ -56,10 +56,10 @@ readHistStmt
   -> m [Tx CommitR]
 readHistStmt root i = do
   bs <- readImport root i
-  bounds <- askDBState csHistoryScope
+  bounds <- askDBState (unHSpan . csHistoryScope)
   return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
   where
-    c = CommitR (hash i) CTTransfer
+    c = CommitR (hash i) CTHistoryStatement
 
 -- TODO this probably won't scale well (pipes?)
 readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]

lib/Internal/Types/Database.hs

@@ -22,47 +22,54 @@ share
 CommitR sql=commits
     hash Int
     type ConfigType
+    UniqueCommitHash hash
     deriving Show Eq Ord
 ConfigStateR sql=config_state
-    historyScopeHash Int
+    historySpan HistorySpan
-    budgetScopeHash Int
+    budgetSpan BudgetSpan
+    deriving Show
 CurrencyR sql=currencies
     symbol CurID
     fullname T.Text
     precision Int
-    deriving Show Eq
+    UniqueCurrencySymbol symbol
+    UniqueCurrencyFullname fullname
+    deriving Show Eq Ord
 TagR sql=tags
     symbol TagID
     fullname T.Text
-    deriving Show Eq
+    UniqueTagSymbol symbol
+    UniqueTagFullname fullname
+    deriving Show Eq Ord
 AccountR sql=accounts
     name T.Text
     fullpath AcntPath
     desc T.Text
     sign AcntSign
     leaf Bool
-    deriving Show Eq
+    UniqueAccountFullpath fullpath
+    deriving Show Eq Ord
 AccountPathR sql=account_paths
-    parent AccountRId OnDeleteCascade
+    parent AccountRId 
-    child AccountRId OnDeleteCascade
+    child AccountRId 
     depth Int
-    deriving Show Eq
+    deriving Show Eq Ord
 TransactionR sql=transactions
-    commit CommitRId OnDeleteCascade
+    commit CommitRId 
     date Day
     description T.Text
     budgetName T.Text
     priority Int
     deriving Show Eq
 EntrySetR sql=entry_sets
-    transaction TransactionRId OnDeleteCascade
+    transaction TransactionRId 
-    currency CurrencyRId OnDeleteCascade
+    currency CurrencyRId 
     index Int
     rebalance Bool
     deriving Show Eq
 EntryR sql=entries
-    entryset EntrySetRId OnDeleteCascade 
+    entryset EntrySetRId  
-    account AccountRId OnDeleteCascade
+    account AccountRId 
     memo T.Text
     value Rational
     index Int
@@ -71,12 +78,20 @@ EntryR sql=entries
     cachedLink (Maybe Int)
     deriving Show Eq
 TagRelationR sql=tag_relations
-    entry EntryRId OnDeleteCascade
+    entry EntryRId 
-    tag TagRId OnDeleteCascade
+    tag TagRId
     deriving Show Eq
 |]
 
-data ConfigType = CTBudget | CTTransfer | CTHistory
+type DaySpan = (Day, Int)
+
+newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
+  deriving newtype (Show, Eq, PersistField, PersistFieldSql)
+
+newtype HistorySpan = HistorySpan {unHSpan :: DaySpan}
+  deriving newtype (Show, Eq, PersistField, PersistFieldSql)
+
+data ConfigType = CTBudget | CTHistoryTransfer | CTHistoryStatement
   deriving (Eq, Show, Read, Enum, Ord)
 
 instance PersistFieldSql ConfigType where

lib/Internal/Types/Main.hs

@@ -39,6 +39,7 @@ data DeleteTxs = DeleteTxs
   , dtEntries :: ![EntryRId]
   , dtTagRelations :: ![TagRelationRId]
   }
+  deriving (Show)
 
 type CDOps c d = CRUDOps [c] () () [d]
 
@@ -53,14 +54,15 @@ data ConfigState = ConfigState
   , csAccountMap :: !AccountMap
   , csCurrencyMap :: !CurrencyMap
   , csTagMap :: !TagMap
-  , csBudgetScope :: !DaySpan
+  , csBudgetScope :: !BudgetSpan
-  , csHistoryScope :: !DaySpan
+  , csHistoryScope :: !HistorySpan
   }
+  deriving (Show)
 
 data ExistingConfig = ExistingConfig
-  { ecAccounts :: !(HashSet Int)
+  { ecAccounts :: !(Set AccountRId)
-  , ecTags :: !(HashSet Int)
+  , ecTags :: !(Set TagRId)
-  , ecCurrencies :: !(HashSet Int)
+  , ecCurrencies :: !(Set CurrencyRId)
   }
 
 type AccountMap = M.Map AcntID (AccountRId, AcntType)
@@ -78,6 +80,7 @@ data CRUDOps c r u d = CRUDOps
   , coUpdate :: !u
   , coDelete :: !d
   }
+  deriving (Show)
 
 data DBState_ = DBState_
   { dbsCurrencyMap :: !CurrencyMap
@@ -198,8 +201,6 @@ data TxRecord = TxRecord
   }
   deriving (Show, Eq, Ord)
 
-type DaySpan = (Day, Natural)
-
 data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
 
 accountSign :: AcntType -> AcntSign

lib/Internal/Utils.hs

@@ -151,7 +151,7 @@ askDays
   -> Maybe Interval
   -> m [Day]
 askDays dp i = do
-  globalSpan <- askDBState csBudgetScope
+  globalSpan <- askDBState (unBSpan . csBudgetScope)
   case i of
     Just i' -> do
       localSpan <- liftExcept $ resolveDaySpan i'