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