ADD better parsing for statements

This commit is contained in:
Nathan Dwarshuis 2023-08-16 21:01:06 -04:00
parent 2ebfe7a125
commit 001ca0ff37
4 changed files with 201 additions and 81 deletions

View File

@ -278,10 +278,38 @@ let DatePat =
-} -}
< Cron : CronPat.Type | Mod : ModPat.Type > < Cron : CronPat.Type | Mod : ModPat.Type >
let TxOpts_ = let TxAmount1 =
{- Additional metadata to use when parsing a statement -} \(re : Type) ->
{ a1Column : Text
, a1Fmt :
{-
Format of the amount field. Must include three fields for the
sign, numerator, and denominator of the amount.
-}
re
}
let TxAmount2 =
\(re : Type) ->
{ a2Positive : Text
, a2Negative : Text
, a2Fmt :
{-
Format of the amount field. Must include two fields for the
numerator and denominator of the amount.
-}
re
}
let TxAmountSpec =
\(re : Type) ->
< AmountSingle : TxAmount1 re | AmountDual : TxAmount2 re >
let TxOpts_ =
{-
Additional metadata to use when parsing a statement
-}
\(re : Type) -> \(re : Type) ->
{ Type =
{ toDate : { toDate :
{- {-
Column title for date Column title for date
@ -291,7 +319,7 @@ let TxOpts_ =
{- {-
Column title for amount Column title for amount
-} -}
Text TxAmountSpec re
, toDesc : , toDesc :
{- {-
Column title for description Column title for description
@ -309,24 +337,29 @@ let TxOpts_ =
Data.Time.Format.formattime Haskell function. Data.Time.Format.formattime Haskell function.
-} -}
Text Text
, toAmountFmt : , toSkipBlankDate : Bool
{- Format of the amount field. Must include three fields for the , toSkipBlankAmount : Bool
sign, numerator, and denominator of the amount. , toSkipBlankDescription : Bool
-} , toSkipBlankOther : List Text
re
} }
let TxOpts =
{ Type = TxOpts_ Text
, default = , default =
{ toDate = "Date" { toDate = "Date"
, toAmount = "Amount" , toAmount =
(TxAmountSpec Text).AmountSingle
{ a1Column = "Amount", a1Fmt = "([-+])?([0-9\\.]+)" }
, toDesc = "Description" , toDesc = "Description"
, toOther = [] : List Text , toOther = [] : List Text
, toDateFmt = "%0m/%0d/%Y" , toDateFmt = "%0m/%0d/%Y"
, toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?" , toSkipBlankDate = False
, toSkipBlankAmount = False
, toSkipBlankDescription = False
, toSkipBlankOther = [] : List Text
} }
} }
let TxOpts = TxOpts_ Text
let Field = let Field =
{- {-
General key-value type General key-value type
@ -1165,4 +1198,7 @@ in { CurID
, SingleAlloAmount , SingleAlloAmount
, AcntMatcher_ , AcntMatcher_
, AcntMatcher , AcntMatcher
, TxAmountSpec
, TxAmount1
, TxAmount2
} }

View File

@ -32,7 +32,7 @@ readHistoryCRUD
readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
-- TODO multithread this for some extra fun :) -- TODO multithread this for some extra fun :)
ss' <- mapM (readHistStmt root) ss ss' <- mapErrorsIO (readHistStmt root) ss
fromEitherM $ runExceptT $ do fromEitherM $ runExceptT $ do
let sRes = mapErrors (ExceptT . return) ss' let sRes = mapErrors (ExceptT . return) ss'
let tRes = mapErrors readHistTransfer ts let tRes = mapErrors readHistTransfer ts
@ -112,16 +112,43 @@ readImport_ n delim tns p = do
-- TODO handle this better, this maybe thing is a hack to skip lines with -- TODO handle this better, this maybe thing is a hack to skip lines with
-- blank dates but will likely want to make this more flexible -- blank dates but will likely want to make this more flexible
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord) parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do parseTxRecord
p
TxOpts
{ toDate
, toDesc
, toAmount
, toOther
, toDateFmt
, toSkipBlankDate
, toSkipBlankAmount
, toSkipBlankDescription
, toSkipBlankOther
}
r = do
d <- r .: T.encodeUtf8 toDate d <- r .: T.encodeUtf8 toDate
if d == ""
then return Nothing
else do
a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
e <- r .: T.encodeUtf8 toDesc e <- r .: T.encodeUtf8 toDesc
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
(af, ax) <- case toAmount of
AmountSingle TxAmount1 {a1Column, a1Fmt} -> do
f <- r .: T.encodeUtf8 a1Column
return (a1Fmt, Right f)
AmountDual TxAmount2 {a2Positive, a2Negative, a2Fmt} -> do
f1 <- r .: T.encodeUtf8 a2Positive
f2 <- r .: T.encodeUtf8 a2Negative
return (a2Fmt, Left (f1, f2))
if (toSkipBlankDate && d == "")
|| (toSkipBlankDescription && e == "")
|| (toSkipBlankAmount && (ax == Right "" || ax == Left ("", "")))
|| elem "" (mapMaybe (`M.lookup` os) toSkipBlankOther)
then return Nothing
else do
a' <- case ax of
Right a -> parseDecimal True af a
Left ("", a) -> ((-1) *) <$> parseDecimal False af a
Left (a, _) -> parseDecimal False af a
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os p return $ Just $ TxRecord d' a' e os p
matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()] matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()]
matchRecords ms rs = do matchRecords ms rs = do
@ -468,9 +495,15 @@ readRational s = case T.split (== '.') s of
err = throwError $ AppException [ConversionError s False] err = throwError $ AppException [ConversionError s False]
compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
compileOptions o@TxOpts {toAmountFmt = pat} = do compileOptions = mapM (compileRegex True)
re <- compileRegex True pat
return $ o {toAmountFmt = re} -- compileOptions o@TxOpts {toAmount = pat} = case pat of
-- AmountSingle (TxAmount1 {a1Fmt}) -> do
-- re <- compileRegex True a1Fmt
-- return $ o {toAmountFmt = re}
-- AmountDual (TxAmount2 {a2Fmt}) -> do
-- re <- compileRegex True a2Fmt
-- return $ o {toAmountFmt = re}
compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe
compileMatch m@StatementParser {spDesc, spOther} = do compileMatch m@StatementParser {spDesc, spOther} = do
@ -480,19 +513,15 @@ compileMatch m@StatementParser {spDesc, spOther} = do
dres = mapM go spDesc dres = mapM go spDesc
ores = combineErrors $ fmap (mapM go) spOther ores = combineErrors $ fmap (mapM go) spOther
parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal parseDecimal :: MonadFail m => Bool -> (T.Text, Regex) -> T.Text -> m Decimal
parseDecimal (pat, re) s = case matchGroupsMaybe s re of parseDecimal wantSign (pat, re) s = case (wantSign, matchGroupsMaybe s re) of
[sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x (True, [sign, num]) -> do
[sign, x, y] -> do k <- readSign sign
d <- readT "decimal" y x <- readNum num
let p = T.length y return $ k * x
(k, w) <- readWhole sign x (False, [num]) -> readNum num
return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
_ -> msg "malformed decimal" _ -> msg "malformed decimal"
where where
readT what t = case readMaybe $ T.unpack t of
Just d -> return $ fromInteger d
_ -> msg $ T.unwords ["could not parse", what, singleQuote t]
msg :: MonadFail m => T.Text -> m a msg :: MonadFail m => T.Text -> m a
msg m = msg m =
fail $ fail $
@ -502,7 +531,10 @@ parseDecimal (pat, re) s = case matchGroupsMaybe s re of
| x == "-" = return (-1) | x == "-" = return (-1)
| x == "+" || x == "" = return 1 | x == "+" || x == "" = return 1
| otherwise = msg $ T.append "invalid sign: " x | otherwise = msg $ T.append "invalid sign: " x
readWhole sign x = do readNum x =
w <- readT "whole number" x maybe
k <- readSign sign (msg $ T.unwords ["could not parse", singleQuote x])
return (k, w) return
$ readMaybe
$ T.unpack
$ T.filter (/= ',') x

View File

@ -102,7 +102,7 @@ newtype EntryIndex = EntryIndex {unEntryIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql) deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype TxDesc = TxDesc {unTxDesc :: T.Text} newtype TxDesc = TxDesc {unTxDesc :: T.Text}
deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField) deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField, IsString)
newtype Precision = Precision {unPrecision :: Word8} newtype Precision = Precision {unPrecision :: Word8}
deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql) deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)

