2018-01-05 01:05:12 +03:00
|
|
|
-- Just another toy example
|
|
|
|
|
2018-01-05 22:12:38 +03:00
|
|
|
{-# LANGUAGE CPP #-}
|
2018-01-05 01:05:12 +03:00
|
|
|
{-# LANGUAGE DataKinds #-}
|
|
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE InstanceSigs #-}
|
|
|
|
{-# LANGUAGE LambdaCase #-}
|
2018-05-30 04:00:10 +03:00
|
|
|
{-# LANGUAGE TypeOperators #-}
|
2018-01-05 01:05:12 +03:00
|
|
|
|
2021-01-26 03:55:07 +03:00
|
|
|
import Control.Monad (replicateM)
|
2018-01-05 01:05:12 +03:00
|
|
|
import GHC.Generics
|
2021-01-26 03:55:07 +03:00
|
|
|
import Test.QuickCheck (Arbitrary(..), Gen, quickCheck, sample, generate)
|
2018-01-05 01:05:12 +03:00
|
|
|
|
2021-01-26 03:55:07 +03:00
|
|
|
import Generic.Random (genericArbitraryG, (:+)(..), (%))
|
2018-01-05 01:05:12 +03:00
|
|
|
|
|
|
|
data MyType
|
|
|
|
= OneThing Int
|
|
|
|
| TwoThings Double String
|
|
|
|
| ThreeThings (Maybe Integer) [()] (Bool -> Word)
|
|
|
|
deriving (Show, Generic)
|
|
|
|
|
2018-05-30 04:00:10 +03:00
|
|
|
custom :: Gen (Maybe Integer) :+ ()
|
|
|
|
custom = (Just <$> arbitrary) :+ ()
|
2018-01-05 01:05:12 +03:00
|
|
|
|
|
|
|
instance Arbitrary MyType where
|
|
|
|
arbitrary :: Gen MyType
|
|
|
|
arbitrary = genericArbitraryG custom (1 % 4 % 4 % ())
|
|
|
|
-- arbitrary = frequency
|
|
|
|
-- [ (1, OneThing <$> arbitrary)
|
|
|
|
-- , (4, TwoThings <$> arbitrary <*> arbitrary)
|
|
|
|
-- , (4, ThreeThings <$> (Just <$> arbitrary) <*> arbitrary <*> arbitrary)
|
|
|
|
-- ]
|
|
|
|
|
2018-01-05 22:12:38 +03:00
|
|
|
main :: IO ()
|
|
|
|
#ifndef BENCHMODE
|
2018-01-05 01:05:12 +03:00
|
|
|
main = do
|
|
|
|
-- Print some examples
|
2021-01-26 03:55:07 +03:00
|
|
|
sample (arbitrary :: Gen MyType)
|
2018-01-05 01:05:12 +03:00
|
|
|
|
|
|
|
-- Check the property that ThreeThings contains three things.
|
|
|
|
quickCheck $ \case
|
|
|
|
ThreeThings Nothing _ _ -> False
|
|
|
|
_ -> True
|
2018-01-05 22:12:38 +03:00
|
|
|
#else
|
|
|
|
-- Quick and dirty benchmark
|
|
|
|
main = do
|
2021-01-26 03:55:07 +03:00
|
|
|
xs <- generate (replicateM 1000000 (arbitrary :: Gen MyType))
|
2018-01-05 22:12:38 +03:00
|
|
|
go xs
|
|
|
|
where
|
|
|
|
go [] = print ()
|
|
|
|
go (x : xs) = x `seq` go xs
|
|
|
|
#endif
|
2018-01-05 01:05:12 +03:00
|
|
|
|
|
|
|
-- Ew. Sorry.
|
|
|
|
instance Show a => Show (Bool -> a) where
|
|
|
|
show f = "<True -> " ++ show (f True) ++ ",False -> " ++ show (f False) ++ ">"
|