{-# 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,(<$>))

-- import Data.Unamb (unamb)

-- 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


-- Richard Smith (lilac)  contributed this code for lazier methods.
--   MaxBound `max` undefined can return full information while the default
--   implementation cannot. And likewise undefined `max` MaxBound.

-- instance Ord a => Ord (AddBounds a) where
--   a <= b = c1 a b `unamb` c2 a b
--     where c1 MinBound     _            = True
--           c1 _            MinBound     = False
--           c1 (NoBound a') (NoBound b') = a' < b'
--           c1 MaxBound     (NoBound _)  = False
--           c1 _            _            = undefined
--           c2 _            MaxBound     = True
--           c2 _            _            = undefined
--   a `min` b = c1 a b `unamb` c2 a b
--     where c1 MinBound     _            = MinBound
--           c1 (NoBound a') (NoBound b') = NoBound $ a' `max` b'
--           c1 (NoBound _ ) MaxBound     = a
--           c1 MaxBound     (NoBound _ ) = b
--           c1 MaxBound     MaxBound     = MaxBound
--           c1 _            _            = undefined
--           c2 _            MinBound     = MinBound
--           c2 _            _            = undefined
--   a `max` b = c1 a b `unamb` c2 a b
--     where c1 MaxBound     _            = MaxBound
--           c1 (NoBound a') (NoBound b') = NoBound $ a' `max` b'
--           c1 (NoBound _ ) MinBound     = a
--           c1 MinBound     (NoBound _ ) = b
--           c1 MinBound     MinBound     = MinBound
--           c1 _            _            = undefined
--           c2 _            MaxBound     = MaxBound
--           c2 _            _            = undefined

-- This second instance has a strange delays in a reactive-fieldtrip
-- program.  My mouse click isn't responded to until I move the mouse.


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