assert-failure (empty) → 0.1

raw patch · 5 files changed

+213/−0 lines, 5 filesdep +basedep +pretty-showdep +textsetup-changed

Dependencies added: base, pretty-show, text

Files

• Control/Exception/Assert/Sugar.hs +122/−0
• LICENSE +27/−0
• README.md +25/−0
• Setup.hs +2/−0
• assert-failure.cabal +37/−0

@@ -0,0 +1,122 @@+{-# LANGUAGE RankNTypes #-}+-- | Syntactic sugar that improves the usability of 'Control.Exception.assert'+-- and 'error'.+--+-- This is actually a bunch of hacks wrapping the original @assert@ function,+-- which is, as of GHC 7.8, the only simple way of obtaining source positions.+-- The original @assert@ function is here re-exported for convenience.+--+-- Make sure to enable assertions for your cabal package, e.g., by setting+--+-- > ghc-options: -fno-ignore-asserts+--+-- in your .cabal file. Otherwise, some of the functions will have+-- no effect at all.+module Control.Exception.Assert.Sugar+  ( assert, blame, failure, twith, swith, allB, skip, forceEither+  ) where++import Control.Exception (assert)+import Data.Text (Text)+import Debug.Trace (trace)+import qualified Text.Show.Pretty as Show.Pretty (ppShow)++infix 1 `blame`+-- | If the condition fails, display the value blamed for the failure.+-- Used as in+--+-- > assert (age >= 0 `blame` age) $ savings / (99 - age)+blame :: Show a => Bool -> a -> Bool+{-# INLINE blame #-}+blame True _ = True+blame False blamed = trace (blameMessage blamed) False++blameMessage :: Show a => a -> String+{-# NOINLINE blameMessage #-}+blameMessage blamed = "Contract failed and the following is to blame:\n  "+                      ++ Show.Pretty.ppShow blamed++infix 1 `failure`+-- | Like 'error', but shows the source position and also+-- the value to blame for the failure. To be used as in+--+-- > case xs of+-- >   0 : _ -> assert `failure` (xs, "has an insignificant zero")+failure :: Show a => (forall x. Bool -> x -> x) -> a -> b+{-# NOINLINE failure #-}+failure asrt blamed =+  let s = "Internal failure occurred and the following is to blame:\n  "+          ++ Show.Pretty.ppShow blamed+  in trace s+     $ asrt False+     $ error "Assert.failure: no error position (upgrade to GHC >= 7.4)"++infix 2 `twith`+-- | Syntactic sugar for the pair operation, to be used in 'blame'+-- and 'failure' as in+--+-- > assert (age >= 0 `blame` "negative age" `twith` age) $ savings / (99 - age)+--+-- or+--+-- > case xs of+-- >   0 : _ -> assert `failure` "insignificant zero" `twith` xs+--+-- Fixing the first component of the pair to @Text@ prevents warnings+-- about defaulting.+twith :: Text -> b -> (Text, b)+{-# INLINE twith #-}+twith t b = (t, b)++infix 2 `swith`+-- | The same as 'twith', but for 'String', not 'Text'.+--+-- Syntactic sugar for the pair operation, to be used in 'blame'+-- and 'failure' as in+--+-- > assert (age >= 0 `blame` "negative age" `swith` age) $ savings / (99 - age)+--+-- or+--+-- > case xs of+-- >   0 : _ -> assert `failure` "insignificant zero" `swith` xs+--+-- Fixing the first component of the pair to @String@ prevents warnings+-- about defaulting.+swith :: String -> b -> (String, b)+{-# INLINE swith #-}+swith t b = (t, b)++-- | Like 'List.all', but if the predicate fails, blame all the list elements+-- and especially those for which it fails. To be used as in+--+-- > assert (allB (<= height) [yf, y1, y2])+allB :: Show a => (a -> Bool) -> [a] -> Bool+{-# INLINE allB #-}+allB predicate l = blame (all predicate l) $ allBMessage predicate l++allBMessage :: Show a => (a -> Bool) -> [a] -> String+{-# NOINLINE allBMessage #-}+allBMessage predicate l = Show.Pretty.ppShow (filter (not . predicate) l)+                          ++ " in the context of "+                          ++ Show.Pretty.ppShow l++-- | To be used in place of the verbose @(return ())@, as in+--+-- > do k <- getK7 r+-- >    assert (k <= maxK `blame` "K7 too large" `twith` r) skip+-- >    return $ k >= averageK+skip :: Monad m => m ()+{-# INLINE skip #-}+skip = return ()++infix 1 `forceEither`+-- | Assuming that @Left@ signifies an error condition,+-- check the @Either@ value and, if @Left@ is encountered,+-- fail outright and show the error message. Used as in+--+-- > assert `forceEither` parseOrFailWithMessage code+forceEither :: Show a => (forall x. Bool -> x -> x) -> Either a b -> b+{-# NOINLINE forceEither #-}+forceEither asrt (Left a)  = asrt `failure` a+forceEither _    (Right b) = b

@@ -0,0 +1,27 @@+Copyright (c) 2013, Mikolaj Konarski+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 the {organization} nor the names of its+  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 HOLDER 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,25 @@+assert-failure [![Build Status](https://secure.travis-ci.org/Mikolaj/assert-failure.png)](http://travis-ci.org/Mikolaj/assert-failure)+==============++This library contains syntactic sugar that improves+the usability of 'assert' and 'error'.+This is actually a bunch of hacks wrapping the original 'assert' function,+which is, as of GHC 7.8, the only simple way of obtaining source positions.+The original 'assert' function is here re-exported for convenience.++Make sure to enable assertions for your cabal package, e.g., by setting++    ghc-options: -fno-ignore-asserts++in your .cabal file. Otherwise, some of the functions will have+no effect at all.++The library is available from [Hackage] [1] and it's homepage+and issue tracker is on [github] [2]. The library emerged from the tons+of assertions (augmented by comments and printouts) and 'error' calls+(marked by unique strings to overcome their lack of source position)+in the [LambdaHack] [3] game engine.++[1]: http://hackage.haskell.org/package/assert-failure+[2]: https://github.com/Mikolaj/assert-failure+[3]: http://hackage.haskell.org/package/LambdaHack

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

@@ -0,0 +1,37 @@+name:          assert-failure+version:       0.1+synopsis:      Syntactic sugar improving 'assert' and 'error'+description:   This library contains syntactic sugar that improves+               the usability of 'assert' and 'error'.+               This is actually a bunch of hacks wrapping the original+               'assert' function, see inside.+homepage:      https://github.com/Mikolaj/assert-failure+bug-reports:   https://github.com/Mikolaj/assert-failure/issues+license:       BSD3+license-file:  LICENSE+tested-with:   GHC == 7.4.2, GHC == 7.6.3+extra-source-files: LICENSE, README.md+author:        Mikolaj Konarski+maintainer:    Mikolaj Konarski <mikolaj.konarski@funktory.com>+category:      Control, Contract+build-type:    Simple+cabal-version: >= 1.10++source-repository head+  type:               git+  location:           git://github.com/Mikolaj/assert-failure.git++library+  exposed-modules:    Control.Exception.Assert.Sugar+--  other-modules:+  build-depends:      base                 >= 4        && < 5,+                      text                 >= 0.11.2.3 && < 2,+                      pretty-show          >= 1.6      && < 1.6.2++  default-language:   Haskell2010+  default-extensions: MonoLocalBinds, ScopedTypeVariables,+                      BangPatterns, RecordWildCards, NamedFieldPuns+  other-extensions:   OverloadedStrings+  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas+  ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude+  ghc-options:        -fno-ignore-asserts -funbox-strict-fields