Derive the HFunctor & Effect instances for Readline.

Author: robrix

semantic-core/src/Control/Effect/Readline.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, OverloadedStrings, RankNTypes, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DeriveGeneric, DerivingStrategies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, OverloadedStrings, RankNTypes, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
 
 module Control.Effect.Readline
 ( Readline (..)
@@ -27,28 +27,25 @@ import Data.Int
 import Data.String
 import Data.Text.Prettyprint.Doc
 import Data.Text.Prettyprint.Doc.Render.Text
+import GHC.Generics (Generic1)
 import System.Console.Haskeline hiding (Handler, handle)
 import System.Directory
 import System.FilePath
 
 data Readline (m :: * -> *) k
   = Prompt String (Maybe String -> m k)
-  | forall a . Print (Doc a) (m k)
+  | Print AnyDoc (m k)
   | AskLine (Line -> m k)
+  deriving stock (Functor, Generic1)
+  deriving anyclass (Effect, HFunctor)
 
-deriving instance Functor m => Functor (Readline m)
-
-instance HFunctor Readline where
-  hmap f (Prompt s k) = Prompt s (f . k)
-  hmap f (Print d k) = Print d (f k)
-  hmap f (AskLine k) = AskLine (f . k)
-
+newtype AnyDoc = AnyDoc { unAnyDoc :: forall a . Doc a }
 
 prompt :: (IsString str, Member Readline sig, Carrier sig m) => String -> m (Maybe str)
 prompt p = fmap fromString <$> send (Prompt p pure)
 
 print :: (Pretty a, Carrier sig m, Member Readline sig) => a -> m ()
-print s = send (Print (pretty s) (pure ()))
+print s = send (Print (AnyDoc (pretty s)) (pure ()))
 
 println :: (Pretty a, Carrier sig m, Member Readline sig) => a -> m ()
 println s = print s >> print @String "\n"
@@ -62,7 +59,7 @@ increment :: Line -> Line
 increment (Line n) = Line (n + 1)
 
 newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (TransC InputT m) a }
-  deriving (Applicative, Functor, Monad, MonadIO)
+  deriving newtype (Applicative, Functor, Monad, MonadIO)
 
 runReadline :: MonadException m => Prefs -> Settings m -> ReadlineC m a -> m a
 runReadline prefs settings = runInputTWithPrefs prefs settings . runTransC . runReader (Line 0) . runReadlineC
@@ -73,7 +70,7 @@ instance (Carrier sig m, Effect sig, MonadException m, MonadIO m) => Carrier (Re
     local increment (runReadlineC (k str))
     where cyan = "\ESC[1;36m\STX"
           plain = "\ESC[0m\STX"
-  eff (L (Print text k)) = liftIO (putDoc text) *> k
+  eff (L (Print text k)) = liftIO (putDoc (unAnyDoc text)) *> k
   eff (L (AskLine k)) = ReadlineC ask >>= k
   eff (R other) = ReadlineC (eff (R (handleCoercible other)))
 
@@ -93,7 +90,7 @@ runReadlineWithHistory block = do
 
 -- | Promote a monad transformer into an effect.
 newtype TransC t (m :: * -> *) a = TransC { runTransC :: t m a }
-  deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)
+  deriving newtype (Applicative, Functor, Monad, MonadIO, MonadTrans)
 
 instance (Carrier sig m, Effect sig, Monad (t m), MonadTrans t) => Carrier sig (TransC t m) where
   eff = TransC . join . lift . eff . handle (pure ()) (pure . (runTransC =<<))
@@ -103,7 +100,7 @@ runControlIO handler = runReader (Handler handler) . runControlIOC
 
 -- | This exists to work around the 'MonadException' constraint that haskeline entails.
 newtype ControlIOC m a = ControlIOC { runControlIOC :: ReaderC (Handler m) m a }
-  deriving (Applicative, Functor, Monad, MonadIO)
+  deriving newtype (Applicative, Functor, Monad, MonadIO)
 
 newtype Handler m = Handler (forall x . m x -> IO x)