    {-# LANGUAGE PackageImports #-}
    {-# LANGUAGE AllowAmbiguousTypes    #-}
    {-# LANGUAGE ConstraintKinds        #-}
    {-# LANGUAGE DataKinds              #-}
    {-# LANGUAGE FlexibleInstances      #-}
    {-# LANGUAGE FunctionalDependencies #-}
    {-# LANGUAGE MultiParamTypeClasses  #-}
    {-# LANGUAGE PolyKinds              #-}
    {-# LANGUAGE ScopedTypeVariables    #-}
    {-# LANGUAGE TypeApplications       #-}
    {-# LANGUAGE TypeOperators          #-}
    {-# LANGUAGE TypeFamilies           #-}
    {-# LANGUAGE UndecidableInstances   #-}
    {-# OPTIONS_GHC -Wno-orphans        #-}

    --------------------------------------------------------------------------------
    -- |
    -- Module      : Data.Generics.Labels
    -- Copyright   : (C) 2020 Csongor Kiss
    -- License     : BSD3
    -- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>
    -- Stability   : experimental
    -- Portability : non-portable
    --
    -- Provides an (orphan) IsLabel instance for field lenses and constructor prisms.
    -- Use at your own risk.
    --------------------------------------------------------------------------------

    module Data.Generics.Labels
      ( -- * Orphan IsLabel Instance
        -- $sec1
        Field(..)
      , Field'
      , Constructor(..)
      , Constructor'
      ) where

    import "this" Data.Generics.Product
    import "this" Data.Generics.Sum

    import "this" Data.Generics.Internal.VL.Lens  (Lens)
    import "this" Data.Generics.Internal.VL.Prism (Prism)

    import Data.Profunctor    (Choice)
    import Data.Type.Bool     (type (&&))
    import Data.Type.Equality (type (==))

    import GHC.OverloadedLabels
    import GHC.TypeLits

    -- $sec1
    -- An instance for creating lenses and prisms with @#identifiers@ from the
    -- @OverloadedLabels@ extension.  Note that since overloaded labels do not
    -- support symbols starting with capital letters, all prisms (which come from
    -- constructor names, which are capitalized) must be prefixed with an underscore
    -- (e.g. @#_ConstructorName@).
    --
    -- Morally:
    --
    -- @
    -- instance (HasField name s t a b) => IsLabel name (Lens s t a b) where ...
    -- @
    -- and
    --
    -- @
    -- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ...
    -- @
    --
    -- Remember:
    --
    -- @
    -- type Lens = forall f. Functor f => (a -> f b) -> s -> f t
    --
    -- type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
    -- @
    --
    -- The orphan instance is unavoidable if we want to work with
    -- lenses-as-functions (as opposed to a 'ReifiedLens'-like newtype).

    -- | 'Field' is morally the same as 'HasField', but it is constructed from an
    -- incoherent combination of 'HasField' and 'HasField''.  In this way, it can be
    -- seamlessly used in the 'IsLabel' instance even when dealing with data types
    -- that don't have 'Field' instances (like data instances).
    class Field name s t a b | s name -> a, t name -> b, s name b -> t, t name a -> s where
      fieldLens :: Lens s t a b

    type Field' name s a = Field name s s a a

    instance {-# INCOHERENT #-} HasField name s t a b => Field name s t a b where
      fieldLens :: (a -> f b) -> s -> f t
    fieldLens = forall s t a b. HasField name s t a b => Lens s t a b
    forall (name :: Symbol) s t a b.
    HasField name s t a b =>
    Lens s t a b
    field @name

    instance {-# INCOHERENT #-} HasField' name s a => Field name s s a a where
      fieldLens :: (a -> f a) -> s -> f s
    fieldLens = forall s a. HasField' name s a => Lens s s a a
    forall (name :: Symbol) s a. HasField' name s a => Lens s s a a
    field' @name

    -- | 'Constructor' is morally the same as 'AsConstructor', but it is constructed from an
    -- incoherent combination of 'AsConstructor' and 'AsConstructor''.  In this way, it can be
    -- seamlessly used in the 'IsLabel' instance even when dealing with data types
    -- that don't have 'Constructor' instances (like data instances).
    class Constructor name s t a b | name s -> a, name t -> b where
      constructorPrism :: Prism s t a b

    type Constructor' name s a = Constructor name s s a a

    instance {-# INCOHERENT #-} AsConstructor name s t a b => Constructor name s t a b where
      constructorPrism :: p a (f b) -> p s (f t)
    constructorPrism = forall s t a b. AsConstructor name s t a b => Prism s t a b
    forall (name :: Symbol) s t a b.
    AsConstructor name s t a b =>
    Prism s t a b
    _Ctor @name

    instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where
      constructorPrism :: p a (f a) -> p s (f s)
    constructorPrism = forall s a. AsConstructor' name s a => Prism s s a a
    forall (name :: Symbol) s a.
    AsConstructor' name s a =>
    Prism s s a a
    _Ctor' @name

    type family BeginsWithCapital (name :: Symbol) :: Bool where
      BeginsWithCapital name = CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT

    instance ( capital ~ BeginsWithCapital name
             , IsLabelHelper capital name p f s t a b
             , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where
      fromLabel :: pafb -> psft
    fromLabel = forall (s :: k) (t :: k) (a :: k) (b :: k).
    IsLabelHelper capital name p f s t a b =>
    p a (f b) -> p s (f t)
    forall k k k k k (capital :: k) (name :: k) (p :: k -> k -> *)
           (f :: k -> k) (s :: k) (t :: k) (a :: k) (b :: k).
    IsLabelHelper capital name p f s t a b =>
    p a (f b) -> p s (f t)
    labelOutput @capital @name @p @f

    -- | This helper class allows us to customize the output type of the lens to be
    -- either 'Prism' or 'Lens' (by choosing appropriate @p@ and @f@) as well as to
    -- choose between whether we're dealing with a lens or a prism.  The choice is
    -- made by whether the @capital@ argument is true or false, which is determined by
    -- whether the symbol starts with an underscore followed by a capital letter
    -- (a check done in the 'IsLabel' instance above).  If so, then we're dealing
    -- with a constructor name, which should be a prism, and otherwise, it's a field
    -- name, so we have a lens.
    class IsLabelHelper capital name p f s t a b where
      labelOutput :: p a (f b) -> p s (f t)

    instance (Functor f, Field name s t a b) => IsLabelHelper 'False name (->) f s t a b where
      labelOutput :: (a -> f b) -> s -> f t
    labelOutput = forall k (name :: k) s t a b. Field name s t a b => Lens s t a b
    forall s t a b. Field name s t a b => Lens s t a b
    fieldLens @name

    instance ( Applicative f, Choice p, Constructor name s t a b
             , name' ~ AppendSymbol "_" name) => IsLabelHelper 'True name' p f s t a b where
      labelOutput :: p a (f b) -> p s (f t)
    labelOutput = forall k (name :: k) s t a b.
    Constructor name s t a b =>
    Prism s t a b
    forall s t a b. Constructor name s t a b => Prism s t a b
    constructorPrism @name