ContinuousFunctions.hs

{-# LANGUAGE RankNTypes, ScopedTypeVariables,
             GeneralizedNewtypeDeriving, DeriveDataTypeable #-}

-- TODO: Can we pattern match on functions?
-- What about functions of several arguments? Can we have interleaved
-- pattern matching? Do we need to use currying to achieve this? What
-- limitations does that lead to?
-- TODO: getMatches: What happens with infinite input? Hmm... We do want the
-- possibility of non-termination, right?
-- TODO: getMatches: Frequencies?
-- TODO: match: Document limitations. Can functions be handled?

-- |
-- Module      :  Test.ChasingBottoms.ContinuousFunctions
-- Copyright   :  (c) Nils Anders Danielsson 2005-2010
-- License     :  See the file LICENCE.
--
-- Maintainer  :  http://www.cs.nott.ac.uk/~nad/
-- Stability   :  experimental
-- Portability :  non-portable (GHC-specific)
--
-- Note: /This module is unfinished and experimental. However, I do not think that I will ever finish it, so I have released it in its current state. The documentation below may not be completely correct. The source code lists some things which should be addressed./
--
-- A framework for generating possibly non-strict, partial,
-- continuous functions.
--
-- The functions generated using the standard QuickCheck 'Arbitrary'
-- instances are all strict. In the presence of partial and infinite
-- values testing using only strict functions leads to worse coverage
-- than if more general functions are used, though.
--
-- Using 'isBottom' it is relatively easy to generate possibly
-- non-strict functions that are, in general, not monotone. For
-- instance, using
--
-- > type Cogen a = forall b. a -> Gen b -> Gen b
-- >
-- > integer :: Gen Integer
-- > integer = frequency [ (1, return bottom), (10, arbitrary) ]
-- >
-- > coBool :: CoGen Bool
-- > coBool b | isBottom b = variant 0
-- > coBool False          = variant 1
-- > coBool True           = variant 2
-- >
-- > function :: Cogen a -> Gen b -> Gen (a -> b)
-- > function coGen gen = promote (\a -> coGen a gen)
--
-- we can generate possibly non-strict functions from 'Bool' to
-- 'Integer' using @function coBool integer@. There is a high
-- likelihood that the functions generated are not monotone, though.
-- The reason that we can get non-monotone functions in a language
-- like Haskell is that we are using the impure function 'isBottom'.
--
-- Sometimes using possibly non-monotone functions is good enough,
-- since that set of functions is a superset of the continuous
-- functions. However, say that we want to test that @x 'O.<=!' y@
-- implies that @f x 'O.<=!' f y@ for all functions @f@ (whenever the
-- latter expression returns a total result). This property is not
-- valid in the presence of non-monotone functions.
--
-- By avoiding 'isBottom' and, unlike the standard 'coarbitrary'
-- functions, deferring some pattern matches, we can generate
-- continuous, possibly non-strict functions. There are two steps
-- involved in generating a continuous function using the framework
-- defined here.
--
-- (1) First the argument to the function is turned into a
--     'PatternMatch'. A 'PatternMatch' wraps up the pattern match on
--     the top-level constructor of the argument, plus all further
--     pattern matches on the children of the argument. Just like when
--     'coarbitrary' is used a pattern match is represented as a
--     generator transformer. The difference here is that there is not
--     just one transformation per input, but one transformation per
--     constructor in the input. 'PatternMatch'es can be constructed
--     generically using 'match'.
--
-- (2) Then the result is generated, almost like for a normal
--     'Arbitrary' instance. However, for each constructor generated a
--     subset of the transformations from step 1 are applied. This
--     transformation application is wrapped up in the function
--     'transform'.
--
-- The net result of this is that some pattern matches are performed
-- later, or not at all, so functions can be lazy.
--
-- Here is an example illustrating typical use of this framework:
--
-- > data Tree a
-- >   = Branch (Tree a) (Tree a)
-- >   | Leaf a
-- >     deriving (Show, Typeable, Data)
-- >
-- > finiteTreeOf :: MakeResult a -> MakeResult (Tree a)
-- > finiteTreeOf makeResult = sized' tree
-- >   where
-- >   tree size = transform $
-- >     if size == 0 then
-- >       baseCase
-- >      else
-- >       frequency' [ (1, baseCase)
-- >                  , (1, liftM2 Branch tree' tree')
-- >                  ]
-- >     where
-- >     tree' = tree (size `div` 2)
-- >
-- >     baseCase =
-- >       frequency' [ (1, return bottom)
-- >                  , (2, liftM Leaf makeResult)
-- >                  ]
--
-- Note the use of 'transform'. To use this function to generate
-- functions of type @Bool -> Tree Integer@ we can use
--
-- > forAll (functionTo (finiteTreeOf flat)) $
-- >   \(f :: Bool -> Tree Integer) ->
-- >     ...

