WIP make field errors useful

lib/Internal/Types.hs

@@ -521,7 +521,15 @@ data MatchRes a = MatchPass a | MatchFail | MatchSkip
 
 data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
 
-data LookupField = AccountField | CurrencyField | OtherField deriving (Show)
+data MatchType = MatchNumeric | MatchText deriving (Show)
+
+data SplitIDType = AcntField | CurField deriving (Show)
+
+data LookupSuberr
+  = SplitIDField SplitIDType
+  | SplitValField
+  | MatchField MatchType
+  deriving (Show)
 
 data AllocationSuberr
   = NoAllocations
@@ -530,13 +538,11 @@ data AllocationSuberr
   | TooManyBlanks
   deriving (Show)
 
--- data ConversionSubError = Malformed |  deriving (Show)
-
 data InsertError
   = RegexError T.Text
   | YearError Natural
   | ConversionError T.Text
-  | LookupError LookupField T.Text
+  | LookupError LookupSuberr T.Text
   | BalanceError BalanceType CurID [RawSplit]
   | AllocationError AllocationSuberr DatePat
   | StatementError [TxRecord] [Match]

lib/Internal/Utils.hs

@@ -14,9 +14,8 @@ import qualified RIO.Text as T
 import RIO.Time
 import Text.Regex.TDFA
 
--- when bifunctor fails...
+--------------------------------------------------------------------------------
-thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
+-- gregorian
-thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
 
 gregTup :: Gregorian -> EitherErr (Integer, Int, Int)
 gregTup Gregorian {..}
@@ -71,84 +70,50 @@ compareDate (In md offset) x = do
       | otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
     toMonth year month = (year * 12) + fromIntegral month
 
-dateMatches :: MatchDate -> Day -> EitherErr Bool
+boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErrs Bounds
-dateMatches md = fmap (EQ ==) . compareDate md
+boundsFromGregorian (a, b) = concatEither2 a_ b_ (,)
-
-valMatches :: MatchVal -> Rational -> Bool
-valMatches MatchVal {..} x =
-  checkMaybe (s ==) mvSign
-    && checkMaybe (n ==) mvNum
-    && checkMaybe ((d * p ==) . fromIntegral) mvDen
   where
-    (n, d) = properFraction $ abs x
+    a_ = fromGregorian' a
-    p = 10 ^ mvPrec
+    b_ = fromGregorian' b
-    s = signum x >= 0
 
-evalSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
+fromGregorian' :: Gregorian -> EitherErr Day
-evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
+fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup
-  concatEither3 (evalAcnt r a) (evalCurrency r c) (mapM (evalExp r) v) $
-    \a_ c_ v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
 
-evalAcnt :: TxRecord -> SplitAcnt -> EitherErr T.Text
+inBounds :: Bounds -> Day -> Bool
-evalAcnt TxRecord {trOther = o} s = case s of
+inBounds (d0, d1) x = d0 <= x && x <= d1
-  ConstT p -> Right p
-  LookupT f -> lookupErr AccountField f o
-  MapT (Field f m) -> do
-    k <- lookupErr AccountField f o
-    lookupErr AccountField k m
-  Map2T (Field (f1, f2) m) -> do
-    k1 <- lookupErr AccountField f1 o
-    k2 <- lookupErr AccountField f2 o
-    lookupErr AccountField (k1, k2) m
 
--- TODO wett codde
+inMaybeBounds :: MaybeBounds -> Day -> Bool
-evalCurrency :: TxRecord -> SplitCur -> EitherErr T.Text
+inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
-evalCurrency TxRecord {trOther = o} s = case s of
-  ConstT p -> Right p
-  LookupT f -> lookupErr CurrencyField f o
-  MapT (Field f m) -> do
-    k <- lookupErr CurrencyField f o
-    lookupErr CurrencyField k m
-  Map2T (Field (f1, f2) m) -> do
-    k1 <- lookupErr CurrencyField f1 o
-    k2 <- lookupErr CurrencyField f2 o
-    lookupErr CurrencyField (k1, k2) m
 
-errorT :: T.Text -> a
+intervalMaybeBounds :: Interval -> EitherErrs MaybeBounds
-errorT = error . T.unpack
+intervalMaybeBounds Interval {intStart = s, intEnd = e} = concatEither2 s_ e_ (,)
+  where
+    s_ = mapM fromGregorian' s
+    e_ = mapM fromGregorian' e
 
-lookupErr :: (Ord k, Show k) => LookupField -> k -> M.Map k v -> EitherErr v
+resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
-lookupErr what k m = case M.lookup k m of
+resolveBounds (s, e) = do
-  Just x -> Right x
+  s' <- maybe getDay return s
-  _ -> Left $ LookupError what $ showT k
+  e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e
+  return (s', e')
+  where
+    getDay = utctDay <$> getCurrentTime
+
+--------------------------------------------------------------------------------
+-- matching
 
 matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx)
 matches Match {..} r@TxRecord {..} = do
   res <- concatEither3 date other desc (\x y z -> x && y && z)
   if val && res
