From 2b9ceaead3f3cd80e973cccecb9a3eebc51154f7 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <pngwjpgh@users.noreply.github.com>
Date: Sun, 17 Jul 2016 19:21:56 +0200
Subject: Fixes for GHC 8.0.1

---
 client/src/Thermoprint/Client.hs | 60 ++++++++++++++++++++++++++++++----------
 1 file changed, 46 insertions(+), 14 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Thermoprint/Client.hs b/client/src/Thermoprint/Client.hs
index 7072ad0..448a912 100644
--- a/client/src/Thermoprint/Client.hs
+++ b/client/src/Thermoprint/Client.hs
@@ -1,7 +1,10 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 -- | A client library for 'Thermoprint.API'
 module Thermoprint.Client
@@ -12,8 +15,8 @@ module Thermoprint.Client
        , ServantError(..)
        , module Thermoprint.API
        , module Servant.Common.BaseUrl
-       , module Control.Monad.Trans.Either
-       , module Servant.Server.Internal.Enter
+       , module Control.Monad.Except
+       , module Servant.Utils.Enter
        ) where
 
 import Thermoprint.API
@@ -24,19 +27,20 @@ import Data.Time (UTCTime)
 import Servant.Client hiding (HasClient(..))
 import qualified Servant.Client as S
 import Servant.Common.BaseUrl
+import Network.HTTP.Client (Manager, ManagerSettings, newManager, defaultManagerSettings)
 import Servant.API
-import Servant.Server.Internal.Enter
-import Control.Monad.Trans.Either
+import Servant.Utils.Enter
+import Control.Monad.Except (ExceptT, runExceptT)
 
+import Control.Monad.Reader (ReaderT, runReaderT, ask)
 import Control.Monad.Catch (Exception, MonadThrow(..))
 import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Trans (lift)
 
 import Control.Monad
 import Control.Category
 import Prelude hiding (id, (.))
 
-instance Exception ServantError
-
 -- | All 'ThermoprintAPI'-functions as a record
 --
 -- Use like this:
@@ -46,7 +50,7 @@ instance Exception ServantError
 -- > main :: IO ()
 -- > -- ^ Display a list of printers with their status
 -- > main = print =<< printers
--- >   where Client{..} = mkClient' $ Http "localhost" 3000
+-- >   where Client{..} = mkClient' defaultManagerSettings $ Http "localhost" 3000
 data Client m = Client
   { printers :: m (Map PrinterId PrinterStatus)
                 -- ^ List all printers
@@ -86,27 +90,55 @@ withArgs :: (x -> a :<|> b) -> ((x -> a) :<|> (x -> b))
 -- ^ Undo factoring of APIs
 withArgs subAPI = (\(a :<|> _) -> a) . subAPI :<|> (\(_ :<|> b) -> b) . subAPI
 
-mkClient :: (EitherT ServantError IO :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors
-         -> BaseUrl
-         -> Client m
+mkClientS :: Monad m
+          => (ClientM :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors
+          -> ManagerSettings
+          -> BaseUrl
+          -> Client m
 -- ^ Generate a 'Client'
-mkClient n url = Client{..}
+mkClientS n mgrS url = Client
+                       { printers = clientF n printers
+                       , jobs = \a b c -> clientF n $ jobs a b c
+                       , jobCreate = \a b -> clientF n $ jobCreate a b
+                       , job = \a -> clientF n $ job a
+                       , jobStatus = \a -> clientF n $ jobStatus a
+                       , jobDelete = \a -> clientF n $ jobDelete a
+                       , drafts = clientF n drafts
+                       , draftCreate = \a b -> clientF n $ draftCreate a b
+                       , draftReplace = \a b c -> clientF n $ draftReplace a b c
+                       , draft = \a -> clientF n $ draft a
+                       , draftDelete = \a -> clientF n $ draftDelete a
+                       , draftPrint = \a b -> clientF n $ draftPrint a b
+                       }
   where
+    clientF :: Monad m => (ClientM :~> m) -> (Manager -> BaseUrl -> m a) -> m a
+    clientF n f = do
+      mgr <- unNat n $ (liftIO $ newManager mgrS :: ClientM Manager)
+      f mgr url
     printers
       :<|> (jobs :<|> jobCreate)
       :<|> (withArgs -> job :<|> (withArgs -> jobStatus :<|> jobDelete))
       :<|> (drafts :<|> draftCreate)
       :<|> (withArgs -> draftReplace :<|> (withArgs -> draft :<|> (withArgs -> draftDelete :<|> draftPrint)))
-      = enter n $ client thermoprintAPI url
+      = enter n $ client thermoprintAPI
 
+mkClient :: Monad m
+         => (ClientM :~> m) -- ^ A monad functor ('Nat') used to make the api functions work in any monad which can do 'IO' and handle errors
+         -> BaseUrl
+         -> Client m
+mkClient n url = mkClientS n defaultManagerSettings url
+  
 mkClient' :: (MonadThrow m, MonadIO m) => BaseUrl -> Client m
 -- ^ @mkClient' = mkClient $ ioNat . throwNat@
 mkClient' = mkClient $ ioNat . throwNat
 
-throwNat :: (Exception e, MonadThrow m) => EitherT e m :~> m
+throwNat :: (Exception e, MonadThrow m) => ExceptT e m :~> m
 -- ^ Squash a layer of 'EitherT' into the underlying monad supporting 'throwM'
-throwNat = Nat $ either throwM return <=< runEitherT
+throwNat = Nat $ either throwM return <=< runExceptT
 
 ioNat :: MonadIO m => IO :~> m
 -- ^ @ioNat = Nat liftIO@
 ioNat = Nat liftIO
+
+readerNat :: a -> ReaderT a m :~> m
+readerNat a = Nat $ flip runReaderT a
-- 
cgit v1.2.3