mirror of
https://github.com/hanshoglund/iso-deriving.git
synced 2024-09-17 09:57:35 +03:00
Add MTL class instances
This commit is contained in:
parent
ca38a7843c
commit
3160f1fcdd
@ -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
|
||||
|
@ -28,6 +28,7 @@ flag strict
|
||||
|
||||
library
|
||||
build-depends: base >= 4.12 && < 5,
|
||||
mtl,
|
||||
profunctors
|
||||
|
||||
exposed-modules: Iso.Deriving
|
||||
|
41
test/Spec.hs
41
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
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user