vty-examples-5.5.0: Verify.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
module Verify ( module Verify
              , module Control.Applicative
              , module Control.DeepSeq
              , module Control.Exception
              , module Control.Monad
              , module Test.QuickCheck
              , module Test.QuickCheck.Modifiers
              , module Text.Printf
              , succeeded
              , failed
              , monadicIO
              , liftIO
              , liftBool
              , Test(..)
              , Prop.Result(..)
              )
    where

import Control.Exception ( bracket, try, SomeException(..) )

import Distribution.TestSuite hiding ( Result(..) )
import qualified Distribution.TestSuite as TS

import Test.QuickCheck hiding ( Result(..) )
import qualified Test.QuickCheck as QC
import Test.QuickCheck.Modifiers
import Test.QuickCheck.Property hiding ( Result(..) )
import qualified Test.QuickCheck.Property as Prop
import Test.QuickCheck.Monadic ( monadicIO ) 

import Text.Printf

import qualified Codec.Binary.UTF8.String as UTF8

import Control.Applicative hiding ( (<|>) )
import Control.DeepSeq
import Control.Monad ( forM, mapM, mapM_, forM_ )
import Control.Monad.State.Strict

import Numeric ( showHex )

verify :: Testable t => String -> t -> Test
verify testName p = Test $ TestInstance
  { name = testName
  , run = do
    qcResult <- quickCheckWithResult (stdArgs {chatty = False}) p
    case qcResult of
        QC.Success {..} -> return $ Finished TS.Pass
        QC.Failure {numShrinks,reason} -> return $ Finished
            $ TS.Fail $ "After " 
                      ++ show numShrinks ++ " shrinks determined failure to be: "
                      ++ show reason
        _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message"
  , tags = []
  , options = []
  , setOption = \_ _ -> Left "no options supported"
  }

data SingleColumnChar = SingleColumnChar Char
    deriving (Show, Eq)

instance Arbitrary SingleColumnChar where
    arbitrary = elements $ map SingleColumnChar [toEnum 0x21 .. toEnum 0x7E]

data DoubleColumnChar = DoubleColumnChar Char
    deriving (Eq)

instance Show DoubleColumnChar where
    show (DoubleColumnChar c) = "(0x" ++ showHex (fromEnum c) "" ++ ") ->" ++ UTF8.encodeString [c]

instance Arbitrary DoubleColumnChar where
    arbitrary = elements $ map DoubleColumnChar $
           [ toEnum 0x3040 .. toEnum 0x3098 ]
        ++ [ toEnum 0x309B .. toEnum 0xA4CF ]

liftIOResult :: Testable prop => IO prop -> Property
liftIOResult = ioProperty

#if __GLASGOW_HASKELL__ <= 701
instance Random Word where
    random g = 
        let (i :: Int, g') = random g
        in (toEnum i, g')
    randomR (l,h) g =
        let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g
        in (toEnum i, g')
#endif

data Bench where
    Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench