{-# 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 "this" Data.Generics.Internal.VL.Lens as VL

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
-- >>> :m +Data.Generics.Internal.VL.Lens
-- >>> :{
-- 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.
  --  Compatible with the lens package's 'Control.Lens.Lens' 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 :: VL.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
VL.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 -> ((a -> Const a a) -> s -> Const a s) -> a
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> 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 s t a b. Lens s t a b -> b -> s -> t
VL.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 :: (a -> f a) -> s -> f s
typed = (ALens a a Any a a -> ALens a a Any s s) -> Lens s s a a
forall a b i s t.
(ALens a b i a b -> ALens a b i s t) -> Lens s t a b
VL.ravel ALens a a Any a a -> ALens a a Any s s
forall a s. Context a s => Lens 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 +d typed
-- typed :: (HasType a s, Functor f) => (a -> f a) -> s -> f s
--
-- Note that this might not longer be needed given the above 'HasType a a' instance.
instance {-# OVERLAPPING #-} HasType a Void where
  typed :: (a -> f a) -> Void -> f Void
typed = (a -> f a) -> Void -> f Void
forall a. HasCallStack => a
undefined