{-# LANGUAGE TypeOperators, GADTs, CPP, Rank2Types #-}
#ifndef NO_SAFE_HASKELL
{-# LANGUAGE Safe #-}
#endif
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
#endif

#ifndef NO_GENERICS
{-# LANGUAGE DefaultSignatures, FlexibleContexts #-}
#endif

#ifndef NO_POLYKINDS
{-# LANGUAGE PolyKinds #-}
#endif

-- | Generation of random shrinkable, showable functions.
-- See the paper \"Shrinking and showing functions\" by Koen Claessen.
--
-- __Note__: most of the contents of this module are re-exported by
-- "Test.QuickCheck". You probably do not need to import it directly.
--
-- Example of use:
--
-- >>> :{
-- >>> let prop :: Fun String Integer -> Bool
-- >>>     prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant"
-- >>> :}
-- >>> quickCheck prop
-- *** Failed! Falsified (after 3 tests and 134 shrinks):
-- {"elephant"->1, "monkey"->1, _->0}
--
-- To generate random values of type @'Fun' a b@,
-- you must have an instance @'Function' a@.
-- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise,
-- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'.
-- See the @'Function' [a]@ instance for an example of the latter.
module Test.QuickCheck.Function
  ( Fun(..)
  , applyFun
  , apply
  , applyFun2
  , applyFun3
  , (:->)
  , Function(..)
  , functionMap
  , functionShow
  , functionIntegral
  , functionRealFrac
  , functionBoundedEnum
  , functionVoid
  , functionMapWith
  , functionEitherWith
  , functionPairWith
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
  , pattern Fn
  , pattern Fn2
  , pattern Fn3
#endif
  )
 where

--------------------------------------------------------------------------
-- imports

import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Poly

import Control.Applicative
import Data.Char
import Data.Word
import Data.List( intersperse )
import Data.Ratio
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Sequence as Sequence
import qualified Data.Tree as Tree
import Data.Int
import Data.Complex
import Data.Foldable(toList)
import Data.Functor.Identity
import qualified Data.Monoid as Monoid

#ifndef NO_FIXED
import Data.Fixed
#endif

#ifndef NO_GENERICS
import GHC.Generics hiding (C)
#endif

--------------------------------------------------------------------------
-- concrete functions

-- | The type of possibly partial concrete functions
data a :-> c where
  Pair  :: (a :-> (b :-> c)) -> ((a,b) :-> c)
  (:+:) :: (a :-> c) -> (b :-> c) -> (Either a b :-> c)
  Unit  :: c -> (() :-> c)
  Nil   :: a :-> c
  Table :: Eq a => [(a,c)] -> (a :-> c)
  Map   :: (a -> b) -> (b -> a) -> (b :-> c) -> (a :-> c)

instance Functor ((:->) a) where
  fmap :: (a -> b) -> (a :-> a) -> a :-> b
fmap a -> b
f (Pair a :-> (b :-> a)
p)    = (a :-> (b :-> b)) -> (a, b) :-> b
forall a b c. (a :-> (b :-> c)) -> (a, b) :-> c
Pair (((b :-> a) -> b :-> b) -> (a :-> (b :-> a)) -> a :-> (b :-> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (b :-> a) -> b :-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) a :-> (b :-> a)
p)
  fmap a -> b
f (a :-> a
p:+:b :-> a
q)     = (a -> b) -> (a :-> a) -> a :-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f a :-> a
p (a :-> b) -> (b :-> b) -> Either a b :-> b
forall a c b. (a :-> c) -> (b :-> c) -> Either a b :-> c
:+: (a -> b) -> (b :-> a) -> b :-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f b :-> a
q
  fmap a -> b
f (Unit a
c)    = b -> () :-> b
forall c. c -> () :-> c
Unit (a -> b
f a
c)
  fmap a -> b
f a :-> a
Nil         = a :-> b
forall a c. a :-> c
Nil
  fmap a -> b
f (Table [(a, a)]
xys) = [(a, b)] -> a :-> b
forall a c. Eq a => [(a, c)] -> a :-> c
Table [ (a
x,a -> b
f a
y) | (a
x,a
y) <- [(a, a)]
xys ]
  fmap a -> b
f (Map a -> b
g b -> a
h b :-> a
p) = (a -> b) -> (b -> a) -> (b :-> b) -> a :-> b
forall a b c. (a -> b) -> (b -> a) -> (b :-> c) -> a :-> c
Map a -> b
g b -> a
h ((a -> b) -> (b :-> a) -> b :-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f b :-> a
p)

instance (Show a, Show b) => Show (a:->b) where
  show :: (a :-> b) -> String
show a :-> b
p = (a :-> b) -> Maybe b -> String
forall a b. (Show a, Show b) => (a :-> b) -> Maybe b -> String
showFunction a :-> b
p Maybe b
forall a. Maybe a
Nothing

-- only use this on finite functions
showFunction :: (Show a, Show b) => (a :-> b) -> Maybe b -> String
showFunction :: (a :-> b) -> Maybe b -> String
showFunction a :-> b
p Maybe b
md =
  String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " ( [ a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"->" String -> ShowS
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Show a => a -> String
show b
c
                                    | (a
x,b
c) <- (a :-> b) -> [(a, b)]
forall a c. (a :-> c) -> [(a, c)]
table a :-> b
p
                                    ]
                                 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"_->" String -> ShowS
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Show a => a -> String
show b
d
                                    | Just b
d <- [Maybe b
md]
                                    ] )) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"

