{-# LANGUAGE UndecidableInstances #-}
module WebGear.Core.Trait (
Trait (..),
TraitAbsence (..),
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)
class Trait (t :: Type) a where
type Attribute t a :: Type
class (Trait t a) => TraitAbsence t a where
type Absence t a :: Type
class (Arrow h, TraitAbsence t a) => Get h t a where
getTrait ::
t ->
h (a `With` ts) (Either (Absence t a) (Attribute t a))
class (Arrow h, Trait t a) => Set h (t :: Type) a where
setTrait ::
t ->
(a `With` ts -> a -> Attribute t a -> a `With` (t : ts)) ->
h (a `With` ts, Attribute t a) (a `With` (t : ts))
type family Gets h ts a :: Constraint where
Gets h '[] a = ()
Gets h (t : ts) a = (Get h t a, Gets h ts a)
type family Sets h ts a :: Constraint where
Sets h '[] a = ()
Sets h (t : ts) a = (Set h t a, Sets h ts a)
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 = 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) = forall a (ts :: [*]). WitnessedAttribute ts a -> a -> With a ts
With WitnessedAttribute ts a
rv a
a
{-# INLINE wminus #-}
probe ::
forall t ts h a.
(Get h t a) =>
t ->
h (a `With` ts) (Either (Absence t a) (a `With` (t : ts)))
probe :: forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe t
t = proc With a ts
l -> do
Either (Absence t a) (Attribute t a)
res <- forall (h :: * -> * -> *) t a (ts :: [*]).
Get h t a =>
t -> h (With a ts) (Either (Absence t a) (Attribute t a))
getTrait t
t -< With a ts
l
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall e.
(With a ts, Either e (Attribute t a)) -> Either e (With a (t : ts))
add -< (With a ts
l, Either (Absence t a) (Attribute t a)
res)
where
add :: (a `With` ts, Either e (Attribute t a)) -> Either e (a `With` (t : ts))
add :: forall e.
(With a ts, Either e (Attribute t a)) -> Either e (With a (t : ts))
add (With a ts
_, Left e
e) = forall a b. a -> Either a b
Left e
e
add (With{a
WitnessedAttribute ts a
unwitness :: a
attribute :: WitnessedAttribute ts a
attribute :: forall a (ts :: [*]). With a ts -> WitnessedAttribute ts a
unwitness :: forall a (ts :: [*]). With a ts -> a
..}, Right Attribute t a
attr) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ With{attribute :: WitnessedAttribute (t : ts) a
attribute = (Attribute t a
attr, WitnessedAttribute ts a
attribute), a
unwitness :: a
unwitness :: a
..}
{-# INLINE probe #-}
plant ::
forall t ts h a.
(Set h t a) =>
t ->
h (a `With` ts, Attribute t a) (a `With` (t : ts))
plant :: forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant t
t = proc (With a ts
l, Attribute t a
attr) -> do
forall (h :: * -> * -> *) t a (ts :: [*]).
Set h t a =>
t
-> (With a ts -> a -> Attribute t a -> With a (t : ts))
-> h (With a ts, Attribute t a) (With a (t : ts))
setTrait t
t With a ts -> a -> Attribute t a -> With a (t : ts)
add -< (With a ts
l, Attribute t a
attr)
where
add :: a `With` ts -> a -> Attribute t a -> a `With` (t : ts)
add :: With a ts -> a -> Attribute t a -> With a (t : ts)
add With{a
WitnessedAttribute ts a
unwitness :: a
attribute :: WitnessedAttribute ts a
attribute :: forall a (ts :: [*]). With a ts -> WitnessedAttribute ts a
unwitness :: forall a (ts :: [*]). With a ts -> a
..} a
a' Attribute t a
attr = With{attribute :: WitnessedAttribute (t : ts) a
attribute = (Attribute t a
attr, WitnessedAttribute ts a
attribute), unwitness :: a
unwitness = a
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
_) = 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 = forall t (ts :: [*]) a.
HasTrait t ts =>
With a ts -> Tagged t (Attribute t a)
from forall a b. (a -> b) -> a -> b
$ 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 = 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 = 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)