{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Generics.Product.Positions
(
HasPosition (..)
, HasPosition' (..)
, getPosition
, setPosition
) where
import Data.Generics.Internal.VL.Lens as VL
import Data.Generics.Internal.Void
import Data.Generics.Internal.Families
import Data.Generics.Product.Internal.Positions
import Data.Kind (Constraint, Type)
import Data.Type.Bool (type (&&))
import GHC.Generics
import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))
import Data.Generics.Internal.Profunctor.Lens
class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where
position :: VL.Lens s t a b
class HasPosition' (i :: Nat) s a | s i -> a where
position' :: VL.Lens s s a a
getPosition :: forall i s a. HasPosition' i s a => s -> a
getPosition s = s ^. position' @i
setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
setPosition = VL.set (position' @i)
instance
( Generic s
, ErrorUnless i s (0 <? i && i <=? Size (Rep s))
, GHasPosition' i (Rep s) a
) => HasPosition' i s a where
position' f s = VL.ravel (repLens . gposition @i) f s
{-# INLINE position' #-}
instance
( Generic s
, ErrorUnless i s (0 <? i && i <=? Size (Rep s))
, Generic t
#if __GLASGOW_HASKELL__ < 802
, '(s', t') ~ '(Proxied s, Proxied t)
#else
, s' ~ Proxied s
, t' ~ Proxied t
#endif
, Generic s'
, Generic t'
, GHasPosition' i (Rep s) a
, GHasPosition' i (Rep s') a'
, GHasPosition i (Rep s) (Rep t) a b
, t ~ Infer s a' b
, GHasPosition' i (Rep t') b'
, s ~ Infer t b' a
) => HasPosition i s t a b where
position = VL.ravel (repLens . gposition @i)
{-# INLINE position #-}
instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where
position = undefined
type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
ErrorUnless i s 'False
= TypeError
( 'Text "The type "
':<>: 'ShowType s
':<>: 'Text " does not contain a field at position "
':<>: 'ShowType i
)
ErrorUnless _ _ 'True
= ()