mirror of
https://github.com/hanshoglund/iso-deriving.git
synced 2024-09-19 02:47:54 +03:00
Add MTL class instances
This commit is contained in:
parent
ca38a7843c
commit
3160f1fcdd
@ -12,6 +12,7 @@
|
|||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module Iso.Deriving
|
module Iso.Deriving
|
||||||
( As (..),
|
( As (..),
|
||||||
@ -23,11 +24,16 @@ module Iso.Deriving
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Data.Kind
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Category
|
import Control.Category
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Control.Monad.Writer
|
||||||
|
import Control.Monad.State
|
||||||
import Data.Bifunctor ()
|
import Data.Bifunctor ()
|
||||||
import Data.Profunctor (Profunctor (..))
|
import Data.Profunctor (Profunctor (..))
|
||||||
import Prelude hiding ((.), id)
|
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)
|
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
|
-- 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@.
|
-- having a *dual representation* as either @a@ or @b@.
|
||||||
--
|
--
|
||||||
-- type As1 :: k -> Type -> Type
|
-- type As1 :: Type -> Type -> Type
|
||||||
newtype As a b = As b
|
newtype As (a :: Type) b = As b
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Like @As@ for kind @k -> Type@.
|
-- Like @As@ for kind @k -> Type@.
|
||||||
--
|
--
|
||||||
-- type As1 :: k1 -> (k2 -> Type) -> k2 -> Type
|
-- type As1 :: (k1 -> Type) -> (k1 -> Type) -> k1 -> Type
|
||||||
newtype As1 f g a = As1 {getAs1 :: g a}
|
newtype As1 (f :: k1 -> Type) (g :: k1 -> Type) (a :: k1) = As1 {getAs1 :: g a}
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Like @As@ for kind @k1 -> k2 -> Type@.
|
-- 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)
|
newtype As2 f g a b = As2 (g a b)
|
||||||
|
|
||||||
class Inject a b where
|
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
|
instance (Project a b, Eq a) => Eq (As a b) where
|
||||||
As a == As b = prj @a @b a == prj b
|
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
|
instance (Project a b, Ord a) => Ord (As a b) where
|
||||||
compare (As a) (As b) = prj @a @b a `compare` prj b
|
compare (As a) (As b) = prj @a @b a `compare` prj b
|
||||||
|
|
||||||
instance (Project a b, Show a) => Show (As a b) where
|
instance (Project a b, Show a) => Show (As a b) where
|
||||||
showsPrec n (As a) = showsPrec n $ prj @a @b a
|
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
|
instance (Isomorphic a b, Num a) => Num (As a b) where
|
||||||
|
|
||||||
(As a) + (As b) =
|
(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
|
(>>=) :: 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
|
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
|
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
|
id :: forall a. As2 f g a a
|
||||||
|
@ -28,6 +28,7 @@ flag strict
|
|||||||
|
|
||||||
library
|
library
|
||||||
build-depends: base >= 4.12 && < 5,
|
build-depends: base >= 4.12 && < 5,
|
||||||
|
mtl,
|
||||||
profunctors
|
profunctors
|
||||||
|
|
||||||
exposed-modules: Iso.Deriving
|
exposed-modules: Iso.Deriving
|
||||||
|
41
test/Spec.hs
41
test/Spec.hs
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE DerivingVia #-}
|
{-# LANGUAGE DerivingVia #-}
|
||||||
@ -8,9 +9,12 @@
|
|||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import Data.Bifunctor
|
||||||
import Control.Monad.Writer (WriterT (..))
|
import Control.Monad.Writer (WriterT (..))
|
||||||
import Data.Coerce (coerce)
|
import Data.Coerce (coerce)
|
||||||
import Data.Monoid (Any (..), Ap (..))
|
import Data.Monoid (Any (..), Ap (..))
|
||||||
|
import Control.Monad.State
|
||||||
|
import Control.Monad.Except
|
||||||
import Iso.Deriving
|
import Iso.Deriving
|
||||||
|
|
||||||
main = pure () -- TODO
|
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
|
inj (WriterT (Right (b, Just a))) = These a b
|
||||||
|
|
||||||
instance Isomorphic (TheseMonad a b) (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