content: {-# LANGUAGE PackageImports #-}
  {-# LANGUAGE AllowAmbiguousTypes    #-}
  {-# LANGUAGE ConstraintKinds        #-}
  {-# LANGUAGE CPP                    #-}
  {-# LANGUAGE DataKinds              #-}
  {-# LANGUAGE FlexibleInstances      #-}
  {-# LANGUAGE FunctionalDependencies #-}
  {-# LANGUAGE MultiParamTypeClasses  #-}
  #if MIN_VERSION_base(4,12,0)
  {-# LANGUAGE NoStarIsType           #-}
  #endif
  {-# 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, as well as positional lenses on GHC >=9.6.
  -- 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 (&&), If)
  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 did 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@) when you use a GHC older than 9.6.
  --
  -- 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 ...
  -- @
  --
  -- Starting with GHC 9.6, you can also write e.g. @#2@ and @#15@ instead of
  -- @position \@1@ and @position \@15@, so we morally have
  --
  -- @
  -- instance (HasPosition i s t a b) => IsLabel (Show i) (Lens 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 = field @name
  
  instance {-# INCOHERENT #-} HasField' name s a => Field name s s a a where
    fieldLens = 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 = _Ctor @name
  
  instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where
    constructorPrism = _Ctor' @name
  
  data LabelType = FieldType | LegacyConstrType | ConstrType | PositionType
  
  type family ClassifyLabel (name :: Symbol) :: LabelType where
    ClassifyLabel name =
      If (StartsWithDigit name)
        'PositionType
        ( If (StartsWithUnderscoreAndUpperCase name)
            'LegacyConstrType
            ( If (StartsWithUpperCase name)
                'ConstrType
                'FieldType
            )
        )
  
  type StartsWithDigit name =
    CmpSymbol "/" name == 'LT && CmpSymbol ":" name == 'GT
  
  type StartsWithUnderscoreAndUpperCase name =
    CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT
  
  type StartsWithUpperCase name =
    CmpSymbol "@" name == 'LT && CmpSymbol "[" name == 'GT
  
  instance ( labelType ~ ClassifyLabel name
           , IsLabelHelper labelType name p f s t a b
           , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where
    fromLabel = labelOutput @labelType @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 the @labelType@ argument, which is determined by whether the symbol
  -- starts with a capital letter, optionally preceded by an underscore (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.
  --
  -- On GHC >=9.6, we also check whether the symbol starts with a digit, in which
  -- case we are dealing with an index for a positional lens.
  class IsLabelHelper labelType 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 'FieldType name (->) f s t a b where
    labelOutput = fieldLens @name
  
  instance ( Applicative f, Choice p, Constructor name s t a b
           , name' ~ AppendSymbol "_" name) => IsLabelHelper 'LegacyConstrType name' p f s t a b where
    labelOutput = constructorPrism @name
  
  instance ( Applicative f, Choice p, Constructor name s t a b
           ) => IsLabelHelper 'ConstrType name p f s t a b where
    labelOutput = constructorPrism @name
  
  class Position (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where
    positionLens :: Lens s t a b
  
  instance {-# INCOHERENT #-} HasPosition i s t a b => Position i s t a b where
    positionLens = position @i
  
  instance {-# INCOHERENT #-} HasPosition' i s a => Position i s s a a where
    positionLens = position' @i
  
  instance ( Functor f, Position i s t a b, i ~ ParseNat name
           ) => IsLabelHelper 'PositionType name (->) f s t a b where
    labelOutput = positionLens @i
  
  -- 'ParseNat' is only necessary for positional lenses, which can only actually
  -- be used with OverloadedLabels since GHC 9.6. Therefore, it is fine that this
  -- code only compiles with GHC >=9.4 due to the use of newer GHC features (such
  -- as 'UnconsSymbol').
  #if MIN_VERSION_base(4,17,0)
  type ParseNat name = ParseNat' 0 (UnconsSymbol name)
  
  type family ParseNat' acc m where
    ParseNat' acc ('Just '(hd, tl)) =
      ParseNat' (10 * acc + DigitToNat hd) (UnconsSymbol tl)
    ParseNat' acc 'Nothing = acc
  
  type DigitToNat c =
    If ('0' <=? c && c <=? '9')
      (CharToNat c - CharToNat '0')
      (TypeError ('Text "Invalid position number"))
  #else
  type family ParseNat name where
    ParseNat name = TypeError ('Text "Positional lenses not supported")
  #endif
  