{-# OPTIONS -fglasgow-exts  -XUndecidableInstances  #-}
module Test.Properties(verify, Property(..), Properties(..), properties,with) where
import Debug.Trace
import Control.Concurrent.MVar
import System.IO.Unsafe
import Control.Exception(evaluate)
import Data.Maybe(catMaybes)
import Control.Monad(when)


import Debug.Trace

debug a b= trace b a

-- | A labeled property includes a string label and an expression
data Property a = Property String a

-- |Properties is a convenient way to express list of properties with
-- the same arity.
data Properties a b c=
 Properties{unary   :: [Property (a -> Bool)]
           ,binary  :: [Property ((a,b) -> Bool)]
           ,ternary :: [Property ((a,b,c) -> Bool)]
 }


-- | empty properties:   @properties= Properties [] [] []@
properties:: forall a b c. Properties a b c
properties= Properties [] [] []




inTest= unsafePerformIO $ newMVar True  

-- | to improve readability: @with= ($)@
with :: (a -> b) -> a -> b
with= ($)


-- |Check a list of properties.
-- when a property is violated, a trace error is printed
-- at the end i return the first value, just like (flip trace)
-- must be used as opeator:
--
--  @<expression>  `verify` <properties> `with` <value tuple> @
--
-- Example:
--
--    @stringProperty= `Property` \"length\" (\\(x, y)-> length (x++y)== length x + length y)
--
--    main= do
--        let s=  \"hello \"
--        let s2= \"world\"
--        print $ s++ s2        \``verify`\` stringProperty \``with`\`(s,s2)
--        print \"that's all!\"@
--
-- It is possible to check quickCheck style properties. The same example with a quickCheck style property:
--
--    @quickCheckProperty x y=  length (x++y)== length x + length y
--
--    main= do
--        let s=  \"hello \"
--        let s2= \"world\"
--        print $ s++ s2        \``verify`\` [Property \"stringSumLength\" $ uncurry quickCheckProperty] \``with`\`(s,s2)
--        print \"that's all!\"@
verify :: Show b => a -> [Property (b -> Bool)] -> b -> a
verify res properties  v =(unsafePerformIO $ check properties  v) `seq` res where
 check properties  v =
    do
        int <- tryTakeMVar inTest
        if int == Nothing then return ()
         else do
         errors <- evaluate$  unlines $ catMaybes $ map ( test  v) properties
         when (not $ null  errors) ( putTraceMsg errors)
         putMVar inTest False
         return ()
   where
   test v (Property n f) = if  f v then  Nothing
                       else  Just $ "violated property "++n ++ " with value/s: " ++ show v