module Test.ChasingBottoms.ContinuousFunctions
  ( -- * Basic framework
    function
  , functionTo
  , PatternMatch(..)
  , GenTransformer
  , MakePM
  , MakeResult
  , transform
    -- * Liftings of some QuickCheck functionality
  , lift'
  , arbitrary'
  , choose'
  , elements'
  , oneof'
  , frequency'
  , sized'
  , resize'
    -- * Generic @MakePM@
  , match
    -- * Some @MakeResult@s
  , flat
  , finiteListOf
  , infiniteListOf
  , listOf
  ) where

import Test.QuickCheck hiding ((><), listOf)
import Data.Sequence as Seq
import Data.Foldable as Seq (foldr)
import Prelude as P hiding (concat)
import Test.ChasingBottoms.IsBottom
import Control.Monad
import Control.Monad.Reader
import Control.Arrow
import System.Random
import Data.Generics
import qualified Data.List as L

import qualified Test.ChasingBottoms.SemanticOrd as O

------------------------------------------------------------------------
-- Generation of functions

-- | Generator for continuous, not necessarily strict functions.
-- Functions are generated by first generating pattern matches, and
-- then generating a result.

function :: MakePM a -> MakeResult b -> Gen (a -> b)
function makePM makeResult =
   promote $ \a -> run makeResult (singleton $ makePM a)

-- | 'functionTo' specialises 'function':
--
-- @
--  'functionTo' = 'function' 'match'
-- @

functionTo :: Data a => MakeResult b -> Gen (a -> b)
functionTo = function match

------------------------------------------------------------------------
-- Pattern matching

