diff --git a/Iso/Deriving.hs b/Iso/Deriving.hs index 21fe531..402dcd8 100644 --- a/Iso/Deriving.hs +++ b/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 diff --git a/iso-deriving.cabal b/iso-deriving.cabal index dd3769b..cec8b52 100755 --- a/iso-deriving.cabal +++ b/iso-deriving.cabal @@ -28,6 +28,7 @@ flag strict library build-depends: base >= 4.12 && < 5, + mtl, profunctors exposed-modules: Iso.Deriving diff --git a/test/Spec.hs b/test/Spec.hs index 6b1d79c..ab4d0f7 100644 --- a/test/Spec.hs +++ b/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 +