{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Semiring.Infinite
( HasPositiveInfinity(..)
, HasNegativeInfinity(..)
, NegativeInfinite(..)
, PositiveInfinite(..)
, Infinite(..)
) where
import Control.Applicative (liftA2)
import Data.Typeable (Typeable)
import GHC.Generics (Generic, Generic1)
import Data.Word (Word8)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (Storable, alignment, peek,
peekByteOff, poke, pokeByteOff,
sizeOf)
import Data.Coerce
import Data.Semigroup as Sem
import Data.Bool
import Data.Semiring
import Data.Semiring.Newtype
import Control.DeepSeq
import Data.Functor.Classes
import Text.Read
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Generic.Mutable as M
import qualified Data.Vector.Unboxed.Base as U
data NegativeInfinite a
= NegativeInfinity
| NegFinite !a
deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor
,Foldable, Traversable)
data PositiveInfinite a
= PosFinite !a
| PositiveInfinity
deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor
,Foldable, Traversable)
instance Applicative NegativeInfinite where
pure = NegFinite
{-# INLINE pure #-}
NegFinite f <*> NegFinite x = NegFinite (f x)
_ <*> _ = NegativeInfinity
{-# INLINE (<*>) #-}
instance Applicative PositiveInfinite where
pure = PosFinite
{-# INLINE pure #-}
PosFinite f <*> PosFinite x = PosFinite (f x)
_ <*> _ = PositiveInfinity
{-# INLINE (<*>) #-}
data Infinite a
= Negative
| Finite !a
| Positive
deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor
,Foldable, Traversable)
instance DetectableZero a =>
Semiring (NegativeInfinite a) where
one = pure one
zero = pure zero
(<+>) =
(coerce :: CoerceBinary (NegativeInfinite (Add a)) (NegativeInfinite a))
mappend
x <.> y | any isZero x = zero
| otherwise = liftA2 (<.>) x y
{-# INLINE zero #-}
{-# INLINE one #-}
{-# INLINE (<+>) #-}
{-# INLINE (<.>) #-}
instance DetectableZero a =>
Semiring (PositiveInfinite a) where
one = pure one
zero = pure zero
(<+>) =
(coerce :: CoerceBinary (PositiveInfinite (Add a)) (PositiveInfinite a))
mappend
x <.> y
| any isZero x || any isZero y = zero
| otherwise = liftA2 (<.>) x y
{-# INLINE zero #-}
{-# INLINE one #-}
{-# INLINE (<+>) #-}
{-# INLINE (<.>) #-}
instance (DetectableZero a, Ord a) =>
Semiring (Infinite a) where
one = pure one
zero = pure zero
(<+>) = (coerce :: CoerceBinary (Infinite (Add a)) (Infinite a)) mappend
Finite x <.> Finite y = Finite (x <.> y)
Finite x <.> Negative = case compare x zero of
LT -> Positive
EQ -> zero
GT -> Negative
Finite x <.> Positive = case compare x zero of
LT -> Negative
EQ -> zero
GT -> Positive
Negative <.> Finite y = case compare y zero of
LT -> Positive
EQ -> zero
GT -> Negative
Positive <.> Finite y = case compare y zero of
LT -> Negative
EQ -> zero
GT -> Positive
Negative <.> Negative = Positive
Negative <.> Positive = Negative
Positive <.> Negative = Negative
Positive <.> Positive = Positive
{-# INLINE zero #-}
{-# INLINE one #-}
{-# INLINE (<+>) #-}
{-# INLINE (<.>) #-}
instance (DetectableZero a) =>
StarSemiring (PositiveInfinite a) where
star (PosFinite x)
| isZero x = one
star _ = PositiveInfinity
instance DetectableZero a =>
DetectableZero (NegativeInfinite a) where
isZero = any isZero
instance DetectableZero a =>
DetectableZero (PositiveInfinite a) where
isZero = any isZero
instance (DetectableZero a, Ord a) =>
DetectableZero (Infinite a) where
isZero = any isZero
instance Applicative Infinite where
pure = Finite
{-# INLINE pure #-}
Finite f <*> Finite x = Finite (f x)
Negative <*> Negative = Positive
Negative <*> _ = Negative
_ <*> Negative = Negative
_ <*> _ = Positive
{-# INLINE (<*>) #-}
instance Bounded a => Bounded (NegativeInfinite a) where
{-# INLINE minBound #-}
{-# INLINE maxBound #-}
minBound = NegativeInfinity
maxBound = pure maxBound
instance Bounded a => Bounded (PositiveInfinite a) where
{-# INLINE minBound #-}
{-# INLINE maxBound #-}
minBound = pure minBound
maxBound = PositiveInfinity
instance Bounded (Infinite a) where
{-# INLINE minBound #-}
{-# INLINE maxBound #-}
minBound = Negative
maxBound = Positive
instance HasNegativeInfinity (NegativeInfinite a) where
{-# INLINE negativeInfinity #-}
negativeInfinity = NegativeInfinity
isNegativeInfinity NegativeInfinity = True
isNegativeInfinity _ = False
instance HasPositiveInfinity (PositiveInfinite a) where
{-# INLINE positiveInfinity #-}
positiveInfinity = PositiveInfinity
isPositiveInfinity PositiveInfinity = True
isPositiveInfinity _ = False
instance HasNegativeInfinity (Infinite a) where
{-# INLINE negativeInfinity #-}
negativeInfinity = Negative
isNegativeInfinity Negative = True
isNegativeInfinity _ = False
instance HasPositiveInfinity (Infinite a) where
{-# INLINE positiveInfinity #-}
positiveInfinity = Positive
isPositiveInfinity Positive = True
isPositiveInfinity _ = False
instance (Enum a, Bounded a, Eq a) => Enum (NegativeInfinite a) where
succ = foldr (const . pure . succ) (pure minBound)
pred NegativeInfinity = error "Predecessor of negative infinity"
pred (NegFinite x) | x == minBound = NegativeInfinity
| otherwise = NegFinite (pred x)
toEnum 0 = NegativeInfinity
toEnum n = NegFinite (toEnum (n-1))
fromEnum = foldr (const . succ . fromEnum) 0
enumFrom NegativeInfinity = NegativeInfinity : map pure [minBound..]
enumFrom (NegFinite x) = map pure [x..]
maxBoundOf :: Bounded a => f a -> a
maxBoundOf _ = maxBound
instance (Enum a, Bounded a, Eq a) => Enum (PositiveInfinite a) where
pred = foldr (const . pure . pred) (pure maxBound)
succ PositiveInfinity = error "Successor of positive infinity"
succ (PosFinite x) | x == maxBound = PositiveInfinity
| otherwise = PosFinite (succ x)
toEnum n
| n == toEnum (maxBoundOf PositiveInfinity) + 1 = PositiveInfinity
| otherwise = PosFinite (toEnum n)
fromEnum p@PositiveInfinity = fromEnum (maxBoundOf p) + 1
fromEnum (PosFinite x) = fromEnum x
enumFrom PositiveInfinity = [PositiveInfinity]
enumFrom (PosFinite x) = map pure [x..] ++ [PositiveInfinity]
instance (Enum a, Bounded a, Eq a) => Enum (Infinite a) where
pred Negative = error "Predecessor of negative infinity"
pred Positive = Finite maxBound
pred (Finite x) | x == minBound = Negative
| otherwise = Finite (pred x)
succ Negative = Finite minBound
succ Positive = error "Successor of positive infinity"
succ (Finite x) | x == maxBound = Positive
| otherwise = Finite (succ x)
toEnum 0 = Negative
toEnum n | n == toEnum (maxBoundOf Positive) + 2 = Positive
| otherwise = Finite (toEnum (n-1))
fromEnum Negative = 0
fromEnum (Finite x) = fromEnum x + 1
fromEnum p@Positive = fromEnum (maxBoundOf p) + 1
enumFrom Positive = [Positive]
enumFrom Negative = Negative : map pure [minBound..] ++ [Positive]
enumFrom (Finite x) = map pure (enumFrom x) ++ [Positive]
instance Sem.Semigroup a => Sem.Semigroup (NegativeInfinite a) where
{-# INLINE (<>) #-}
(<>) = liftA2 (<>)
instance (Sem.Semigroup a, Monoid a) => Monoid (NegativeInfinite a) where
{-# INLINE mempty #-}
mempty = pure mempty
#if !(MIN_VERSION_base(4,11,0))
{-# INLINE mappend #-}
mappend = (<>)
#endif
instance Sem.Semigroup a => Sem.Semigroup (PositiveInfinite a) where
{-# INLINE (<>) #-}
(<>) = liftA2 (<>)
instance (Sem.Semigroup a, Monoid a) => Monoid (PositiveInfinite a) where
{-# INLINE mempty #-}
mempty = pure mempty
#if !(MIN_VERSION_base(4,11,0))
{-# INLINE mappend #-}
mappend = (<>)
#endif
instance Sem.Semigroup a => Sem.Semigroup (Infinite a) where
{-# INLINE (<>) #-}
Negative <> Positive = Positive
Positive <> Negative = Positive
Finite x <> Finite y = pure (x <> y)
Negative <> _ = Negative
Positive <> _ = Positive
_ <> y = y
instance (Sem.Semigroup a, Monoid a) => Monoid (Infinite a) where
{-# INLINE mempty #-}
mempty = pure mempty
#if !(MIN_VERSION_base(4,11,0))
{-# INLINE mappend #-}
mappend = (<>)
#endif
instance Num a => Num (NegativeInfinite a) where
fromInteger = pure . fromInteger
(+) = liftA2 (+)
(*) = liftA2 (*)
abs = fmap abs
signum = foldr (const . pure . signum) (-1)
(-) = liftA2 (-)
instance Num a => Num (PositiveInfinite a) where
fromInteger = pure . fromInteger
(+) = liftA2 (+)
(*) = liftA2 (*)
abs = fmap abs
signum = foldr (const . pure . signum) (-1)
(-) = liftA2 (-)
instance Num a => Num (Infinite a) where
fromInteger = Finite . fromInteger
(+) = (coerce :: CoerceBinary (Infinite (Sum a)) (Infinite a)) mappend
(*) = liftA2 (*)
signum Positive = 1
signum Negative = -1
signum (Finite x) = Finite (signum x)
negate Positive = Negative
negate Negative = Positive
negate (Finite x) = Finite (negate x)
abs Negative = Positive
abs x = fmap abs x
instance Storable a => Storable (NegativeInfinite a) where
sizeOf x = sizeOf (strip x) + 1
alignment x = alignment (strip x)
peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case
(1 :: Word8) -> NegFinite <$> peek (stripFPtr ptr)
_ -> pure NegativeInfinity
poke ptr NegativeInfinity
= pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (0 :: Word8)
poke ptr (NegFinite a)
= poke (stripFPtr ptr) a
*> pokeByteOff ptr (sizeOf a) (1 :: Word8)
instance Storable a => Storable (PositiveInfinite a) where
sizeOf x = sizeOf (strip x) + 1
alignment x = alignment (strip x)
peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case
(1 :: Word8) -> PosFinite <$> peek (stripFPtr ptr)
_ -> pure PositiveInfinity
poke ptr PositiveInfinity
= pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (0 :: Word8)
poke ptr (PosFinite a)
= poke (stripFPtr ptr) a
*> pokeByteOff ptr (sizeOf a) (1 :: Word8)
instance Storable a => Storable (Infinite a) where
sizeOf x = sizeOf (strip x) + 1
alignment x = alignment (strip x)
peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case
0 -> pure Negative
(1 :: Word8) -> Finite <$> peek (stripFPtr ptr)
_ -> pure Positive
poke ptr Positive
= pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (2 :: Word8)
poke ptr Negative
= pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (0 :: Word8)
poke ptr (Finite a)
= poke (stripFPtr ptr) a
*> pokeByteOff ptr (sizeOf a) (1 :: Word8)
strip :: f a -> a
strip _ = error "strip"
stripFPtr :: Ptr (f a) -> Ptr a
stripFPtr = castPtr
stripPtr :: Ptr a -> a
stripPtr _ = error "stripPtr"
instance NFData a =>
NFData (NegativeInfinite a) where
rnf NegativeInfinity = ()
rnf (NegFinite x) = rnf x
instance NFData a =>
NFData (PositiveInfinite a) where
rnf PositiveInfinity = ()
rnf (PosFinite x) = rnf x
instance NFData a =>
NFData (Infinite a) where
rnf Negative = ()
rnf Positive = ()
rnf (Finite x) = rnf x
instance Eq1 NegativeInfinite where
liftEq eq = go
where
go NegativeInfinity NegativeInfinity = True
go (NegFinite x) (NegFinite y) = eq x y
go _ _ = False
instance Eq1 PositiveInfinite where
liftEq eq = go
where
go PositiveInfinity PositiveInfinity = True
go (PosFinite x) (PosFinite y) = eq x y
go _ _ = False
instance Eq1 Infinite where
liftEq eq = go
where
go Positive Positive = True
go Negative Negative = True
go (Finite x) (Finite y) = eq x y
go _ _ = False
instance Ord1 NegativeInfinite where
liftCompare cmp = go
where
go NegativeInfinity NegativeInfinity = EQ
go (NegFinite x) (NegFinite y) = cmp x y
go NegativeInfinity (NegFinite _) = LT
go (NegFinite _) NegativeInfinity = GT
instance Ord1 PositiveInfinite where
liftCompare cmp = go
where
go PositiveInfinity PositiveInfinity = EQ
go (PosFinite x) (PosFinite y) = cmp x y
go PositiveInfinity (PosFinite _) = GT
go (PosFinite _) PositiveInfinity = LT
instance Ord1 Infinite where
liftCompare cmp = go
where
go Positive Positive = EQ
go Positive Negative = GT
go Negative Positive = LT
go Negative Negative = EQ
go Positive (Finite _) = GT
go Negative (Finite _) = LT
go (Finite _) Positive = LT
go (Finite _) Negative = GT
go (Finite x) (Finite y) = cmp x y
instance Show1 PositiveInfinite where
liftShowsPrec sp _ n = go
where
go PositiveInfinity = showString "PositiveInfinity"
go (PosFinite x) =
showParen (n > 10) $ showString "PosFinite " . sp 11 x
instance Show1 NegativeInfinite where
liftShowsPrec sp _ n = go
where
go NegativeInfinity = showString "NegativeInfinity"
go (NegFinite x) =
showParen (n > 10) $ showString "NegFinite " . sp 11 x
instance Show1 Infinite where
liftShowsPrec sp _ n = go
where
go Positive = showString "Positive"
go Negative = showString "Negative"
go (Finite x) =
showParen (n > 10) $ showString "Finite " . sp 11 x
instance Read1 PositiveInfinite where
liftReadsPrec rp _ =
readPrec_to_S $
parens $
(do Ident "PositiveInfinity" <- lexP
pure PositiveInfinity) +++
prec
10
(do Ident "PosFinite" <- lexP
m <- step (readS_to_Prec rp)
pure (PosFinite m))
instance Read1 NegativeInfinite where
liftReadsPrec rp _ =
readPrec_to_S $
parens $
(do Ident "NegativeInfinity" <- lexP
pure NegativeInfinity) +++
prec
10
(do Ident "NegFinite" <- lexP
m <- step (readS_to_Prec rp)
pure (NegFinite m))
instance Read1 Infinite where
liftReadsPrec rp _ =
readPrec_to_S $
parens $
(do Ident "Negative" <- lexP
pure Negative) +++
(do Ident "Positive" <- lexP
pure Positive) +++
prec
10
(do Ident "Finite" <- lexP
m <- step (readS_to_Prec rp)
pure (Finite m))
data instance
U.MVector s
(NegativeInfinite
a) = MV_NegativeInfinite {-# UNPACK #-} !(U.MVector s Bool)
!(U.MVector s a)
data instance
U.Vector
(NegativeInfinite a) = V_NegativeInfinite {-# UNPACK #-} !(U.Vector
Bool)
!(U.Vector a)
instance U.Unbox a => U.Unbox (NegativeInfinite a)
instance (U.Unbox a) =>
M.MVector U.MVector (NegativeInfinite a) where
{-# INLINE basicLength #-}
basicLength (MV_NegativeInfinite xs _) = M.basicLength xs
{-# INLINE basicUnsafeSlice #-}
basicUnsafeSlice i_ m_ (MV_NegativeInfinite as bs) =
MV_NegativeInfinite
(M.basicUnsafeSlice i_ m_ as)
(M.basicUnsafeSlice i_ m_ bs)
{-# INLINE basicOverlaps #-}
basicOverlaps (MV_NegativeInfinite as1 bs1) (MV_NegativeInfinite as2 bs2) =
M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2
{-# INLINE basicUnsafeNew #-}
basicUnsafeNew n_ =
liftA2
MV_NegativeInfinite
(M.basicUnsafeNew n_)
(M.basicUnsafeNew n_)
{-# INLINE basicInitialize #-}
basicInitialize (MV_NegativeInfinite as bs) =
M.basicInitialize as *> M.basicInitialize bs
{-# INLINE basicUnsafeReplicate #-}
basicUnsafeReplicate n_ NegativeInfinity =
liftA2
MV_NegativeInfinite
(M.basicUnsafeReplicate n_ False)
(M.basicUnsafeNew n_)
basicUnsafeReplicate n_ (NegFinite x) =
liftA2
MV_NegativeInfinite
(M.basicUnsafeReplicate n_ True)
(M.basicUnsafeReplicate n_ x)
{-# INLINE basicUnsafeRead #-}
basicUnsafeRead (MV_NegativeInfinite as bs) i_ =
M.basicUnsafeRead as i_ >>=
bool (pure NegativeInfinity) (NegFinite <$> M.basicUnsafeRead bs i_)
{-# INLINE basicUnsafeWrite #-}
basicUnsafeWrite (MV_NegativeInfinite as _) i_ NegativeInfinity =
M.basicUnsafeWrite as i_ False
basicUnsafeWrite (MV_NegativeInfinite as bs) i_ (NegFinite x) =
M.basicUnsafeWrite as i_ True *> M.basicUnsafeWrite bs i_ x
{-# INLINE basicClear #-}
basicClear (MV_NegativeInfinite as bs) =
M.basicClear as *> M.basicClear bs
{-# INLINE basicSet #-}
basicSet (MV_NegativeInfinite as bs) NegativeInfinity =
M.basicSet as False *> M.basicClear bs
basicSet (MV_NegativeInfinite as bs) (NegFinite x) =
M.basicSet as True *> M.basicSet bs x
{-# INLINE basicUnsafeCopy #-}
basicUnsafeCopy (MV_NegativeInfinite as1 bs1) (MV_NegativeInfinite as2 bs2) =
M.basicUnsafeCopy as1 as2 *> M.basicUnsafeCopy bs1 bs2
{-# INLINE basicUnsafeMove #-}
basicUnsafeMove (MV_NegativeInfinite as1 bs1) (MV_NegativeInfinite as2 bs2) =
M.basicUnsafeMove as1 as2 *> M.basicUnsafeMove bs1 bs2
{-# INLINE basicUnsafeGrow #-}
basicUnsafeGrow (MV_NegativeInfinite as bs) m_ =
liftA2
MV_NegativeInfinite
(M.basicUnsafeGrow as m_)
(M.basicUnsafeGrow bs m_)
instance (U.Unbox a) =>
G.Vector U.Vector (NegativeInfinite a) where
{-# INLINE basicUnsafeFreeze #-}
basicUnsafeFreeze (MV_NegativeInfinite as bs) =
liftA2
V_NegativeInfinite
(G.basicUnsafeFreeze as)
(G.basicUnsafeFreeze bs)
{-# INLINE basicUnsafeThaw #-}
basicUnsafeThaw (V_NegativeInfinite as bs) =
liftA2
MV_NegativeInfinite
(G.basicUnsafeThaw as)
(G.basicUnsafeThaw bs)
{-# INLINE basicLength #-}
basicLength (V_NegativeInfinite xs _) = G.basicLength xs
{-# INLINE basicUnsafeSlice #-}
basicUnsafeSlice i_ m_ (V_NegativeInfinite as bs) =
V_NegativeInfinite
(G.basicUnsafeSlice i_ m_ as)
(G.basicUnsafeSlice i_ m_ bs)
{-# INLINE basicUnsafeIndexM #-}
basicUnsafeIndexM (V_NegativeInfinite as bs) i_ =
G.basicUnsafeIndexM as i_ >>=
bool (pure NegativeInfinity) (NegFinite <$> G.basicUnsafeIndexM bs i_)
{-# INLINE basicUnsafeCopy #-}
basicUnsafeCopy (MV_NegativeInfinite as1 bs1) (V_NegativeInfinite as2 bs2) =
G.basicUnsafeCopy as1 as2 *> G.basicUnsafeCopy bs1 bs2
{-# INLINE elemseq #-}
elemseq _ NegativeInfinity b = b
elemseq _ (NegFinite x) b = G.elemseq (undefined :: U.Vector a) x b
data instance
U.MVector s
(PositiveInfinite
a) = MV_PositiveInfinite {-# UNPACK #-} !(U.MVector s Bool)
!(U.MVector s a)
data instance
U.Vector
(PositiveInfinite a) = V_PositiveInfinite {-# UNPACK #-} !(U.Vector
Bool)
!(U.Vector a)
instance U.Unbox a => U.Unbox (PositiveInfinite a)
instance (U.Unbox a) =>
M.MVector U.MVector (PositiveInfinite a) where
{-# INLINE basicLength #-}
basicLength (MV_PositiveInfinite xs _) = M.basicLength xs
{-# INLINE basicUnsafeSlice #-}
basicUnsafeSlice i_ m_ (MV_PositiveInfinite as bs) =
MV_PositiveInfinite
(M.basicUnsafeSlice i_ m_ as)
(M.basicUnsafeSlice i_ m_ bs)
{-# INLINE basicOverlaps #-}
basicOverlaps (MV_PositiveInfinite as1 bs1) (MV_PositiveInfinite as2 bs2) =
M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2
{-# INLINE basicUnsafeNew #-}
basicUnsafeNew n_ =
liftA2
MV_PositiveInfinite
(M.basicUnsafeNew n_)
(M.basicUnsafeNew n_)
{-# INLINE basicInitialize #-}
basicInitialize (MV_PositiveInfinite as bs) =
M.basicInitialize as *> M.basicInitialize bs
{-# INLINE basicUnsafeReplicate #-}
basicUnsafeReplicate n_ PositiveInfinity =
liftA2
MV_PositiveInfinite
(M.basicUnsafeReplicate n_ False)
(M.basicUnsafeNew n_)
basicUnsafeReplicate n_ (PosFinite x) =
liftA2
MV_PositiveInfinite
(M.basicUnsafeReplicate n_ True)
(M.basicUnsafeReplicate n_ x)
{-# INLINE basicUnsafeRead #-}
basicUnsafeRead (MV_PositiveInfinite as bs) i_ =
M.basicUnsafeRead as i_ >>=
bool (pure PositiveInfinity) (PosFinite <$> M.basicUnsafeRead bs i_)
{-# INLINE basicUnsafeWrite #-}
basicUnsafeWrite (MV_PositiveInfinite as _) i_ PositiveInfinity =
M.basicUnsafeWrite as i_ False
basicUnsafeWrite (MV_PositiveInfinite as bs) i_ (PosFinite x) =
M.basicUnsafeWrite as i_ True *> M.basicUnsafeWrite bs i_ x
{-# INLINE basicClear #-}
basicClear (MV_PositiveInfinite as bs) =
M.basicClear as *> M.basicClear bs
{-# INLINE basicSet #-}
basicSet (MV_PositiveInfinite as bs) PositiveInfinity =
M.basicSet as False *> M.basicClear bs
basicSet (MV_PositiveInfinite as bs) (PosFinite x) =
M.basicSet as True *> M.basicSet bs x
{-# INLINE basicUnsafeCopy #-}
basicUnsafeCopy (MV_PositiveInfinite as1 bs1) (MV_PositiveInfinite as2 bs2) =
M.basicUnsafeCopy as1 as2 *> M.basicUnsafeCopy bs1 bs2
{-# INLINE basicUnsafeMove #-}
basicUnsafeMove (MV_PositiveInfinite as1 bs1) (MV_PositiveInfinite as2 bs2) =
M.basicUnsafeMove as1 as2 *> M.basicUnsafeMove bs1 bs2
{-# INLINE basicUnsafeGrow #-}
basicUnsafeGrow (MV_PositiveInfinite as bs) m_ =
liftA2
MV_PositiveInfinite
(M.basicUnsafeGrow as m_)
(M.basicUnsafeGrow bs m_)
instance (U.Unbox a) =>
G.Vector U.Vector (PositiveInfinite a) where
{-# INLINE basicUnsafeFreeze #-}
basicUnsafeFreeze (MV_PositiveInfinite as bs) =
liftA2
V_PositiveInfinite
(G.basicUnsafeFreeze as)
(G.basicUnsafeFreeze bs)
{-# INLINE basicUnsafeThaw #-}
basicUnsafeThaw (V_PositiveInfinite as bs) =
liftA2
MV_PositiveInfinite
(G.basicUnsafeThaw as)
(G.basicUnsafeThaw bs)
{-# INLINE basicLength #-}
basicLength (V_PositiveInfinite xs _) = G.basicLength xs
{-# INLINE basicUnsafeSlice #-}
basicUnsafeSlice i_ m_ (V_PositiveInfinite as bs) =
V_PositiveInfinite
(G.basicUnsafeSlice i_ m_ as)
(G.basicUnsafeSlice i_ m_ bs)
{-# INLINE basicUnsafeIndexM #-}
basicUnsafeIndexM (V_PositiveInfinite as bs) i_ =
G.basicUnsafeIndexM as i_ >>=
bool (pure PositiveInfinity) (PosFinite <$> G.basicUnsafeIndexM bs i_)
{-# INLINE basicUnsafeCopy #-}
basicUnsafeCopy (MV_PositiveInfinite as1 bs1) (V_PositiveInfinite as2 bs2) =
G.basicUnsafeCopy as1 as2 *> G.basicUnsafeCopy bs1 bs2
{-# INLINE elemseq #-}
elemseq _ PositiveInfinity b = b
elemseq _ (PosFinite x) b = G.elemseq (undefined :: U.Vector a) x b
data instance
U.MVector s (Infinite a) = MV_Infinite {-# UNPACK #-} !(U.MVector s
Word8)
!(U.MVector s a)
data instance
U.Vector (Infinite a) = V_Infinite {-# UNPACK #-} !(U.Vector Word8)
!(U.Vector a)
instance U.Unbox a => U.Unbox (Infinite a)
instance (U.Unbox a) =>
M.MVector U.MVector (Infinite a) where
{-# INLINE basicLength #-}
basicLength (MV_Infinite xs _) = M.basicLength xs
{-# INLINE basicUnsafeSlice #-}
basicUnsafeSlice i_ m_ (MV_Infinite as bs) =
MV_Infinite
(M.basicUnsafeSlice i_ m_ as)
(M.basicUnsafeSlice i_ m_ bs)
{-# INLINE basicOverlaps #-}
basicOverlaps (MV_Infinite as1 bs1) (MV_Infinite as2 bs2) =
M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2
{-# INLINE basicUnsafeNew #-}
basicUnsafeNew n_ =
liftA2
MV_Infinite
(M.basicUnsafeNew n_)
(M.basicUnsafeNew n_)
{-# INLINE basicInitialize #-}
basicInitialize (MV_Infinite as bs) =
M.basicInitialize as *> M.basicInitialize bs
{-# INLINE basicUnsafeReplicate #-}
basicUnsafeReplicate n_ Positive =
liftA2
MV_Infinite
(M.basicUnsafeReplicate n_ 2)
(M.basicUnsafeNew n_)
basicUnsafeReplicate n_ Negative =
liftA2
MV_Infinite
(M.basicUnsafeReplicate n_ 0)
(M.basicUnsafeNew n_)
basicUnsafeReplicate n_ (Finite x) =
liftA2
MV_Infinite
(M.basicUnsafeReplicate n_ 1)
(M.basicUnsafeReplicate n_ x)
{-# INLINE basicUnsafeRead #-}
basicUnsafeRead (MV_Infinite as bs) i_ =
M.basicUnsafeRead as i_ >>= \case
0 -> pure Negative
1 -> Finite <$> M.basicUnsafeRead bs i_
_ -> pure Positive
{-# INLINE basicUnsafeWrite #-}
basicUnsafeWrite (MV_Infinite as _) i_ Positive =
M.basicUnsafeWrite as i_ 2
basicUnsafeWrite (MV_Infinite as _) i_ Negative =
M.basicUnsafeWrite as i_ 0
basicUnsafeWrite (MV_Infinite as bs) i_ (Finite x) =
M.basicUnsafeWrite as i_ 1 *> M.basicUnsafeWrite bs i_ x
{-# INLINE basicClear #-}
basicClear (MV_Infinite as bs) =
M.basicClear as *> M.basicClear bs
{-# INLINE basicSet #-}
basicSet (MV_Infinite as bs) Positive =
M.basicSet as 2 *> M.basicClear bs
basicSet (MV_Infinite as bs) Negative =
M.basicSet as 0 *> M.basicClear bs
basicSet (MV_Infinite as bs) (Finite x) =
M.basicSet as 1 *> M.basicSet bs x
{-# INLINE basicUnsafeCopy #-}
basicUnsafeCopy (MV_Infinite as1 bs1) (MV_Infinite as2 bs2) =
M.basicUnsafeCopy as1 as2 *> M.basicUnsafeCopy bs1 bs2
{-# INLINE basicUnsafeMove #-}
basicUnsafeMove (MV_Infinite as1 bs1) (MV_Infinite as2 bs2) =
M.basicUnsafeMove as1 as2 *> M.basicUnsafeMove bs1 bs2
{-# INLINE basicUnsafeGrow #-}
basicUnsafeGrow (MV_Infinite as bs) m_ =
liftA2
MV_Infinite
(M.basicUnsafeGrow as m_)
(M.basicUnsafeGrow bs m_)
instance (U.Unbox a) =>
G.Vector U.Vector (Infinite a) where
{-# INLINE basicUnsafeFreeze #-}
basicUnsafeFreeze (MV_Infinite as bs) =
liftA2
V_Infinite
(G.basicUnsafeFreeze as)
(G.basicUnsafeFreeze bs)
{-# INLINE basicUnsafeThaw #-}
basicUnsafeThaw (V_Infinite as bs) =
liftA2
MV_Infinite
(G.basicUnsafeThaw as)
(G.basicUnsafeThaw bs)
{-# INLINE basicLength #-}
basicLength (V_Infinite xs _) = G.basicLength xs
{-# INLINE basicUnsafeSlice #-}
basicUnsafeSlice i_ m_ (V_Infinite as bs) =
V_Infinite
(G.basicUnsafeSlice i_ m_ as)
(G.basicUnsafeSlice i_ m_ bs)
{-# INLINE basicUnsafeIndexM #-}
basicUnsafeIndexM (V_Infinite as bs) i_ =
G.basicUnsafeIndexM as i_ >>= \case
0 -> pure Negative
1 -> Finite <$> G.basicUnsafeIndexM bs i_
_ -> pure Positive
{-# INLINE basicUnsafeCopy #-}
basicUnsafeCopy (MV_Infinite as1 bs1) (V_Infinite as2 bs2) =
G.basicUnsafeCopy as1 as2 *> G.basicUnsafeCopy bs1 bs2
{-# INLINE elemseq #-}
elemseq _ Positive b = b
elemseq _ Negative b = b
elemseq _ (Finite x) b = G.elemseq (undefined :: U.Vector a) x b