@@ -1,31 +1,23 @@
1−{-# LANGUAGE TypeOperators, FlexibleInstances, KindSignatures, MultiParamTypeClasses, DeriveFunctor, UndecidableInstances, GeneralizedNewtypeDeriving #-}
1+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DeriveGeneric, DerivingStrategies, FlexibleInstances, GeneralizedNewtypeDeriving,
2+ KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
23
34module Fused.HTTP where
45
56import Control.Effect
6−import Control.Effect.Sum
77import Control.Effect.Carrier
8−import Data.Coerce
98import Control.Monad.IO.Class
9+import GHC.Generics (Generic1)
1010
1111newtype HttpC m a = HttpC { runHttpC :: m a }
12− deriving (Applicative, Functor, Monad, MonadIO)
12+ deriving newtype (Applicative, Functor, Monad, MonadIO)
1313
1414data HTTP (m :: * -> *) k
15− = Open String k
16− | Close k
17− | Post String (String -> k)
18− | HGet (String -> k)
19− deriving Functor
20−
21−instance Effect HTTP where
22− handle state handler (Open s k) = Open s (handler . (<$ state) $ k)
23− handle state handler (Close k) = Close (handler . (<$ state) $ k)
24− handle state handler (Post s k) = Post s (handler . (<$ state) . k)
25− handle state handler (HGet k) = HGet (handler . (<$ state) . k)
26−
27−instance HFunctor HTTP where
28− hmap _ = coerce
15+ = Open String (m k)
16+ | Close (m k)
17+ | Post String (String -> m k)
18+ | HGet (String -> m k)
19+ deriving stock (Functor, Generic1)
20+ deriving anyclass (HFunctor, Effect)
2921
3022open' :: String -> HttpM ()
3123open' s = send (Open s (pure ()))
@@ -46,7 +38,7 @@ instance (Effect sig, Carrier sig m) => Carrier (HTTP :+: sig) (HttpC m) where
4638 Open _ k -> k
4739 Close k -> k
4840 Post s k -> k ("posted " <> s)
49− HGet k -> k "lmao"
41+ HGet k -> k "lmao"
5042 eff (R other) = HttpC (eff (handleCoercible other))
5143
5244runHttp :: HttpM a -> IO a