{-# LANGUAGE AllowAmbiguousTypes    #-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Generics.Sum.Internal.Constructors
-- Copyright   :  (C) 2019 Csongor Kiss
-- License     :  BSD3
-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Derive constructor-name-based prisms generically.
--
-----------------------------------------------------------------------------

module Data.Generics.Sum.Internal.Constructors
  ( GAsConstructor (..)
  , GAsConstructor'
  ) where

import Data.Generics.Internal.Families
import Data.Generics.Product.Internal.HList
import Data.Profunctor (Profunctor(..))

import GHC.Generics
import GHC.TypeLits (Symbol)
import Data.Generics.Internal.Profunctor.Lens
import Data.Generics.Internal.Profunctor.Iso
import Data.Generics.Internal.Profunctor.Prism

-- |As 'AsConstructor' but over generic representations as defined by
--  "GHC.Generics".
class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
  _GCtor :: Prism (s x) (t x) a b

type GAsConstructor' ctor s a = GAsConstructor ctor s s a a

instance
  ( GIsList f f as as
  , GIsList g g bs bs
  , ListTuple a as
  , ListTuple b bs
  ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where

  _GCtor :: p a b
-> p (M1 C ('MetaCons ctor fixity fields) f x)
     (M1 C ('MetaCons ctor fixity fields) g x)
_GCtor = (M1 C ('MetaCons ctor fixity fields) f x -> a)
-> (b -> M1 C ('MetaCons ctor fixity fields) g x)
-> p a b
-> p (M1 C ('MetaCons ctor fixity fields) f x)
     (M1 C ('MetaCons ctor fixity fields) g x)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (HList as -> a
forall tuple (as :: [*]). ListTuple tuple as => HList as -> tuple
listToTuple (HList as -> a)
-> (M1 C ('MetaCons ctor fixity fields) f x -> HList as)
-> M1 C ('MetaCons ctor fixity fields) f x
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens (f x) (f x) (HList as) (HList as) -> f x -> HList as
forall s a. Lens s s a a -> s -> a
view forall (f :: * -> *) (g :: * -> *) (as :: [*]) (bs :: [*]) x.
GIsList f g as bs =>
Iso (f x) (g x) (HList as) (HList bs)
Lens (f x) (f x) (HList as) (HList as)
glist (f x -> HList as)
-> (M1 C ('MetaCons ctor fixity fields) f x -> f x)
-> M1 C ('MetaCons ctor fixity fields) f x
-> HList as
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 C ('MetaCons ctor fixity fields) f x -> f x
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1) (g x -> M1 C ('MetaCons ctor fixity fields) g x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (g x -> M1 C ('MetaCons ctor fixity fields) g x)
-> (b -> g x) -> b -> M1 C ('MetaCons ctor fixity fields) g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens (HList bs) (HList bs) (g x) (g x) -> HList bs -> g x
forall s a. Lens s s a a -> s -> a
view (Iso (g x) (g x) (HList bs) (HList bs)
-> Iso (HList bs) (HList bs) (g x) (g x)
forall s t a b. Iso s t a b -> Iso b a t s
fromIso forall (f :: * -> *) (g :: * -> *) (as :: [*]) (bs :: [*]) x.
GIsList f g as bs =>
Iso (f x) (g x) (HList as) (HList bs)
Iso (g x) (g x) (HList bs) (HList bs)
glist) (HList bs -> g x) -> (b -> HList bs) -> b -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> HList bs
forall tuple (as :: [*]). ListTuple tuple as => tuple -> HList as
tupleToList)
  {-# INLINE[0] _GCtor #-}

instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
  _GCtor :: p a b -> p ((:+:) l r x) ((:+:) l' r' x)
_GCtor = forall (ctor :: Symbol) (contains :: Bool) (l :: * -> *)
       (r :: * -> *) (l' :: * -> *) (r' :: * -> *) a b x.
GSumAsConstructor ctor contains l r l' r' a b =>
Prism ((:+:) l r x) ((:+:) l' r' x) a b
forall (l :: * -> *) (r :: * -> *) (l' :: * -> *) (r' :: * -> *) a
       b x.
GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b =>
Prism ((:+:) l r x) ((:+:) l' r' x) a b
_GSumCtor @ctor @(HasCtorP ctor l)
  {-# INLINE[0] _GCtor #-}

instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
  _GCtor :: p a b -> p (M1 D meta f x) (M1 D meta f' x)
_GCtor = p (f x) (f' x) -> p (M1 D meta f x) (M1 D meta f' x)
forall i (c :: Meta) (f :: * -> *) p (g :: * -> *).
Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
mIso (p (f x) (f' x) -> p (M1 D meta f x) (M1 D meta f' x))
-> (p a b -> p (f x) (f' x))
-> p a b
-> p (M1 D meta f x) (M1 D meta f' x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ctor :: Symbol) (s :: * -> *) (t :: * -> *) a b x.
GAsConstructor ctor s t a b =>
Prism (s x) (t x) a b
forall (s :: * -> *) (t :: * -> *) a b x.
GAsConstructor ctor s t a b =>
Prism (s x) (t x) a b
_GCtor @ctor
  {-# INLINE[0] _GCtor #-}

class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
  _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b

instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
  _GSumCtor :: p a b -> p ((:+:) l r x) ((:+:) l' r x)
_GSumCtor = p (l x) (l' x) -> p ((:+:) l r x) ((:+:) l' r x)
forall (a :: * -> *) (c :: * -> *) x (b :: * -> *).
Prism ((:+:) a c x) ((:+:) b c x) (a x) (b x)
left (p (l x) (l' x) -> p ((:+:) l r x) ((:+:) l' r x))
-> (p a b -> p (l x) (l' x))
-> p a b
-> p ((:+:) l r x) ((:+:) l' r x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ctor :: Symbol) (s :: * -> *) (t :: * -> *) a b x.
GAsConstructor ctor s t a b =>
Prism (s x) (t x) a b
forall (s :: * -> *) (t :: * -> *) a b x.
GAsConstructor ctor s t a b =>
Prism (s x) (t x) a b
_GCtor @ctor
  {-# INLINE[0] _GSumCtor #-}

instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
  _GSumCtor :: p a b -> p ((:+:) l r x) ((:+:) l r' x)
_GSumCtor = p (r x) (r' x) -> p ((:+:) l r x) ((:+:) l r' x)
forall (a :: * -> *) (b :: * -> *) x (c :: * -> *).
Prism ((:+:) a b x) ((:+:) a c x) (b x) (c x)
right (p (r x) (r' x) -> p ((:+:) l r x) ((:+:) l r' x))
-> (p a b -> p (r x) (r' x))
-> p a b
-> p ((:+:) l r x) ((:+:) l r' x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ctor :: Symbol) (s :: * -> *) (t :: * -> *) a b x.
GAsConstructor ctor s t a b =>
Prism (s x) (t x) a b
forall (s :: * -> *) (t :: * -> *) a b x.
GAsConstructor ctor s t a b =>
Prism (s x) (t x) a b
_GCtor @ctor
  {-# INLINE[0] _GSumCtor #-}