{-# 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