{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
{- |
The 'Newtype' typeclass and related functions.
Primarily pulled from Conor McBride's Epigram work. Some examples:

>>> ala Sum foldMap [1,2,3,4]
10

>>> ala Endo foldMap [(+1), (+2), (subtract 1), (*2)] 3
8

>>> under2 Min (<>) 2 1
1

>>> over All not (All False)
All {getAll = True)

This package includes 'Newtype' instances for all the (non-GHC\/foreign)
newtypes in base (as seen in the examples).
However, there are neat things you can do with this with
/any/ newtype and you should definitely define your own 'Newtype'
instances for the power of this library.
For example, see @ala Cont traverse@, with the proper 'Newtype' instance for Cont.
You can easily define new instances for your newtypes with the help of GHC.Generics

 > {-# LANGUAGE DeriveGeneric #-}
 > import GHC.Generics
 >
 > (...)
 > newtype Example = Example Int
 >   deriving (Generic)
 >
 > instance Newtype Example
 >

This avoids the use of Template Haskell (TH) to get new instances.
-}
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
import Data.Semigroup (Min(..), Max(..), WrappedMonoid(..), Option(..))
import GHC.Generics
{-import Generics.Deriving-}

-- | Given a newtype @n@, we will always have the same unwrapped type @o@,
-- meaning we can represent this with a fundep @n -> o@.
--
-- Any instance of this class just needs to let @pack@ equal to the newtype's
-- constructor, and let @unpack@ destruct the newtype with pattern matching.
{-class Newtype n o | n -> o where-}
  {-pack :: o -> n-}
  {-unpack :: n -> o-}


-- Generic Newtype
class GNewtype n where
  type GO n :: Type
  gpack   :: GO n -> n p
  gunpack :: n p  -> GO n

-- We only need one instance, if these generic functions are only to work for
-- newtypes, as these have a fixed form. For example, for a newtype X = Y,
-- Rep X = D1 ... (C1 ... (S1 ... (K1 ... Y)))
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 :: 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                     = M1 C c (S1 s (K1 i a)) p -> D1 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 (M1 S s (K1 i a) p -> M1 C 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 -> M1 S 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 :: 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

-- Original Newtype class, extended with generic defaults (trivial) and deprived
-- of the second type argument (less trivial, as it involves a type family with
-- a default, plus an equality constraint for the related type family in
-- GNewtype). We do get rid of MultiParamTypeClasses and FunctionalDependencies,
-- though.

-- | As long as the type @n@ is an instance of Generic, you can create an instance
-- with just @instance Newtype n@
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
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 (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 (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 a x. Generic a => a -> Rep a x
from

-- |
-- This function serves two purposes:
--
-- 1. Giving you the unpack of a newtype without you needing to remember the name.
--
-- 2. Showing that the first parameter is /completely ignored/ on the value level,
--    meaning the only reason you pass in the constructor is to provide type
--    information.  Typeclasses sure are neat.
--
-- >>> op Identity (Identity 3)
-- 3
op :: (Newtype n,o ~ O n ) => (o -> n) -> n -> o
op :: (o -> n) -> n -> o
op o -> n
_ = n -> o
forall n. Newtype n => n -> O n
unpack

-- | The workhorse of the package. Given a "packer" and a \"higher order function\" (/hof/),
-- it handles the packing and unpacking, and just sends you back a regular old
-- function, with the type varying based on the /hof/ you passed.
--
-- The reason for the signature of the /hof/ is due to 'ala' not caring about structure.
-- To illustrate why this is important, consider this alternative implementation of 'under2':
--
-- > under2 :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
-- >        => (o -> n) -> (n -> n -> n') -> (o -> o -> o')
-- > under2' pa f o0 o1 = ala pa (\p -> uncurry f . bimap p p) (o0, o1)
--
-- Being handed the "packer", the /hof/ may apply it in any structure of its choosing –
-- in this case a tuple.
--
-- >>> ala Sum foldMap [1,2,3,4]
-- 10
ala :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
    => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o')
ala :: (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

-- | This is the original function seen in Conor McBride's work.
-- The way it differs from the 'ala' function in this package,
-- is that it provides an extra hook into the \"packer\" passed to the hof.
-- However, this normally ends up being @id@, so 'ala' wraps this function and
-- passes @id@ as the final parameter by default.
-- If you want the convenience of being able to hook right into the hof,
-- you may use this function.
--
-- >>> ala' Sum foldMap length ["hello", "world"]
-- 10
--
-- >>> ala' First foldMap (readMaybe @Int) ["x", "42", "1"]
-- Just 42
ala' :: (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') -> (a -> o) -> b -> o'
ala' o -> n
_ (a -> n) -> b -> n'
hof a -> o
f = n' -> o'
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
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)

-- | A very simple operation involving running the function \'under\' the newtype.
--
-- >>> under Product (stimes 3) 3
-- 27
under :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
      => (o -> n) -> (n -> n') -> (o -> o')
under :: (o -> n) -> (n -> n') -> o -> o'
under o -> n
_ n -> n'
f = n' -> o'
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
forall n. Newtype n => O n -> n
pack

-- | The opposite of 'under'. I.e., take a function which works on the
-- underlying types, and switch it to a function that works on the newtypes.
--
-- >>> over All not (All False)
-- All {getAll = True}
over :: (Newtype n,  Newtype n', o' ~ O n', o ~ O n)
     => (o -> n) -> (o -> o') -> (n -> n')
over :: (o -> n) -> (o -> o') -> n -> n'
over o -> n
_ o -> o'
f = o' -> 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
forall n. Newtype n => n -> O n
unpack

-- | Lower a binary function to operate on the underlying values.
--
-- >>> under2 Any (<>) True False
-- True
--
-- @since 0.5.2
under2 :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
       => (o -> n) -> (n -> n -> n') -> (o -> o -> o')
under2 :: (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)

-- | The opposite of 'under2'.
--
-- @since 0.5.2
over2 :: (Newtype n, Newtype n', o' ~ O n', o ~ O n)
       => (o -> n) -> (o -> o -> o') -> (n -> n -> n')
over2 :: (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)

-- | 'under' lifted into a Functor.
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 :: (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n' -> o'
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap o -> n
forall n. Newtype n => O n -> n
pack

-- | 'over' lifted into a Functor.
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 :: (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap o' -> 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n -> o
forall n. Newtype n => n -> O n
unpack

-- Instances from Control.Applicative

instance Newtype (WrappedMonad m a) where
  type O (WrappedMonad m a) = m a
  pack :: O (WrappedMonad m a) -> WrappedMonad m a
pack = 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 = 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 = 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

-- Instances from Control.Arrow

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
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 = 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

-- Instances from Data.Fixed

-- | @since 0.5.1
instance Newtype (Fixed a) where
  type O (Fixed a) = Integer
  pack :: O (Fixed a) -> Fixed a
pack = 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

-- Instances from Data.Functor.Compose

-- | @since 0.5.1
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 = 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

-- Instances from Data.Functor.Const

instance Newtype (Const a x) where
  type O (Const a x) = a
  pack :: O (Const a x) -> Const a x
pack = 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

-- Instances from Data.Functor.Identity

-- | @since 0.5.1
instance Newtype (Identity a) where
  type O (Identity a) = a
  pack :: O (Identity a) -> Identity a
pack = 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

-- Instances from Data.Monoid

-- | @since 0.5.1
instance Newtype (Dual a) where
  type O (Dual a) = a
  pack :: O (Dual a) -> Dual a
pack = 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
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 = 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 = 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 = 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 = 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

-- | @since 0.5.1
instance Newtype (Alt f a) where
  type O (Alt f a) = f a
  pack :: O (Alt f a) -> Alt f a
pack = 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)
-- | @since 0.5.4
instance Newtype (Ap f a) where
  type O (Ap f a) = f a
  pack :: O (Ap f a) -> Ap f a
pack = 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 -> O (Ap f a)
forall k (f :: k -> *) (a :: k). Ap f a -> f a
getAp
#endif

-- Instances from Data.Ord

-- | @since 0.5.1
instance Newtype (Down a) where
  type O (Down a) = a
  pack :: O (Down a) -> Down a
pack = 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


-- Instances from Data.Semigroup

-- | @since 0.5.1
instance Newtype (Min a) where
  type O (Min a) = a
  pack :: O (Min a) -> Min a
pack = 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

-- | @since 0.5.1
instance Newtype (Max a) where
  type O (Max a) = a
  pack :: O (Max a) -> Max a
pack = 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

-- | @since 0.5.1
instance Newtype (Data.Semigroup.First a) where
  type O (Data.Semigroup.First a) = a
  pack :: O (First a) -> First a
pack = 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

-- | @since 0.5.1
instance Newtype (Data.Semigroup.Last a) where
  type O (Data.Semigroup.Last a) = a
  pack :: O (Last a) -> Last a
pack = 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

-- | @since 0.5.1
instance Newtype (WrappedMonoid m) where
  type O (WrappedMonoid m) = m
  pack :: O (WrappedMonoid m) -> WrappedMonoid m
pack = 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

-- | @since 0.5.1
instance Newtype (Option a) where
  type O (Option a) = Maybe a
  pack :: O (Option a) -> Option a
pack = O (Option a) -> Option a
forall a. Maybe a -> Option a
Option
  unpack :: Option a -> O (Option a)
unpack (Option Maybe a
x) = Maybe a
O (Option a)
x