git.iko.soy/vty
on ae06339 help sign in
vty/test/Verify.hs
86 lines 2.4 kB history raw
1{-# LANGUAGE TypeSynonymInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE StandaloneDeriving #-}
4{-# LANGUAGE DisambiguateRecordFields #-}
5{-# LANGUAGE NamedFieldPuns #-}
6module Verify ( module Verify
7 , module Test.QuickCheck
8 , succeeded
9 , failed
10 , result
11 , Result(..)
12 , monadicIO
13 , liftIO
14 , liftIOResult
15 , liftResult
16 , liftBool
17 )
18 where
20import Test.QuickCheck hiding ( Result(..) )
21import qualified Test.QuickCheck as QC
22import Test.QuickCheck.Property
23import Test.QuickCheck.Monadic ( monadicIO )
25import qualified Codec.Binary.UTF8.String as UTF8
27import Control.Applicative
28import Control.Monad.State.Strict
29import Control.Monad.Trans ( liftIO )
31import Data.IORef
32import Data.Word
34import Numeric ( showHex )
36import System.IO
38type Test = StateT TestState IO
40instance Applicative Test where
41 pure = return
42 ( <*> ) = ap
44data TestState = TestState
45 { results_ref :: IORef [QC.Result]
46 }
48run_test :: Test () -> IO ()
49run_test t = do
50 s <- newIORef [] >>= return . TestState
51 s' <- runStateT t s >>= return . snd
52 results <- readIORef $ results_ref s'
53 let fail_results = [ fail_result | fail_result@(QC.Failure {}) <- results ]
54 case fail_results of
55 [] -> putStrLn "state: PASS"
56 rs -> do
57 putStrLn "state: FAIL"
58 putStrLn $ "fail_count: " ++ show (length rs)
60verify :: Testable prop => String -> prop -> Test QC.Result
61verify prop_name prop = do
62 liftIO $ putStrLn $ "verify " ++ prop_name
63 get >>= \s -> do
64 r <- liftIO $ quickCheckResult prop
65 liftIO $ modifyIORef (results_ref s) (\rs -> r : rs)
66 return r
68data SingleColumnChar = SingleColumnChar Char
69 deriving (Show, Eq)
71instance Arbitrary SingleColumnChar where
72 arbitrary = elements $ map SingleColumnChar [toEnum 0x21 .. toEnum 0x7E]
74data DoubleColumnChar = DoubleColumnChar Char
75 deriving (Eq)
77instance Show DoubleColumnChar where
78 show (DoubleColumnChar c) = "(0x" ++ showHex (fromEnum c) "" ++ ") ->" ++ UTF8.encodeString [c]
80instance Arbitrary DoubleColumnChar where
81 arbitrary = elements $ map DoubleColumnChar $
82 [ toEnum 0x3040 .. toEnum 0x3098 ]
83 ++ [ toEnum 0x309B .. toEnum 0xA4CF]
85instance Arbitrary Word where
86 arbitrary = choose (0, 1024) >>= return . toEnum