{-# LANGUAGE PackageImports #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Generics.Product.Typed
-- Copyright   :  (C) 2020 Csongor Kiss
-- License     :  BSD3
-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Derive lenses of a given type in a product.
--
-----------------------------------------------------------------------------

module Data.Generics.Product.Typed
  ( -- *Lenses
    --
    -- $setup
    HasType (..)
  ) where

import Optics.Core
import Optics.Internal.Optic
import "this" Data.Generics.Internal.Optics

import qualified "generic-lens-core" Data.Generics.Product.Internal.Typed as Core
import "generic-lens-core" Data.Generics.Internal.Void

-- $setup
-- == /Running example:/
--
-- >>> :set -XTypeApplications
-- >>> :set -XDataKinds
-- >>> :set -XDeriveGeneric
-- >>> import GHC.Generics
-- >>> import Optics.Core
-- >>> :{
-- data Human
--   = Human
--     { name    :: String
--     , age     :: Int
--     , address :: String
--     , tall    :: Bool
--     }
--   | HumanNoTall
--     { name    :: String
--     , age     :: Int
--     , address :: String
--     }
--   deriving (Generic, Show)
-- human :: Human
-- human = Human "Tunyasz" 50 "London" False
-- :}

-- |Records that have a field with a unique type.
class HasType a s where
  -- |A lens that focuses on a field with a unique type in its parent type.
  --
  --  >>> human ^. typed @Int
  --  50
  --
  --  === /Type errors/
  --
  --  >>> human ^. typed @String
  --  ...
  --  ...
  --  ... The type Human contains multiple values of type [Char].
  --  ... The choice of value is thus ambiguous. The offending constructors are:
  --  ... Human
  --  ... HumanNoTall
  --  ...
  --
  --  >>> human ^. typed @Bool
  --  ...
  --  ...
  --  ... Not all constructors of the type Human contain a field of type Bool.
  --  ... The offending constructors are:
  --  ... HumanNoTall
  --  ...
  typed :: Lens s s a a
  typed
    = (s -> a) -> (s -> a -> s) -> Lens s s a a
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (forall s. HasType a s => s -> a
forall a s. HasType a s => s -> a
getTyped @a) ((a -> s -> s) -> s -> a -> s
forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall s. HasType a s => a -> s -> s
forall a s. HasType a s => a -> s -> s
setTyped @a))
  {-# INLINE typed #-}

  -- |Get field at type.
  getTyped :: s -> a
  getTyped s
s = s
s s -> Lens s s a a -> a
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall s. HasType a s => Lens s s a a
forall a s. HasType a s => Lens s s a a
typed @a

  -- |Set field at type.
  setTyped :: a -> s -> s
  setTyped = Lens s s a a -> a -> s -> s
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (forall s. HasType a s => Lens s s a a
forall a s. HasType a s => Lens s s a a
typed @a)

  {-# MINIMAL typed | setTyped, getTyped #-}

instance Core.Context a s => HasType a s where
  typed :: Lens s s a a
typed = Lens s s a a -> Lens s s a a
forall s t a b. Lens s t a b -> Lens s t a b
normaliseLens ((forall (p :: * -> * -> * -> *) i.
 Profunctor p =>
 Optic_ A_Lens p i (Curry NoIx i) s s a a)
-> Lens s s a a
forall k (is :: IxList) s t a b.
(forall (p :: * -> * -> * -> *) i.
 Profunctor p =>
 Optic_ k p i (Curry is i) s t a b)
-> Optic k is s t a b
Optic forall a s. Context a s => Lens s s a a
forall (p :: * -> * -> * -> *) i.
Profunctor p =>
Optic_ A_Lens p i (Curry NoIx i) s s a a
Core.derived)
  {-# INLINE typed #-}

instance {-# OVERLAPPING #-} HasType a a where
    getTyped :: a -> a
getTyped = a -> a
forall a. a -> a
id
    {-# INLINE getTyped #-}

    setTyped :: a -> a -> a
setTyped a
a a
_ = a
a
    {-# INLINE setTyped #-}

-- | See Note [Uncluttering type signatures]
-- >>> :t typed
-- typed :: HasType a s => Lens s s a a
--
-- Note that this might not longer be needed given the above 'HasType a a' instance.
instance {-# OVERLAPPING #-} HasType a Void where
  typed :: Lens Void Void a a
typed = Lens Void Void a a
forall a. HasCallStack => a
undefined