Борьба с подключением пары монад с ограниченным классом типов внутри слуги - PullRequest
Новая
       72

Борьба с подключением пары монад с ограниченным классом типов внутри слуги

3 голосов
/ 08 июля 2019

Пожалуйста, прокрутите вниз, чтобы прочитать важные изменения к этому вопросу

Оригинальный (многословный) вопрос

Код моего веб-приложения написан в монаде с ограниченным классом типов, которая выглядит примерно так: 

fetchOrderById :: (HasDatabase m) => Args -> m Result

sendConfirmationMail :: (HasSmtp m) => Args -> m EmailId

Каждый модуль имеет свой собственный блок server, который выглядит следующим образом: 

data Routes route = Routes
  { rFetchOrder :: route :- CustomAuth :> "orders" :> Capture "OrderId" OrderId :> Get '[JSON] Order
  , rDeleteOrder :: route :- CustomAuth :> "deleteOrder" :> Capture "OrderId" OrderId :> Delete '[JSON] ()
  }

--
-- NOTE: This type-signature WILL NOT compile...
--
server :: Routes (AsServerT m)
server = Routes
  { rFetchOrder = \userId orderId -> runForUser fetchOrderPerms userId $ fetchOrderById orderId
  , rDeleteOrder = \userId orderId -> runForUser deleteOrderPerms userId $ deleteOrderById orderId
  }

fetchOrderPerms :: Proxy '[ 'PermissionFetchOrder]
fetchOrderPerms = Proxy

deleteOrderPerms :: Proxy '[ 'PermissionDeleteOrder]
deleteOrderPerms = Proxy

Теперь, функция runForUser - это то место, куда входит «пара» монад. Я хочу, чтобы runForUser имел следующий тип sig, где он преобразует «внутреннюю монаду» n во внешнюю монаду m БЕЗ изготовления из них бетона: 

runForUser :: UserId -> n a -> m a

Эта «магия класса типов» обязана не фиксировать конкретную монаду как можно дольше, что, я надеюсь, позволит мне писать тесты.

Когда, наконец, подключен к производственному приложению, вот что runForUid преобразует: 

AppM '[PermissionFetchOrder] a -> ServantM a

AppM '[PermissionDeleteOrder] a -> ServantM a

-- and so on...

А при подключении к тестам: 

TestM '[PermissionFetchOrder] a -> TestServantM a

TestM '[PermissionDeleteOrder] a -> TestServantM a

-- and so on...

Я пытаюсь написать класс типов для функции runForUid. Я пробовал разные техники, и самое близкое, что я получил, это следующее: 

-- 
-- This compiles...
--
class (HasDatabase (InnerMonad m), HasSmtp (InnerMonad m)) => RunForUser m where
  type InnerMonad m :: * -> *

  runForUser :: Proxy (p :: [Permission]) ->  UserId -> (InnerMonad m) a -> m a


--
-- Even this compiles...
--
server :: (RunForUser m) => Routes (ServerT m)
server = Route
  { rFetchOrder = \uid orderId -> runForUser fetchOrderPerms userId $ fetchOrderById orderId
  , rDeleteOrder = ...
  }

-- 
-- And this is where it gets stuck, because the compiler 
-- doesn't know how to deal with `perms` as it is not in 
-- scope
--
instance (HasDatabase (AppM perms), HasSmtp (AppM perms)) => RunForUser ServantM where
  type InnerMonad ServantM = AppM (perms :: [Permission])

  runForUser permProxy userId action = ...

Если решение, которое я представил выше, находится на правильном пути, тогда мой вопрос - как мне сказать компилятору не беспокоиться о perms? Это работа по внедрению runForUser. Могу ли я использовать RankNTypes любым способом, вставить forall perms куда-нибудь и заставить это работать?

С другой стороны, если приведенный выше подход является полным мусором, как лучше это сделать?

Редактировать

Я может нашел приемлемое решение, но я все еще ищу лучший способ избежать типового шаблона. 

{-# LANGUAGE DataKinds, RankNTypes, PartialSignature, ScopedTypeVariables -#}

type HasApp m = (HasDatabase m, HasSmtp m)

class HasServant ...

class (HasApp m, HasServant n) => RunForUser m n where
  runForUser :: Proxy (perms :: [Permission]) -> UserId -> m a -> n a

server :: forall m n . (RunForUser m n, HasApp m) => Routes (AsServerT n)
server = Routes
  { rFetchOrder = \userId orderId -> 
      runForUser fetchOrderPerms userId 
        --
        -- NOTE: Had to manually annotate the type `m a` and had
        -- to use PartialTypeSignatures to avoid having to specify
        -- the type `a` again.
        --
        (fetchOrderById orderId :: m _)
  , ...
  }

1 Ответ

0 голосов
/ 09 июля 2019

Хотя моя вся кодовая база еще не скомпилирована, я может иметь возможный ответ, который использует RankNTypes: 

type HasApp m = (HasDatabase m, HasSmtp m)

type UserRunner m n = (forall perms a . Proxy (perms :: [Permission]) -> UserId -> (HasApp (m perms) => m perms a) -> n a)

server :: UserRunner m n -> Routes (AsServerT n)
server runForUid = Routes
  { rFetchOrder = \uid orderId -> runForUid fetchOrderPerms uid $ fetchOrderById orderId
  , rDeleteOrder = \uid orderId -> runForUid deleteOrderPerms uid $ deleteOrderById orderId
  }
...