{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module : Data.UnBounded
-- Copyright : (C) Frank Staals
-- License : see the LICENSE file
-- Maintainer : Frank Staals
--
-- Add an unbounded/infintity element to a data type. Essentially,
-- t'Bottom' adds \(-\infty\) (and is pretty much identical to Maybe),
-- whereas t'Top' adds \(\infty\). The 'UnBounded' type adds both.
--
--------------------------------------------------------------------------------
module Data.UnBounded( Top( ValT, Top), topToMaybe
, _ValT, _Top, _TopMaybe
, Bottom(Bottom, ValB), bottomToMaybe
, _ValB, _Bottom, _BottomMaybe
, UnBounded(..)
, _Val
, unBoundedToMaybe
) where
import Control.Lens
import qualified Data.Foldable as F
import Data.Functor.Classes
import qualified Data.Traversable as T
--------------------------------------------------------------------------------
-- * Top and Bottom
-- | @Top a@ represents the type a, together with a v'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 (Maybe a)
deriving (Eq,Functor,F.Foldable,T.Traversable,Applicative,Monad,Eq1)
-- | @Top a@ values are isomorphing to @Maybe a@ values.
topToMaybe :: Top a -> Maybe a
topToMaybe (GTop mb) = mb
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. Can be used to access the non-bottom element if it exists:
--
-- >>> ValT True & _ValT %~ not
-- ValT False
--
-- >>> Top & _ValT %~ not
-- Top
_ValT :: Prism (Top a) (Top b) a b
_ValT = prism ValT (\case Top -> Left Top ; ValT x -> Right x)
-- | t'Top' prism.
_Top :: Prism' (Top a) ()
_Top = prism' (const Top) (\case Top -> Just () ; ValT _ -> Nothing)
-- | Iso between a @Top a@ and a @Maybe a@, interpreting a v'Top' as a
-- 'Nothing' and vice versa. Note that this reverses the ordering of
-- the elements.
--
-- >>> ValT 5 ^. _TopMaybe
-- Just 5
-- >>> Just 5 ^.re _TopMaybe
-- ValT 5
-- >>> Top ^. _TopMaybe
-- Nothing
-- >>> Nothing ^.re _TopMaybe
-- Top
_TopMaybe :: Iso' (Top a) (Maybe a)
_TopMaybe = iso topToMaybe GTop
--------------------------------------------------------------------------------
-- | @`Bottom a`@ represents the type a, together with a v'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 (Maybe a)
deriving (Eq,Ord,Functor,F.Foldable,T.Traversable,Applicative,Monad,Eq1,Ord1)
-- | `Bottom a` values are isomorphing to `Maybe a` values.
bottomToMaybe :: Bottom a -> Maybe a
bottomToMaybe (GBottom mb) = mb
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. Can be used to access the non-bottom element if it exists:
--
-- >>> ValB True & _ValB %~ not
-- ValB False
--
-- >>> Bottom & _ValB %~ not
-- Bottom
_ValB :: Prism (Bottom a) (Bottom b) a b
_ValB = prism ValB (\case Bottom -> Left Bottom ; ValB x -> Right x)
-- | t'Bottom' prism.
_Bottom :: Prism' (Bottom a) ()
_Bottom = prism' (const Bottom) (\case Bottom -> Just () ; ValB _ -> Nothing)
-- | Iso between a 'Bottom a' and a 'Maybe a', interpreting a Bottom as a
-- Nothing and vice versa.
--
-- >>> ValB 5 ^. _BottomMaybe
-- Just 5
-- >>> Just 5 ^.re _BottomMaybe
-- ValB 5
-- >>> Bottom ^. _BottomMaybe
-- Nothing
-- >>> Nothing ^.re _BottomMaybe
-- Bottom
_BottomMaybe :: Iso' (Bottom a) (Maybe a)
_BottomMaybe = iso bottomToMaybe GBottom
--------------------------------------------------------------------------------
-- | `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)
-- | Prism to access unbounded value if it exists.
--
-- >>> Val True ^? _Val
-- Just True
--
-- >>> MinInfinity ^? _Val :: Maybe Bool
-- Nothing
--
-- >>> Val True & _Val %~ not
-- Val False
--
-- >>> MaxInfinity & _Val %~ not
-- MaxInfinity
_Val :: Prism (UnBounded a) (UnBounded b) a b
_Val = prism Val fromUnBounded
where
fromUnBounded MinInfinity = Left MinInfinity
fromUnBounded MaxInfinity = Left MaxInfinity
fromUnBounded (Val v) = Right v
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