ledger: handle errors better in the ledger reader

hledger-lib/Hledger/Read/LedgerReader.hs

@@ -33,7 +33,7 @@ import Test.HUnit
 -- import Test.Framework
 -- import Text.Megaparsec.Error
 -- #endif
--- import Text.Megaparsec hiding (parse)
+import Text.Megaparsec (eof)
 -- import Text.Printf
 import System.FilePath
 import System.Time
@@ -75,60 +75,82 @@ parse _mrulespath assrt path txt = do
     Failure ei -> throwError $ show ei
     Success res -> do
       -- dbg7IO "raw entities" res
-      pj <- liftIO $ foldM journalAddRawEntityInSitu nulljournal res
+      ejus <- liftIO $ sequence <$> mapM rawEntityInSituToJournalUpdate res
-      t <- liftIO getClockTime
+      case ejus of
-      either throwError return $ journalFinalise t path txt assrt pj
+        Left err  -> throwError err
+        Right jus -> do
+          let pj = foldr (flip (.)) id jus nulljournal
+          t <- liftIO getClockTime
+          either throwError return $ journalFinalise t path txt assrt pj
 
-journalAddRawEntityInSitu :: ParsedJournal -> RawEntityInSitu -> IO ParsedJournal
+-- (I'm not too fond of journal update functions, but ok..)
-journalAddRawEntityInSitu
+-- | Convert a ledger4 RawEntityInSitu - representing a parsed transaction,
-  j
+-- directive, comment etc. - into either a journal update function or an error.
-  RawEntityInSitu{rawEntity=RawTransactionEntity (rt@RawTransaction{
+-- Currently converts only transactions, and ignores some transaction fields.
-      rawTxnDate    = date -- :: !String
+-- Runs in IO because it uses some hledger parsers that have some need for that.
-    , rawTxnDateAux = mdate2 -- :: Maybe String
+rawEntityInSituToJournalUpdate :: RawEntityInSitu -> IO (Either String (ParsedJournal -> ParsedJournal))
-    , rawTxnState   = _mstatus -- :: Maybe Char
+rawEntityInSituToJournalUpdate RawEntityInSitu{rawEntity=RawTransactionEntity (rt@RawTransaction{
-    , rawTxnCode    = _mcode -- :: Maybe String
+    rawTxnDate    = date     -- :: !String
-    , rawTxnDesc    = desc -- :: !String
+  , rawTxnDateAux = mdate2   -- :: Maybe String
-    , rawTxnNote    = _mnote -- :: Maybe String
+  , rawTxnState   = _mstatus -- :: Maybe Char
-    , rawTxnPosts   = rps -- :: ![RawPosting]
+  , rawTxnCode    = _mcode   -- :: Maybe String
-    })}
+  , rawTxnDesc    = desc     -- :: !String
+  , rawTxnNote    = _mnote   -- :: Maybe String
+  , rawTxnPosts   = rps      -- :: ![RawPosting]
+  })}
   = do
-    ps <- catMaybes <$> mapM rawPostingToPosting rps
+    let md = parsedateM date
-    let t = nulltransaction{
+        md2 = mdate2 >>= parsedateM
-      -- tindex                   -- :: Integer,   -- ^ this transaction's 1-based position in the input stream, or 0 when not available
+        dateerr = return . Left . ("could not parse date "++)
-      -- tsourcepos               -- :: GenericSourcePos,
+    case (md, mdate2, md2) of
-        tdate = parsedate date -- XXX                   -- :: Day,
+      (Nothing, _, _)          -> dateerr date
-      , tdate2 = parsedate <$> mdate2 -- XXX                  -- :: Maybe Day,
+      (_, Just date2, Nothing) -> dateerr date2
-      -- tstatus                  -- :: ClearedStatus,
+      (Just d, _, _)           -> do
-      -- tcode                    -- :: Text,
+        eps <- sequence . catMaybes <$> mapM rawPostingToPosting rps
-      , tdescription = pack desc            -- :: Text,
+        case eps of
-      -- tcomment                 -- :: Text,      -- ^ this transaction's comment lines, as a single non-indented multi-line string
+          Left err -> return $ Left err
-      -- ttags                    -- :: [Tag],     -- ^ tag names and values, extracted from the comment
+          Right ps -> do
-      , tpostings = ps               -- :: [Posting], -- ^ this transaction's postings
+            let t = nulltransaction{
-      -- tpreceding_comment_lines -- :: Text       -- ^ any comment lines immediately preceding this transaction
+              -- XXX TODO more complete transaction parsing
-      }
+              -- tindex                   -- :: Integer,   -- ^ this transaction's 1-based position in the input stream, or 0 when not available
-    dbg7IO "raw transaction" rt
+              -- tsourcepos               -- :: GenericSourcePos,
-    dbg7IO "cooked transaction" t
+                tdate = d                 -- :: Day
-    return $ addTransaction t j
+              , tdate2 = md2              -- :: Maybe Day
+              -- tstatus                  -- :: ClearedStatus,
+              -- tcode                    -- :: Text,
+              , tdescription = pack desc  -- :: Text,
+              -- tcomment                 -- :: Text,      -- ^ this transaction's comment lines, as a single non-indented multi-line string
+              -- ttags                    -- :: [Tag],     -- ^ tag names and values, extracted from the comment
+              , tpostings = ps            -- :: [Posting], -- ^ this transaction's postings
+              -- tpreceding_comment_lines -- :: Text       -- ^ any comment lines immediately preceding this transaction
+              }
+            dbg7IO "raw transaction" rt
+            dbg7IO "cooked transaction" t
+            return $ Right $ addTransaction t
+-- TODO convert other entities
+rawEntityInSituToJournalUpdate _ = return $ Right id
 
-journalAddRawEntityInSitu j _ = return j
+-- | Convert a ledger4 RawPosting to a hledger Posting or an error message.
-
+-- Currently ignores some posting fields, and the RawPostingNote variant
-rawPostingToPosting :: RawPosting -> IO (Maybe Posting)
+-- (which represents a comment line, not a posting; returns Nothing for these).
+rawPostingToPosting :: RawPosting -> IO (Maybe (Either String Posting))
 rawPostingToPosting RawPosting{
+    -- TODO
     rawPostState   = _mstatus -- :: Maybe Char
-  , rawPostAccount = acct -- :: !String
+  , rawPostAccount = acct     -- :: !String
-  , rawPostAmount  = mamtstr -- :: Maybe String
+  , rawPostAmount  = mamtstr  -- :: Maybe String
-  , rawPostNote    = _mnote -- :: Maybe String
+  , rawPostNote    = _mnote   -- :: Maybe String
   } = do
-    eamt <- runErroringJournalParser spaceandamountormissingp $ pack $ maybe "" (' ':) mamtstr
+    eamt <- runErroringJournalParser (spaceandamountormissingp <* eof) $ pack $ maybe "" (' ':) mamtstr
     case eamt of
-      Left _err -> return Nothing -- XXX should throw error
+      Left err -> return $ Just $ Left err
       Right (amt :: MixedAmount) -> do
-        return $ Just nullposting{
+        return $ Just $ Right nullposting{
         --   pdate             -- :: Maybe Day,         -- ^ this posting's date, if different from the transaction's
         -- , pdate2            -- :: Maybe Day,         -- ^ this posting's secondary date, if different from the transaction's
         -- , pstatus           -- :: ClearedStatus,
-          paccount = pack acct         -- :: AccountName,
+          paccount = pack acct -- :: AccountName,
-        , pamount = amt          -- :: MixedAmount,
+        , pamount = amt        -- :: MixedAmount,
         -- , pcomment          -- :: Text,              -- ^ this posting's comment lines, as a single non-indented multi-line string
         -- , ptype             -- :: PostingType,
         -- , ptags             -- :: [Tag],             -- ^ tag names and values, extracted from the comment
@@ -137,7 +159,8 @@ rawPostingToPosting RawPosting{
         }
 rawPostingToPosting (RawPostingNote _) = return Nothing
 
--- raw parse example:
+
+-- A raw parse example:
 --
 -- 2010/01/01 * T1
 --     Accounts:Hub    30.00 USD
@@ -162,10 +185,7 @@ rawPostingToPosting (RawPostingNote _) = return Nothing
 -- ]
 
 
-
-
 --- * hunit tests
 
 tests_Hledger_Read_LedgerReader = TestList $ concat [
-    -- test_numberp
  ]