-- | 'PatternMatch' packages up the possible outcomes of a pattern
-- match in a style suitable for generating functions. A pattern match
-- is a generator ('Gen') transformer based on the top-level
-- constructor, and a sequence (see
-- <http://www.soi.city.ac.uk/~ross/software/html/Data.Sequence.html>) of
-- 'PatternMatch'es based on the children of that constructor.

data PatternMatch
  = PatternMatch { apply :: GenTransformer
                   -- ^ A generator transformer, in the style of 'coarbitrary'.
                 , more :: Seq PatternMatch
                   -- ^ Further pattern matches made possible by this
                   -- match.
                 }

-- | The type of a generator transformer.

type GenTransformer = forall a. Gen a -> Gen a

-- | This newtype is (currently) necessary if we want to use
-- 'GenTransformer' as an argument to a type constructor.

newtype GenTransformer' = GenT GenTransformer

-- | The type of a 'PatternMatch' generator.

type MakePM a = a -> PatternMatch

------------------------------------------------------------------------
-- Generic MakePM

-- These functions provided inspiration for the generic one below.

matchFlat :: CoArbitrary a => MakePM a
matchFlat a = PatternMatch { apply = coarbitrary a, more = empty }

data Tree a
   = Branch (Tree a) (Tree a)
   | Leaf a
     deriving (Show, Typeable, Data)

matchTree :: MakePM a -> MakePM (Tree a)
matchTree match t = PatternMatch { apply = toVariant t, more = moreT t }
  where
  toVariant (Branch {}) = variant 1
  toVariant (Leaf {})   = variant 0

  moreT (Branch l r) = fromList [matchTree match l, matchTree match r]
  moreT (Leaf x)     = singleton (match x)

-- | Generic implementation of 'PatternMatch' construction.

match :: forall a. Data a => MakePM a
match x = PatternMatch
            { apply = toVariant x
            , more  = more x
            }
  where
  toVariant :: forall a b. Data a => a -> Gen b -> Gen b
  toVariant x = case constrRep (toConstr x) of
    AlgConstr n   -> variant (n - 1)  -- n >= 1.
    IntConstr i   -> coarbitrary i
    FloatConstr d -> coarbitrary d
    CharConstr s  -> nonBottomError "match: Encountered CharConstr."

  more :: forall a. Data a => a -> Seq PatternMatch
  more = gmapQr (<|) empty match

------------------------------------------------------------------------
-- MakeResult monad

-- | Monad for generating results given previously generated pattern
-- matches.
--
-- A @'MakeResult' a@ should be implemented almost as other generators for
-- the type @a@, with the difference that 'transform' should be
-- used wherever the resulting function should be allowed to pattern
-- match (typically for each constructor emitted). See example above.

-- Note that we do not want to export a 'MonadReader' instance, so we
-- cannot define one...

newtype MakeResult a
  = MR { unMR :: ReaderT PatternMatches Gen a }
    deriving (Functor, Monad)

type PatternMatches = Seq PatternMatch

-- | Lowering of a 'MakeResult'.

run :: MakeResult a -> PatternMatches -> Gen a
run mr pms = runReaderT (unMR mr) pms

-- | Lifting of a 'Gen'.

lift' :: Gen a -> MakeResult a
lift' gen = MR $ lift gen

-- | Returns the 'PatternMatches' in scope.

getPMs :: MakeResult PatternMatches
getPMs = MR ask

withPMs :: (PatternMatches -> Gen a) -> MakeResult a
withPMs f = do
  pms <- getPMs
  lift' $ f pms

-- | 'transform' makes sure that the pattern matches get to influence
-- the generated value. See 'MakeResult'.

transform :: MakeResult a -> MakeResult a
transform makeResult = withPMs $ \pms -> do
  (GenT trans, keep) <- getMatches pms
  trans (run makeResult keep)

-- | Extracts some pattern matches to trigger right away. These
-- triggered pattern matches may result in new pattern matches which
-- may in turn also be triggered, and so on.

getMatches :: Seq PatternMatch -> Gen (GenTransformer', Seq PatternMatch)
getMatches pms = do
  -- Throw away pattern matches with probability 0.1.
  (_, pms') <- partition' 9 pms
  -- Use pattern matches with probability 0.33.
  (use, keep) <- partition' 2 pms'
  let transform = compose $ fmap apply use
      further = concat $ fmap more use
  if Seq.null further then
    return (GenT transform, keep)
   else do
    (GenT transform', keep') <- getMatches further
    return (GenT (transform . transform'), keep >< keep')

------------------------------------------------------------------------
-- Sequence helpers

-- | Concatenates arguments.

concat :: Seq (Seq a) -> Seq a
concat = Seq.foldr (><) empty

-- | Composes arguments.

compose :: Seq (a -> a) -> a -> a
compose = Seq.foldr (.) id

-- | Partitions a 'Seq'. The first argument (a positive integer) is
-- the relative probability with which elements end up in the second
-- part compared to the first one.

partition' :: Int -> Seq a -> Gen (Seq a, Seq a)
partition' freq ss = case viewl ss of
  EmptyL  -> return (empty, empty)
  x :< xs -> do
    (ys, zs) <- partition' freq xs
    frequency [ (1,    return (x <| ys, zs))
              , (freq, return (ys, x <| zs))
              ]

------------------------------------------------------------------------
-- Lifting of QuickCheck's Gen monad

-- | Lifting of 'arbitrary'.

arbitrary' :: Arbitrary a => MakeResult a
arbitrary' = lift' arbitrary

-- | Lifting of 'choose'.

choose' :: Random a => (a, a) -> MakeResult a
choose' = lift' . choose

-- | Lifting of 'elements'.

elements' :: [a] -> MakeResult a
elements' = lift' . elements

-- | Lifting of 'oneof'.

oneof' :: [MakeResult a] -> MakeResult a
oneof' mrs = withPMs $ \pms -> oneof $ map (\mr -> run mr pms) mrs

-- | Lifting of 'frequency'.

frequency' :: [(Int, MakeResult a)] -> MakeResult a
frequency' freqs = withPMs $ \pms ->
  frequency $ map (id *** flip run pms) freqs

-- | Lifting of 'sized'.

sized' :: (Int -> MakeResult a) -> MakeResult a
sized' mr = withPMs $ \pms -> sized (\size -> run (mr size) pms)

-- | Lifting of 'resize'.

resize' :: Int -> MakeResult a -> MakeResult a
resize' n mr = withPMs $ \pms -> resize n (run mr pms)

------------------------------------------------------------------------
-- Some predefined generators

-- | An implementation of @'MakeResult' a@ which is suitable when @a@
-- is flat and has an 'Arbitrary' instance. Yields bottoms around 10%
-- of the time.

flat :: Arbitrary a => MakeResult a
flat = transform $
  frequency' [ (1, return bottom)
             , (9, arbitrary')
             ]

-- | This 'MakeResult' yields finite partial lists.

finiteListOf :: MakeResult a -> MakeResult [a]
finiteListOf makeResult = sized' list
    where
    list size = transform $
      if size == 0 then
        baseCase
       else
        frequency' [ (1, baseCase)
                   , (9, liftM2 (:) makeResult (list (size - 1)))
                   ]

    baseCase =
      frequency' [(1, return bottom), (1, return [])]

-- | This 'MakeResult' yields infinite partial lists.

infiniteListOf :: MakeResult a -> MakeResult [a]
infiniteListOf makeResult = transform $
  liftM2 (:) makeResult (infiniteListOf makeResult)

-- | This 'MakeResult' yields finite or infinite partial lists.

listOf :: MakeResult a -> MakeResult [a]
                    -- Not really necessary to have a transform here...
listOf makeResult = transform $
   oneof' [ finiteListOf makeResult
          , infiniteListOf makeResult
          ]

------------------------------------------------------------------------
-- Failed attempt at a generic implementation of MakeResult

-- Main problem: Getting the frequencies right. Lists are very short
-- right now.

-- Other problem: Int and Float.

-- Further remark: We need finite and infinite versions of this
-- function.

makeResult :: forall a. Data a => MakeResult a
makeResult = transform (frequency' $ (1, return bottom) : others)
  where
  others = case dataTypeRep (dataTypeOf (undefined :: a)) of
             AlgRep constrs ->
               map (handle (L.genericLength constrs)) constrs
             IntRep         -> [(9, cast' (arbitrary' :: MakeResult Integer))]
             FloatRep       -> [(9, cast' (arbitrary' :: MakeResult Double))]
             CharRep        -> nonBottomError "makeResult: CharRep."
             NoRep          -> nonBottomError "makeResult: NoRep."

  handle noConstrs con =
    (freq, fromConstrM makeResult con :: MakeResult a)
    where noArgs = glength (fromConstr con :: a)
          -- Aim for at most 10% bottoms (on average).
          freq = 1 `max` ceiling (9 / noConstrs)

  cast' gen = flip fmap gen $ \x -> case cast x of
    Just x' -> x'
    Nothing -> nonBottomError $
                 "makeResult: Cannot handle Int and Float." ++
                 " Use Integer or Double instead."