-    then maybe (Right MatchSkip) (fmap MatchPass . eval) mTx
+    then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
     else Right MatchFail
   where
     val = valMatches mVal trAmount
     date = maybe (Right True) (`dateMatches` trDate) mDate
-    other = foldM (\a o -> (a &&) <$> fieldMatches trOther o) True mOther
+    other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
     desc = maybe (return True) (matchMaybe trDesc) mDesc
-    eval (ToTx cur a ss) = toTx cur a ss r
+    convert (ToTx cur a ss) = toTx cur a ss r
-
-matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b
-matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re
-
-fieldMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool
-fieldMatches dict m = case m of
-  Val (Field n mv) -> valMatches mv <$> (readRational =<< lookup_ n)
-  Desc (Field n md) -> (`matchMaybe` md) =<< lookup_ n
-  where
-    lookup_ n = case M.lookup n dict of
-      Just r -> Right r
-      Nothing -> Left $ LookupError OtherField n
-
-checkMaybe :: (a -> Bool) -> Maybe a -> Bool
-checkMaybe = maybe True
 
 toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
 toTx sc sa toSplits r@TxRecord {..} =
@@ -167,8 +132,68 @@ toTx sc sa toSplits r@TxRecord {..} =
           , txSplits = fromSplit : ss_
           }
   where
-    acRes = concatEither2 (evalAcnt r sa) (evalCurrency r sc) (,)
+    acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,)
-    ssRes = concatEithersL $ fmap (evalSplit r) toSplits
+    ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
+
+valMatches :: MatchVal -> Rational -> Bool
+valMatches MatchVal {..} x =
+  checkMaybe (s ==) mvSign
+    && checkMaybe (n ==) mvNum
+    && checkMaybe ((d * p ==) . fromIntegral) mvDen
+  where
+    (n, d) = properFraction $ abs x
+    p = 10 ^ mvPrec
+    s = signum x >= 0
+    checkMaybe = maybe True
+
+dateMatches :: MatchDate -> Day -> EitherErr Bool
+dateMatches md = fmap (EQ ==) . compareDate md
+
+otherMatches :: M.Map T.Text T.Text -> MatchOther -> EitherErr Bool
+otherMatches dict m = case m of
+  Val (Field n mv) -> valMatches mv <$> (readRational =<< lookup_ MatchNumeric n)
+  Desc (Field n md) -> (`matchMaybe` md) =<< lookup_ MatchText n
+  where
+    lookup_ t n = lookupErr (MatchField t) n dict
+
+resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
+resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
+  concatEithers2 acRes valRes $
+    \(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
+  where
+    acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,)
+    valRes = plural $ mapM (resolveValue r) v
+
+resolveValue :: TxRecord -> SplitNum -> EitherErr Rational
+resolveValue r s = case s of
+  (LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r)
+  (ConstN c) -> Right $ dec2Rat c
+  AmountN -> Right $ trAmount r
+
+resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text
+resolveAcnt = resolveSplitField AcntField
+
+resolveCurrency :: TxRecord -> SplitCur -> EitherErrs T.Text
+resolveCurrency = resolveSplitField CurField
+
+resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text
+resolveSplitField t TxRecord {trOther = o} s = case s of
+  ConstT p -> Right p
+  LookupT f -> plural $ lookup_ f o
+  MapT (Field f m) -> plural $ do
+    k <- lookup_ f o
+    lookup_ k m
+  Map2T (Field (f1, f2) m) -> do
+    (k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,)
+    plural $ lookup_ (k1, k2) m
+  where
+    lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErr v
+    lookup_ = lookupErr (SplitIDField t)
+
+lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErr v
+lookupErr what k m = case M.lookup k m of
+  Just x -> Right x
+  _ -> Left $ LookupError what $ showT k
 
 parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
 parseRational pat s = case ms of
@@ -221,35 +246,6 @@ readRational s = case T.split (== '.') s of
 mapTxSplits :: (a -> b) -> Tx a -> Tx b
 mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
 
-boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErrs Bounds
-boundsFromGregorian (a, b) = concatEither2 a_ b_ (,)
-  where
-    a_ = fromGregorian' a
-    b_ = fromGregorian' b
-
-fromGregorian' :: Gregorian -> EitherErr Day
-fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup
-
-inBounds :: Bounds -> Day -> Bool
-inBounds (d0, d1) x = d0 <= x && x <= d1
-
-inMaybeBounds :: MaybeBounds -> Day -> Bool
-inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
-
-intervalMaybeBounds :: Interval -> EitherErrs MaybeBounds
-intervalMaybeBounds Interval {intStart = s, intEnd = e} = concatEither2 s_ e_ (,)
-  where
-    s_ = mapM fromGregorian' s
-    e_ = mapM fromGregorian' e
-
-resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
-resolveBounds (s, e) = do
-  s' <- maybe getDay return s
-  e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e
-  return (s', e')
-  where
-    getDay = utctDay <$> getCurrentTime
-
 fmtRational :: Natural -> Rational -> T.Text
 fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
   where
@@ -261,21 +257,6 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
     txt = T.pack . show
     pad i c z = T.append (T.replicate (i - T.length z) c) z
 
-uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
-uncurry3 f (a, b, c) = f a b c
-
-lpad :: a -> Int -> [a] -> [a]
-lpad c n s = replicate (n - length s) c ++ s
-
-rpad :: a -> Int -> [a] -> [a]
-rpad c n s = s ++ replicate (n - length s) c
-
-evalExp :: TxRecord -> SplitNum -> EitherErr Rational
-evalExp r s = case s of
-  (LookupN t) -> readRational =<< lookupErr OtherField t (trOther r)
-  (ConstN c) -> Right $ dec2Rat c
-  AmountN -> Right $ trAmount r
-
 dec2Rat :: Decimal -> Rational
 dec2Rat D {..} =
   k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
@@ -285,14 +266,38 @@ dec2Rat D {..} =
 acntPath2Text :: AcntPath -> T.Text
 acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
 
+--------------------------------------------------------------------------------
+-- error display
+
 showError :: InsertError -> [T.Text]
 showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
 showError other = (: []) $ case other of
+  -- TODO show whole date here since this is kinda useless
   (YearError y) -> T.append "Year must be two digits: " $ showT y
   (RegexError re) -> T.append "could not make regex from pattern: " re
   (ConversionError x) -> T.append "Could not convert to rational number: " x
   -- TODO use the field indicator
-  (LookupError _ f) -> T.append "Could not find field: " f
+  (LookupError t f) ->
+    T.unwords
+      [ "Could not find field"
+      , singleQuote f
+      , "when resolving"
+      , what
+      ]
+    where
+      what = case t of
+        SplitIDField st ->
+          T.unwords
+            [ "split"
+            , case st of AcntField -> "account"; CurField -> "currency"
+            , "ID"
+            ]
+        SplitValField -> "split value"
+        MatchField mt ->
+          T.unwords
+            [ case mt of MatchNumeric -> "numeric"; MatchText -> "text"
+            , "match"
+            ]
   (AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp]
     where
       msg = case t of
@@ -301,7 +306,7 @@ showError other = (: []) $ case other of
         MissingBlank -> "No blank allocation to balance"
         TooManyBlanks -> "Cannot balance multiple blank allocations"
   (BalanceError t cur rss) ->
-    T.concat
+    T.unwords
       [ msg
       , "for currency"
       , singleQuote cur
@@ -357,9 +362,6 @@ showMatchDate md = case md of
 --       YMD (Gregorian {..}) -> [gYear, gMonth, gDay]
 --  in T.intercalate "-" $ L.take 3 (fmap showT ys ++ L.repeat "*")
 
-showT :: Show a => a -> T.Text
-showT = T.pack . show
-
 showMatchVal :: MatchVal -> Maybe T.Text
 showMatchVal = undefined
 
@@ -387,6 +389,12 @@ keyVal a b = T.concat [a, "=", b]
 keyVals :: [(T.Text, T.Text)] -> T.Text
 keyVals = T.intercalate "; " . fmap (uncurry keyVal)
 
+showT :: Show a => a -> T.Text
+showT = T.pack . show
+
+--------------------------------------------------------------------------------
+-- pure error processing
+
 concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
 concatEither2 a b fun = case (a, b) of
   (Right a_, Right b_) -> Right $ fun a_ b_
@@ -398,7 +406,7 @@ concatEither3 a b c fun = case (a, b, c) of
   _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
 
 concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
-concatEithers2 a b = first concat . concatEither2 a b
+concatEithers2 a b = merge . concatEither2 a b
 
 concatEithers3
   :: Either [x] a
@@ -406,7 +414,7 @@ concatEithers3
   -> Either [x] c
   -> (a -> b -> c -> d)
   -> Either [x] d
-concatEithers3 a b c = first concat . concatEither3 a b c
+concatEithers3 a b c = merge . concatEither3 a b c
 
 concatEitherL :: [Either x a] -> Either [x] [a]
 concatEitherL as = case partitionEithers as of
@@ -414,7 +422,7 @@ concatEitherL as = case partitionEithers as of
   (es, _) -> Left es
 
 concatEithersL :: [Either [x] a] -> Either [x] [a]
-concatEithersL = first concat . concatEitherL
+concatEithersL = merge . concatEitherL
 
 leftToMaybe :: Either a b -> Maybe a
 leftToMaybe (Left a) = Just a
@@ -427,3 +435,28 @@ unlessLeft (Right rs) f = f rs >> return mzero
 unlessLefts :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
 unlessLefts (Left es) _ = return es
 unlessLefts (Right rs) f = f rs >> return mzero
+
+plural :: Either a b -> Either [a] b
+plural = first (: [])
+
+merge :: Either [[a]] b -> Either [a] b
+merge = first concat
+
+--------------------------------------------------------------------------------
+-- random functions
+
+-- when bifunctor fails...
+thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
+thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
+
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c
+
+lpad :: a -> Int -> [a] -> [a]
+lpad c n s = replicate (n - length s) c ++ s
+
+rpad :: a -> Int -> [a] -> [a]
+rpad c n s = s ++ replicate (n - length s) c
+
+matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b
+matchMaybe q re = first (const $ RegexError re) $ pureTry $ q =~ re