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

                     , Bottom, bottomToMaybe
                     , pattern Bottom, pattern ValB
                     , _ValB, _Bottom

                     , UnBounded(..)
                     , unUnBounded
                     , _MinInfinity, _Val, _MaxInfinity
                     , 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

_ValT :: Prism (Top a) (Top b) a b
_ValT = prism ValT (\ta -> case ta of Top -> Left Top ; ValT x -> Right x)

_Top :: Prism' (Top a) ()
_Top = prism' (const Top) (\ta -> case ta of Top -> Just () ; ValT _ -> Nothing)

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

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

_ValB :: Prism (Bottom a) (Bottom b) a b
_ValB = prism ValB (\ba -> case ba of Bottom -> Left Bottom ; ValB x -> Right x)

_Bottom :: Prism' (Bottom a) ()
_Bottom = prism' (const Bottom) (\ba -> case ba of Bottom -> Just () ; ValB _ -> Nothing)

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

-- | `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
makePrisms ''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

-- | Test if an Unbounded is actually bounded.
--
-- >>> unBoundedToMaybe (Val 5)
-- Just 5
-- >>> unBoundedToMaybe MinInfinity
-- Nothing
-- >>> unBoundedToMaybe MaxInfinity
-- Nothing
unBoundedToMaybe         :: UnBounded a -> Maybe a
unBoundedToMaybe (Val x) = Just x
unBoundedToMaybe _       = Nothing