{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Wrapped
(
Wrapped(..), Wrapped1(..)
, GSemigroup(..), GMonoid(..)
) where
import Control.Applicative (liftA2)
import qualified Data.Foldable as F (toList)
import Data.Function (on)
import Data.Kind (Constraint, Type)
#if !MIN_VERSION_base(4, 11, 0)
import Data.Semigroup (Semigroup(..))
#endif
import GHC.Exts (IsList(Item))
import qualified GHC.Exts as Exts (IsList(..))
import GHC.Generics
( Generic(..), Generic1(..)
, M1(..), (:*:)(..), U1(..), K1(..)
)
import Text.Read (Read(..), readListPrecDefault)
newtype Wrapped (c :: Type -> Constraint) a = Wrapped { Wrapped c a -> a
unWrapped :: a }
newtype Wrapped1 (c :: (k -> Type) -> Constraint) f (a :: k) =
Wrapped1 { Wrapped1 c f a -> f a
unWrapped1 :: f a }
class GSemigroup f where
gsop :: f x -> f x -> f x
instance GSemigroup U1 where
gsop :: U1 x -> U1 x -> U1 x
gsop = (U1 x -> U1 x) -> U1 x -> U1 x -> U1 x
forall a b. a -> b -> a
const ((U1 x -> U1 x) -> U1 x -> U1 x -> U1 x)
-> (U1 x -> U1 x) -> U1 x -> U1 x -> U1 x
forall a b. (a -> b) -> a -> b
$ U1 x -> U1 x -> U1 x
forall a b. a -> b -> a
const U1 x
forall k (p :: k). U1 p
U1
instance GSemigroup a => GSemigroup (M1 i c a) where
M1 a x
a gsop :: M1 i c a x -> M1 i c a x -> M1 i c a x
`gsop` M1 a x
b = a x -> M1 i c a x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a x -> M1 i c a x) -> a x -> M1 i c a x
forall a b. (a -> b) -> a -> b
$ a x
a a x -> a x -> a x
forall k (f :: k -> *) (x :: k). GSemigroup f => f x -> f x -> f x
`gsop` a x
b
instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where
(f x
fa :*: g x
ga) gsop :: (:*:) f g x -> (:*:) f g x -> (:*:) f g x
`gsop` (f x
fb :*: g x
gb) = (f x
fa f x -> f x -> f x
forall k (f :: k -> *) (x :: k). GSemigroup f => f x -> f x -> f x
`gsop` f x
fb) f x -> g x -> (:*:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: (g x
ga g x -> g x -> g x
forall k (f :: k -> *) (x :: k). GSemigroup f => f x -> f x -> f x
`gsop` g x
gb)
instance Semigroup a => GSemigroup (K1 i a) where
K1 a
fa gsop :: K1 i a x -> K1 i a x -> K1 i a x
`gsop` K1 a
ga = a -> K1 i a x
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a x) -> a -> K1 i a x
forall a b. (a -> b) -> a -> b
$ a
fa a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
ga
instance (Generic a, GSemigroup (Rep a)) => Semigroup (Wrapped Generic a) where
Wrapped a
a <> :: Wrapped Generic a -> Wrapped Generic a -> Wrapped Generic a
<> Wrapped a
b = a -> Wrapped Generic a
forall (c :: * -> Constraint) a. a -> Wrapped c a
Wrapped (a -> Wrapped Generic a)
-> (Rep a Any -> a) -> Rep a Any -> Wrapped Generic a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> Wrapped Generic a) -> Rep a Any -> Wrapped Generic a
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
a Rep a Any -> Rep a Any -> Rep a Any
forall k (f :: k -> *) (x :: k). GSemigroup f => f x -> f x -> f x
`gsop` a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
b
class GMonoid f where
gmempty :: f x
instance GMonoid f => GMonoid (M1 i m f) where
gmempty :: M1 i m f x
gmempty = f x -> M1 i m f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f x
forall k (f :: k -> *) (x :: k). GMonoid f => f x
gmempty
instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where
gmempty :: (:*:) f g x
gmempty = f x
forall k (f :: k -> *) (x :: k). GMonoid f => f x
gmempty f x -> g x -> (:*:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g x
forall k (f :: k -> *) (x :: k). GMonoid f => f x
gmempty
instance GMonoid U1 where
gmempty :: U1 x
gmempty = U1 x
forall k (p :: k). U1 p
U1
instance Monoid a => GMonoid (K1 i a) where
gmempty :: K1 i a x
gmempty = a -> K1 i a x
forall k i c (p :: k). c -> K1 i c p
K1 a
forall a. Monoid a => a
mempty
instance (Generic a, GSemigroup (Rep a), GMonoid (Rep a))
=> Monoid (Wrapped Generic a) where
#if !MIN_VERSION_base(4, 11, 0)
mappend = (<>)
#endif
mempty :: Wrapped Generic a
mempty = a -> Wrapped Generic a
forall (c :: * -> Constraint) a. a -> Wrapped c a
Wrapped (a -> Wrapped Generic a) -> a -> Wrapped Generic a
forall a b. (a -> b) -> a -> b
$ Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to Rep a Any
forall k (f :: k -> *) (x :: k). GMonoid f => f x
gmempty
instance IsList a => IsList (Wrapped IsList a) where
type Item (Wrapped IsList a) = Exts.Item a
fromList :: [Item (Wrapped IsList a)] -> Wrapped IsList a
fromList = a -> Wrapped IsList a
forall (c :: * -> Constraint) a. a -> Wrapped c a
Wrapped (a -> Wrapped IsList a)
-> ([Item a] -> a) -> [Item a] -> Wrapped IsList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Item a] -> a
forall l. IsList l => [Item l] -> l
Exts.fromList
fromListN :: Int -> [Item (Wrapped IsList a)] -> Wrapped IsList a
fromListN Int
n = a -> Wrapped IsList a
forall (c :: * -> Constraint) a. a -> Wrapped c a
Wrapped (a -> Wrapped IsList a)
-> ([Item a] -> a) -> [Item a] -> Wrapped IsList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Item a] -> a
forall l. IsList l => Int -> [Item l] -> l
Exts.fromListN Int
n
toList :: Wrapped IsList a -> [Item (Wrapped IsList a)]
toList = a -> [Item a]
forall l. IsList l => l -> [Item l]
Exts.toList (a -> [Item a])
-> (Wrapped IsList a -> a) -> Wrapped IsList a -> [Item a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wrapped IsList a -> a
forall (c :: * -> Constraint) a. Wrapped c a -> a
unWrapped
instance (IsList a, Eq (Item a)) => Eq (Wrapped IsList a) where
== :: Wrapped IsList a -> Wrapped IsList a -> Bool
(==) = [Item a] -> [Item a] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([Item a] -> [Item a] -> Bool)
-> (Wrapped IsList a -> [Item a])
-> Wrapped IsList a
-> Wrapped IsList a
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Wrapped IsList a -> [Item a]
forall l. IsList l => l -> [Item l]
Exts.toList
instance (IsList a, Ord (Item a)) => Ord (Wrapped IsList a) where
compare :: Wrapped IsList a -> Wrapped IsList a -> Ordering
compare = [Item a] -> [Item a] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Item a] -> [Item a] -> Ordering)
-> (Wrapped IsList a -> [Item a])
-> Wrapped IsList a
-> Wrapped IsList a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Wrapped IsList a -> [Item a]
forall l. IsList l => l -> [Item l]
Exts.toList
instance (IsList a, Show (Item a)) => Show (Wrapped IsList a) where
showsPrec :: Int -> Wrapped IsList a -> ShowS
showsPrec Int
p = Int -> [Item a] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p ([Item a] -> ShowS)
-> (Wrapped IsList a -> [Item a]) -> Wrapped IsList a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wrapped IsList a -> [Item a]
forall l. IsList l => l -> [Item l]
Exts.toList
instance (IsList a, Read (Item a)) => Read (Wrapped IsList a) where
readPrec :: ReadPrec (Wrapped IsList a)
readPrec = ([Item a] -> Wrapped IsList a)
-> ReadPrec [Item a] -> ReadPrec (Wrapped IsList a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Item a] -> Wrapped IsList a
forall l. IsList l => [Item l] -> l
Exts.fromList (ReadPrec [Item a] -> ReadPrec (Wrapped IsList a))
-> ReadPrec [Item a] -> ReadPrec (Wrapped IsList a)
forall a b. (a -> b) -> a -> b
$ Read [Item a] => ReadPrec [Item a]
forall a. Read a => ReadPrec a
readPrec @[Item a]
readListPrec :: ReadPrec [Wrapped IsList a]
readListPrec = ReadPrec [Wrapped IsList a]
forall a. Read a => ReadPrec [a]
readListPrecDefault
deriving instance Foldable f => Foldable (Wrapped1 Foldable f)
instance (Foldable f, Eq a) => Eq (Wrapped1 Foldable f a) where
== :: Wrapped1 Foldable f a -> Wrapped1 Foldable f a -> Bool
(==) = [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([a] -> [a] -> Bool)
-> (Wrapped1 Foldable f a -> [a])
-> Wrapped1 Foldable f a
-> Wrapped1 Foldable f a
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Wrapped1 Foldable f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList
instance (Foldable f, Ord a) => Ord (Wrapped1 Foldable f a) where
compare :: Wrapped1 Foldable f a -> Wrapped1 Foldable f a -> Ordering
compare = [a] -> [a] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([a] -> [a] -> Ordering)
-> (Wrapped1 Foldable f a -> [a])
-> Wrapped1 Foldable f a
-> Wrapped1 Foldable f a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Wrapped1 Foldable f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList
instance (Foldable f, Show a) => Show (Wrapped1 Foldable f a) where
showsPrec :: Int -> Wrapped1 Foldable f a -> ShowS
showsPrec Int
p = Int -> [a] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p ([a] -> ShowS)
-> (Wrapped1 Foldable f a -> [a]) -> Wrapped1 Foldable f a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wrapped1 Foldable f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList
instance (Applicative f, Semigroup a)
=> Semigroup (Wrapped1 Applicative f a) where
<> :: Wrapped1 Applicative f a
-> Wrapped1 Applicative f a -> Wrapped1 Applicative f a
(<>) = (f a -> Wrapped1 Applicative f a)
-> (Wrapped1 Applicative f a -> f a)
-> Wrapped1 Applicative f a
-> Wrapped1 Applicative f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> Wrapped1 Applicative f a
forall k (c :: (k -> *) -> Constraint) (f :: k -> *) (a :: k).
f a -> Wrapped1 c f a
Wrapped1 ((Wrapped1 Applicative f a -> f a)
-> Wrapped1 Applicative f a -> Wrapped1 Applicative f a)
-> (Wrapped1 Applicative f a -> Wrapped1 Applicative f a -> f a)
-> Wrapped1 Applicative f a
-> Wrapped1 Applicative f a
-> Wrapped1 Applicative f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> a -> a) -> f a -> f a -> f a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) (f a -> f a -> f a)
-> (Wrapped1 Applicative f a -> f a)
-> Wrapped1 Applicative f a
-> Wrapped1 Applicative f a
-> f a
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Wrapped1 Applicative f a -> f a
forall k (c :: (k -> *) -> Constraint) (f :: k -> *) (a :: k).
Wrapped1 c f a -> f a
unWrapped1)
instance ( Applicative f
, Monoid a
#if !MIN_VERSION_base(4, 11, 0)
, Semigroup a
#endif
)
=> Monoid (Wrapped1 Applicative f a) where
#if !MIN_VERSION_base(4, 11, 0)
mappend = (<>)
#endif
mempty :: Wrapped1 Applicative f a
mempty = f a -> Wrapped1 Applicative f a
forall k (c :: (k -> *) -> Constraint) (f :: k -> *) (a :: k).
f a -> Wrapped1 c f a
Wrapped1 (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty)
deriving instance Functor f => Functor (Wrapped1 Generic1 f)