-- Copyright 2019-2021 Google LLC
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- | Provides 'Wrapped' and 'Wrapped1' types to hold @DerivingVia@ instances.

{-# 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
         ( -- * Derived Instances
           Wrapped(..), Wrapped1(..)
           -- ** Wrapped 'Generic'
           -- $Wrapped_Generic

           -- ** Wrapped 'IsList'
           -- $Wrapped_IsList

           -- ** Wrapped 'Foldable'
           -- $Wrapped_Foldable

           -- * Internals
           , 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)

-- | A type holding derived instances for classes of kind @Type -> Constraint@.
--
-- For example, 'Show' or @Pretty@.
--
-- Generally, instances derived from @SomeClass@ should be placed on
-- @'Wrapped' SomeClass@.  This way, they can be grouped into relatively few
-- deriving clauses per type.
newtype Wrapped (c :: Type -> Constraint) a = Wrapped { Wrapped c a -> a
unWrapped :: a }

-- | A type holding derived instances of kind @(k -> Type) -> Constraint@.
--
-- For example, 'Functor' or 'Traversable'.
--
-- See also 'Wrapped'.
newtype Wrapped1 (c :: (k -> Type) -> Constraint) f (a :: k) =
  Wrapped1 { Wrapped1 c f a -> f a
unWrapped1 :: f a }

-- $Wrapped_Generic
--
-- Instances of @'Wrapped' 'Generic'@ work on 'Rep' types by 'to' and 'from'.
--
-- Typically these implement the "obvious" way to make a sum-of-products type
-- (an algebraic data type) an instance of the given class.  For example, for
-- 'Monoid', it provides field-wise 'mappend' and 'mempty' of types that are
-- products of other 'Monoid's.
--
-- Likewise, @'Wrapped1' 'GHC.Generics.Generic1'@ works on 'GHC.Generics.Rep1'
-- types by 'GHC.Generics.to1' and 'GHC.Generics.from1'.  This is the same
-- concept applied to type constructors with one parameter.

-- | Generic Semigroup.
--
-- Exported just to give Haddock something to link to; use @Wrapped Generic@
-- with @-XDerivingVia@ instead.
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

-- | `<>` by field-wise `<>`.
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

-- | Generic Monoid.
--
-- Exported just to give Haddock something to link to; use @Wrapped Generic@
-- with @-XDerivingVia@ instead.
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

-- | `mappend` by field-wise `<>`, and `mempty` by field-wise `mempty`
--
-- Beware: this determines the entire instance including `mappend`, so do not
-- mix this with a `Semigroup` instance from another source.
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

-- $Wrapped_IsList
--
-- Instances of @'Wrapped' 'IsList'@ work by conversion to/from list.
--
-- For example, we provide 'Eq', 'Ord', and 'Show' instances that convert both
-- operands to lists and compare them, and a 'Read' instance that parses a list
-- and converts to the desired type.
--
-- Whereas @Wrapped 'Foldable'@ requires that the type is a type constructor
-- whose argument is the list element, this works on any type with an 'IsList'
-- instance.
--
-- On the other hand, 'IsList' requires that the type can be converted /from/ a
-- list, not only /to/ a list, so it can often require unneeded constraints
-- compared to 'Foldable'.
--
-- Generally, if both of these compile, they should be expected to be
-- equivalent.  More specifically, if you implement instances for @Wrapped
-- Foldable@ or @Wrapped IsList@ these types, you should ensure that, as long
-- as the 'Foldable' instance of @f@ and the 'IsList' instance of @f a@ are
-- consistent, the instances are the same; and if you adopt instances from this
-- type, you should ensure that your 'Foldable' and 'IsList' instances agree,
-- and may then assume that 'IsList' and 'Foldable' give the same instances.

-- | Just forwarding the instance; not meant to be used for deriving.
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

-- | Equality of the results of 'Exts.toList'.
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

-- | Comparison of the results of '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

-- | Show of the results of '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

-- | 'Exts.fromList' of a parsed list.
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

-- $Wrapped_Foldable
--
-- Instances of @'Wrapped' 'Foldable'@ work by folding over the type.
--
-- See above for a description of how this differs from @'Wrapped' 'IsList'@.

-- | Just forwarding the instance; not meant to be used for deriving.
deriving instance Foldable f => Foldable (Wrapped1 Foldable f)

-- | Equality of the results of 'F.toList'.
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

-- | Comparison of the results of '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

-- | Show of the results of 'Exts.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

-- | Provide ('<>') by 'liftA2' of an underlying ('<>').
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)

-- | Provide 'mappend' by 'liftA2' and 'mempty' by @'pure' 'mempty'@.
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)

-- | Forwarding instance for 'Functor'.
--
-- If we want @Wrapped1 Generic1 f@ to have instances for things with 'Functor'
-- as a superclass, then it needs to have a 'Functor' instance.  There's not
-- much point in providing a Generics-based one, though because @DeriveFunctor@
-- exists.  So, just forward the underlying type's instance.
deriving instance Functor f => Functor (Wrapped1 Generic1 f)