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