{-# LANGUAGE UndecidableInstances #-}
module WebGear.Trait
(
Trait (..)
, Result (..)
, Linked
, link
, unlink
, probe
, remove
, Has (..)
, Have
, MissingTrait
) where
import Data.Kind (Constraint, Type)
import Data.Proxy (Proxy (..))
import GHC.TypeLits (ErrorMessage (..), TypeError)
class Monad m => Trait t a m where
type Attribute t a :: Type
type Absence t a :: Type
toAttribute :: a -> m (Result t a)
data Result t a = NotFound (Absence t a)
| Found (Attribute t a)
instance Monad m => Trait '[] a m where
type Attribute '[] a = ()
type Absence '[] a = ()
toAttribute :: a -> m (Result '[] a)
toAttribute :: a -> m (Result '[] a)
toAttribute = m (Result '[] a) -> a -> m (Result '[] a)
forall a b. a -> b -> a
const (m (Result '[] a) -> a -> m (Result '[] a))
-> m (Result '[] a) -> a -> m (Result '[] a)
forall a b. (a -> b) -> a -> b
$ Result '[] a -> m (Result '[] a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result '[] a -> m (Result '[] a))
-> Result '[] a -> m (Result '[] a)
forall a b. (a -> b) -> a -> b
$ Attribute '[] a -> Result '[] a
forall k (t :: k) a. Attribute t a -> Result t a
Found ()
instance (Trait t a m, Trait ts a m, Monad m) => Trait (t:ts) a m where
type Attribute (t:ts) a = (Attribute t a, Attribute ts a)
type Absence (t:ts) a = Either (Result t a) (Result ts a)
toAttribute :: a -> m (Result (t:ts) a)
toAttribute :: a -> m (Result (t : ts) a)
toAttribute a
a = a -> m (Result t a)
forall k (t :: k) a (m :: * -> *).
Trait t a m =>
a -> m (Result t a)
toAttribute @t a
a m (Result t a)
-> (Result t a -> m (Result (t : ts) a)) -> m (Result (t : ts) a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
e :: Result t a
e@(NotFound Absence t a
_) -> Result (t : ts) a -> m (Result (t : ts) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (t : ts) a -> m (Result (t : ts) a))
-> Result (t : ts) a -> m (Result (t : ts) a)
forall a b. (a -> b) -> a -> b
$ Absence (t : ts) a -> Result (t : ts) a
forall k (t :: k) a. Absence t a -> Result t a
NotFound (Absence (t : ts) a -> Result (t : ts) a)
-> Absence (t : ts) a -> Result (t : ts) a
forall a b. (a -> b) -> a -> b
$ Result t a -> Either (Result t a) (Result ts a)
forall a b. a -> Either a b
Left Result t a
e
Found Attribute t a
l -> a -> m (Result ts a)
forall k (t :: k) a (m :: * -> *).
Trait t a m =>
a -> m (Result t a)
toAttribute @ts a
a m (Result ts a)
-> (Result ts a -> m (Result (t : ts) a)) -> m (Result (t : ts) a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
e :: Result ts a
e@(NotFound Absence ts a
_) -> Result (t : ts) a -> m (Result (t : ts) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (t : ts) a -> m (Result (t : ts) a))
-> Result (t : ts) a -> m (Result (t : ts) a)
forall a b. (a -> b) -> a -> b
$ Absence (t : ts) a -> Result (t : ts) a
forall k (t :: k) a. Absence t a -> Result t a
NotFound (Absence (t : ts) a -> Result (t : ts) a)
-> Absence (t : ts) a -> Result (t : ts) a
forall a b. (a -> b) -> a -> b
$ Result ts a -> Either (Result t a) (Result ts a)
forall a b. b -> Either a b
Right Result ts a
e
Found Attribute ts a
r -> Result (t : ts) a -> m (Result (t : ts) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (t : ts) a -> m (Result (t : ts) a))
-> Result (t : ts) a -> m (Result (t : ts) a)
forall a b. (a -> b) -> a -> b
$ Attribute (t : ts) a -> Result (t : ts) a
forall k (t :: k) a. Attribute t a -> Result t a
Found (Attribute t a
l, Attribute ts a
r)
data Linked (ts :: [Type]) a = Linked
{ Linked ts a -> Attribute ts a
linkAttribute :: !(Attribute ts a)
, Linked ts a -> a
unlink :: !a
}
link :: a -> Linked '[] a
link :: a -> Linked '[] a
link = Attribute '[] a -> a -> Linked '[] a
forall (ts :: [*]) a. Attribute ts a -> a -> Linked ts a
Linked ()
probe :: forall t ts a m. Trait t a m
=> Linked ts a
-> m (Either (Absence t a) (Linked (t:ts) a))
probe :: Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe Linked ts a
l = do
Result t a
v <- a -> m (Result t a)
forall k (t :: k) a (m :: * -> *).
Trait t a m =>
a -> m (Result t a)
toAttribute @t (Linked ts a -> a
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts a
l)
Either (Absence t a) (Linked (t : ts) a)
-> m (Either (Absence t a) (Linked (t : ts) a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Absence t a) (Linked (t : ts) a)
-> m (Either (Absence t a) (Linked (t : ts) a)))
-> Either (Absence t a) (Linked (t : ts) a)
-> m (Either (Absence t a) (Linked (t : ts) a))
forall a b. (a -> b) -> a -> b
$ Result t a
-> Linked ts a -> Either (Absence t a) (Linked (t : ts) a)
mkLinked Result t a
v Linked ts a
l
where
mkLinked :: Result t a -> Linked ts a -> Either (Absence t a) (Linked (t:ts) a)
mkLinked :: Result t a
-> Linked ts a -> Either (Absence t a) (Linked (t : ts) a)
mkLinked (Found Attribute t a
left) Linked ts a
lv = Linked (t : ts) a -> Either (Absence t a) (Linked (t : ts) a)
forall a b. b -> Either a b
Right (Linked (t : ts) a -> Either (Absence t a) (Linked (t : ts) a))
-> Linked (t : ts) a -> Either (Absence t a) (Linked (t : ts) a)
forall a b. (a -> b) -> a -> b
$ Attribute (t : ts) a -> a -> Linked (t : ts) a
forall (ts :: [*]) a. Attribute ts a -> a -> Linked ts a
Linked (Attribute t a
left, Linked ts a -> Attribute ts a
forall (ts :: [*]) a. Linked ts a -> Attribute ts a
linkAttribute Linked ts a
lv) (Linked ts a -> a
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts a
lv)
mkLinked (NotFound Absence t a
e) Linked ts a
_ = Absence t a -> Either (Absence t a) (Linked (t : ts) a)
forall a b. a -> Either a b
Left Absence t a
e
remove :: Linked (t:ts) a -> Linked ts a
remove :: Linked (t : ts) a -> Linked ts a
remove Linked (t : ts) a
l = Attribute ts a -> a -> Linked ts a
forall (ts :: [*]) a. Attribute ts a -> a -> Linked ts a
Linked ((Attribute t a, Attribute ts a) -> Attribute ts a
forall a b. (a, b) -> b
snd ((Attribute t a, Attribute ts a) -> Attribute ts a)
-> (Attribute t a, Attribute ts a) -> Attribute ts a
forall a b. (a -> b) -> a -> b
$ Linked (t : ts) a -> Attribute (t : ts) a
forall (ts :: [*]) a. Linked ts a -> Attribute ts a
linkAttribute Linked (t : ts) a
l) (Linked (t : ts) a -> a
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked (t : ts) a
l)
class Has t ts where
get :: Proxy t -> Linked ts a -> Attribute t a
instance Has t (t:ts) where
get :: Proxy t -> Linked (t:ts) a -> Attribute t a
get :: Proxy t -> Linked (t : ts) a -> Attribute t a
get Proxy t
_ (Linked (lv, _) a
_) = Attribute t a
lv
instance {-# OVERLAPPABLE #-} Has t ts => Has t (t':ts) where
get :: Proxy t -> Linked (t':ts) a -> Attribute t a
get :: Proxy t -> Linked (t' : ts) a -> Attribute t a
get Proxy t
_ Linked (t' : ts) a
l = Proxy t -> Linked ts a -> Attribute t a
forall k (t :: k) (ts :: [*]) a.
Has t ts =>
Proxy t -> Linked ts a -> Attribute t a
get (Proxy t
forall k (t :: k). Proxy t
Proxy @t) (Linked (t' : ts) a -> Linked ts a
forall q (qs :: [*]) b. Linked (q : qs) b -> Linked qs b
rightLinked Linked (t' : ts) a
l)
where
rightLinked :: Linked (q:qs) b -> Linked qs b
rightLinked :: Linked (q : qs) b -> Linked qs b
rightLinked (Linked (_, rv) b
a) = Attribute qs b -> b -> Linked qs b
forall (ts :: [*]) a. Attribute ts a -> a -> Linked ts a
Linked Attribute qs b
rv b
a
instance TypeError (MissingTrait t) => Has t '[] where
get :: Proxy t -> Linked '[] a -> Attribute t a
get = Proxy t -> Linked '[] a -> Attribute t a
forall a. HasCallStack => a
undefined
type MissingTrait t = Text "The request doesn't have the trait ‘" :<>: ShowType t :<>: Text "’."
:$$: Text ""
:$$: Text "Did you use a wrong trait type?"
:$$: Text "For e.g., ‘PathVar \"foo\" Int’ instead of ‘PathVar \"foo\" String’?"
:$$: Text ""
:$$: Text "Or did you forget to apply an appropriate middleware?"
:$$: Text "For e.g. The trait ‘JSONRequestBody Foo’ can be used with ‘jsonRequestBody @Foo’ middleware."
:$$: Text ""
type family Have ts qs :: Constraint where
Have '[] qs = ()
Have (t:ts) qs = (Has t qs, Have ts qs)