Add MTL class instances

Iso/Deriving.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Iso.Deriving
   ( As (..),
@@ -23,11 +24,16 @@ module Iso.Deriving
   )
 where
 
+import Data.Kind
 import Control.Applicative
 import Control.Category
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
 import Data.Bifunctor ()
 import Data.Profunctor (Profunctor (..))
 import Prelude hiding ((.), id)
+import Data.Functor.Classes (Eq1)
 
 type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
 
@@ -41,19 +47,19 @@ iso sa bt = dimap sa (fmap bt)
 -- convert it into an @a@ with no loss of information. We can think of it has
 -- having a *dual representation* as either @a@ or @b@.
 --
--- type As1 :: k -> Type -> Type
-newtype As a b = As b
+-- type As1 :: Type -> Type -> Type
+newtype As (a :: Type) b = As b
 
 -- |
 -- Like @As@ for kind @k -> Type@.
 --
--- type As1 :: k1 -> (k2 -> Type) -> k2 -> Type
-newtype As1 f g a = As1 {getAs1 :: g a}
+-- type As1 :: (k1 -> Type) -> (k1 -> Type) -> k1 -> Type
+newtype As1 (f :: k1 -> Type) (g :: k1 -> Type) (a :: k1) = As1 {getAs1 :: g a}
 
 -- |
 -- Like @As@ for kind @k1 -> k2 -> Type@.
 --
--- type As2 :: k1 -> (k2 -> k3 -> Type) -> k2 -> k3 -> Type
+-- type As2 :: (k1 -> k2 -> Type) -> (k1 -> k2 -> Type) -> k1 -> k2 -> Type
 newtype As2 f g a b = As2 (g a b)
 
 class Inject a b where
@@ -75,12 +81,16 @@ class (Inject a b, Project a b) => Isomorphic a b where
 instance (Project a b, Eq a) => Eq (As a b) where
   As a == As b = prj @a @b a == prj b
 
+{-# SPECIALIZE (==) :: As a b -> As a b -> As a b  #-}
+
 instance (Project a b, Ord a) => Ord (As a b) where
   compare (As a) (As b) = prj @a @b a `compare` prj b
 
 instance (Project a b, Show a) => Show (As a b) where
   showsPrec n (As a) = showsPrec n $ prj @a @b a
 
+-- instance (forall x . Isomorphic (f x) (g x), Eq1 f) => Eq1 (As1 f g) where
+
 instance (Isomorphic a b, Num a) => Num (As a b) where
 
   (As a) + (As b) =
@@ -136,6 +146,21 @@ instance (forall x. Isomorphic (f x) (g x), Monad f) => Monad (As1 f g) where
   (>>=) :: forall a b. As1 f g a -> (a -> As1 f g b) -> As1 f g b
   As1 k >>= f = As1 $ inj @(f b) @(g b) $ (prj @(f a) @(g a) k) >>= prj . getAs1 . f
 
+instance forall f g s . (forall x . Isomorphic (f x) (g x), MonadState s f) =>
+  MonadState s (As1 f g) where
+    state :: forall a . (s -> (a, s)) -> As1 f g a
+    state k = As1 $ inj @(f a) @(g a) (state @s @f k)
+
+instance forall f g s . (forall x . Isomorphic (f x) (g x), MonadReader s f) =>
+  MonadReader s (As1 f g) where
+    reader :: forall a . (s -> (a)) -> As1 f g a
+    reader k = As1 $ inj @(f a) @(g a) (reader @s @f k)
+
+instance forall f g s . (forall x . Isomorphic (f x) (g x), MonadWriter s f) =>
+  MonadWriter s (As1 f g) where
+    writer :: forall a . (a, s) -> As1 f g a
+    writer k = As1 $ inj @(f a) @(g a) (writer @s @f k)
+
 instance (forall x y. Isomorphic (f x y) (g x y), Category f) => Category (As2 f g) where
 
   id :: forall a. As2 f g a a

iso-deriving.cabal

@@ -28,6 +28,7 @@ flag strict
 
 library
     build-depends:      base >= 4.12 && < 5,
+                        mtl,
                         profunctors
 
     exposed-modules:    Iso.Deriving

test/Spec.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DerivingVia #-}
@@ -8,9 +9,12 @@
 
 module Main where
 
+import Data.Bifunctor
 import Control.Monad.Writer (WriterT (..))
 import Data.Coerce (coerce)
 import Data.Monoid (Any (..), Ap (..))
+import Control.Monad.State
+import Control.Monad.Except
 import Iso.Deriving
 
 main = pure () -- TODO
@@ -72,3 +76,40 @@ instance Inject (TheseMonad a b) (These a b) where
   inj (WriterT (Right (b, Just a))) = These a b
 
 instance Isomorphic (TheseMonad a b) (These a b)
+
+-- |
+-- Abort is like 'State' but allow short-circuiting the computation.
+data Abort s a = Abort { runAbort :: s -> (Maybe a, s) }
+  deriving (Functor)
+  deriving (Applicative, Monad, MonadState s) via
+    (ExceptT () (State s) `As1` Abort s)
+
+-- | Abort the computation. The current state will be retained, but no
+-- result will be returned.
+abort :: Abort s a
+abort = Abort $ \s -> (Nothing, s)
+
+quit :: a -> Abort s a
+quit x = Abort $ \s -> (Just x, s)
+
+instance Inject (ExceptT () (State s) a) (Abort s a) where
+  inj (ExceptT f) = Abort $ \s -> first eitherToMaybe $ runState f s
+instance Project (ExceptT () (State s) a) (Abort s a) where
+  prj (Abort f) = ExceptT $ StateT $ fmap (pure . first maybeToEither) f
+instance Isomorphic (ExceptT () (State s) a) (Abort s a)
+
+eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe (Left _) = Nothing
+eitherToMaybe (Right x) = Just x
+
+maybeToEither :: Maybe a -> Either () a
+maybeToEither Nothing = Left ()
+maybeToEither (Just x) = Right x
+
+t :: Abort Int ()
+t = do
+  !x <- get
+  when (x > 10) abort
+  put $ x + 1
+  t
+