{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Rank2Types #-}
module Factis.Haskoon.WebTrans (WebTrans(..), liftWebRec) where

----------------------------------------
-- STDLIB
----------------------------------------
import Control.Monad.Trans (MonadTrans)

----------------------------------------
-- LOCAL
----------------------------------------
import Factis.Haskoon.Web (Web(..), WebRec(..))

class MonadTrans t => WebTrans t where
    liftWeb :: Web m => m a -> t m a
    liftWebFun :: Web m => (forall a. m a -> m a) -> t m b -> t m b

liftWebRec :: (Web m, WebTrans t) => (m (WebRes m) -> m (WebRes (t m))) -> WebRec m -> WebRec (t m)
liftWebRec liftRes wr =
    WebRec
    { web_documentRoot = lift0 (web_documentRoot wr)
    , web_containerUri = lift0 (web_containerUri wr)
    , web_requestUri = lift0 (web_requestUri wr)
    , web_pathInfo = lift0 (web_pathInfo wr)
    , web_method = lift0 (web_method wr)
    , web_getBody = lift0 (web_getBody wr)
    , web_getParams = lift0 (web_getParams wr)
    , web_getHeaders = lift0 (web_getHeaders wr)
    , web_getCookies = lift0 (web_getCookies wr)
    , web_setStatus = lift2 (web_setStatus wr)
    , web_sendBSL = \x -> lift0 (liftRes $ web_sendBSL wr x)
    , web_setHeader = lift2 (web_setHeader wr)
    , web_setCookie = lift1 (web_setCookie wr)
    , web_unsetCookie = lift1 (web_unsetCookie wr)
    , web_log = lift3 (web_log wr)
    , web_getRepls = lift0 (web_getRepls wr)
    , web_withRepls = \rs cont -> liftWebFun (web_withRepls wr rs) cont
    , web_fail = lift1 (web_fail wr)
    }
    where
      lift0 = liftWeb
      lift1 f x = lift0 (f x)
      lift2 f x y = lift0 (f x y)
      lift3 f x y z = lift0 (f x y z)