{-# LANGUAGE TemplateHaskell   #-}
module Data.UnBounded( Top, topToMaybe
                     , pattern ValT, pattern Top

                     , Bottom, bottomToMaybe
                     , pattern Bottom, pattern ValB

                     , UnBounded(..)
                     , unUnBounded
                     , unBoundedToMaybe
                     ) where

import           Control.Lens
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import           Data.Functor.Classes

--------------------------------------------------------------------------------
-- * Top and Bottom

-- | `Top a` represents the type a, together with a 'Top' element, i.e. an element
-- that is greater than any other element. We can think of `Top a` being defined as:
--
-- >>> data Top a = ValT a | Top
newtype Top a = GTop { topToMaybe :: Maybe a }
                deriving (Eq,Functor,F.Foldable,T.Traversable,Applicative,Monad,Eq1)

pattern ValT  :: a -> Top a
pattern ValT x = GTop (Just x)

pattern Top    :: Top a
pattern Top    = GTop Nothing

{-# COMPLETE ValT, Top #-}


instance Ord1 Top where
  liftCompare _   Top       Top       = EQ
  liftCompare _   _         Top       = LT
  liftCompare _   Top       _         = GT
  liftCompare cmp ~(ValT x) ~(ValT y) = x `cmp` y

instance Ord a => Ord (Top a) where
  compare = compare1

instance Show a => Show (Top a) where
  show Top       = "Top"
  show ~(ValT x) = "ValT " ++ show x

--------------------------------------------------------------------------------

-- | `Bottom a` represents the type a, together with a 'Bottom' element,
-- i.e. an element that is smaller than any other element. We can think of
-- `Bottom a` being defined as:
--
-- >>> data Bottom a = Bottom | ValB a
newtype Bottom a = GBottom { bottomToMaybe :: Maybe a }
                 deriving (Eq,Ord,Functor,F.Foldable,T.Traversable,Applicative,Monad,Eq1,Ord1)

pattern Bottom :: Bottom a
pattern Bottom = GBottom Nothing

pattern ValB   :: a -> Bottom a
pattern ValB x = GBottom (Just x)

{-# COMPLETE Bottom, ValB #-}

instance Show a => Show (Bottom a) where
  show Bottom    = "Bottom"
  show ~(ValB x) = "ValB " ++ show x

--------------------------------------------------------------------------------

-- | `UnBounded a` represents the type a, together with an element
-- `MaxInfinity` larger than any other element, and an element `MinInfinity`,
-- smaller than any other element.
data UnBounded a = MinInfinity | Val { _unUnBounded :: a }  | MaxInfinity
                 deriving (Eq,Ord,Functor,F.Foldable,T.Traversable)

makeLenses ''UnBounded

instance Show a => Show (UnBounded a) where
  show MinInfinity = "MinInfinity"
  show (Val x)     = "Val " ++ show x
  show MaxInfinity = "MaxInfinity"

instance Num a => Num (UnBounded a) where
  MinInfinity + _           = MinInfinity
  _           + MinInfinity = MinInfinity
  (Val x)     + (Val y)     = Val $ x + y
  _           + MaxInfinity = MaxInfinity
  MaxInfinity + _           = MaxInfinity


  MinInfinity * _           = MinInfinity
  _           * MinInfinity = MinInfinity

  (Val x)     * (Val y)     = Val $ x * y
  _           * MaxInfinity = MaxInfinity
  MaxInfinity * _           = MaxInfinity

  abs MinInfinity = MinInfinity
  abs (Val x)     = Val $ abs x
  abs MaxInfinity = MaxInfinity

  signum MinInfinity = -1
  signum (Val x)     = Val $ signum x
  signum MaxInfinity = 1

  fromInteger = Val . fromInteger

  negate MinInfinity = MaxInfinity
  negate (Val x)     = Val $ negate x
  negate MaxInfinity = MinInfinity

instance Fractional a => Fractional (UnBounded a) where
  MinInfinity / _       = MinInfinity
  (Val x)     / (Val y) = Val $ x / y
  (Val _)     / _       = 0
  MaxInfinity / _       = MaxInfinity

  fromRational = Val . fromRational


unBoundedToMaybe         :: UnBounded a -> Maybe a
unBoundedToMaybe (Val x) = Just x
unBoundedToMaybe _       = Nothing