View File

@ -49,14 +49,12 @@ makeHaskellTypesWith
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type" , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type" , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type" , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
, SingleConstructor "TxAmount1" "TxAmount1" "(./dhall/Types.dhall).TxAmount1"
, SingleConstructor "TxAmount2" "TxAmount2" "(./dhall/Types.dhall).TxAmount2"
, SingleConstructor , SingleConstructor
"Amount" "Amount"
"Amount" "Amount"
"\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type" "\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
, SingleConstructor
"TxOpts"
"TxOpts"
"\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type"
, SingleConstructor , SingleConstructor
"AcntMatcher_" "AcntMatcher_"
"AcntMatcher_" "AcntMatcher_"
@ -468,12 +466,44 @@ deriving instance Eq a => Eq (TxOpts a)
deriving instance Generic (TxOpts a) deriving instance Generic (TxOpts a)
deriving instance Hashable a => Hashable (TxOpts a) deriving instance Hashable (TxOpts T.Text)
deriving instance FromDhall a => FromDhall (TxOpts a) deriving instance FromDhall (TxOpts T.Text)
deriving instance Show a => Show (TxOpts a) deriving instance Show a => Show (TxOpts a)
deriving instance Eq re => Eq (TxAmount1 re)
deriving instance Eq re => Eq (TxAmount2 re)
deriving instance Show re => Show (TxAmount1 re)
deriving instance Show re => Show (TxAmount2 re)
deriving instance Generic (TxAmount1 T.Text)
deriving instance Generic (TxAmount2 T.Text)
deriving instance Hashable (TxAmount1 T.Text)
deriving instance Hashable (TxAmount2 T.Text)
deriving instance FromDhall (TxAmount1 T.Text)
deriving instance FromDhall (TxAmount2 T.Text)
deriving instance Functor TxAmount1
deriving instance Functor TxAmount2
deriving instance Foldable TxAmount1
deriving instance Foldable TxAmount2
deriving instance Traversable TxAmount1
deriving instance Traversable TxAmount2
data Statement = Statement data Statement = Statement
{ stmtPaths :: ![FilePath] { stmtPaths :: ![FilePath]
, stmtParsers :: ![StatementParser T.Text] , stmtParsers :: ![StatementParser T.Text]
@ -483,6 +513,28 @@ data Statement = Statement
} }
deriving (Eq, Hashable, Generic, FromDhall, Show) deriving (Eq, Hashable, Generic, FromDhall, Show)
data TxAmountSpec re = AmountSingle (TxAmount1 re) | AmountDual (TxAmount2 re)
deriving (Eq, Show, Functor, Foldable, Traversable)
deriving instance Generic (TxAmountSpec T.Text)
deriving instance FromDhall (TxAmountSpec T.Text)
deriving instance Hashable (TxAmountSpec T.Text)
data TxOpts re = TxOpts
{ toDate :: !T.Text
, toAmount :: !(TxAmountSpec re)
, toDesc :: !T.Text
, toOther :: ![T.Text]
, toDateFmt :: !T.Text
, toSkipBlankDate :: !Bool
, toSkipBlankAmount :: !Bool
, toSkipBlankDescription :: !Bool
, toSkipBlankOther :: ![Text]
}
deriving (Functor, Foldable, Traversable)
-- | the value of a field in entry (text version) -- | the value of a field in entry (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