{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
-- | This is an internal module and subject to change. Should not be used in production
module Control.Validation.Internal.SOP where
import Data.Proxy(Proxy(..))
import Generics.SOP(constructorName, hpure, hmap, hcmap, constructorInfo, datatypeName, unI, ConstructorInfo(..), SListI, SListI2, NP, HasDatatypeInfo(..), ConstructorName, FieldName, POP(..), K(..), DatatypeName, Generic(..), FieldInfo(..), Rep, NS(..), I(..), NP(..))
-- | Helper functions to supply the datatype-info
errMsgPOP :: forall e a e'. (HasDatatypeInfo a) => Proxy a -> (DatatypeName -> ConstructorName -> FieldName -> e -> e') -> POP (K (e -> e')) (Code a)
errMsgPOP p f = errMsgPOP' @e @a (f $ datatypeName inf) (constructorInfo inf :: NP ConstructorInfo (Code a))
where inf = datatypeInfo p
errMsgPOP' :: forall e a e'. (SListI2 (Code a)) => (ConstructorName -> FieldName -> e -> e') -> NP ConstructorInfo (Code a) -> POP (K (e -> e')) (Code a)
errMsgPOP' f cinfos = POP $ hcmap (Proxy @SListI) (errMsgNP f) cinfos
errMsgNP :: forall e xs e'. (SListI xs) => (ConstructorName -> FieldName -> e -> e') -> ConstructorInfo xs -> NP (K (e -> e')) xs
errMsgNP f = \case
Record name finfos -> hmap (\(FieldInfo fname) -> K $ f name fname) finfos
constr -> hpure $ (K $ f (constructorName constr) "" :: forall a. K (e -> e') a)
-- helper optics
type Optic f s a = (a -> f a) -> (s -> f s)
type T' s a = forall f. Applicative f => Optic f s a
sopLensTo :: (Functor f, Generic a) => Optic f a (Rep a)
sopLensTo l = fmap to . l . from
tZ :: T' (NS g (x ': xs)) (g x)
tZ f = \case
Z h -> Z <$> f h
S t -> pure (S t)
tS :: T' (NS g (x ': xs)) (NS g xs)
tS f = \case
Z h -> pure (Z h)
S t -> S <$> f t
tI :: T' (I a) a
tI f = fmap I . f . unI
tH :: T' (NP g (x ': xs)) (g x)
tH f = \(x :* xs) -> (:* xs) <$> f x
tT :: T' (NP g (x ': xs)) (NP g xs)
tT f = \(x :* xs) -> (x :*) <$> f xs