-- turning a concrete function into an abstract function (with a default result)
abstract :: (a :-> c) -> c -> (a -> c)
abstract :: (a :-> c) -> c -> a -> c
abstract (Pair a :-> (b :-> c)
p)    c
d (x,y) = (a :-> c) -> c -> a -> c
forall a c. (a :-> c) -> c -> a -> c
abstract (((b :-> c) -> c) -> (a :-> (b :-> c)) -> a :-> c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\b :-> c
q -> (b :-> c) -> c -> b -> c
forall a c. (a :-> c) -> c -> a -> c
abstract b :-> c
q c
d b
y) a :-> (b :-> c)
p) c
d a
x
abstract (a :-> c
p :+: b :-> c
q)   c
d a
exy   = (a -> c) -> (b -> c) -> Either a b -> c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((a :-> c) -> c -> a -> c
forall a c. (a :-> c) -> c -> a -> c
abstract a :-> c
p c
d) ((b :-> c) -> c -> b -> c
forall a c. (a :-> c) -> c -> a -> c
abstract b :-> c
q c
d) a
Either a b
exy
abstract (Unit c
c)    c
_ a
_     = c
c
abstract a :-> c
Nil         c
d a
_     = c
d
abstract (Table [(a, c)]
xys) c
d a
x     = [c] -> c
forall a. [a] -> a
head ([c
y | (a
x',c
y) <- [(a, c)]
xys, a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x'] [c] -> [c] -> [c]
forall a. [a] -> [a] -> [a]
++ [c
d])
abstract (Map a -> b
g b -> a
_ b :-> c
p) c
d a
x     = (b :-> c) -> c -> b -> c
forall a c. (a :-> c) -> c -> a -> c
abstract b :-> c
p c
d (a -> b
g a
x)

-- generating a table from a concrete function
table :: (a :-> c) -> [(a,c)]
table :: (a :-> c) -> [(a, c)]
table (Pair a :-> (b :-> c)
p)    = [ ((a
x,b
y),c
c) | (a
x,b :-> c
q) <- (a :-> (b :-> c)) -> [(a, b :-> c)]
forall a c. (a :-> c) -> [(a, c)]
table a :-> (b :-> c)
p, (b
y,c
c) <- (b :-> c) -> [(b, c)]
forall a c. (a :-> c) -> [(a, c)]
table b :-> c
q ]
table (a :-> c
p :+: b :-> c
q)   = [ (a -> Either a b
forall a b. a -> Either a b
Left a
x, c
c) | (a
x,c
c) <- (a :-> c) -> [(a, c)]
forall a c. (a :-> c) -> [(a, c)]
table a :-> c
p ]
                 [(Either a b, c)] -> [(Either a b, c)] -> [(Either a b, c)]
forall a. [a] -> [a] -> [a]
++ [ (b -> Either a b
forall a b. b -> Either a b
Right b
y,c
c) | (b
y,c
c) <- (b :-> c) -> [(b, c)]
forall a c. (a :-> c) -> [(a, c)]
table b :-> c
q ]
table (Unit c
c)    = [ ((), c
c) ]
table a :-> c
Nil         = []
table (Table [(a, c)]
xys) = [(a, c)]
xys
table (Map a -> b
_ b -> a
h b :-> c
p) = [ (b -> a
h b
x, c
c) | (b
x,c
c) <- (b :-> c) -> [(b, c)]
forall a c. (a :-> c) -> [(a, c)]
table b :-> c
p ]

--------------------------------------------------------------------------
-- Function

-- | The class @Function a@ is used for random generation of showable
-- functions of type @a -> b@.
--
-- There is a default implementation for 'function', which you can use
-- if your type has structural equality. Otherwise, you can normally
-- use 'functionMap' or 'functionShow'.
class Function a where
  function :: (a->b) -> (a:->b)
#ifndef NO_GENERICS
  default function :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b)
  function = (a -> b) -> a :-> b
forall a b. (Generic a, GFunction (Rep a)) => (a -> b) -> a :-> b
genericFunction
#endif

-- basic instances

-- | Provides a 'Function' instance for types with 'Bounded' and 'Enum'.
-- Use only for small types (i.e. not integers): creates
-- the list @['minBound'..'maxBound']@!
functionBoundedEnum :: (Eq a, Bounded a, Enum a) => (a->b) -> (a:->b)
functionBoundedEnum :: (a -> b) -> a :-> b
functionBoundedEnum a -> b
f = [(a, b)] -> a :-> b
forall a c. Eq a => [(a, c)] -> a :-> c
Table [(a
x,a -> b
f a
x) | a
x <- [a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound]]

-- | Provides a 'Function' instance for types with 'RealFrac'.
functionRealFrac :: RealFrac a => (a->b) -> (a:->b)
functionRealFrac :: (a -> b) -> a :-> b
functionRealFrac = (a -> Rational) -> (Rational -> a) -> (a -> b) -> a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap a -> Rational
forall a. Real a => a -> Rational
toRational Rational -> a
forall a. Fractional a => Rational -> a
fromRational

-- | Provides a 'Function' instance for types with 'Integral'.
functionIntegral :: Integral a => (a->b) -> (a:->b)
functionIntegral :: (a -> b) -> a :-> b
functionIntegral = (a -> Integer) -> (Integer -> a) -> (a -> b) -> a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer -> a
forall a. Num a => Integer -> a
fromInteger

-- | Provides a 'Function' instance for types with 'Show' and 'Read'.
functionShow :: (Show a, Read a) => (a->c) -> (a:->c)
functionShow :: (a -> c) -> a :-> c
functionShow a -> c
f = (a -> String) -> (String -> a) -> (a -> c) -> a :-> c
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap a -> String
forall a. Show a => a -> String
show String -> a
forall a. Read a => String -> a
read a -> c
f

-- | Provides a 'Function' instance for types isomorphic to 'Data.Void.Void'.
--
-- An actual @'Function' 'Data.Void.Void'@ instance is defined in
-- @quickcheck-instances@.
functionVoid :: (forall b. void -> b) -> void :-> c
functionVoid :: (forall b. void -> b) -> void :-> c
functionVoid forall b. void -> b
_ = void :-> c
forall a c. a :-> c
Nil

