{-# LANGUAGE DerivingVia, StandaloneDeriving, TypeOperators #-} {-# LANGUAGE CPP #-} module Control.Subcategory.Pointed where import Control.Subcategory.Functor import qualified Control.Applicative as App import qualified Control.Monad.ST.Lazy as LST import qualified Control.Monad.ST.Strict as SST import qualified Data.Functor.Compose as SOP import Data.Functor.Identity (Identity) import qualified Data.Functor.Product as SOP import qualified Data.HashSet as HS import qualified Data.IntSet as IS import Data.List.NonEmpty (NonEmpty) import qualified Data.Monoid as Mon import Data.MonoTraversable (MonoPointed, opoint) import Data.Ord (Down) import qualified Data.Pointed as Pt import qualified Data.Primitive.Array as A import qualified Data.Primitive.PrimArray as PA import qualified Data.Primitive.SmallArray as SA import Data.Proxy (Proxy) import qualified Data.Semigroup as Sem import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Tree as Tree import qualified Data.Vector as V import qualified Data.Vector.Primitive as P import qualified Data.Vector.Storable as S import qualified Data.Vector.Unboxed as U import GHC.Conc (STM) import GHC.Generics ((:*:) (..), (:.:) (..)) import GHC.Generics (Par1, Rec1, U1) import Text.ParserCombinators.ReadP (ReadP) import Text.ParserCombinators.ReadPrec (ReadPrec) class Constrained f => CPointed f where cpure :: Dom f a => a -> f a default cpure :: App.Applicative f => a -> f a cpure = forall (f :: * -> *) a. Applicative f => a -> f a pure instance (Functor f, Pt.Pointed f) => CPointed (WrapFunctor f) where cpure :: forall a. Dom (WrapFunctor f) a => a -> WrapFunctor f a cpure = forall (p :: * -> *) a. Pointed p => a -> p a Pt.point {-# INLINE cpure #-} instance CPointed [] instance CPointed Maybe instance CPointed IO instance CPointed (SST.ST s) instance CPointed (LST.ST s) instance CPointed Par1 instance CPointed Sem.Min instance CPointed Sem.Max instance CPointed Mon.First instance CPointed Mon.Last instance CPointed Sem.First instance CPointed Sem.Last #if !MIN_VERSION_base(4,16,0) instance CPointed Sem.Option #endif instance CPointed NonEmpty instance CPointed App.ZipList instance CPointed Identity instance CPointed STM instance CPointed Sem.Dual instance CPointed Sem.Sum instance CPointed Sem.Product instance CPointed Down instance CPointed Tree.Tree instance CPointed Seq.Seq instance CPointed Set.Set where cpure :: forall a. Dom Set a => a -> Set a cpure = forall a. a -> Set a Set.singleton {-# INLINE cpure #-} instance CPointed (Either a) instance CPointed U1 instance CPointed Proxy instance (Pt.Pointed f) => CPointed (Rec1 f) where cpure :: forall a. Dom (Rec1 f) a => a -> Rec1 f a cpure = forall (p :: * -> *) a. Pointed p => a -> p a Pt.point {-# INLINE cpure #-} instance (Pt.Pointed p, Pt.Pointed q) => CPointed (p :*: q) where cpure :: forall a. Dom (p :*: q) a => a -> (:*:) p q a cpure a a = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> g p -> (:*:) f g p (:*:) (forall (p :: * -> *) a. Pointed p => a -> p a Pt.point a a) (forall (p :: * -> *) a. Pointed p => a -> p a Pt.point a a) {-# INLINE cpure #-} instance (Pt.Pointed p, Pt.Pointed q) => CPointed (p :.: q) where cpure :: forall a. Dom (p :.: q) a => a -> (:.:) p q a cpure a a = forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1). f (g p) -> (:.:) f g p Comp1 forall a b. (a -> b) -> a -> b $ forall (p :: * -> *) a. Pointed p => a -> p a Pt.point forall a b. (a -> b) -> a -> b $ forall (p :: * -> *) a. Pointed p => a -> p a Pt.point a a {-# INLINE cpure #-} instance (Constrained p, Constrained q, Pt.Pointed p, Pt.Pointed q) => CPointed (SOP.Compose p q) where cpure :: forall a. Dom (Compose p q) a => a -> Compose p q a cpure a a = forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1). f (g a) -> Compose f g a SOP.Compose forall a b. (a -> b) -> a -> b $ forall (p :: * -> *) a. Pointed p => a -> p a Pt.point forall a b. (a -> b) -> a -> b $ forall (p :: * -> *) a. Pointed p => a -> p a Pt.point a a {-# INLINE cpure #-} instance (CPointed p, CPointed q) => CPointed (SOP.Product p q) where cpure :: forall a. Dom (Product p q) a => a -> Product p q a cpure a a = forall {k} (f :: k -> *) (g :: k -> *) (a :: k). f a -> g a -> Product f g a SOP.Pair (forall (f :: * -> *) a. (CPointed f, Dom f a) => a -> f a cpure a a) (forall (f :: * -> *) a. (CPointed f, Dom f a) => a -> f a cpure a a) {-# INLINE cpure #-} instance CPointed ReadP instance CPointed ReadPrec instance CPointed (WrapMono IS.IntSet) where cpure :: forall a. Dom (WrapMono IntSet) a => a -> WrapMono IntSet a cpure = forall b mono. (b ~ Element mono, b ~ Element mono) => mono -> WrapMono mono b WrapMono forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> IntSet IS.singleton {-# INLINE cpure #-} instance CPointed HS.HashSet where cpure :: forall a. Dom HashSet a => a -> HashSet a cpure = forall a. Hashable a => a -> HashSet a HS.singleton {-# INLINE cpure #-} instance MonoPointed mono => CPointed (WrapMono mono) where cpure :: forall a. Dom (WrapMono mono) a => a -> WrapMono mono a cpure = forall mono. MonoPointed mono => Element mono -> mono opoint instance CPointed V.Vector where cpure :: forall a. Dom Vector a => a -> Vector a cpure = forall a. a -> Vector a V.singleton {-# INLINE [1] cpure #-} instance CPointed U.Vector where cpure :: forall a. Dom Vector a => a -> Vector a cpure = forall a. Unbox a => a -> Vector a U.singleton {-# INLINE [1] cpure #-} instance CPointed S.Vector where cpure :: forall a. Dom Vector a => a -> Vector a cpure = forall a. Storable a => a -> Vector a S.singleton {-# INLINE [1] cpure #-} instance CPointed P.Vector where cpure :: forall a. Dom Vector a => a -> Vector a cpure = forall a. Prim a => a -> Vector a P.singleton {-# INLINE [1] cpure #-} instance CPointed PA.PrimArray where cpure :: forall a. Dom PrimArray a => a -> PrimArray a cpure = forall a. Prim a => Int -> a -> PrimArray a PA.replicatePrimArray Int 1 {-# INLINE [1] cpure #-} instance CPointed SA.SmallArray where cpure :: forall a. Dom SmallArray a => a -> SmallArray a cpure = forall a. Int -> [a] -> SmallArray a SA.smallArrayFromListN Int 1 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a. Applicative f => a -> f a pure {-# INLINE [1] cpure #-} instance CPointed A.Array where cpure :: forall a. Dom Array a => a -> Array a cpure = forall l. IsList l => Int -> [Item l] -> l A.fromListN Int 1 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a. Applicative f => a -> f a pure {-# INLINE [1] cpure #-}