AddBounds.hs

{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  Data.AddBounds
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Add bounds to an ordered type
----------------------------------------------------------------------

module Data.AddBounds (AddBounds(..)) where

import Control.Applicative (pure,(<$>))

-- Testing
import Test.QuickCheck
import Test.QuickCheck.Checkers


-- | Wrap a type into one having new least and greatest elements,
-- preserving the existing ordering.
data AddBounds a = MinBound | NoBound a | MaxBound
	deriving (Eq {-, Ord-}, Read, Show)

instance Bounded (AddBounds a) where
	minBound = MinBound
	maxBound = MaxBound


-- Normally, I'd derive 'Ord' as well, but there's a sticky point.  The
-- derived instance uses the default definition of 'min', which is uses
-- '(<=)' and thus cannot exploit any partial information.  So, define our
-- own 'min' in terms of 'min' on @a@.
-- Examples:
--   (NoBound undefined) `min` (NoBound undefined) can return (NoBound _|_)
--   using this definition, but will not produce any output using the
--   default min.
--   
--   (NoBound a) `min` (NoBound b) can return partial information from
--   a `min` b while the default implementation cannot.

instance Ord a => Ord (AddBounds a) where
  MinBound  <= _         = True
  NoBound _ <= MinBound  = False
  NoBound a <= NoBound b = a <= b
  NoBound _ <= MaxBound  = True
  MaxBound  <= MaxBound  = True
  MaxBound  <= _         = False        -- given previous 
  
  MinBound  `min` _         = MinBound
  _         `min` MinBound  = MinBound
  NoBound a `min` NoBound b = NoBound (a `min` b)
  u         `min` MaxBound  = u
  MaxBound  `min` v         = v
  
  MinBound  `max` v         = v
  u         `max` MinBound  = u
  NoBound a `max` NoBound b = NoBound (a `max` b)
  _         `max` MaxBound  = MaxBound
  MaxBound  `max` _         = MaxBound


instance Arbitrary a => Arbitrary (AddBounds a) where
  arbitrary = frequency [ (1 ,pure MinBound)
                        , (10, NoBound <$> arbitrary)
                        , (1 ,pure MaxBound) ]
  coarbitrary MinBound    = variant 0
  coarbitrary (NoBound a) = variant 1 . coarbitrary a
  coarbitrary MaxBound    = variant 2

instance (EqProp a, Eq a) => EqProp (AddBounds a) where
  NoBound a =-= NoBound b = a =-= b
  u =-= v = u `eq` v