-- | The basic building block for 'Function' instances.
-- Provides a 'Function' instance by mapping to and from a type that
-- already has a 'Function' instance.
functionMap :: Function b => (a->b) -> (b->a) -> (a->c) -> (a:->c)
functionMap :: (a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap = ((b -> c) -> b :-> c)
-> (a -> b) -> (b -> a) -> (a -> c) -> a :-> c
forall b c a.
((b -> c) -> b :-> c)
-> (a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMapWith (b -> c) -> b :-> c
forall a b. Function a => (a -> b) -> a :-> b
function

-- | @since 2.13.3
functionMapWith :: ((b->c) -> (b:->c)) -> (a->b) -> (b->a) -> (a->c) -> (a:->c)
functionMapWith :: ((b -> c) -> b :-> c)
-> (a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMapWith (b -> c) -> b :-> c
function a -> b
g b -> a
h a -> c
f = (a -> b) -> (b -> a) -> (b :-> c) -> a :-> c
forall a b c. (a -> b) -> (b -> a) -> (b :-> c) -> a :-> c
Map a -> b
g b -> a
h ((b -> c) -> b :-> c
function (\b
b -> a -> c
f (b -> a
h b
b)))

instance Function () where
  function :: (() -> b) -> () :-> b
function () -> b
f = b -> () :-> b
forall c. c -> () :-> c
Unit (() -> b
f ())

instance Function a => Function (Const a b) where
  function :: (Const a b -> b) -> Const a b :-> b
function = (Const a b -> a)
-> (a -> Const a b) -> (Const a b -> b) -> Const a b :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Const a b -> a
forall a k (b :: k). Const a b -> a
getConst a -> Const a b
forall k a (b :: k). a -> Const a b
Const

instance Function a => Function (Identity a) where
  function :: (Identity a -> b) -> Identity a :-> b
function = (Identity a -> a)
-> (a -> Identity a) -> (Identity a -> b) -> Identity a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Identity a -> a
forall a. Identity a -> a
runIdentity a -> Identity a
forall a. a -> Identity a
Identity

instance (Function a, Function b) => Function (a,b) where
  function :: ((a, b) -> b) -> (a, b) :-> b
function = ((a -> b -> b) -> a :-> (b -> b))
-> ((b -> b) -> b :-> b) -> ((a, b) -> b) -> (a, b) :-> b
forall a b c.
((a -> b -> c) -> a :-> (b -> c))
-> ((b -> c) -> b :-> c) -> ((a, b) -> c) -> (a, b) :-> c
functionPairWith (a -> b -> b) -> a :-> (b -> b)
forall a b. Function a => (a -> b) -> a :-> b
function (b -> b) -> b :-> b
forall a b. Function a => (a -> b) -> a :-> b
function

-- | @since 2.13.3
functionPairWith :: ((a->b->c) -> (a:->(b->c))) -> ((b->c) -> (b:->c)) -> ((a,b)->c) -> ((a,b):->c)
functionPairWith :: ((a -> b -> c) -> a :-> (b -> c))
-> ((b -> c) -> b :-> c) -> ((a, b) -> c) -> (a, b) :-> c
functionPairWith (a -> b -> c) -> a :-> (b -> c)
func1 (b -> c) -> b :-> c
func2 (a, b) -> c
f = (a :-> (b :-> c)) -> (a, b) :-> c
forall a b c. (a :-> (b :-> c)) -> (a, b) :-> c
Pair ((b -> c) -> b :-> c
func2 ((b -> c) -> b :-> c) -> (a :-> (b -> c)) -> a :-> (b :-> c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (a -> b -> c) -> a :-> (b -> c)
func1 (((a, b) -> c) -> a -> b -> c
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (a, b) -> c
f))

instance (Function a, Function b) => Function (Either a b) where
  function :: (Either a b -> b) -> Either a b :-> b
function = ((a -> b) -> a :-> b)
-> ((b -> b) -> b :-> b) -> (Either a b -> b) -> Either a b :-> b
forall a c b.
((a -> c) -> a :-> c)
-> ((b -> c) -> b :-> c) -> (Either a b -> c) -> Either a b :-> c
functionEitherWith (a -> b) -> a :-> b
forall a b. Function a => (a -> b) -> a :-> b
function (b -> b) -> b :-> b
forall a b. Function a => (a -> b) -> a :-> b
function

-- | @since 2.13.3
functionEitherWith :: ((a->c) -> (a:->c)) -> ((b->c) -> (b:->c)) -> (Either a b->c) -> (Either a b:->c)
functionEitherWith :: ((a -> c) -> a :-> c)
-> ((b -> c) -> b :-> c) -> (Either a b -> c) -> Either a b :-> c
functionEitherWith (a -> c) -> a :-> c
func1 (b -> c) -> b :-> c
func2 Either a b -> c
f = (a -> c) -> a :-> c
func1 (Either a b -> c
f (Either a b -> c) -> (a -> Either a b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left) (a :-> c) -> (b :-> c) -> Either a b :-> c
forall a c b. (a :-> c) -> (b :-> c) -> Either a b :-> c
:+: (b -> c) -> b :-> c
func2 (Either a b -> c
f (Either a b -> c) -> (b -> Either a b) -> b -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right)

-- tuple convenience instances

instance (Function a, Function b, Function c) => Function (a,b,c) where
  function :: ((a, b, c) -> b) -> (a, b, c) :-> b
function = ((a, b, c) -> (a, (b, c)))
-> ((a, (b, c)) -> (a, b, c))
-> ((a, b, c) -> b)
-> (a, b, c) :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap (\(a
a,b
b,c
c) -> (a
a,(b
b,c
c))) (\(a
a,(b
b,c
c)) -> (a
a,b
b,c
c))

instance (Function a, Function b, Function c, Function d) => Function (a,b,c,d) where
  function :: ((a, b, c, d) -> b) -> (a, b, c, d) :-> b
function = ((a, b, c, d) -> (a, (b, c, d)))
-> ((a, (b, c, d)) -> (a, b, c, d))
-> ((a, b, c, d) -> b)
-> (a, b, c, d) :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap (\(a
a,b
b,c
c,d
d) -> (a
a,(b
b,c
c,d
d))) (\(a
a,(b
b,c
c,d
d)) -> (a
a,b
b,c
c,d
d))

instance (Function a, Function b, Function c, Function d, Function e) => Function (a,b,c,d,e) where
  function :: ((a, b, c, d, e) -> b) -> (a, b, c, d, e) :-> b
function = ((a, b, c, d, e) -> (a, (b, c, d, e)))
-> ((a, (b, c, d, e)) -> (a, b, c, d, e))
-> ((a, b, c, d, e) -> b)
-> (a, b, c, d, e) :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap (\(a
a,b
b,c
c,d
d,e
e) -> (a
a,(b
b,c
c,d
d,e
e))) (\(a
a,(b
b,c
c,d
d,e
e)) -> (a
a,b
b,c
c,d
d,e
e))

instance (Function a, Function b, Function c, Function d, Function e, Function f) => Function (a,b,c,d,e,f) where
  function :: ((a, b, c, d, e, f) -> b) -> (a, b, c, d, e, f) :-> b
function = ((a, b, c, d, e, f) -> (a, (b, c, d, e, f)))
-> ((a, (b, c, d, e, f)) -> (a, b, c, d, e, f))
-> ((a, b, c, d, e, f) -> b)
-> (a, b, c, d, e, f) :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap (\(a
a,b
b,c
c,d
d,e
e,f
f) -> (a
a,(b
b,c
c,d
d,e
e,f
f))) (\(a
a,(b
b,c
c,d
d,e
e,f
f)) -> (a
a,b
b,c
c,d
d,e
e,f
f))

instance (Function a, Function b, Function c, Function d, Function e, Function f, Function g) => Function (a,b,c,d,e,f,g) where
  function :: ((a, b, c, d, e, f, g) -> b) -> (a, b, c, d, e, f, g) :-> b
function = ((a, b, c, d, e, f, g) -> (a, (b, c, d, e, f, g)))
-> ((a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g))
-> ((a, b, c, d, e, f, g) -> b)
-> (a, b, c, d, e, f, g) :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap (\(a
a,b
b,c
c,d
d,e
e,f
f,g
g) -> (a
a,(b
b,c
c,d
d,e
e,f
f,g
g))) (\(a
a,(b
b,c
c,d
d,e
e,f
f,g
g)) -> (a
a,b
b,c
c,d
d,e
e,f
f,g
g))

-- other instances

instance Function a => Function [a] where
  function :: ([a] -> b) -> [a] :-> b
function = ([a] -> Either () (a, [a]))
-> (Either () (a, [a]) -> [a]) -> ([a] -> b) -> [a] :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap [a] -> Either () (a, [a])
forall a. [a] -> Either () (a, [a])
g Either () (a, [a]) -> [a]
forall a a. Either a (a, [a]) -> [a]
h
   where
    g :: [a] -> Either () (a, [a])
g []     = () -> Either () (a, [a])
forall a b. a -> Either a b
Left ()
    g (a
x:[a]
xs) = (a, [a]) -> Either () (a, [a])
forall a b. b -> Either a b
Right (a
x,[a]
xs)

    h :: Either a (a, [a]) -> [a]
h (Left a
_)       = []
    h (Right (a
x,[a]
xs)) = a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs

instance Function a => Function (Maybe a) where
  function :: (Maybe a -> b) -> Maybe a :-> b
function = (Maybe a -> Either () a)
-> (Either () a -> Maybe a) -> (Maybe a -> b) -> Maybe a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Maybe a -> Either () a
forall b. Maybe b -> Either () b
g Either () a -> Maybe a
forall a a. Either a a -> Maybe a
h
   where
    g :: Maybe b -> Either () b
g Maybe b
Nothing  = () -> Either () b
forall a b. a -> Either a b
Left ()
    g (Just b
x) = b -> Either () b
forall a b. b -> Either a b
Right b
x

    h :: Either a a -> Maybe a
h (Left a
_)  = Maybe a
forall a. Maybe a
Nothing
    h (Right a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x

instance Function Bool where
  function :: (Bool -> b) -> Bool :-> b
function = (Bool -> Either () ())
-> (Either () () -> Bool) -> (Bool -> b) -> Bool :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Bool -> Either () ()
g Either () () -> Bool
forall a b. Either a b -> Bool
h
   where
    g :: Bool -> Either () ()
g Bool
False = () -> Either () ()
forall a b. a -> Either a b
Left ()
    g Bool
True  = () -> Either () ()
forall a b. b -> Either a b
Right ()

    h :: Either a b -> Bool
h (Left a
_)  = Bool
False
    h (Right b
_) = Bool
True

instance Function Integer where
  function :: (Integer -> b) -> Integer :-> b
function = (Integer -> Either [Word8] [Word8])
-> (Either [Word8] [Word8] -> Integer)
-> (Integer -> b)
-> Integer :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Integer -> Either [Word8] [Word8]
forall t. Integral t => t -> Either [Word8] [Word8]
gInteger Either [Word8] [Word8] -> Integer
forall a a p.
(Integral a, Integral a, Num p) =>
Either [a] [a] -> p
hInteger
   where
    gInteger :: t -> Either [Word8] [Word8]
gInteger t
n | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
0     = [Word8] -> Either [Word8] [Word8]
forall a b. a -> Either a b
Left (t -> [Word8]
forall t. Integral t => t -> [Word8]
gNatural (t -> t
forall a. Num a => a -> a
abs t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1))
               | Bool
otherwise = [Word8] -> Either [Word8] [Word8]
forall a b. b -> Either a b
Right (t -> [Word8]
forall t. Integral t => t -> [Word8]
gNatural t
n)

    hInteger :: Either [a] [a] -> p
hInteger (Left [a]
ws)  = -([a] -> p
forall a p. (Integral a, Num p) => [a] -> p
hNatural [a]
ws p -> p -> p
forall a. Num a => a -> a -> a
+ p
1)
    hInteger (Right [a]
ws) = [a] -> p
forall a p. (Integral a, Num p) => [a] -> p
hNatural [a]
ws

    gNatural :: t -> [Word8]
gNatural t
0 = []
    gNatural t
n = (t -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t
n t -> t -> t
forall a. Integral a => a -> a -> a
`mod` t
256) :: Word8) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: t -> [Word8]
gNatural (t
n t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
256)

    hNatural :: [a] -> p
hNatural []     = p
0
    hNatural (a
w:[a]
ws) = a -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w p -> p -> p
forall a. Num a => a -> a -> a
+ p
256 p -> p -> p
forall a. Num a => a -> a -> a
* [a] -> p
hNatural [a]
ws

instance Function Int where
  function :: (Int -> b) -> Int :-> b
function = (Int -> b) -> Int :-> b
forall a b. Integral a => (a -> b) -> a :-> b
functionIntegral

instance Function Word where
  function :: (Word -> b) -> Word :-> b
function = (Word -> b) -> Word :-> b
forall a b. Integral a => (a -> b) -> a :-> b
functionIntegral

instance Function Char where
  function :: (Char -> b) -> Char :-> b
function = (Char -> Int) -> (Int -> Char) -> (Char -> b) -> Char :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Char -> Int
ord Int -> Char
chr

instance Function Float where
  function :: (Float -> b) -> Float :-> b
function = (Float -> b) -> Float :-> b
forall a b. RealFrac a => (a -> b) -> a :-> b
functionRealFrac

instance Function Double where
  function :: (Double -> b) -> Double :-> b
function = (Double -> b) -> Double :-> b
forall a b. RealFrac a => (a -> b) -> a :-> b
functionRealFrac

-- instances for assorted types in the base package

instance Function Ordering where
  function :: (Ordering -> b) -> Ordering :-> b
function = (Ordering -> Either Bool ())
-> (Either Bool () -> Ordering)
-> (Ordering -> b)
-> Ordering :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Ordering -> Either Bool ()
g Either Bool () -> Ordering
forall b. Either Bool b -> Ordering
h
    where
      g :: Ordering -> Either Bool ()
g Ordering
LT = Bool -> Either Bool ()
forall a b. a -> Either a b
Left Bool
False
      g Ordering
EQ = Bool -> Either Bool ()
forall a b. a -> Either a b
Left Bool
True
      g Ordering
GT = () -> Either Bool ()
forall a b. b -> Either a b
Right ()

      h :: Either Bool b -> Ordering
h (Left Bool
False) = Ordering
LT
      h (Left Bool
True)  = Ordering
EQ
      h (Right b
_)    = Ordering
GT

instance (Integral a, Function a) => Function (Ratio a) where
  function :: (Ratio a -> b) -> Ratio a :-> b
function = (Ratio a -> (a, a))
-> ((a, a) -> Ratio a) -> (Ratio a -> b) -> Ratio a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Ratio a -> (a, a)
forall b. Ratio b -> (b, b)
g (a, a) -> Ratio a
forall a. Integral a => (a, a) -> Ratio a
h
   where
     g :: Ratio b -> (b, b)
g Ratio b
r = (Ratio b -> b
forall a. Ratio a -> a
numerator Ratio b
r, Ratio b -> b
forall a. Ratio a -> a
denominator Ratio b
r)
     h :: (a, a) -> Ratio a
h (a
n, a
d) = a
n a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
d

#ifndef NO_FIXED
instance HasResolution a => Function (Fixed a) where
  function :: (Fixed a -> b) -> Fixed a :-> b
function = (Fixed a -> b) -> Fixed a :-> b
forall a b. RealFrac a => (a -> b) -> a :-> b
functionRealFrac
#endif

instance (RealFloat a, Function a) => Function (Complex a) where
  function :: (Complex a -> b) -> Complex a :-> b
function = (Complex a -> (a, a))
-> ((a, a) -> Complex a) -> (Complex a -> b) -> Complex a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Complex a -> (a, a)
forall b. Complex b -> (b, b)
g (a, a) -> Complex a
forall a. (a, a) -> Complex a
h
   where
     g :: Complex b -> (b, b)
g (b
x :+ b
y) = (b
x,   b
y)
     h :: (a, a) -> Complex a
h (a
x,   a
y) =  a
x a -> a -> Complex a
forall a. a -> a -> Complex a
:+ a
y

instance (Ord a, Function a) => Function (Set.Set a) where
  function :: (Set a -> b) -> Set a :-> b
function = (Set a -> [a]) -> ([a] -> Set a) -> (Set a -> b) -> Set a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Set a -> [a]
forall a. Set a -> [a]
Set.toList [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList

instance (Ord a, Function a, Function b) => Function (Map.Map a b) where
  function :: (Map a b -> b) -> Map a b :-> b
function = (Map a b -> [(a, b)])
-> ([(a, b)] -> Map a b) -> (Map a b -> b) -> Map a b :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

instance Function IntSet.IntSet where
  function :: (IntSet -> b) -> IntSet :-> b
function = (IntSet -> [Int])
-> ([Int] -> IntSet) -> (IntSet -> b) -> IntSet :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap IntSet -> [Int]
IntSet.toList [Int] -> IntSet
IntSet.fromList

instance Function a => Function (IntMap.IntMap a) where
  function :: (IntMap a -> b) -> IntMap a :-> b
function = (IntMap a -> [(Int, a)])
-> ([(Int, a)] -> IntMap a) -> (IntMap a -> b) -> IntMap a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap IntMap a -> [(Int, a)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList [(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
IntMap.fromList

instance Function a => Function (Sequence.Seq a) where
  function :: (Seq a -> b) -> Seq a :-> b
function = (Seq a -> [a]) -> ([a] -> Seq a) -> (Seq a -> b) -> Seq a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [a] -> Seq a
forall a. [a] -> Seq a
Sequence.fromList

instance Function a => Function (Tree.Tree a) where
  function :: (Tree a -> b) -> Tree a :-> b
function = (Tree a -> (a, [Tree a]))
-> ((a, [Tree a]) -> Tree a) -> (Tree a -> b) -> Tree a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap (\(Tree.Node a
x [Tree a]
xs) -> (a
x,[Tree a]
xs)) ((a -> [Tree a] -> Tree a) -> (a, [Tree a]) -> Tree a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Tree.Node)

instance Function Int8 where
  function :: (Int8 -> b) -> Int8 :-> b
function = (Int8 -> b) -> Int8 :-> b
forall a b. (Eq a, Bounded a, Enum a) => (a -> b) -> a :-> b
functionBoundedEnum

instance Function Int16 where
  function :: (Int16 -> b) -> Int16 :-> b
function = (Int16 -> b) -> Int16 :-> b
forall a b. Integral a => (a -> b) -> a :-> b
functionIntegral

instance Function Int32 where
  function :: (Int32 -> b) -> Int32 :-> b
function = (Int32 -> b) -> Int32 :-> b
forall a b. Integral a => (a -> b) -> a :-> b
functionIntegral

instance Function Int64 where
  function :: (Int64 -> b) -> Int64 :-> b
function = (Int64 -> b) -> Int64 :-> b
forall a b. Integral a => (a -> b) -> a :-> b
functionIntegral

instance Function Word8 where
  function :: (Word8 -> b) -> Word8 :-> b
function = (Word8 -> b) -> Word8 :-> b
forall a b. (Eq a, Bounded a, Enum a) => (a -> b) -> a :-> b
functionBoundedEnum

instance Function Word16 where
  function :: (Word16 -> b) -> Word16 :-> b
function = (Word16 -> b) -> Word16 :-> b
forall a b. Integral a => (a -> b) -> a :-> b
functionIntegral

instance Function Word32 where
  function :: (Word32 -> b) -> Word32 :-> b
function = (Word32 -> b) -> Word32 :-> b
forall a b. Integral a => (a -> b) -> a :-> b
functionIntegral

instance Function Word64 where
  function :: (Word64 -> b) -> Word64 :-> b
function = (Word64 -> b) -> Word64 :-> b
forall a b. Integral a => (a -> b) -> a :-> b
functionIntegral

-- instances for Data.Monoid newtypes

instance Function a => Function (Monoid.Dual a) where
  function :: (Dual a -> b) -> Dual a :-> b
function = (Dual a -> a) -> (a -> Dual a) -> (Dual a -> b) -> Dual a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Dual a -> a
forall a. Dual a -> a
Monoid.getDual a -> Dual a
forall a. a -> Dual a
Monoid.Dual

instance Function Monoid.All where
  function :: (All -> b) -> All :-> b
function = (All -> Bool) -> (Bool -> All) -> (All -> b) -> All :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap All -> Bool
Monoid.getAll Bool -> All
Monoid.All

instance Function Monoid.Any where
  function :: (Any -> b) -> Any :-> b
function = (Any -> Bool) -> (Bool -> Any) -> (Any -> b) -> Any :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Any -> Bool
Monoid.getAny Bool -> Any
Monoid.Any

instance Function a => Function (Monoid.Sum a) where
  function :: (Sum a -> b) -> Sum a :-> b
function = (Sum a -> a) -> (a -> Sum a) -> (Sum a -> b) -> Sum a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Sum a -> a
forall a. Sum a -> a
Monoid.getSum a -> Sum a
forall a. a -> Sum a
Monoid.Sum

instance Function a => Function (Monoid.Product a) where
  function :: (Product a -> b) -> Product a :-> b
function = (Product a -> a)
-> (a -> Product a) -> (Product a -> b) -> Product a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Product a -> a
forall a. Product a -> a
Monoid.getProduct a -> Product a
forall a. a -> Product a
Monoid.Product

instance Function a => Function (Monoid.First a) where
  function :: (First a -> b) -> First a :-> b
function = (First a -> Maybe a)
-> (Maybe a -> First a) -> (First a -> b) -> First a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap First a -> Maybe a
forall a. First a -> Maybe a
Monoid.getFirst Maybe a -> First a
forall a. Maybe a -> First a
Monoid.First

instance Function a => Function (Monoid.Last a) where
  function :: (Last a -> b) -> Last a :-> b
function = (Last a -> Maybe a)
-> (Maybe a -> Last a) -> (Last a -> b) -> Last a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Last a -> Maybe a
forall a. Last a -> Maybe a
Monoid.getLast Maybe a -> Last a
forall a. Maybe a -> Last a
Monoid.Last

#if MIN_VERSION_base(4,8,0)
instance Function (f a) => Function (Monoid.Alt f a) where
  function :: (Alt f a -> b) -> Alt f a :-> b
function = (Alt f a -> f a)
-> (f a -> Alt f a) -> (Alt f a -> b) -> Alt f a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap Alt f a -> f a
forall k (f :: k -> *) (a :: k). Alt f a -> f a
Monoid.getAlt f a -> Alt f a
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Monoid.Alt
#endif

-- poly instances

instance Function A where
  function :: (A -> b) -> A :-> b
function = (A -> Integer) -> (Integer -> A) -> (A -> b) -> A :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap A -> Integer
unA Integer -> A
A

instance Function B where
  function :: (B -> b) -> B :-> b
function = (B -> Integer) -> (Integer -> B) -> (B -> b) -> B :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap B -> Integer
unB Integer -> B
B

instance Function C where
  function :: (C -> b) -> C :-> b
function = (C -> Integer) -> (Integer -> C) -> (C -> b) -> C :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap C -> Integer
unC Integer -> C
C

instance Function OrdA where
  function :: (OrdA -> b) -> OrdA :-> b
function = (OrdA -> Integer) -> (Integer -> OrdA) -> (OrdA -> b) -> OrdA :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap OrdA -> Integer
unOrdA Integer -> OrdA
OrdA

instance Function OrdB where
  function :: (OrdB -> b) -> OrdB :-> b
function = (OrdB -> Integer) -> (Integer -> OrdB) -> (OrdB -> b) -> OrdB :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap OrdB -> Integer
unOrdB Integer -> OrdB
OrdB

instance Function OrdC where
  function :: (OrdC -> b) -> OrdC :-> b
function = (OrdC -> Integer) -> (Integer -> OrdC) -> (OrdC -> b) -> OrdC :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap OrdC -> Integer
unOrdC Integer -> OrdC
OrdC

-- instance Arbitrary

instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (a:->b) where
  arbitrary :: Gen (a :-> b)
arbitrary = (a -> b) -> a :-> b
forall a b. Function a => (a -> b) -> a :-> b
function ((a -> b) -> a :-> b) -> Gen (a -> b) -> Gen (a :-> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Gen (a -> b)
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: (a :-> b) -> [a :-> b]
shrink    = (b -> [b]) -> (a :-> b) -> [a :-> b]
forall c a. (c -> [c]) -> (a :-> c) -> [a :-> c]
shrinkFun b -> [b]
forall a. Arbitrary a => a -> [a]
shrink

--------------------------------------------------------------------------
-- generic function instances

#ifndef NO_GENERICS
-- | Generic 'Function' implementation.
genericFunction :: (Generic a, GFunction (Rep a)) => (a->b) -> (a:->b)
genericFunction :: (a -> b) -> a :-> b
genericFunction = ((Rep a Any -> b) -> Rep a Any :-> b)
-> (a -> Rep a Any) -> (Rep a Any -> a) -> (a -> b) -> a :-> b
forall b c a.
((b -> c) -> b :-> c)
-> (a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMapWith (Rep a Any -> b) -> Rep a Any :-> b
forall k (f :: k -> *) (a :: k) b.
GFunction f =>
(f a -> b) -> f a :-> b
gFunction a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to

class GFunction f where
  gFunction :: (f a -> b) -> (f a :-> b)

instance GFunction U1 where
  gFunction :: (U1 a -> b) -> U1 a :-> b
gFunction = (U1 a -> ()) -> (() -> U1 a) -> (U1 a -> b) -> U1 a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap (\U1 a
U1 -> ()) (\() -> U1 a
forall k (p :: k). U1 p
U1)

instance (GFunction f, GFunction g) => GFunction (f :*: g) where
  gFunction :: ((:*:) f g a -> b) -> (:*:) f g a :-> b
gFunction = (((f a, g a) -> b) -> (f a, g a) :-> b)
-> ((:*:) f g a -> (f a, g a))
-> ((f a, g a) -> (:*:) f g a)
-> ((:*:) f g a -> b)
-> (:*:) f g a :-> b
forall b c a.
((b -> c) -> b :-> c)
-> (a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMapWith (((f a -> g a -> b) -> f a :-> (g a -> b))
-> ((g a -> b) -> g a :-> b)
-> ((f a, g a) -> b)
-> (f a, g a) :-> b
forall a b c.
((a -> b -> c) -> a :-> (b -> c))
-> ((b -> c) -> b :-> c) -> ((a, b) -> c) -> (a, b) :-> c
functionPairWith (f a -> g a -> b) -> f a :-> (g a -> b)
forall k (f :: k -> *) (a :: k) b.
GFunction f =>
(f a -> b) -> f a :-> b
gFunction (g a -> b) -> g a :-> b
forall k (f :: k -> *) (a :: k) b.
GFunction f =>
(f a -> b) -> f a :-> b
gFunction) (:*:) f g a -> (f a, g a)
forall k (f :: k -> *) (g :: k -> *) (p :: k).
(:*:) f g p -> (f p, g p)
g (f a, g a) -> (:*:) f g a
forall k (f :: k -> *) (p :: k) (g :: k -> *).
(f p, g p) -> (:*:) f g p
h
   where
     g :: (:*:) f g p -> (f p, g p)
g (f p
x :*: g p
y) = (f p
x, g p
y)
     h :: (f p, g p) -> (:*:) f g p
h (f p
x, g p
y) = f p
x f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p
y

instance (GFunction f, GFunction g) => GFunction (f :+: g) where
  gFunction :: ((:+:) f g a -> b) -> (:+:) f g a :-> b
gFunction = ((Either (f a) (g a) -> b) -> Either (f a) (g a) :-> b)
-> ((:+:) f g a -> Either (f a) (g a))
-> (Either (f a) (g a) -> (:+:) f g a)
-> ((:+:) f g a -> b)
-> (:+:) f g a :-> b
forall b c a.
((b -> c) -> b :-> c)
-> (a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMapWith (((f a -> b) -> f a :-> b)
-> ((g a -> b) -> g a :-> b)
-> (Either (f a) (g a) -> b)
-> Either (f a) (g a) :-> b
forall a c b.
((a -> c) -> a :-> c)
-> ((b -> c) -> b :-> c) -> (Either a b -> c) -> Either a b :-> c
functionEitherWith (f a -> b) -> f a :-> b
forall k (f :: k -> *) (a :: k) b.
GFunction f =>
(f a -> b) -> f a :-> b
gFunction (g a -> b) -> g a :-> b
forall k (f :: k -> *) (a :: k) b.
GFunction f =>
(f a -> b) -> f a :-> b
gFunction) (:+:) f g a -> Either (f a) (g a)
forall k (f :: k -> *) (g :: k -> *) (p :: k).
(:+:) f g p -> Either (f p) (g p)
g Either (f a) (g a) -> (:+:) f g a
forall k (f :: k -> *) (p :: k) (g :: k -> *).
Either (f p) (g p) -> (:+:) f g p
h
   where
     g :: (:+:) f g p -> Either (f p) (g p)
g (L1 f p
x) = f p -> Either (f p) (g p)
forall a b. a -> Either a b
Left f p
x
     g (R1 g p
x) = g p -> Either (f p) (g p)
forall a b. b -> Either a b
Right g p
x
     h :: Either (f p) (g p) -> (:+:) f g p
h (Left f p
x) = f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 f p
x
     h (Right g p
x) = g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 g p
x

instance GFunction f => GFunction (M1 i c f) where
  gFunction :: (M1 i c f a -> b) -> M1 i c f a :-> b
gFunction = ((f a -> b) -> f a :-> b)
-> (M1 i c f a -> f a)
-> (f a -> M1 i c f a)
-> (M1 i c f a -> b)
-> M1 i c f a :-> b
forall b c a.
((b -> c) -> b :-> c)
-> (a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMapWith (f a -> b) -> f a :-> b
forall k (f :: k -> *) (a :: k) b.
GFunction f =>
(f a -> b) -> f a :-> b
gFunction (\(M1 f a
x) -> f a
x) f a -> M1 i c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1

instance Function a => GFunction (K1 i a) where
  gFunction :: (K1 i a a -> b) -> K1 i a a :-> b
gFunction = (K1 i a a -> a)
-> (a -> K1 i a a) -> (K1 i a a -> b) -> K1 i a a :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
functionMap (\(K1 a
x) -> a
x) a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1
#endif

--------------------------------------------------------------------------
-- shrinking

shrinkFun :: (c -> [c]) -> (a :-> c) -> [a :-> c]
shrinkFun :: (c -> [c]) -> (a :-> c) -> [a :-> c]
shrinkFun c -> [c]
shr (Pair a :-> (b :-> c)
p) =
  [ (a :-> (b :-> c)) -> (a, b) :-> c
forall a b c. (a :-> (b :-> c)) -> (a, b) :-> c
pair a :-> (b :-> c)
p' | a :-> (b :-> c)
p' <- ((b :-> c) -> [b :-> c]) -> (a :-> (b :-> c)) -> [a :-> (b :-> c)]
forall c a. (c -> [c]) -> (a :-> c) -> [a :-> c]
shrinkFun (\b :-> c
q -> (c -> [c]) -> (b :-> c) -> [b :-> c]
forall c a. (c -> [c]) -> (a :-> c) -> [a :-> c]
shrinkFun c -> [c]
shr b :-> c
q) a :-> (b :-> c)
p ]
 where
  pair :: (a :-> (b :-> c)) -> (a, b) :-> c
pair a :-> (b :-> c)
Nil = (a, b) :-> c
forall a c. a :-> c
Nil
  pair a :-> (b :-> c)
p   = (a :-> (b :-> c)) -> (a, b) :-> c
forall a b c. (a :-> (b :-> c)) -> (a, b) :-> c
Pair a :-> (b :-> c)
p

shrinkFun c -> [c]
shr (a :-> c
p :+: b :-> c
q) =
  [ a :-> c
p (a :-> c) -> (b :-> c) -> Either a b :-> c
forall a c b. (a :-> c) -> (b :-> c) -> Either a b :-> c
.+. b :-> c
forall a c. a :-> c
Nil | Bool -> Bool
not ((b :-> c) -> Bool
forall a b. (a :-> b) -> Bool
isNil b :-> c
q) ] [Either a b :-> c] -> [Either a b :-> c] -> [Either a b :-> c]
forall a. [a] -> [a] -> [a]
++
  [ a :-> c
forall a c. a :-> c
Nil (a :-> c) -> (b :-> c) -> Either a b :-> c
forall a c b. (a :-> c) -> (b :-> c) -> Either a b :-> c
.+. b :-> c
q | Bool -> Bool
not ((a :-> c) -> Bool
forall a b. (a :-> b) -> Bool
isNil a :-> c
p) ] [Either a b :-> c] -> [Either a b :-> c] -> [Either a b :-> c]
forall a. [a] -> [a] -> [a]
++
  [ a :-> c
p  (a :-> c) -> (b :-> c) -> Either a b :-> c
forall a c b. (a :-> c) -> (b :-> c) -> Either a b :-> c
.+. b :-> c
q' | b :-> c
q' <- (c -> [c]) -> (b :-> c) -> [b :-> c]
forall c a. (c -> [c]) -> (a :-> c) -> [a :-> c]
shrinkFun c -> [c]
shr b :-> c
q ] [Either a b :-> c] -> [Either a b :-> c] -> [Either a b :-> c]
forall a. [a] -> [a] -> [a]
++
  [ a :-> c
p' (a :-> c) -> (b :-> c) -> Either a b :-> c
forall a c b. (a :-> c) -> (b :-> c) -> Either a b :-> c
.+. b :-> c
q  | a :-> c
p' <- (c -> [c]) -> (a :-> c) -> [a :-> c]
forall c a. (c -> [c]) -> (a :-> c) -> [a :-> c]
shrinkFun c -> [c]
shr a :-> c
p ]
 where
  isNil :: (a :-> b) -> Bool
  isNil :: (a :-> b) -> Bool
isNil a :-> b
Nil = Bool
True
  isNil a :-> b
_   = Bool
False

  a :-> c
Nil .+. :: (a :-> c) -> (b :-> c) -> Either a b :-> c
.+. b :-> c
Nil = Either a b :-> c
forall a c. a :-> c
Nil
  a :-> c
p   .+. b :-> c
q   = a :-> c
p (a :-> c) -> (b :-> c) -> Either a b :-> c
forall a c b. (a :-> c) -> (b :-> c) -> Either a b :-> c
:+: b :-> c
q

shrinkFun c -> [c]
shr (Unit c
c) =
  [ () :-> c
forall a c. a :-> c
Nil ] [() :-> c] -> [() :-> c] -> [() :-> c]
forall a. [a] -> [a] -> [a]
++
  [ c -> () :-> c
forall c. c -> () :-> c
Unit c
c' | c
c' <- c -> [c]
shr c
c ]

shrinkFun c -> [c]
shr (Table [(a, c)]
xys) =
  [ [(a, c)] -> a :-> c
forall a c. Eq a => [(a, c)] -> a :-> c
table [(a, c)]
xys' | [(a, c)]
xys' <- ((a, c) -> [(a, c)]) -> [(a, c)] -> [[(a, c)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (a, c) -> [(a, c)]
shrXy [(a, c)]
xys ]
 where
  shrXy :: (a, c) -> [(a, c)]
shrXy (a
x,c
y) = [(a
x,c
y') | c
y' <- c -> [c]
shr c
y]

  table :: [(a, c)] -> a :-> c
table []  = a :-> c
forall a c. a :-> c
Nil
  table [(a, c)]
xys = [(a, c)] -> a :-> c
forall a c. Eq a => [(a, c)] -> a :-> c
Table [(a, c)]
xys

shrinkFun c -> [c]
shr a :-> c
Nil =
  []

shrinkFun c -> [c]
shr (Map a -> b
g b -> a
h b :-> c
p) =
  [ (a -> b) -> (b -> a) -> (b :-> c) -> a :-> c
forall a b c. (a -> b) -> (b -> a) -> (b :-> c) -> a :-> c
mapp a -> b
g b -> a
h b :-> c
p' | b :-> c
p' <- (c -> [c]) -> (b :-> c) -> [b :-> c]
forall c a. (c -> [c]) -> (a :-> c) -> [a :-> c]
shrinkFun c -> [c]
shr b :-> c
p ]
 where
  mapp :: (a -> b) -> (b -> a) -> (b :-> c) -> a :-> c
mapp a -> b
g b -> a
h b :-> c
Nil = a :-> c
forall a c. a :-> c
Nil
  mapp a -> b
g b -> a
h b :-> c
p   = (a -> b) -> (b -> a) -> (b :-> c) -> a :-> c
forall a b c. (a -> b) -> (b -> a) -> (b :-> c) -> a :-> c
Map a -> b
g b -> a
h b :-> c
p

--------------------------------------------------------------------------
-- the Fun modifier

-- | Generation of random shrinkable, showable functions.
--
-- To generate random values of type @'Fun' a b@,
-- you must have an instance @'Function' a@.
--
-- See also 'applyFun', and 'Fn' with GHC >= 7.8.
data Fun a b = Fun (a :-> b, b, Shrunk) (a -> b)
data Shrunk = Shrunk | NotShrunk deriving Shrunk -> Shrunk -> Bool
(Shrunk -> Shrunk -> Bool)
-> (Shrunk -> Shrunk -> Bool) -> Eq Shrunk
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Shrunk -> Shrunk -> Bool
$c/= :: Shrunk -> Shrunk -> Bool
== :: Shrunk -> Shrunk -> Bool
$c== :: Shrunk -> Shrunk -> Bool
Eq

instance Functor (Fun a) where
  fmap :: (a -> b) -> Fun a a -> Fun a b
fmap a -> b
f (Fun (a :-> a
p, a
d, Shrunk
s) a -> a
g) = (a :-> b, b, Shrunk) -> (a -> b) -> Fun a b
forall a b. (a :-> b, b, Shrunk) -> (a -> b) -> Fun a b
Fun ((a -> b) -> (a :-> a) -> a :-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f a :-> a
p, a -> b
f a
d, Shrunk
s) (a -> b
f (a -> b) -> (a -> a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
g)

#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
-- | A modifier for testing functions.
--
-- > prop :: Fun String Integer -> Bool
-- > prop (Fn f) = f "banana" == f "monkey"
-- >            || f "banana" == f "elephant"
#if __GLASGOW_HASKELL__ >= 800
pattern Fn :: (a -> b) -> Fun a b
#endif
pattern $mFn :: forall r a b. Fun a b -> ((a -> b) -> r) -> (Void# -> r) -> r
Fn f <- (applyFun -> f)

-- | A modifier for testing binary functions.
--
-- > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool
-- > prop_zipWith (Fn2 f) xs ys = zipWith f xs ys == [ f x y | (x, y) <- zip xs ys]
#if __GLASGOW_HASKELL__ >= 800
pattern Fn2 :: (a -> b -> c) -> Fun (a, b) c
#endif
pattern $mFn2 :: forall r a b c.
Fun (a, b) c -> ((a -> b -> c) -> r) -> (Void# -> r) -> r
Fn2 f <- (applyFun2 -> f)

-- | A modifier for testing ternary functions.
#if __GLASGOW_HASKELL__ >= 800
pattern Fn3 :: (a -> b -> c -> d) -> Fun (a, b, c) d
#endif
pattern $mFn3 :: forall r a b c d.
Fun (a, b, c) d -> ((a -> b -> c -> d) -> r) -> (Void# -> r) -> r
Fn3 f <- (applyFun3 -> f)
#endif

mkFun :: (a :-> b) -> b -> Fun a b
mkFun :: (a :-> b) -> b -> Fun a b
mkFun a :-> b
p b
d = (a :-> b, b, Shrunk) -> (a -> b) -> Fun a b
forall a b. (a :-> b, b, Shrunk) -> (a -> b) -> Fun a b
Fun (a :-> b
p, b
d, Shrunk
NotShrunk) ((a :-> b) -> b -> a -> b
forall a c. (a :-> c) -> c -> a -> c
abstract a :-> b
p b
d)

-- | Alias to 'applyFun'.
apply :: Fun a b -> (a -> b)
apply :: Fun a b -> a -> b
apply = Fun a b -> a -> b
forall a b. Fun a b -> a -> b
applyFun

-- | Extracts the value of a function.
--
-- 'Fn' is the pattern equivalent of this function.
--
-- > prop :: Fun String Integer -> Bool
-- > prop f = applyFun f "banana" == applyFun f "monkey"
-- >       || applyFun f "banana" == applyFun f "elephant"
applyFun :: Fun a b -> (a -> b)
applyFun :: Fun a b -> a -> b
applyFun (Fun (a :-> b, b, Shrunk)
_ a -> b
f) = a -> b
f

-- | Extracts the value of a binary function.
--
-- 'Fn2' is the pattern equivalent of this function.
--
--  > prop_zipWith :: Fun (Int, Bool) Char -> [Int] -> [Bool] -> Bool
--  > prop_zipWith f xs ys = zipWith (applyFun2 f) xs ys == [ applyFun2 f x y | (x, y) <- zip xs ys]
--
applyFun2 :: Fun (a, b) c -> (a -> b -> c)
applyFun2 :: Fun (a, b) c -> a -> b -> c
applyFun2 (Fun ((a, b) :-> c, c, Shrunk)
_ (a, b) -> c
f) a
a b
b = (a, b) -> c
f (a
a, b
b)

-- | Extracts the value of a ternary function. 'Fn3' is the
-- pattern equivalent of this function.
applyFun3 :: Fun (a, b, c) d -> (a -> b -> c -> d)
applyFun3 :: Fun (a, b, c) d -> a -> b -> c -> d
applyFun3 (Fun ((a, b, c) :-> d, d, Shrunk)
_ (a, b, c) -> d
f) a
a b
b c
c = (a, b, c) -> d
f (a
a, b
b, c
c)

instance (Show a, Show b) => Show (Fun a b) where
  show :: Fun a b -> String
show (Fun (a :-> b
_, b
_, Shrunk
NotShrunk) a -> b
_) = String
"<fun>"
  show (Fun (a :-> b
p, b
d, Shrunk
Shrunk) a -> b
_)    = (a :-> b) -> Maybe b -> String
forall a b. (Show a, Show b) => (a :-> b) -> Maybe b -> String
showFunction a :-> b
p (b -> Maybe b
forall a. a -> Maybe a
Just b
d)

instance (Function a, CoArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where
  arbitrary :: Gen (Fun a b)
arbitrary =
    do a :-> b
p <- Gen (a :-> b)
forall a. Arbitrary a => Gen a
arbitrary
       b
d <- Gen b
forall a. Arbitrary a => Gen a
arbitrary
       Fun a b -> Gen (Fun a b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a :-> b) -> b -> Fun a b
forall a b. (a :-> b) -> b -> Fun a b
mkFun a :-> b
p b
d)

  shrink :: Fun a b -> [Fun a b]
shrink (Fun (a :-> b
p, b
d, Shrunk
s) a -> b
f) =
    [ (a :-> b) -> b -> Fun a b
forall a b. (a :-> b) -> b -> Fun a b
mkFun a :-> b
p' b
d' | (a :-> b
p', b
d') <- (a :-> b, b) -> [(a :-> b, b)]
forall a. Arbitrary a => a -> [a]
shrink (a :-> b
p, b
d) ] [Fun a b] -> [Fun a b] -> [Fun a b]
forall a. [a] -> [a] -> [a]
++
    [ (a :-> b, b, Shrunk) -> (a -> b) -> Fun a b
forall a b. (a :-> b, b, Shrunk) -> (a -> b) -> Fun a b
Fun (a :-> b
p, b
d, Shrunk
Shrunk) a -> b
f | Shrunk
s Shrunk -> Shrunk -> Bool
forall a. Eq a => a -> a -> Bool
== Shrunk
NotShrunk ]

--------------------------------------------------------------------------
-- the end.