From cc3bbd76dc42f62214e9c6ab50059fc37ce4354e Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 13 Aug 2022 15:07:44 +0530 Subject: [PATCH] Use a macro definition for assertM So that the error location is reported correctly by the compiler when the assert is hit. --- .../Streamly/Internal/Control/Exception.hs | 14 +------ .../Internal/Data/Array/Unboxed/Mut/Type.hs | 13 +++---- .../Streamly/Internal/Data/Parser/ParserD.hs | 17 +++++---- .../Internal/Data/Parser/ParserD/Type.hs | 37 ++++++++++--------- core/src/assert.hs | 6 +++ src/assert.hs | 6 +++ streamly.cabal | 6 ++- 7 files changed, 51 insertions(+), 48 deletions(-) create mode 100644 core/src/assert.hs create mode 100644 src/assert.hs diff --git a/core/src/Streamly/Internal/Control/Exception.hs b/core/src/Streamly/Internal/Control/Exception.hs index 9d0079c25..616e017e5 100644 --- a/core/src/Streamly/Internal/Control/Exception.hs +++ b/core/src/Streamly/Internal/Control/Exception.hs @@ -10,23 +10,11 @@ -- Additional "Control.Exception" utilities. module Streamly.Internal.Control.Exception - ( assertM - , verify + ( verify , verifyM ) where -import Control.Exception (assert) - --- Like 'assert' but returns @()@ in an 'Applicative' context so that it can be --- used as an independent statement in a @do@ block. --- --- /Pre-release/ --- -{-# INLINE assertM #-} -assertM :: Applicative f => Bool -> f () -assertM predicate = assert predicate (pure ()) - -- | Like 'assert' but is not removed by the compiler, it is always present in -- production code. -- diff --git a/core/src/Streamly/Internal/Data/Array/Unboxed/Mut/Type.hs b/core/src/Streamly/Internal/Data/Array/Unboxed/Mut/Type.hs index 407995cac..2df6e7402 100644 --- a/core/src/Streamly/Internal/Data/Array/Unboxed/Mut/Type.hs +++ b/core/src/Streamly/Internal/Data/Array/Unboxed/Mut/Type.hs @@ -210,11 +210,11 @@ where -- When we use a purely lazy Monad like Identity, we need to force ordering of -- some actions for correctness. +#include "assert.hs" #include "inline.hs" #include "ArrayMacros.h" #include "MachDeps.h" -import Control.Exception (assert) import Control.DeepSeq (NFData(..), NFData1(..)) import Control.Monad (when, void) import Control.Monad.IO.Class (MonadIO(..)) @@ -225,7 +225,6 @@ import Data.Semigroup (Semigroup(..)) import Data.Word (Word8) import Foreign.C.Types (CSize(..), CInt(..)) import Foreign.Ptr (plusPtr, minusPtr, nullPtr) -import Streamly.Internal.Control.Exception (assertM) import Streamly.Internal.Data.Unboxed ( ArrayContents(..) , Unboxed @@ -722,7 +721,7 @@ roundDownTo elemSize size = size - (size `mod` elemSize) {-# NOINLINE reallocAligned #-} reallocAligned :: Int -> Int -> Int -> Array a -> IO (Array a) reallocAligned elemSize alignSize newCapacityInBytes Array{..} = do - assertM (aEnd <= aBound) + assertM(aEnd <= aBound) -- Allocate new array let newCapMaxInBytes = roundUpLargeArray newCapacityInBytes @@ -776,7 +775,7 @@ reallocWith label capSizer minIncrBytes arr = do newCapBytes = capSizer oldSizeBytes newSizeBytes = oldSizeBytes + minIncrBytes safeCapBytes = max newCapBytes newSizeBytes - assertM (safeCapBytes >= newSizeBytes || error (badSize newSizeBytes)) + assertM(safeCapBytes >= newSizeBytes || error (badSize newSizeBytes)) realloc safeCapBytes arr @@ -2023,8 +2022,8 @@ fromListRev xs = fromListRevN (Prelude.length xs) xs {-# INLINE putSliceUnsafe #-} putSliceUnsafe :: MonadIO m => Array a -> Int -> Array a -> Int -> Int -> m () putSliceUnsafe src srcStartBytes dst dstStartBytes lenBytes = liftIO $ do - assertM (lenBytes <= aBound dst - dstStartBytes) - assertM (lenBytes <= aEnd src - srcStartBytes) + assertM(lenBytes <= aBound dst - dstStartBytes) + assertM(lenBytes <= aEnd src - srcStartBytes) let !(I# srcStartBytes#) = srcStartBytes !(I# dstStartBytes#) = dstStartBytes !(I# lenBytes#) = lenBytes @@ -2065,7 +2064,7 @@ spliceUnsafe dst src = let startSrc = arrStart src srcLen = aEnd src - startSrc endDst = aEnd dst - assertM (endDst + srcLen <= aBound dst) + assertM(endDst + srcLen <= aBound dst) putSliceUnsafe src startSrc dst endDst srcLen return $ dst {aEnd = endDst + srcLen} diff --git a/core/src/Streamly/Internal/Data/Parser/ParserD.hs b/core/src/Streamly/Internal/Data/Parser/ParserD.hs index beca8a1c2..40f2b5b72 100644 --- a/core/src/Streamly/Internal/Data/Parser/ParserD.hs +++ b/core/src/Streamly/Internal/Data/Parser/ParserD.hs @@ -196,12 +196,13 @@ module Streamly.Internal.Data.Parser.ParserD ) where +#include "assert.hs" + import Control.Exception (Exception) import Control.Monad (when) import Control.Monad.Catch (MonadCatch, MonadThrow(..)) import Data.Bifunctor (first) import Fusion.Plugin.Types (Fuse(..)) -import Streamly.Internal.Control.Exception (assertM) import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.SVar.Type (defState) import Streamly.Internal.Data.Either.Strict (Either'(..)) @@ -1705,17 +1706,17 @@ takeP lim (Parser pstep pinitial pextract) = Parser step initial extract IError e -> return $ IError e step (Tuple' cnt r) a = do - assertM (cnt < lim) + assertM(cnt < lim) res <- pstep r a let cnt1 = cnt + 1 case res of Partial 0 s -> do - assertM (cnt1 >= 0) + assertM(cnt1 >= 0) if cnt1 < lim then return $ Partial 0 $ Tuple' cnt1 s else Done 0 <$> pextract s Continue 0 s -> do - assertM (cnt1 >= 0) + assertM(cnt1 >= 0) if cnt1 < lim then return $ Continue 0 $ Tuple' cnt1 s -- XXX This should error out? @@ -1732,11 +1733,11 @@ takeP lim (Parser pstep pinitial pextract) = Parser step initial extract else Done 0 <$> pextract s Partial n s -> do let taken = cnt1 - n - assertM (taken >= 0) + assertM(taken >= 0) return $ Partial n $ Tuple' taken s Continue n s -> do let taken = cnt1 - n - assertM (taken >= 0) + assertM(taken >= 0) return $ Continue n $ Tuple' taken s Done n b -> return $ Done n b Error str -> return $ Error str @@ -2131,7 +2132,7 @@ manyTill (Fold fstep finitial fextract) case r of Partial n s -> return $ Partial n (ManyTillR 0 fs s) Continue n s -> do - assertM (cnt + 1 - n >= 0) + assertM(cnt + 1 - n >= 0) return $ Continue n (ManyTillR (cnt + 1 - n) fs s) Done n _ -> do b <- fextract fs @@ -2157,7 +2158,7 @@ manyTill (Fold fstep finitial fextract) case r of Partial n s -> return $ Partial n (ManyTillL 0 fs s) Continue n s -> do - assertM (cnt + 1 - n >= 0) + assertM(cnt + 1 - n >= 0) return $ Continue n (ManyTillL (cnt + 1 - n) fs s) Done n b -> do fs1 <- fstep fs b diff --git a/core/src/Streamly/Internal/Data/Parser/ParserD/Type.hs b/core/src/Streamly/Internal/Data/Parser/ParserD/Type.hs index 1f7f5dc5e..9c48304c2 100644 --- a/core/src/Streamly/Internal/Data/Parser/ParserD/Type.hs +++ b/core/src/Streamly/Internal/Data/Parser/ParserD/Type.hs @@ -207,6 +207,8 @@ module Streamly.Internal.Data.Parser.ParserD.Type ) where +#include "assert.hs" + import Control.Applicative (Alternative(..), liftA2) import Control.Exception (Exception(..)) import Control.Monad (MonadPlus(..), (>=>)) @@ -216,7 +218,6 @@ import Control.Monad.State.Class (MonadState, get, put) import Control.Monad.Catch (MonadCatch, try, throwM, MonadThrow) import Data.Bifunctor (Bifunctor(..)) import Fusion.Plugin.Types (Fuse(..)) -import Streamly.Internal.Control.Exception (assertM) import Streamly.Internal.Data.Fold.Type (Fold(..), toList) import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..)) @@ -505,15 +506,15 @@ parseDToK pstep initial extract leftover (level, count) cont = do pRes <- pstep r x case pRes of Done n b -> do - assertM (n <= cnt1) + assertM(n <= cnt1) cont (level, cnt1 - n) (K.Success n b) Error err -> cont (level, cnt1) (K.Failure err) Partial n pst1 -> do - assertM (n <= cnt1) + assertM(n <= cnt1) return $ K.Partial n (parseCont (cnt1 - n) (return pst1)) Continue n pst1 -> do - assertM (n <= cnt1) + assertM(n <= cnt1) return $ K.Continue n (parseCont (cnt1 - n) (return pst1)) parseCont cnt acc Nothing = do pst <- acc @@ -584,7 +585,7 @@ fromParserK parser0 = Parser step initial extract -- always transitions to only FPKCont. The input remains unconsumed in -- this case so we use "n + 1". step (FPKDone n b) _ = do - assertM (n == 0) + assertM(n == 0) return $ Done (n + 1) b step (FPKCont cont) a = do r <- cont (Just a) @@ -981,7 +982,7 @@ alt (Parser stepL initialL extractL) (Parser stepR initialR extractR) = case r of Partial n s -> return $ Partial n (AltParseL 0 s) Continue n s -> do - assertM (cnt + 1 - n >= 0) + assertM(cnt + 1 - n >= 0) return $ Continue n (AltParseL (cnt + 1 - n) s) Done n b -> return $ Done n b Error _ -> do @@ -1038,13 +1039,13 @@ splitMany (Parser step1 initial1 extract1) (Fold fstep finitial fextract) = let cnt1 = cnt + 1 case r of Partial n s -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) return $ Continue n (Tuple3' s (cnt1 - n) fs) Continue n s -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) return $ Continue n (Tuple3' s (cnt1 - n) fs) Done n b -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) fstep fs b >>= handleCollect (Partial n) (Done n) Error _ -> do xs <- fextract fs @@ -1098,13 +1099,13 @@ splitManyPost (Parser step1 initial1 extract1) (Fold fstep finitial fextract) = let cnt1 = cnt + 1 case r of Partial n s -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) return $ Continue n (Tuple3' s (cnt1 - n) fs) Continue n s -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) return $ Continue n (Tuple3' s (cnt1 - n) fs) Done n b -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) fstep fs b >>= handleCollect (Partial n) (Done n) Error _ -> do xs <- fextract fs @@ -1171,13 +1172,13 @@ splitSome (Parser step1 initial1 extract1) (Fold fstep finitial fextract) = let cnt1 = cnt + 1 case r of Partial n s -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) return $ Continue n (Tuple3' s (cnt1 - n) (Left fs)) Continue n s -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) return $ Continue n (Tuple3' s (cnt1 - n) (Left fs)) Done n b -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) fstep fs b >>= handleCollect (Partial n) (Done n) Error err -> return $ Error err step (Tuple3' st cnt (Right fs)) a = do @@ -1185,13 +1186,13 @@ splitSome (Parser step1 initial1 extract1) (Fold fstep finitial fextract) = let cnt1 = cnt + 1 case r of Partial n s -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) return $ Partial n (Tuple3' s (cnt1 - n) (Right fs)) Continue n s -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) return $ Continue n (Tuple3' s (cnt1 - n) (Right fs)) Done n b -> do - assertM (cnt1 - n >= 0) + assertM(cnt1 - n >= 0) fstep fs b >>= handleCollect (Partial n) (Done n) Error _ -> Done cnt1 <$> fextract fs diff --git a/core/src/assert.hs b/core/src/assert.hs new file mode 100644 index 000000000..e679bf0d6 --- /dev/null +++ b/core/src/assert.hs @@ -0,0 +1,6 @@ +-- A convenient macro to assert in a do block. We cannot define this as a +-- Haskell function because then the compiler reports the assert location +-- inside the wrapper function rather than the original location. + +import Control.Exception (assert) +#define assertM(p) assert (p) (return ()) diff --git a/src/assert.hs b/src/assert.hs new file mode 100644 index 000000000..e679bf0d6 --- /dev/null +++ b/src/assert.hs @@ -0,0 +1,6 @@ +-- A convenient macro to assert in a do block. We cannot define this as a +-- Haskell function because then the compiler reports the assert location +-- inside the wrapper function rather than the original location. + +import Control.Exception (assert) +#define assertM(p) assert (p) (return ()) diff --git a/streamly.cabal b/streamly.cabal index 11f9f1112..9774d8951 100644 --- a/streamly.cabal +++ b/streamly.cabal @@ -85,6 +85,7 @@ extra-source-files: src/Streamly/Internal/Data/Array/ArrayMacros.h src/Streamly/Internal/FileSystem/Event/Darwin.h + src/assert.hs src/config.h.in src/inline.hs test/Streamly/Test/Data/*.hs @@ -124,11 +125,12 @@ extra-source-files: -- This is temporary as we will soon break this package out core/configure core/configure.ac + core/src/assert.hs + core/src/config.h.in + core/src/inline.hs core/src/Streamly/Internal/Data/Stream/Instances.hs core/src/Streamly/Internal/Data/Array/ArrayMacros.h - core/src/inline.hs core/src/Streamly/Internal/Data/Time/Clock/config-clock.h - core/src/config.h.in core/src/Streamly/Internal/BaseCompat.hs core/src/Streamly/Internal/Control/Exception.hs core/src/Streamly/Internal/Control/Monad.hs