Merge pull request #1733 from danidiaz/danidiaz_add_mkhandler_pattern_synonym

Add `MkHandler` pattern synonym

Author: ysangkok

changelog.d/1733

@@ -0,0 +1,7 @@
+synopsis: Add `MkHandler` pattern synonym
+prs: #1733
+issues: #1732
+description: {
+Add a bidirectional pattern synonym to construct `Handler a` values from `IO
+(Either ServerError a)` ones, and match in the other direction.
+}

servant-server/src/Servant/Server.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE PatternSynonyms     #-}
 
 -- | This module lets you implement 'Server's for defined APIs. You'll
 -- most likely just need 'serve'.
@@ -25,6 +26,7 @@ module Servant.Server
   , emptyServer
   , Handler (..)
   , runHandler
+  , pattern MkHandler
 
     -- * Debugging the server layout
   , layout

servant-server/src/Servant/Server/Internal/Handler.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE PatternSynonyms            #-}
 module Servant.Server.Internal.Handler where
 
 import           Prelude ()
@@ -19,7 +20,7 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Control
                  (MonadBaseControl (..))
 import           Control.Monad.Trans.Except
-                 (ExceptT, runExceptT)
+                 (ExceptT(ExceptT), runExceptT)
 import           Data.String
                  (fromString)
 import           GHC.Generics
@@ -51,3 +52,10 @@ instance MonadBaseControl IO Handler where
 
 runHandler :: Handler a -> IO (Either ServerError a)
 runHandler = runExceptT . runHandler'
+
+-- | Pattern synonym that matches directly on the inner 'IO' action.
+--
+-- To lift 'IO' actions that don't carry a 'ServerError', use 'Control.Monad.IO.Class.liftIO' instead.
+pattern MkHandler :: IO (Either ServerError a) -> Handler a
+pattern MkHandler ioe = Handler (ExceptT ioe)
+{-# COMPLETE MkHandler #-}