{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Newtype.Generics
( Newtype(..)
, op
, ala
, ala'
, under
, over
, under2
, over2
, underF
, overF
) where
import Control.Applicative
import Control.Arrow
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Fixed
import Data.Kind (Type)
import Data.Monoid
import Data.Ord
import qualified Data.Semigroup
#if MIN_VERSION_base(4,16,0)
import Data.Semigroup (Min(..), Max(..), WrappedMonoid(..))
#else
import Data.Semigroup (Min(..), Max(..), WrappedMonoid(..),Option(..))
#endif
import GHC.Generics
class GNewtype n where
type GO n :: Type
gpack :: GO n -> n p
gunpack :: n p -> GO n
instance GNewtype (D1 d (C1 c (S1 s (K1 i a)))) where
type GO (D1 d (C1 c (S1 s (K1 i a)))) = a
gpack :: forall p.
GO (D1 d (C1 c (S1 s (K1 i a)))) -> D1 d (C1 c (S1 s (K1 i a))) p
gpack GO (D1 d (C1 c (S1 s (K1 i a))))
x = C1 c (S1 s (K1 i a)) p -> M1 D d (C1 c (S1 s (K1 i a))) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (S1 s (K1 i a) p -> C1 c (S1 s (K1 i a)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i a p -> S1 s (K1 i a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 a
GO (D1 d (C1 c (S1 s (K1 i a))))
x)))
gunpack :: forall p.
D1 d (C1 c (S1 s (K1 i a))) p -> GO (D1 d (C1 c (S1 s (K1 i a))))
gunpack (M1 (M1 (M1 (K1 a
x)))) = a
GO (D1 d (C1 c (S1 s (K1 i a))))
x
class Newtype n where
type O n :: Type
type O n = GO (Rep n)
pack :: O n -> n
default pack :: (Generic n, GNewtype (Rep n), O n ~ GO (Rep n)) => O n -> n
pack = Rep n Any -> n
forall a x. Generic a => Rep a x -> a
forall x. Rep n x -> n
to (Rep n Any -> n) -> (GO (Rep n) -> Rep n Any) -> GO (Rep n) -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GO (Rep n) -> Rep n Any
forall p. GO (Rep n) -> Rep n p
forall (n :: * -> *) p. GNewtype n => GO n -> n p
gpack
unpack :: n -> O n
default unpack :: (Generic n, GNewtype (Rep n), O n ~ GO (Rep n)) => n -> O n
unpack = Rep n Any -> GO (Rep n)
forall p. Rep n p -> GO (Rep n)
forall (n :: * -> *) p. GNewtype n => n p -> GO n
gunpack (Rep n Any -> GO (Rep n)) -> (n -> Rep n Any) -> n -> GO (Rep n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Rep n Any
forall x. n -> Rep n x
forall a x. Generic a => a -> Rep a x
from
op :: (Newtype n,o ~ O n ) => (o -> n) -> n -> o
op :: forall n o. (Newtype n, o ~ O n) => (o -> n) -> n -> o
op o -> n
_ = n -> o
n -> O n
forall n. Newtype n => n -> O n
unpack
ala :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
=> (o -> n) -> ((o -> n) -> b -> n') -> (b -> o')
ala :: forall n n' o' o b.
(Newtype n, Newtype n', o' ~ O n', o ~ O n) =>
(o -> n) -> ((o -> n) -> b -> n') -> b -> o'
ala o -> n
pa (o -> n) -> b -> n'
hof = (o -> n) -> ((o -> n) -> b -> n') -> (o -> o) -> b -> o'
forall n n' o' o a b.
(Newtype n, Newtype n', o' ~ O n', o ~ O n) =>
(o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> b -> o'
ala' o -> n
pa (o -> n) -> b -> n'
hof o -> o
forall a. a -> a
id
ala' :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
=> (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o')
ala' :: forall n n' o' o a b.
(Newtype n, Newtype n', o' ~ O n', o ~ O n) =>
(o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> b -> o'
ala' o -> n
_ (a -> n) -> b -> n'
hof a -> o
f = n' -> o'
n' -> O n'
forall n. Newtype n => n -> O n
unpack (n' -> o') -> (b -> n') -> b -> o'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> n) -> b -> n'
hof (o -> n
O n -> n
forall n. Newtype n => O n -> n
pack (o -> n) -> (a -> o) -> a -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> o
f)
under :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
=> (o -> n) -> (n -> n') -> (o -> o')
under :: forall n n' o' o.
(Newtype n, Newtype n', o' ~ O n', o ~ O n) =>
(o -> n) -> (n -> n') -> o -> o'
under o -> n
_ n -> n'
f = n' -> o'
n' -> O n'
forall n. Newtype n => n -> O n
unpack (n' -> o') -> (o -> n') -> o -> o'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> n'
f (n -> n') -> (o -> n) -> o -> n'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. o -> n
O n -> n
forall n. Newtype n => O n -> n
pack
over :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
=> (o -> n) -> (o -> o') -> (n -> n')
over :: forall n n' o' o.
(Newtype n, Newtype n', o' ~ O n', o ~ O n) =>
(o -> n) -> (o -> o') -> n -> n'
over o -> n
_ o -> o'
f = o' -> n'
O n' -> n'
forall n. Newtype n => O n -> n
pack (o' -> n') -> (n -> o') -> n -> n'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. o -> o'
f (o -> o') -> (n -> o) -> n -> o'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> o
n -> O n
forall n. Newtype n => n -> O n
unpack
under2 :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
=> (o -> n) -> (n -> n -> n') -> (o -> o -> o')
under2 :: forall n n' o' o.
(Newtype n, Newtype n', o' ~ O n', o ~ O n) =>
(o -> n) -> (n -> n -> n') -> o -> o -> o'
under2 o -> n
_ n -> n -> n'
f o
o0 o
o1 = n' -> O n'
forall n. Newtype n => n -> O n
unpack (n' -> O n') -> n' -> O n'
forall a b. (a -> b) -> a -> b
$ n -> n -> n'
f (O n -> n
forall n. Newtype n => O n -> n
pack o
O n
o0) (O n -> n
forall n. Newtype n => O n -> n
pack o
O n
o1)
over2 :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
=> (o -> n) -> (o -> o -> o') -> (n -> n -> n')
over2 :: forall n n' o' o.
(Newtype n, Newtype n', o' ~ O n', o ~ O n) =>
(o -> n) -> (o -> o -> o') -> n -> n -> n'
over2 o -> n
_ o -> o -> o'
f n
n0 n
n1 = O n' -> n'
forall n. Newtype n => O n -> n
pack (O n' -> n') -> O n' -> n'
forall a b. (a -> b) -> a -> b
$ o -> o -> o'
f (n -> O n
forall n. Newtype n => n -> O n
unpack n
n0) (n -> O n
forall n. Newtype n => n -> O n
unpack n
n1)
underF :: (Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f, Functor g)
=> (o -> n) -> (f n -> g n') -> (f o -> g o')
underF :: forall n n' o' o (f :: * -> *) (g :: * -> *).
(Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f,
Functor g) =>
(o -> n) -> (f n -> g n') -> f o -> g o'
underF o -> n
_ f n -> g n'
f = (n' -> o') -> g n' -> g o'
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n' -> o'
n' -> O n'
forall n. Newtype n => n -> O n
unpack (g n' -> g o') -> (f o -> g n') -> f o -> g o'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f n -> g n'
f (f n -> g n') -> (f o -> f n) -> f o -> g n'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (o -> n) -> f o -> f n
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap o -> n
O n -> n
forall n. Newtype n => O n -> n
pack
overF :: (Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f, Functor g)
=> (o -> n) -> (f o -> g o') -> (f n -> g n')
overF :: forall n n' o' o (f :: * -> *) (g :: * -> *).
(Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f,
Functor g) =>
(o -> n) -> (f o -> g o') -> f n -> g n'
overF o -> n
_ f o -> g o'
f = (o' -> n') -> g o' -> g n'
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap o' -> n'
O n' -> n'
forall n. Newtype n => O n -> n
pack (g o' -> g n') -> (f n -> g o') -> f n -> g n'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f o -> g o'
f (f o -> g o') -> (f n -> f o) -> f n -> g o'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> o) -> f n -> f o
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n -> o
n -> O n
forall n. Newtype n => n -> O n
unpack
instance Newtype (WrappedMonad m a) where
type O (WrappedMonad m a) = m a
pack :: O (WrappedMonad m a) -> WrappedMonad m a
pack = m a -> WrappedMonad m a
O (WrappedMonad m a) -> WrappedMonad m a
forall (m :: * -> *) a. m a -> WrappedMonad m a
WrapMonad
unpack :: WrappedMonad m a -> O (WrappedMonad m a)
unpack (WrapMonad m a
a) = m a
O (WrappedMonad m a)
a
instance Newtype (WrappedArrow a b c) where
type O (WrappedArrow a b c) = a b c
pack :: O (WrappedArrow a b c) -> WrappedArrow a b c
pack = a b c -> WrappedArrow a b c
O (WrappedArrow a b c) -> WrappedArrow a b c
forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow
unpack :: WrappedArrow a b c -> O (WrappedArrow a b c)
unpack (WrapArrow a b c
a) = a b c
O (WrappedArrow a b c)
a
instance Newtype (ZipList a) where
type O (ZipList a) = [a]
pack :: O (ZipList a) -> ZipList a
pack = [a] -> ZipList a
O (ZipList a) -> ZipList a
forall a. [a] -> ZipList a
ZipList
unpack :: ZipList a -> O (ZipList a)
unpack (ZipList [a]
a) = [a]
O (ZipList a)
a
instance Newtype (Kleisli m a b) where
type O (Kleisli m a b) = a -> m b
pack :: O (Kleisli m a b) -> Kleisli m a b
pack = O (Kleisli m a b) -> Kleisli m a b
(a -> m b) -> Kleisli m a b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli
unpack :: Kleisli m a b -> O (Kleisli m a b)
unpack (Kleisli a -> m b
a) = O (Kleisli m a b)
a -> m b
a
instance Newtype (ArrowMonad a b) where
type O (ArrowMonad a b) = a () b
pack :: O (ArrowMonad a b) -> ArrowMonad a b
pack = a () b -> ArrowMonad a b
O (ArrowMonad a b) -> ArrowMonad a b
forall (a :: * -> * -> *) b. a () b -> ArrowMonad a b
ArrowMonad
unpack :: ArrowMonad a b -> O (ArrowMonad a b)
unpack (ArrowMonad a () b
a) = a () b
O (ArrowMonad a b)
a
instance Newtype (Fixed a) where
type O (Fixed a) = Integer
pack :: O (Fixed a) -> Fixed a
pack = Integer -> Fixed a
O (Fixed a) -> Fixed a
forall k (a :: k). Integer -> Fixed a
MkFixed
unpack :: Fixed a -> O (Fixed a)
unpack (MkFixed Integer
x) = Integer
O (Fixed a)
x
instance Newtype (Compose f g a) where
type O (Compose f g a) = f (g a)
pack :: O (Compose f g a) -> Compose f g a
pack = f (g a) -> Compose f g a
O (Compose f g a) -> Compose f g a
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose
unpack :: Compose f g a -> O (Compose f g a)
unpack (Compose f (g a)
x) = f (g a)
O (Compose f g a)
x
instance Newtype (Const a x) where
type O (Const a x) = a
pack :: O (Const a x) -> Const a x
pack = a -> Const a x
O (Const a x) -> Const a x
forall {k} a (b :: k). a -> Const a b
Const
unpack :: Const a x -> O (Const a x)
unpack (Const a
a) = a
O (Const a x)
a
instance Newtype (Identity a) where
type O (Identity a) = a
pack :: O (Identity a) -> Identity a
pack = a -> Identity a
O (Identity a) -> Identity a
forall a. a -> Identity a
Identity
unpack :: Identity a -> O (Identity a)
unpack (Identity a
a) = a
O (Identity a)
a
instance Newtype (Dual a) where
type O (Dual a) = a
pack :: O (Dual a) -> Dual a
pack = a -> Dual a
O (Dual a) -> Dual a
forall a. a -> Dual a
Dual
unpack :: Dual a -> O (Dual a)
unpack (Dual a
a) = a
O (Dual a)
a
instance Newtype (Endo a) where
type O (Endo a) = (a -> a)
pack :: O (Endo a) -> Endo a
pack = O (Endo a) -> Endo a
(a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo
unpack :: Endo a -> O (Endo a)
unpack (Endo a -> a
a) = O (Endo a)
a -> a
a
instance Newtype All where
type O All = Bool
pack :: O All -> All
pack = Bool -> All
O All -> All
All
unpack :: All -> O All
unpack (All Bool
x) = Bool
O All
x
instance Newtype Any where
type O Any = Bool
pack :: O Any -> Any
pack = Bool -> Any
O Any -> Any
Any
unpack :: Any -> O Any
unpack (Any Bool
x) = Bool
O Any
x
instance Newtype (Sum a) where
type O (Sum a) = a
pack :: O (Sum a) -> Sum a
pack = a -> Sum a
O (Sum a) -> Sum a
forall a. a -> Sum a
Sum
unpack :: Sum a -> O (Sum a)
unpack (Sum a
a) = a
O (Sum a)
a
instance Newtype (Product a) where
type O (Product a) = a
pack :: O (Product a) -> Product a
pack = a -> Product a
O (Product a) -> Product a
forall a. a -> Product a
Product
unpack :: Product a -> O (Product a)
unpack (Product a
a) = a
O (Product a)
a
instance Newtype (First a) where
type O (First a) = Maybe a
pack :: O (First a) -> First a
pack = Maybe a -> First a
O (First a) -> First a
forall a. Maybe a -> First a
First
unpack :: First a -> O (First a)
unpack (First Maybe a
a) = Maybe a
O (First a)
a
instance Newtype (Last a) where
type O (Last a) = Maybe a
pack :: O (Last a) -> Last a
pack = Maybe a -> Last a
O (Last a) -> Last a
forall a. Maybe a -> Last a
Last
unpack :: Last a -> O (Last a)
unpack (Last Maybe a
a) = Maybe a
O (Last a)
a
instance Newtype (Alt f a) where
type O (Alt f a) = f a
pack :: O (Alt f a) -> Alt f a
pack = f a -> Alt f a
O (Alt f a) -> Alt f a
forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt
unpack :: Alt f a -> O (Alt f a)
unpack (Alt f a
x) = f a
O (Alt f a)
x
#if MIN_VERSION_base(4,12,0)
instance Newtype (Ap f a) where
type O (Ap f a) = f a
pack :: O (Ap f a) -> Ap f a
pack = f a -> Ap f a
O (Ap f a) -> Ap f a
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap
unpack :: Ap f a -> O (Ap f a)
unpack = Ap f a -> f a
Ap f a -> O (Ap f a)
forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp
#endif
instance Newtype (Down a) where
type O (Down a) = a
pack :: O (Down a) -> Down a
pack = a -> Down a
O (Down a) -> Down a
forall a. a -> Down a
Down
unpack :: Down a -> O (Down a)
unpack (Down a
a) = a
O (Down a)
a
instance Newtype (Min a) where
type O (Min a) = a
pack :: O (Min a) -> Min a
pack = a -> Min a
O (Min a) -> Min a
forall a. a -> Min a
Min
unpack :: Min a -> O (Min a)
unpack (Min a
a) = a
O (Min a)
a
instance Newtype (Max a) where
type O (Max a) = a
pack :: O (Max a) -> Max a
pack = a -> Max a
O (Max a) -> Max a
forall a. a -> Max a
Max
unpack :: Max a -> O (Max a)
unpack (Max a
a) = a
O (Max a)
a
instance Newtype (Data.Semigroup.First a) where
type O (Data.Semigroup.First a) = a
pack :: O (First a) -> First a
pack = a -> First a
O (First a) -> First a
forall a. a -> First a
Data.Semigroup.First
unpack :: First a -> O (First a)
unpack (Data.Semigroup.First a
a) = a
O (First a)
a
instance Newtype (Data.Semigroup.Last a) where
type O (Data.Semigroup.Last a) = a
pack :: O (Last a) -> Last a
pack = a -> Last a
O (Last a) -> Last a
forall a. a -> Last a
Data.Semigroup.Last
unpack :: Last a -> O (Last a)
unpack (Data.Semigroup.Last a
a) = a
O (Last a)
a
instance Newtype (WrappedMonoid m) where
type O (WrappedMonoid m) = m
pack :: O (WrappedMonoid m) -> WrappedMonoid m
pack = m -> WrappedMonoid m
O (WrappedMonoid m) -> WrappedMonoid m
forall m. m -> WrappedMonoid m
WrapMonoid
unpack :: WrappedMonoid m -> O (WrappedMonoid m)
unpack (WrapMonoid m
m) = m
O (WrappedMonoid m)
m
#if !MIN_VERSION_base(4,16,0)
instance Newtype (Option a) where
type O (Option a) = Maybe a
pack = Option
unpack (Option x) = x
#endif