{-# 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 = const $ pure $ 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 = toAttribute @t a >>= \case
e@(NotFound _) -> pure $ NotFound $ Left e
Found l -> toAttribute @ts a >>= \case
e@(NotFound _) -> pure $ NotFound $ Right e
Found r -> pure $ Found (l, r)
data Linked (ts :: [Type]) a = Linked
{ linkAttribute :: !(Attribute ts a)
, unlink :: !a
}
link :: a -> Linked '[] a
link = Linked ()
probe :: forall t ts a m. Trait t a m
=> Linked ts a
-> m (Either (Absence t a) (Linked (t:ts) a))
probe l = do
v <- toAttribute @t (unlink l)
pure $ mkLinked v l
where
mkLinked :: Result t a -> Linked ts a -> Either (Absence t a) (Linked (t:ts) a)
mkLinked (Found left) lv = Right $ Linked (left, linkAttribute lv) (unlink lv)
mkLinked (NotFound e) _ = Left e
remove :: Linked (t:ts) a -> Linked ts a
remove l = Linked (snd $ linkAttribute l) (unlink 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 _ (Linked (lv, _) _) = lv
instance {-# OVERLAPPABLE #-} Has t ts => Has t (t':ts) where
get :: Proxy t -> Linked (t':ts) a -> Attribute t a
get _ l = get (Proxy @t) (rightLinked l)
where
rightLinked :: Linked (q:qs) b -> Linked qs b
rightLinked (Linked (_, rv) a) = Linked rv a
instance TypeError (MissingTrait t) => Has t '[] where
get = 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)