{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}

module Web.Minion.Args.Internal where

import Data.Functor (($>))
import Data.Kind (Type)
import Data.Void (Void)
import Web.Minion.Request (IsRequest (..))

data (a :: Type) :+ (b :: Type)

infixl 9 :+
data HList ts where
  HNil :: HList '[]
  (:#) :: t -> HList ts -> HList (t ': ts)

-- | Reversed HList
data RHList ts where
  RHNil :: RHList Void
  (:#!) :: t -> RHList ts -> RHList (ts :+ t)

type family MapElem ts t t' where
  MapElem (ts :+ t) t t' = ts :+ t'
  MapElem (ts :+ x) t t' = MapElem ts t t' :+ x
  MapElem Void t t' = Void

infixr 1 :#
infixr 1 :#!

deriving instance Show (RHList Void)
deriving instance (Show (RHList as), Show a) => Show (RHList (as :+ a))

deriving instance Show (HList '[])
deriving instance (Show (HList as), Show a) => Show (HList (a ': as))

type family RevToList ts where
  RevToList Void = '[]
  RevToList (as :+ a) = a ': RevToList as

class RHListToHList (ts :: Type) where
  type HListTypes ts :: [Type]
  revHListToList :: RHList ts -> HList (HListTypes ts)

instance RHListToHList Void where
  type HListTypes Void = '[]
  revHListToList :: RHList Void -> HList (HListTypes Void)
revHListToList RHList Void
_ = HList '[]
HList (HListTypes Void)
HNil

instance (RHListToHList as) => RHListToHList (as :+ a) where
  type HListTypes (as :+ a) = a ': HListTypes as
  revHListToList :: RHList (as :+ a) -> HList (HListTypes (as :+ a))
revHListToList (t
a :#! RHList ts
as) = t
a t -> HList (HListTypes as) -> HList (t : HListTypes as)
forall t (ts :: [*]). t -> HList ts -> HList (t : ts)
:# RHList ts -> HList (HListTypes ts)
forall ts. RHListToHList ts => RHList ts -> HList (HListTypes ts)
revHListToList RHList ts
as

class GetByType t ts where
  getByType :: HList ts -> t

instance (GetByType t ts) => GetByType t (x ': ts) where
  getByType :: HList (x : ts) -> t
getByType (t
_ :# HList ts
as) = forall t (ts :: [*]). GetByType t ts => HList ts -> t
getByType @t @ts HList ts
HList ts
as

instance {-# OVERLAPPING #-} GetByType t (t ': ts) where
  getByType :: HList (t : ts) -> t
getByType (t
a :# HList ts
_) = t
t
a

class Reverse' (l1 :: [Type]) (l2 :: [Type]) (l3 :: [Type]) | l1 l2 -> l3 where
  reverse' :: HList l1 -> HList l2 -> HList l3

instance Reverse' '[] l2 l2 where
  reverse' :: HList '[] -> HList l2 -> HList l2
reverse' HList '[]
_ HList l2
l = HList l2
l

instance (Reverse' l (x ': l') z) => Reverse' (x ': l) l' z where
  reverse' :: HList (x : l) -> HList l' -> HList z
reverse' (t
x :# HList ts
l) HList l'
l' = HList ts -> HList (t : l') -> HList z
forall (l1 :: [*]) (l2 :: [*]) (l3 :: [*]).
Reverse' l1 l2 l3 =>
HList l1 -> HList l2 -> HList l3
reverse' HList ts
l (t
x t -> HList l' -> HList (t : l')
forall t (ts :: [*]). t -> HList ts -> HList (t : ts)
:# HList l'
l')

class Reverse xs sx | xs -> sx, sx -> xs where
  reverseHList :: HList xs -> HList sx

instance
  ( Reverse' xs '[] sx
  , Reverse' sx '[] xs
  ) =>
  Reverse xs sx
  where
  reverseHList :: HList xs -> HList sx
reverseHList HList xs
l = HList xs -> HList '[] -> HList sx
forall (l1 :: [*]) (l2 :: [*]) (l3 :: [*]).
Reverse' l1 l2 l3 =>
HList l1 -> HList l2 -> HList l3
reverse' HList xs
l HList '[]
HNil

data Lenient e
data Strict

data Required
data Optional

class IsRequired a where
  isRequired :: Bool

instance IsRequired Required where
  isRequired :: Bool
isRequired = Bool
True

instance IsRequired Optional where
  isRequired :: Bool
isRequired = Bool
False

class IsLenient a where
  isLenient :: Bool

instance IsLenient (Lenient a) where
  isLenient :: Bool
isLenient = Bool
True

instance IsLenient Strict where
  isLenient :: Bool
isLenient = Bool
False

type family Arg presence parsing a where
  Arg Required (Lenient e) a = (Either e a)
  Arg Required Strict a = a
  Arg Optional (Lenient e) a = (Maybe (Either e a))
  Arg Optional Strict a = (Maybe a)

newtype WithHeader presence parsing m a = WithHeader (m (Arg presence parsing a))
newtype WithQueryParam presence parsing m a = WithQueryParam (m (Arg presence parsing a))
newtype WithPiece a = WithPiece a
newtype WithPieces a = WithPieces [a]
newtype WithReq m r = WithReq (m r)
newtype Hide a = Hide a

class Hidden m a where
  runHidden :: Hide a -> m ()

instance (Monad m) => Hidden m (WithHeader a b m a) where
  runHidden :: Hide (WithHeader a b m a) -> m ()
runHidden (Hide (WithHeader m (Arg a b a)
a)) = m (Arg a b a)
a m (Arg a b a) -> () -> m ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

instance (Monad m) => Hidden m (WithQueryParam a b m a) where
  runHidden :: Hide (WithQueryParam a b m a) -> m ()
runHidden (Hide (WithQueryParam m (Arg a b a)
a)) = m (Arg a b a)
a m (Arg a b a) -> () -> m ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

instance (Monad m) => Hidden m (WithPiece a) where
  runHidden :: Hide (WithPiece a) -> m ()
runHidden (Hide (WithPiece a
_)) = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance (Monad m) => Hidden m (WithPieces a) where
  runHidden :: Hide (WithPieces a) -> m ()
runHidden (Hide (WithPieces [a]
_)) = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance (Monad m) => Hidden m (WithReq m a) where
  runHidden :: Hide (WithReq m a) -> m ()
runHidden (Hide (WithReq m a
a)) = m a
a m a -> () -> m ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

instance (Hidden m a) => Hidden m (Hide a) where
  runHidden :: Hide (Hide a) -> m ()
runHidden (Hide Hide a
a) = Hide a -> m ()
forall (m :: * -> *) a. Hidden m a => Hide a -> m ()
runHidden Hide a
a

class FunArgs (ts :: [Type]) where
  type ts ~> r :: Type

  apply :: (ts ~> r) -> HList ts -> r

type HandleArgs ts st m =
  ( FunArgs (DelayedArgs st)
  , RHListToHList ts
  , Reverse (HListTypes ts) st
  , RunDelayed st m
  , Monad m
  )

instance FunArgs '[] where
  type '[] ~> r = r
  {-# INLINE apply #-}
  apply :: forall r. ('[] ~> r) -> HList '[] -> r
apply '[] ~> r
a HList '[]
_ = r
'[] ~> r
a

instance (FunArgs as) => FunArgs (a ': as) where
  type (a ': as) ~> r = a -> as ~> r
  {-# INLINE apply #-}
  apply :: forall r. ((a : as) ~> r) -> HList (a : as) -> r
apply (a : as) ~> r
a (t
x :# HList ts
xs) = (ts ~> r) -> HList ts -> r
forall (ts :: [*]) r. FunArgs ts => (ts ~> r) -> HList ts -> r
forall r. (ts ~> r) -> HList ts -> r
apply ((a : as) ~> r
t -> as ~> r
a t
x) HList ts
xs

class (Monad m) => RunDelayed ts m where
  type DelayedArgs ts :: [Type]
  runDelayed :: HList ts -> m (HList (DelayedArgs ts))

instance (Monad m) => RunDelayed '[] m where
  type DelayedArgs '[] = '[]
  {-# INLINE runDelayed #-}
  runDelayed :: HList '[] -> m (HList (DelayedArgs '[]))
runDelayed HList '[]
HNil = HList '[] -> m (HList '[])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HList '[]
HNil

instance (RunDelayed as m) => RunDelayed (WithHeader required lenient m a ': as) m where
  type DelayedArgs (WithHeader required lenient m a ': as) = Arg required lenient a ': DelayedArgs as
  {-# INLINE runDelayed #-}
  runDelayed :: HList (WithHeader required lenient m a : as)
-> m (HList (DelayedArgs (WithHeader required lenient m a : as)))
runDelayed (WithHeader m (Arg required lenient a)
hIO :# HList ts
as) = do
    Arg required lenient a
h <- m (Arg required lenient a)
hIO
    HList (DelayedArgs as)
rest <- HList ts -> m (HList (DelayedArgs ts))
forall (ts :: [*]) (m :: * -> *).
RunDelayed ts m =>
HList ts -> m (HList (DelayedArgs ts))
runDelayed HList ts
as
    HList (Arg required lenient a : DelayedArgs as)
-> m (HList (Arg required lenient a : DelayedArgs as))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HList (Arg required lenient a : DelayedArgs as)
 -> m (HList (Arg required lenient a : DelayedArgs as)))
-> HList (Arg required lenient a : DelayedArgs as)
-> m (HList (Arg required lenient a : DelayedArgs as))
forall a b. (a -> b) -> a -> b
$ Arg required lenient a
h Arg required lenient a
-> HList (DelayedArgs as)
-> HList (Arg required lenient a : DelayedArgs as)
forall t (ts :: [*]). t -> HList ts -> HList (t : ts)
:# HList (DelayedArgs as)
rest

instance (RunDelayed as m, IsRequest r) => RunDelayed (WithReq m r ': as) m where
  type DelayedArgs (WithReq m r ': as) = RequestValue r ': DelayedArgs as
  {-# INLINE runDelayed #-}
  runDelayed :: HList (WithReq m r : as)
-> m (HList (DelayedArgs (WithReq m r : as)))
runDelayed (WithReq m r
hIO :# HList ts
as) = do
    r
h <- m r
hIO
    HList (DelayedArgs as)
rest <- HList ts -> m (HList (DelayedArgs ts))
forall (ts :: [*]) (m :: * -> *).
RunDelayed ts m =>
HList ts -> m (HList (DelayedArgs ts))
runDelayed HList ts
as
    HList (RequestValue r : DelayedArgs as)
-> m (HList (RequestValue r : DelayedArgs as))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HList (RequestValue r : DelayedArgs as)
 -> m (HList (RequestValue r : DelayedArgs as)))
-> HList (RequestValue r : DelayedArgs as)
-> m (HList (RequestValue r : DelayedArgs as))
forall a b. (a -> b) -> a -> b
$ r -> RequestValue r
forall r. IsRequest r => r -> RequestValue r
getRequestValue r
h RequestValue r
-> HList (DelayedArgs as)
-> HList (RequestValue r : DelayedArgs as)
forall t (ts :: [*]). t -> HList ts -> HList (t : ts)
:# HList (DelayedArgs as)
rest

instance (RunDelayed as m) => RunDelayed (WithQueryParam required lenient m a ': as) m where
  type DelayedArgs (WithQueryParam required lenient m a ': as) = Arg required lenient a ': DelayedArgs as
  {-# INLINE runDelayed #-}
  runDelayed :: HList (WithQueryParam required lenient m a : as)
-> m (HList
        (DelayedArgs (WithQueryParam required lenient m a : as)))
runDelayed (WithQueryParam m (Arg required lenient a)
a :# HList ts
as) = do
    Arg required lenient a
a' <- m (Arg required lenient a)
a
    HList (DelayedArgs as)
rest <- HList ts -> m (HList (DelayedArgs ts))
forall (ts :: [*]) (m :: * -> *).
RunDelayed ts m =>
HList ts -> m (HList (DelayedArgs ts))
runDelayed HList ts
as
    HList (Arg required lenient a : DelayedArgs as)
-> m (HList (Arg required lenient a : DelayedArgs as))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HList (Arg required lenient a : DelayedArgs as)
 -> m (HList (Arg required lenient a : DelayedArgs as)))
-> HList (Arg required lenient a : DelayedArgs as)
-> m (HList (Arg required lenient a : DelayedArgs as))
forall a b. (a -> b) -> a -> b
$ Arg required lenient a
a' Arg required lenient a
-> HList (DelayedArgs as)
-> HList (Arg required lenient a : DelayedArgs as)
forall t (ts :: [*]). t -> HList ts -> HList (t : ts)
:# HList (DelayedArgs as)
rest

instance (RunDelayed as m) => RunDelayed (WithPiece a ': as) m where
  type DelayedArgs (WithPiece a ': as) = a ': DelayedArgs as
  {-# INLINE runDelayed #-}
  runDelayed :: HList (WithPiece a : as)
-> m (HList (DelayedArgs (WithPiece a : as)))
runDelayed (WithPiece a
a :# HList ts
as) = do
    HList (DelayedArgs as)
rest <- HList ts -> m (HList (DelayedArgs ts))
forall (ts :: [*]) (m :: * -> *).
RunDelayed ts m =>
HList ts -> m (HList (DelayedArgs ts))
runDelayed HList ts
as
    HList (a : DelayedArgs as) -> m (HList (a : DelayedArgs as))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HList (a : DelayedArgs as) -> m (HList (a : DelayedArgs as)))
-> HList (a : DelayedArgs as) -> m (HList (a : DelayedArgs as))
forall a b. (a -> b) -> a -> b
$ a
a a -> HList (DelayedArgs as) -> HList (a : DelayedArgs as)
forall t (ts :: [*]). t -> HList ts -> HList (t : ts)
:# HList (DelayedArgs as)
rest

instance (RunDelayed as m) => RunDelayed (WithPieces a ': as) m where
  type DelayedArgs (WithPieces a ': as) = [a] ': DelayedArgs as
  {-# INLINE runDelayed #-}
  runDelayed :: HList (WithPieces a : as)
-> m (HList (DelayedArgs (WithPieces a : as)))
runDelayed (WithPieces [a]
a :# HList ts
as) = do
    HList (DelayedArgs as)
rest <- HList ts -> m (HList (DelayedArgs ts))
forall (ts :: [*]) (m :: * -> *).
RunDelayed ts m =>
HList ts -> m (HList (DelayedArgs ts))
runDelayed HList ts
as
    HList ([a] : DelayedArgs as) -> m (HList ([a] : DelayedArgs as))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HList ([a] : DelayedArgs as) -> m (HList ([a] : DelayedArgs as)))
-> HList ([a] : DelayedArgs as) -> m (HList ([a] : DelayedArgs as))
forall a b. (a -> b) -> a -> b
$ [a]
a [a] -> HList (DelayedArgs as) -> HList ([a] : DelayedArgs as)
forall t (ts :: [*]). t -> HList ts -> HList (t : ts)
:# HList (DelayedArgs as)
rest

instance (RunDelayed as m, Hidden m a) => RunDelayed (Hide a ': as) m where
  type DelayedArgs (Hide a ': as) = DelayedArgs as
  {-# INLINE runDelayed #-}
  runDelayed :: HList (Hide a : as) -> m (HList (DelayedArgs (Hide a : as)))
runDelayed (t
a :# HList ts
as) = Hide a -> m ()
forall (m :: * -> *) a. Hidden m a => Hide a -> m ()
runHidden t
Hide a
a m () -> m (HList (DelayedArgs as)) -> m (HList (DelayedArgs as))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HList ts -> m (HList (DelayedArgs ts))
forall (ts :: [*]) (m :: * -> *).
RunDelayed ts m =>
HList ts -> m (HList (DelayedArgs ts))
runDelayed HList ts
as