{-# LANGUAGE UndecidableInstances #-}
module WebGear.Core.Trait (
Attribute,
Absence,
Prerequisite,
Get (..),
Gets,
Set (..),
Sets,
With,
wzero,
wminus,
unwitness,
probe,
plant,
HasTrait (..),
HaveTraits,
pick,
MissingTrait,
) where
import Control.Arrow (Arrow (..))
import Data.Kind (Constraint, Type)
import Data.Tagged (Tagged (..), untag)
import GHC.TypeLits (ErrorMessage (..), TypeError)
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response)
type family Attribute t a :: Type
type family Absence t :: Type
type family Prerequisite (t :: Type) (ts :: [Type]) :: Constraint
class (Arrow h) => Get h t where
getTrait ::
(Prerequisite t ts) =>
t ->
h (Request `With` ts) (Either (Absence t) (Attribute t Request))
class (Arrow h) => Set h (t :: Type) where
setTrait ::
t ->
(Response `With` ts -> Response -> Attribute t Response -> Response `With` (t : ts)) ->
h (Response `With` ts, Attribute t Response) (Response `With` (t : ts))
type family Gets h ts :: Constraint where
Gets h '[] = ()
Gets h (t : ts) = (Get h t, Gets h ts)
type family Sets h ts :: Constraint where
Sets h '[] = ()
Sets h (t : ts) = (Set h t, Sets h ts)
data With a (ts :: [Type]) = With
{ forall a (ts :: [*]). With a ts -> WitnessedAttribute ts a
attribute :: !(WitnessedAttribute ts a)
, forall a (ts :: [*]). With a ts -> a
unwitness :: !a
}
type family WitnessedAttribute (ts :: [Type]) (a :: Type) where
WitnessedAttribute '[] a = ()
WitnessedAttribute (t : ts) a = (Attribute t a, WitnessedAttribute ts a)
wzero :: a -> a `With` '[]
wzero :: forall a. a -> With a '[]
wzero = WitnessedAttribute '[] a -> a -> With a '[]
forall a (ts :: [*]). WitnessedAttribute ts a -> a -> With a ts
With ()
{-# INLINE wzero #-}
wminus :: a `With` (t : ts) -> a `With` ts
wminus :: forall a t (ts :: [*]). With a (t : ts) -> With a ts
wminus (With (Attribute t a
_, WitnessedAttribute ts a
rv) a
a) = WitnessedAttribute ts a -> a -> With a ts
forall a (ts :: [*]). WitnessedAttribute ts a -> a -> With a ts
With WitnessedAttribute ts a
rv a
a
{-# INLINE wminus #-}
probe ::
forall t ts h.
(Get h t, Prerequisite t ts) =>
t ->
h (Request `With` ts) (Either (Absence t) (Request `With` (t : ts)))
probe :: forall t (ts :: [*]) (h :: * -> * -> *).
(Get h t, Prerequisite t ts) =>
t
-> h (With Request ts) (Either (Absence t) (With Request (t : ts)))
probe t
t = proc With Request ts
l -> do
Either (Absence t) (Attribute t Request)
res <- t -> h (With Request ts) (Either (Absence t) (Attribute t Request))
forall (ts :: [*]).
Prerequisite t ts =>
t -> h (With Request ts) (Either (Absence t) (Attribute t Request))
forall (h :: * -> * -> *) t (ts :: [*]).
(Get h t, Prerequisite t ts) =>
t -> h (With Request ts) (Either (Absence t) (Attribute t Request))
getTrait t
t -< With Request ts
l
((With Request ts, Either (Absence t) (Attribute t Request))
-> Either (Absence t) (With Request (t : ts)))
-> h (With Request ts, Either (Absence t) (Attribute t Request))
(Either (Absence t) (With Request (t : ts)))
forall b c. (b -> c) -> h b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (With Request ts, Either (Absence t) (Attribute t Request))
-> Either (Absence t) (With Request (t : ts))
forall e.
(With Request ts, Either e (Attribute t Request))
-> Either e (With Request (t : ts))
add -< (With Request ts
l, Either (Absence t) (Attribute t Request)
res)
where
add :: (Request `With` ts, Either e (Attribute t Request)) -> Either e (Request `With` (t : ts))
add :: forall e.
(With Request ts, Either e (Attribute t Request))
-> Either e (With Request (t : ts))
add (With Request ts
_, Left e
e) = e -> Either e (With Request (t : ts))
forall a b. a -> Either a b
Left e
e
add (With{Request
WitnessedAttribute ts Request
unwitness :: forall a (ts :: [*]). With a ts -> a
attribute :: forall a (ts :: [*]). With a ts -> WitnessedAttribute ts a
attribute :: WitnessedAttribute ts Request
unwitness :: Request
..}, Right Attribute t Request
attr) = With Request (t : ts) -> Either e (With Request (t : ts))
forall a b. b -> Either a b
Right (With Request (t : ts) -> Either e (With Request (t : ts)))
-> With Request (t : ts) -> Either e (With Request (t : ts))
forall a b. (a -> b) -> a -> b
$ With{attribute :: WitnessedAttribute (t : ts) Request
attribute = (Attribute t Request
attr, WitnessedAttribute ts Request
attribute), Request
unwitness :: Request
unwitness :: Request
..}
{-# INLINE probe #-}
plant ::
forall t ts h.
(Set h t) =>
t ->
h (Response `With` ts, Attribute t Response) (Response `With` (t : ts))
plant :: forall t (ts :: [*]) (h :: * -> * -> *).
Set h t =>
t
-> h (With Response ts, Attribute t Response)
(With Response (t : ts))
plant t
t = proc (With Response ts
l, Attribute t Response
attr) -> do
t
-> (With Response ts
-> Response -> Attribute t Response -> With Response (t : ts))
-> h (With Response ts, Attribute t Response)
(With Response (t : ts))
forall (ts :: [*]).
t
-> (With Response ts
-> Response -> Attribute t Response -> With Response (t : ts))
-> h (With Response ts, Attribute t Response)
(With Response (t : ts))
forall (h :: * -> * -> *) t (ts :: [*]).
Set h t =>
t
-> (With Response ts
-> Response -> Attribute t Response -> With Response (t : ts))
-> h (With Response ts, Attribute t Response)
(With Response (t : ts))
setTrait t
t With Response ts
-> Response -> Attribute t Response -> With Response (t : ts)
add -< (With Response ts
l, Attribute t Response
attr)
where
add :: Response `With` ts -> Response -> Attribute t Response -> Response `With` (t : ts)
add :: With Response ts
-> Response -> Attribute t Response -> With Response (t : ts)
add With{Response
WitnessedAttribute ts Response
unwitness :: forall a (ts :: [*]). With a ts -> a
attribute :: forall a (ts :: [*]). With a ts -> WitnessedAttribute ts a
attribute :: WitnessedAttribute ts Response
unwitness :: Response
..} Response
a' Attribute t Response
attr = With{attribute :: WitnessedAttribute (t : ts) Response
attribute = (Attribute t Response
attr, WitnessedAttribute ts Response
attribute), unwitness :: Response
unwitness = Response
a'}
{-# INLINE plant #-}
class HasTrait t ts where
from :: a `With` ts -> Tagged t (Attribute t a)
instance HasTrait t (t : ts) where
from :: a `With` (t : ts) -> Tagged t (Attribute t a)
from :: forall a. With a (t : ts) -> Tagged t (Attribute t a)
from (With (Attribute t a
lv, WitnessedAttribute ts a
_) a
_) = Attribute t a -> Tagged t (Attribute t a)
forall {k} (s :: k) b. b -> Tagged s b
Tagged Attribute t a
lv
{-# INLINE from #-}
instance {-# OVERLAPPABLE #-} (HasTrait t ts) => HasTrait t (t' : ts) where
from :: a `With` (t' : ts) -> Tagged t (Attribute t a)
from :: forall a. With a (t' : ts) -> Tagged t (Attribute t a)
from With a (t' : ts)
l = With a ts -> Tagged t (Attribute t a)
forall a. With a ts -> Tagged t (Attribute t a)
forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from (With a ts -> Tagged t (Attribute t a))
-> With a ts -> Tagged t (Attribute t a)
forall a b. (a -> b) -> a -> b
$ With a (t' : ts) -> With a ts
forall a t (ts :: [*]). With a (t : ts) -> With a ts
wminus With a (t' : ts)
l
{-# INLINE from #-}
pick :: Tagged t a -> a
pick :: forall {k} (t :: k) a. Tagged t a -> a
pick = Tagged t a -> a
forall {k} (t :: k) a. Tagged t a -> a
untag
{-# INLINE pick #-}
instance (TypeError (MissingTrait t)) => HasTrait t '[] where
from :: forall a. With a '[] -> Tagged t (Attribute t a)
from = With a '[] -> Tagged t (Attribute t a)
forall a. HasCallStack => a
undefined
type MissingTrait t =
Text "The value doesn't have the ‘"
:<>: ShowType t
:<>: Text "’ trait."
:$$: Text ""
:$$: Text "Did you forget to apply an appropriate middleware?"
:$$: Text "For e.g. The trait ‘Body JSON t’ requires ‘requestBody @t JSON’ middleware."
:$$: Text ""
:$$: Text "or did you use a wrong trait type?"
:$$: Text "For e.g., ‘RequiredQueryParam \"foo\" Int’ instead of ‘RequiredQueryParam \"foo\" String’?"
:$$: Text ""
type family HaveTraits ts qs :: Constraint where
HaveTraits '[] qs = ()
HaveTraits (t : ts) qs = (HasTrait t qs, HaveTraits ts qs)