assert (empty) → 0.0.1.0

raw patch · 5 files changed

+180/−0 lines, 5 filesdep +Cabaldep +assertdep +basesetup-changed

Dependencies added: Cabal, assert, base, directory, filepath, system-posix-redirect

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• assert.cabal +45/−0
• src/Control/Exception/Assert.hs +72/−0
• tests/rewrite.hs +31/−0

@@ -0,0 +1,30 @@+Copyright (c) 2013, Liyang HU++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Liyang HU nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,45 @@+name:           assert+version:        0.0.1.0+synopsis:       Helpers for Control.Exception.assert+description:+    GHC supports compile-time toggling of run-time assertions via the+    @-fignore-asserts@ flag, which only effects a behavioural change in+    'Control.Exception.assert'. Furthermore the reported location only gives+    the use site of the aforementioned, making it difficult to abstract over+    and hence cumbersome to use.+    .+    This package aims to make assertions more convenient, and also provides+    a rule to rewrite assertions to 'id' when @-fignore-asserts@ is used.+homepage:       https://github.com/liyang/assert+license:        BSD3+license-file:   LICENSE+author:         Liyang HU+maintainer:     assert@liyang.hu+copyright:      © 2013 Liyang HU+category:       Control+build-type:     Simple+cabal-version:  >= 1.8+stability:      experimental++source-repository head+    type:       git+    location:   http://github.com/liyang/assert++library+    hs-source-dirs: src+    exposed-modules:+        Control.Exception.Assert+    build-depends:+        base >= 4 && <= 9000+    ghc-options: -Wall++test-suite rewrite+    type: exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is: rewrite.hs+    build-depends: assert, base, Cabal, directory, filepath,+        system-posix-redirect >= 1.0.0.1+    ghc-options: -Wall -fignore-asserts++-- vim: et sw=4 ts=4 sts=4:+

@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Control.Exception.Assert+    ( module Control.Exception.Assert+    , assert+    ) where++import Prelude+import Control.Applicative+import Control.Exception+import Data.Data++-- | A distict 'Exception' from 'AssertionFailed', so that we stop fudging+-- the exception message after the first 'mapException'.+--+-- The name comes from abbreviating ‘assert’ and translating the result to+-- my native tongue.+newtype Arse = Arse String deriving (Typeable)+instance Show Arse where show (Arse s) = s+instance Exception Arse where+    fromException se = do+        AssertionFailed failure <- fromException se+        return (Arse failure)++-- | Generic helper for 'assert' that includes a descriptive message to the+-- 'AssertFailure' exception if thrown. Use this to build your own 'assert'+-- helpers, such as 'byOrd'. A rule is included which rewrites+-- 'assertMessage' to 'id' when compiling with @-fignore-asserts@.+{-# INLINE [1] assertMessage #-}+{-# RULES "assertMessage" forall name msg.+    assertMessage name msg (\x -> x) = id #-}+assertMessage :: String -> String -> (a -> a) -> a -> a+assertMessage name msg arse = mapException describe . arse where+    describe (AssertionFailed failure) = Arse $+        oneline failure ++ " \"" ++ name ++ "\", " ++ msg+    oneline = filter ((&&) <$> (/=) '\n' <*> (/=) '\r')++-- | Assert that two values are equal.+--+-- >>> byEq assert "Bool" False True ()+-- *** Exception: … Assertion failed "Bool", False ≠ True+{-# INLINE byEq #-}+byEq :: (Eq x, Show x) => (Bool -> a -> a) -> String ->+    x -> x -> a -> a+byEq arse name x y = assertMessage name+    (show x ++ " ≠ " ++ show y) (arse $ x == y)++-- | Assert that two values obey the given 'Ordering'.+--+-- >>> byOrd assert "Int" LT 0 1 ()+-- ()+{-# INLINE byOrd #-}+byOrd :: (Ord x, Show x) => (Bool -> a -> a) -> String ->+    Ordering -> x -> x -> a -> a+byOrd arse name o x y = assertMessage name+    (show x ++ no ++ show y) (arse $ o == compare x y)+  where+    no = case o of+        LT -> " ≮ "+        EQ -> " ≠ "+        GT -> " ≯ "++-- | Assert that a value satisfies the given predicate.+--+-- >>> byPred assert "Odd" odd 4 ()+-- *** Exception: … Assertion failed "Odd", 4+{-# INLINE byPred #-}+byPred :: (Show x) => (Bool -> a -> a) -> String ->+    (x -> Bool) -> x -> a -> a+byPred arse name p x = assertMessage name (show x) (arse $ p x)+

@@ -0,0 +1,31 @@+import Prelude+import Control.Exception.Assert+import Control.Monad+import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup+import System.Directory+import System.Exit+import System.FilePath+import System.Posix.Redirect++main :: IO ()+main = byPred assert "false" id False $ do+    defaultMainWithHooksArgs simpleUserHooks+        { buildHook = hook }+        [ "build", "--ghc-option=-ddump-rule-firings" ]+    putStrLn "http://youtu.be/HOLYYYsFqcI"++hook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()+hook pd lbi uh bf = do+    forM_ ["hi", "o"] $ \ suf -> removeFile $+        buildDir lbi </> "rewrite" </> "rewrite-tmp" </> "Main" <.> suf+    (err, (out, _)) <- redirectStderr . redirectStdout $+        buildHook simpleUserHooks pd lbi uh bf+    let combined = err ++ out+    unless ("Rule fired: assertMessage" `elem` lines combined) $ do+        putStr combined+        putStrLn "Rule NOT fired: assertMessage"+        exitWith (ExitFailure 1)+