├── Setup.hs ├── hie.yaml ├── cabal.project ├── CHANGELOG.md ├── .envrc ├── CACHES.md ├── .gitignore ├── default.nix ├── lib ├── FunList.hs ├── Types.hs ├── Classes.hs ├── Instances.hs ├── Optics.hs └── MTL.hs ├── shell.nix ├── package.yaml ├── nix ├── sources.json └── sources.nix ├── app └── Main.hs └── README.md /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: { cabal: { component: "monadoptics" } } 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | index-state: 2020-07-01T00:00:00Z 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for monadoptics 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /.envrc: -------------------------------------------------------------------------------- 1 | use nix 2 | 3 | # TODO: Remove the grep stuff once https://github.com/hercules-ci/ghcide-nix/issues/26 is resolved 4 | source <(grep 'export NIX_' $(which ghc)) 5 | -------------------------------------------------------------------------------- /CACHES.md: -------------------------------------------------------------------------------- 1 | This project uses various nix expressions for building code. In order to avoid building a huge amount of stuff at once, you might want to enable the following [cachix](https://cachix.org/) caches: 2 | 3 | - iohk 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | 24 | *.cabal 25 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | let 2 | sources = import ./nix/sources.nix; 3 | compilerVersion = "ghc883"; 4 | hnix = import sources.iohk-hnix {}; 5 | pkgs = (import hnix.sources.nixpkgs) hnix.nixpkgsArgs; 6 | in 7 | pkgs.haskell-nix.cabalProject { 8 | src = pkgs.haskell-nix.haskellLib.cleanGit { src = ./.; }; 9 | compiler-nix-name = compilerVersion; 10 | } 11 | -------------------------------------------------------------------------------- /lib/FunList.hs: -------------------------------------------------------------------------------- 1 | module FunList where 2 | 3 | import Prelude hiding (replicate) 4 | 5 | import Unsafe.Coerce 6 | import Control.Monad.Free 7 | 8 | import Types 9 | 10 | replicate :: Functor f => SNat n -> f ~> Onion (S n) f 11 | replicate SZ fx = Layer $ Core <$> fx 12 | replicate (SS n) fx = Layer $ (const $ replicate n fx) <$> fx 13 | 14 | freeToOnion :: Functor f => Free f a -> SomeOnion f a 15 | freeToOnion (Pure a) = SomeOnion $ Core a 16 | freeToOnion (Free fa) = SomeOnion $ Layer $ ((\(SomeOnion x) -> unsafeCoerce x) . freeToOnion <$> fa) 17 | 18 | onionToFree :: Functor f => Onion n f a -> Free f a 19 | onionToFree (Core a) = Pure a 20 | onionToFree (Layer fa) = Free (onionToFree <$> fa) 21 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | sources = import ./nix/sources.nix; 3 | compilerVersion = "ghc883"; 4 | hnix = import sources.iohk-hnix {}; 5 | pkgs = (import hnix.sources.nixpkgs) hnix.nixpkgsArgs; 6 | hls = import sources.all-hls { inherit pkgs; version = "0.4.0"; ghc = "8.8.3"; }; # TODO: generate this string from the ghc template variable 7 | in 8 | (import ./.).shellFor { 9 | withHoogle = true; 10 | buildInputs = [ 11 | hls 12 | (pkgs.haskell-nix.tool compilerVersion "hpack" { index-state = "2020-07-01T00:00:00Z"; version = "0.34.2"; }) 13 | (pkgs.haskell-nix.tool compilerVersion "cabal-install" { index-state = "2020-07-01T00:00:00Z"; version = "3.2.0.0"; }) 14 | (pkgs.haskell-nix.tool compilerVersion "ghcid" { index-state = "2020-07-01T00:00:00Z"; version = "0.8.7"; }) 15 | ]; 16 | } 17 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | spec-version: 0.30.0 2 | name: monadoptics 3 | author: Asad Saeeduddin 4 | maintainer: masaeedu@gmail.com 5 | license: MIT 6 | 7 | build-type: Simple 8 | 9 | dependencies: 10 | - { name: "base", version: '>=4.13 && <4.14' } 11 | - mtl 12 | - transformers 13 | - free 14 | - comonad 15 | - bifunctors 16 | 17 | ghc-options: -Wall 18 | default-extensions: 19 | - GADTs 20 | 21 | - StandaloneDeriving 22 | - DeriveFunctor 23 | - DerivingVia 24 | - GeneralizedNewtypeDeriving 25 | 26 | - ScopedTypeVariables 27 | - RankNTypes 28 | - QuantifiedConstraints 29 | 30 | - TypeApplications 31 | - TypeOperators 32 | - MultiParamTypeClasses 33 | - TypeFamilies 34 | 35 | - ConstraintKinds 36 | - DataKinds 37 | - PolyKinds 38 | - KindSignatures 39 | 40 | - UndecidableInstances 41 | - FlexibleInstances 42 | - FlexibleContexts 43 | - DefaultSignatures 44 | 45 | - TupleSections 46 | 47 | library: 48 | source-dirs: lib 49 | 50 | executable: 51 | source-dirs: app 52 | main: Main.hs 53 | dependencies: 54 | - monadoptics 55 | -------------------------------------------------------------------------------- /lib/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import Data.Functor.Const 4 | import Data.Functor.Compose 5 | 6 | type F = (* -> *) 7 | type HP = F -> F -> * 8 | 9 | type (~>) f g = forall x. f x -> g x 10 | infixr 1 ~> 11 | 12 | newtype (f :~> g) = Nat { runNat :: forall x. f x -> g x } 13 | 14 | newtype (f :*: g) a = Product { runProduct :: (f a, g a) } 15 | type Product = (:*:) 16 | 17 | newtype (f :+: g) a = Sum { runSum :: Either (f a) (g a) } 18 | type Sum = (:+:) 19 | 20 | type (:.:) = Compose 21 | infixr :.: 22 | 23 | data Nat = Z | S Nat 24 | 25 | data SNat n 26 | where 27 | SZ :: SNat Z 28 | SS :: SNat n -> SNat (S n) 29 | 30 | data Onion n f a 31 | where 32 | Core :: { reveal :: a } -> Onion Z f a 33 | Layer :: { peel :: f (Onion n f a) } -> Onion (S n) f a 34 | 35 | data SomeOnion f a 36 | where 37 | SomeOnion :: Onion n f a -> SomeOnion f a 38 | 39 | data HFunList a b t x 40 | where 41 | HFunList :: Onion n a r -> (Onion n b r -> t x) -> HFunList a b t x 42 | 43 | data HForget :: F -> HP 44 | where 45 | HForget :: { runHForget :: a ~> r } -> HForget r a b 46 | 47 | data HCIso a b s t = HCIso { fwd :: s ~> a, bwd :: b ~> t } 48 | 49 | data HCLens a b s t = HCLens { v :: s ~> a, p :: (b `Product` s) ~> t } 50 | 51 | data HReverse :: HP -> F -> F -> HP 52 | where 53 | HReverse :: { runRe :: p b a -> p t s } -> HReverse p s t a b 54 | 55 | newtype Bikleisli n m = Bikleisli { runBikleisli :: forall x. n x -> m x } 56 | 57 | newtype Tagged n m = Tagged { runTagged :: Bikleisli (Const ()) m } 58 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "all-hls": { 3 | "branch": "master", 4 | "description": null, 5 | "homepage": "", 6 | "owner": "masaeedu", 7 | "repo": "all-hls", 8 | "rev": "643cfcb07a724c31464f969320faee4df4931b10", 9 | "sha256": "1wxmz4iqmyazwfyzwc0s0dkvxyk2c7c7qllbx2yyn6kj1dj3p0ay", 10 | "type": "tarball", 11 | "url": "https://github.com/masaeedu/all-hls/archive/643cfcb07a724c31464f969320faee4df4931b10.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "iohk-hnix": { 15 | "branch": "master", 16 | "description": "Alternative Haskell Infrastructure for Nixpkgs", 17 | "homepage": "https://input-output-hk.github.io/haskell.nix", 18 | "owner": "input-output-hk", 19 | "repo": "haskell.nix", 20 | "rev": "32baaac4d7858ae3349c1f6d1452371f998c7f49", 21 | "sha256": "0g0jh0jwips3qyxs7rb1d4qvqs6rralnq318x5x2wvy1mkzvxvlg", 22 | "type": "tarball", 23 | "url": "https://github.com/input-output-hk/haskell.nix/archive/32baaac4d7858ae3349c1f6d1452371f998c7f49.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | }, 26 | "niv": { 27 | "branch": "master", 28 | "description": "Easy dependency management for Nix projects", 29 | "homepage": "https://github.com/nmattia/niv", 30 | "owner": "nmattia", 31 | "repo": "niv", 32 | "rev": "e82eb322ea32a747a51c431d7787221bcc6d9038", 33 | "sha256": "1fy4dcr05d80diwlxmh42xnjm5ki1pkbky38smvlqjaky2y2f71f", 34 | "type": "tarball", 35 | "url": "https://github.com/nmattia/niv/archive/e82eb322ea32a747a51c431d7787221bcc6d9038.tar.gz", 36 | "url_template": "https://github.com///archive/.tar.gz" 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /lib/Classes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuantifiedConstraints #-} 2 | module Classes where 3 | 4 | import GHC.Exts 5 | import Data.Functor.Const 6 | 7 | import Types 8 | 9 | class KnownNat n 10 | where 11 | knownNat :: SNat n 12 | 13 | class HProfunctor p 14 | where 15 | hdimap :: (a' ~> a) -> (b ~> b') -> p a b -> p a' b' 16 | 17 | class HBifunctor p 18 | where 19 | hbimap :: (a ~> a') -> (b ~> b') -> p a b -> p a' b' 20 | 21 | class HContrabifunctor p 22 | where 23 | hcontrabimap :: (a' ~> a) -> (b' ~> b) -> p a b -> p a' b' 24 | 25 | hmap :: (HProfunctor p, HBifunctor p) => (b ~> b') -> p a b -> p a' b' 26 | hmap f = hdimap (const $ Const ()) f . hbimap (const $ Const ()) id 27 | 28 | hcontramap :: (HProfunctor p, HContrabifunctor p) => (a' ~> a) -> p a b -> p a' b' 29 | hcontramap f = hcontrabimap id (const $ Const ()) . hdimap f (const $ Const ()) 30 | 31 | class HProfunctor p => HStrong p 32 | where 33 | hfirst :: p f g -> p (f :*: h) (g :*: h) 34 | 35 | class HProfunctor p => HCostrong p 36 | where 37 | hunfirst :: p (f :*: h) (g :*: h) -> p f g 38 | 39 | class HProfunctor p => HChoice p 40 | where 41 | hleft :: p f g -> p (f :+: h) (g :+: h) 42 | 43 | class HProfunctor p => HCochoice p 44 | where 45 | hunleft :: p (f :+: h) (g :+: h) -> p f g 46 | 47 | class HProfunctor p => HLeftComposing p 48 | where 49 | type Inside p :: (* -> *) -> Constraint 50 | type Inside p = Functor 51 | 52 | houtside :: (Functor a, Functor b, Inside p f) => p a b -> p (a :.: f) (b :.: f) 53 | 54 | class HProfunctor p => HRightComposing p 55 | where 56 | type Outside p :: (* -> *) -> Constraint 57 | type Outside p = Functor 58 | hinside :: (Functor a, Functor b, Outside p f) => p a b -> p (f :.: a) (f :.: b) 59 | 60 | class HProfunctor p => HDescending p 61 | where 62 | hspelunk :: (Functor s, Functor t, Functor a, Functor b) => (s ~> HFunList a b t) -> (p a b -> p s t) 63 | 64 | class HMapping p 65 | where 66 | hmapped :: HHFunctor f => p n m -> p (f n) (f m) 67 | 68 | class HHFunctor f 69 | where 70 | hhfmap :: (Functor a, Functor b) => (a ~> b) -> f a ~> f b 71 | 72 | class HHFunctor f => HHApplicative f 73 | where 74 | hhpure :: Functor a => a ~> f a 75 | hhliftA2 :: (Functor a, Functor b, Functor c) => (a :*: b ~> c) -> (f a :*: f b ~> f c) 76 | 77 | class HHFunctor f => HHComposative f 78 | where 79 | hhwrap :: Functor a => a ~> f a 80 | hhstitch :: (Functor a, Functor b, Functor c) => (a :.: b ~> c) -> (f a :.: f b ~> f c) 81 | 82 | class HHFunctor t => HHTraversable t 83 | where 84 | hhtraverse :: (Functor a, Functor b, HHApplicative f) => (a ~> f b) -> (t a ~> f (t b)) 85 | 86 | class HHFunctor t => HHDescendable t 87 | where 88 | hhdescend :: (Functor a, Functor b, HHComposative f) => (a ~> f b) -> (t a ~> f (t b)) 89 | 90 | class (forall a. Functor a => HHFunctor (t a)) => HHBifunctor t 91 | where 92 | hhbimap :: (Functor a, Functor b, Functor c, Functor d) => (a ~> b) -> (c ~> d) -> t a c ~> t b d 93 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, DeriveFunctor, LambdaCase, TypeApplications #-} 2 | module Main where 3 | 4 | import Data.IORef 5 | import Data.Function 6 | import Data.Coerce 7 | 8 | import Data.Functor.Compose 9 | 10 | import Control.Comonad 11 | 12 | import Control.Monad.Identity 13 | import Control.Monad.Fail 14 | import Control.Monad.Reader 15 | import Control.Monad.Writer hiding (Sum) 16 | import Control.Monad.State 17 | import Control.Monad.Free 18 | 19 | import Types 20 | import Optics 21 | 22 | checkIORef :: Show a => IORef a -> IO () 23 | checkIORef ior = readIORef ior >>= print 24 | 25 | -- Try running an abstract stateful computation using global state 26 | computation :: (MonadState String m, MonadIO m) => m () 27 | computation = do 28 | put "this stuff is left over!" 29 | liftIO $ print "foo" 30 | pure () 31 | 32 | test1 :: IO () 33 | test1 = do 34 | x <- newIORef "" 35 | 36 | computation ^. inIORef x 37 | -- > "foo" 38 | 39 | checkIORef x 40 | -- > "this stuff is left over!" 41 | 42 | -- Try fiddling with free monads 43 | data StackF k 44 | = Push Int k 45 | | Top (Int -> k) 46 | | Pop k 47 | | Add k 48 | deriving Functor 49 | 50 | type Stack = Free StackF 51 | 52 | push :: Int -> Stack () 53 | push n = liftF $ Push n () 54 | 55 | pop :: Stack () 56 | pop = liftF $ Pop () 57 | 58 | top :: Stack Int 59 | top = liftF $ Top id 60 | 61 | add :: Stack () 62 | add = liftF $ Add () 63 | 64 | runStack :: (MonadState [Int] m, MonadFail m, MonadIO m) => Stack a -> m a 65 | runStack = \case 66 | (Pure x) -> do 67 | liftIO $ putStrLn "Done!" 68 | pure x 69 | (Free f) -> 70 | case f of 71 | Push n k -> do 72 | liftIO $ putStrLn $ "Push " ++ show n 73 | modify ((:) n) 74 | runStack k 75 | Top ik -> do 76 | (t : _) <- get 77 | liftIO $ putStrLn $ "Top: " ++ show t 78 | runStack $ ik t 79 | Pop k -> do 80 | liftIO $ putStrLn "Pop" 81 | modify tail 82 | runStack k 83 | Add k -> do 84 | (x : y : r) <- get 85 | liftIO $ putStrLn $ "Add " ++ show x ++ " to " ++ show y 86 | put (x + y : r) 87 | runStack k 88 | 89 | _Push :: HPrism' StackF ((,) Int) 90 | _Push = hprism (uncurry Push) go 91 | where 92 | go (Push i k) = Sum $ Left (i, k) 93 | go x = Sum $ Right x 94 | 95 | calc :: Stack Int 96 | calc = do 97 | push 3 98 | push 4 99 | add 100 | x <- top 101 | return x 102 | 103 | test2 :: IO () 104 | test2 = do 105 | x <- newIORef [] 106 | 107 | runStack calc ^. inIORef x 108 | -- > Push 3 109 | -- > Push 4 110 | -- > Add 4 to 3 111 | -- > Top: 7 112 | -- > Done! 113 | 114 | checkIORef x 115 | -- > [7] 116 | 117 | let pushes = each . _Push . _1 118 | let calc' = calc & pushes %~ (* 2) 119 | 120 | runStack calc' ^. inIORef x 121 | -- > Push 6 122 | -- > Push 8 123 | -- > Add 8 to 6 124 | -- > Top: 14 125 | -- > Done! 126 | 127 | checkIORef x 128 | -- > [14, 7] 129 | 130 | myRWST :: (MonadReader String m, MonadWriter String m, MonadState String m) => m String 131 | myRWST = do 132 | r <- ask 133 | tell "w" 134 | modify (++ "'") 135 | pure (r ++ "esult") 136 | 137 | -- foo :: String -> String -> Identity (String, (String, String)) 138 | -- foo = coerce $ hview test myRWST 139 | 140 | -- test3 :: IO () 141 | -- test3 = do 142 | -- runReaderT'' . hinside . runWriterT'' $ myRWST 143 | 144 | 145 | main :: IO () 146 | main = do 147 | test1 148 | test2 149 | -------------------------------------------------------------------------------- /lib/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, TypeApplications, StandaloneDeriving, QuantifiedConstraints, ConstraintKinds #-} 2 | 3 | module Instances where 4 | 5 | import Data.Bifunctor 6 | import Data.Functor.Compose 7 | 8 | import Control.Comonad 9 | 10 | import Control.Monad.State 11 | import Control.Monad.Free 12 | 13 | import Types 14 | import Classes 15 | import FunList 16 | 17 | -- Compose 18 | instance Functor f => HHFunctor (Compose f) 19 | where 20 | hhfmap f (Compose x) = Compose $ fmap f x 21 | 22 | instance HHBifunctor Compose 23 | where 24 | hhbimap f g (Compose fgx) = Compose $ f $ fmap g $ fgx 25 | 26 | -- Onion 27 | instance KnownNat Z 28 | where 29 | knownNat = SZ 30 | 31 | instance KnownNat n => KnownNat (S n) 32 | where 33 | knownNat = SS knownNat 34 | 35 | instance Functor (Onion Z f) 36 | where 37 | fmap f (Core x) = Core $ f x 38 | 39 | instance (Functor f, Functor (Onion n f)) => Functor (Onion (S n) f) 40 | where 41 | fmap f (Layer fr) = Layer $ fmap f <$> fr 42 | 43 | instance HHFunctor (Onion n) 44 | where 45 | hhfmap f (Core x) = Core x 46 | hhfmap f (Layer fr) = Layer $ f $ hhfmap f <$> fr 47 | 48 | -- HFunList 49 | deriving instance (forall x. Show x => Show (f x), Show a) => Show (Onion n f a) 50 | 51 | instance Functor t => Functor (HFunList a b t) 52 | where 53 | fmap f (HFunList contents fill) = HFunList contents (fmap f . fill) 54 | 55 | instance HHFunctor (HFunList a b) 56 | where 57 | hhfmap f (HFunList contents fill) = HFunList contents (f . fill) 58 | 59 | -- Profunctors 60 | instance HProfunctor (:~>) 61 | where 62 | hdimap f g (Nat x) = Nat $ g . x . f 63 | 64 | instance HStrong (:~>) 65 | where 66 | hfirst (Nat f) = Nat $ (\(Product x) -> Product $ bimap f id x) 67 | 68 | instance HChoice (:~>) 69 | where 70 | hleft (Nat f) = Nat $ \(Sum x) -> Sum $ bimap f id x 71 | 72 | instance HLeftComposing (:~>) 73 | where 74 | houtside (Nat f) = Nat $ \(Compose x) -> Compose $ f $ x 75 | 76 | instance HRightComposing (:~>) 77 | where 78 | hinside (Nat f) = Nat $ \(Compose x) -> Compose $ fmap f $ x 79 | 80 | type HComposing p = (HLeftComposing p, HRightComposing p) 81 | 82 | instance HDescending (:~>) 83 | where 84 | hspelunk t pab = Nat $ (\(HFunList contents fill) -> fill $ hhfmap (runNat pab) $ contents) . t 85 | 86 | hforgetMap :: (b ~> a) -> HForget r a x -> HForget r b y 87 | hforgetMap f (HForget x) = HForget (x . f) 88 | 89 | instance HProfunctor (HForget r) 90 | where 91 | hdimap f _ = hforgetMap f 92 | 93 | instance HProfunctor (HCIso a b) 94 | where 95 | hdimap f g (HCIso v p) = HCIso (v . f) (g . p) 96 | 97 | instance HProfunctor p => HProfunctor (HReverse p s t) 98 | where 99 | hdimap f g (HReverse r) = HReverse (r . hdimap g f) 100 | 101 | instance HProfunctor Bikleisli 102 | where 103 | hdimap f g (Bikleisli k) = Bikleisli $ g . k . f 104 | 105 | instance HProfunctor Tagged 106 | where 107 | hdimap _ g (Tagged (Bikleisli k)) = Tagged $ Bikleisli $ g . k 108 | 109 | -- HHThings 110 | instance HHFunctor Free 111 | where 112 | hhfmap = hoistFree 113 | 114 | instance HHDescendable Free 115 | where 116 | hhdescend f (Pure a) = hhwrap $ Pure a 117 | hhdescend f (Free a) = hhstitch (Free . getCompose) (Compose $ f $ hhdescend f <$> a) 118 | 119 | instance HHFunctor (StateT s) 120 | where 121 | hhfmap f (StateT mx) = StateT $ \s -> f $ mx s 122 | 123 | instance HHComposative (StateT s) 124 | where 125 | hhwrap mx = StateT $ \s -> (, s) <$> mx 126 | hhstitch f mmx = StateT $ f' . fmap (uncurry ($)) . mmx' 127 | where 128 | -- remove all newtypes from inputs 129 | f' = f . Compose 130 | mmx' = (fmap . fmap . first) runStateT . runStateT $ getCompose $ mmx 131 | -------------------------------------------------------------------------------- /lib/Optics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PartialTypeSignatures #-} 2 | 3 | module Optics where 4 | 5 | import GHC.Exts 6 | 7 | import Unsafe.Coerce 8 | 9 | import Data.IORef 10 | import Data.Tuple (swap) 11 | 12 | import Data.Functor.Const 13 | import Data.Functor.Compose 14 | import Data.Coerce 15 | 16 | import Control.Monad.Reader 17 | import Control.Monad.Writer hiding (Product, Sum) 18 | import Control.Monad.State 19 | import Control.Monad.Free 20 | 21 | import Types 22 | import Classes 23 | import Instances 24 | import FunList 25 | 26 | -- General stuff 27 | type HOptic (p :: (* -> *) -> (* -> *) -> *) s t a b = p a b -> p s t 28 | 29 | type HIso s t a b = forall p. HProfunctor p => HOptic p s t a b 30 | type HLens s t a b = forall p. HStrong p => HOptic p s t a b 31 | type HPrism s t a b = forall p. HChoice p => HOptic p s t a b 32 | type HDescent s t a b = forall p. HDescending p => HOptic p s t a b 33 | type HFold r s t a b = HOptic (HForget r) s t a b 34 | type HGetter s t a b = HFold a s t a b 35 | type HSetter s t a b = HOptic (:~>) s t a b 36 | 37 | type HOptic' p s a = HOptic p s s a a 38 | 39 | type HFold' r s a = HFold r s s a a 40 | type HGetter' s a = HGetter s s a a 41 | 42 | type HIso' s a = HIso s s a a 43 | type HLens' s a = HLens s s a a 44 | type HPrism' s a = HPrism s s a a 45 | 46 | hreverse :: HOptic (HReverse p a b) s t a b -> HOptic p b a t s 47 | hreverse t = runRe $ t (HReverse id) 48 | 49 | hover :: HSetter s t a b -> (a ~> b) -> (s ~> t) 50 | hover l ab = runNat $ l $ Nat $ ab 51 | 52 | hview :: HGetter s t a b -> s ~> a 53 | hview p = runHForget $ p (HForget id) 54 | 55 | hlens :: (s ~> a) -> (b :*: s ~> t) -> HLens s t a b 56 | hlens view put = hdimap (\s -> Product $ (view s, s)) put . hfirst 57 | 58 | hprism :: (b ~> t) -> (s ~> (a :+: t)) -> HPrism s t a b 59 | hprism build match = hdimap match (either build id . runSum) . hleft 60 | 61 | hmapped :: (HHFunctor f, Functor a, Functor b) => HSetter (f a) (f b) a b 62 | hmapped ab = Nat $ hhfmap $ runNat ab 63 | 64 | hlmapped :: (HHBifunctor t, Functor a, Functor b, Functor x) => HSetter (t a x) (t b x) a b 65 | hlmapped ab = Nat $ hhbimap (runNat ab) id 66 | 67 | hrmapped :: (HHBifunctor t, Functor a, Functor b, Functor x) => HSetter (t x a) (t x b) a b 68 | hrmapped ab = Nat $ hhbimap id (runNat ab) 69 | 70 | hLiftIso :: HSetter s t a b -> HSetter s' t' a' b' -> HGetter a _ b _ -> HGetter a' _ b' _ -> HIso s t' t s' 71 | hLiftIso f b i j = hdimap (hover f $ hview i) (hover b $ hview $ j) 72 | 73 | -- Specific stuff 74 | each :: (Functor a, Functor b) => HDescent (Free a) (Free b) a b 75 | each pab = hspelunk go pab 76 | where 77 | go f = HFunList ((\(SomeOnion x) -> unsafeCoerce x) $ freeToOnion f) onionToFree 78 | 79 | readerTAsStateT :: MonadIO m => HIso (ReaderT (IORef a) m) (ReaderT (IORef b) m) (StateT a m) (StateT b m) 80 | readerTAsStateT = hdimap f g 81 | where 82 | f (ReaderT m) = StateT $ \s -> do 83 | ioref <- liftIO $ newIORef s 84 | v <- m ioref 85 | s <- liftIO $ readIORef ioref 86 | pure (v, s) 87 | 88 | g (StateT m) = ReaderT $ \ioref -> do 89 | s <- liftIO $ readIORef ioref 90 | (v, s1) <- m s 91 | liftIO $ writeIORef ioref s1 92 | pure v 93 | 94 | stateTAsReaderT :: MonadIO m => HIso (StateT a m) (StateT b m) (ReaderT (IORef a) m) (ReaderT (IORef b) m) 95 | stateTAsReaderT = hreverse readerTAsStateT 96 | 97 | runReaderT' :: r -> HGetter (ReaderT r m) _ m _ 98 | runReaderT' v = hforgetMap (\(ReaderT r) -> r v) 99 | 100 | runStateT' :: Functor m => s -> HGetter (StateT s m) _ (m :.: (,) s) _ 101 | runStateT' s _ = HForget (\(StateT m) -> Compose $ fmap swap $ m s) 102 | 103 | runReaderT'' :: HIso (ReaderT a m) (ReaderT b m) ((->) a :.: m) ((->) b :.: m) 104 | runReaderT'' = hdimap coerce coerce 105 | 106 | runWriterT'' :: Functor m => HIso (WriterT a m) (WriterT b m) (m :.: (,) a) (m :.: (,) b) 107 | runWriterT'' = hdimap fwd bwd 108 | where 109 | fwd (WriterT m) = Compose $ fmap swap $ m 110 | bwd (Compose m) = WriterT $ fmap swap $ m 111 | 112 | runStateT'' :: Functor m => HIso (StateT a m) (StateT b m) ((->) a :.: m :.: (,) a) ((->) b :.: m :.: (,) b) 113 | runStateT'' = hdimap fwd bwd 114 | where 115 | fwd (StateT s) = coerce $ (fmap . fmap) swap $ s 116 | bwd (Compose s) = coerce $ (fmap . fmap) swap $ fmap getCompose $ s 117 | 118 | type RWST r w s m = ReaderT r (WriterT w (StateT s m)) 119 | 120 | test :: (Functor m, HProfunctor p) => HOptic' p (RWST r w s m) ((->) r :.: ((->) s :.: m :.: (,) s) :.: (,) w) 121 | test = 122 | let _1 = hLiftIso hinside hinside 123 | _2 = hLiftIso (hinside . houtside) (hinside . houtside) 124 | in runReaderT'' . _1 runWriterT'' (hreverse runWriterT'') . _2 runStateT'' (hreverse runStateT'') 125 | 126 | inIORef :: MonadIO m => IORef s -> HGetter' (StateT s m) m 127 | inIORef ior = stateTAsReaderT . runReaderT' ior 128 | 129 | _1 :: HLens ((,) a) ((,) b) (Const a) (Const b) 130 | _1 = hlens (Const . uncurry const) (\(Product (Const b, (_, x))) -> (b, x)) 131 | 132 | (%~) :: HSetter s t a b -> (a ~> b) -> s ~> t 133 | (%~) l x = runNat $ l $ Nat x 134 | 135 | (^.) :: s x -> HGetter s t a b -> a x 136 | (^.) = flip hview 137 | 138 | infixr 4 %~, ^. 139 | 140 | type Parametric f = (forall a b. Coercible a b => Coercible (f a) (f b) :: Constraint) 141 | type CoercibleF f g = (forall x. Coercible (f x) (g x) :: Constraint) 142 | 143 | hcoerce :: forall s t a b. (CoercibleF s a, CoercibleF b t) => HIso s t a b 144 | hcoerce = hdimap coerce coerce 145 | 146 | _1' :: forall x a b p. (Inside p x, Functor a, Functor b, HLeftComposing p) => HOptic p (a :.: x) (b :.: x) a b 147 | _1' = houtside 148 | 149 | _2' :: forall x a b p. (Outside p x, Functor a, Functor b, HRightComposing p) => HOptic p (x :.: a) (x :.: b) a b 150 | _2' = hinside 151 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: spec: 10 | if spec.builtin or true then 11 | builtins_fetchurl { inherit (spec) url sha256; } 12 | else 13 | pkgs.fetchurl { inherit (spec) url sha256; }; 14 | 15 | fetch_tarball = pkgs: name: spec: 16 | let 17 | ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str); 18 | # sanitize the name, though nix will still fail if name starts with period 19 | name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src"; 20 | in 21 | if spec.builtin or true then 22 | builtins_fetchTarball { name = name'; inherit (spec) url sha256; } 23 | else 24 | pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; 25 | 26 | fetch_git = spec: 27 | builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; }; 28 | 29 | fetch_local = spec: spec.path; 30 | 31 | fetch_builtin-tarball = name: throw 32 | ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. 33 | $ niv modify ${name} -a type=tarball -a builtin=true''; 34 | 35 | fetch_builtin-url = name: throw 36 | ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. 37 | $ niv modify ${name} -a type=file -a builtin=true''; 38 | 39 | # 40 | # Various helpers 41 | # 42 | 43 | # The set of packages used when specs are fetched using non-builtins. 44 | mkPkgs = sources: 45 | let 46 | sourcesNixpkgs = 47 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {}; 48 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 49 | hasThisAsNixpkgsPath = == ./.; 50 | in 51 | if builtins.hasAttr "nixpkgs" sources 52 | then sourcesNixpkgs 53 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 54 | import {} 55 | else 56 | abort 57 | '' 58 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 59 | add a package called "nixpkgs" to your sources.json. 60 | ''; 61 | 62 | # The actual fetching function. 63 | fetch = pkgs: name: spec: 64 | 65 | if ! builtins.hasAttr "type" spec then 66 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 67 | else if spec.type == "file" then fetch_file pkgs spec 68 | else if spec.type == "tarball" then fetch_tarball pkgs name spec 69 | else if spec.type == "git" then fetch_git spec 70 | else if spec.type == "local" then fetch_local spec 71 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball name 72 | else if spec.type == "builtin-url" then fetch_builtin-url name 73 | else 74 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 75 | 76 | # If the environment variable NIV_OVERRIDE_${name} is set, then use 77 | # the path directly as opposed to the fetched source. 78 | replace = name: drv: 79 | let 80 | saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; 81 | ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; 82 | in 83 | if ersatz == "" then drv else ersatz; 84 | 85 | # Ports of functions for older nix versions 86 | 87 | # a Nix version of mapAttrs if the built-in doesn't exist 88 | mapAttrs = builtins.mapAttrs or ( 89 | f: set: with builtins; 90 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 91 | ); 92 | 93 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 94 | range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); 95 | 96 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 97 | stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); 98 | 99 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 100 | stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); 101 | concatStrings = builtins.concatStringsSep ""; 102 | 103 | # fetchTarball version that is compatible between all the versions of Nix 104 | builtins_fetchTarball = { url, name, sha256 }@attrs: 105 | let 106 | inherit (builtins) lessThan nixVersion fetchTarball; 107 | in 108 | if lessThan nixVersion "1.12" then 109 | fetchTarball { inherit name url; } 110 | else 111 | fetchTarball attrs; 112 | 113 | # fetchurl version that is compatible between all the versions of Nix 114 | builtins_fetchurl = { url, sha256 }@attrs: 115 | let 116 | inherit (builtins) lessThan nixVersion fetchurl; 117 | in 118 | if lessThan nixVersion "1.12" then 119 | fetchurl { inherit url; } 120 | else 121 | fetchurl attrs; 122 | 123 | # Create the final "sources" from the config 124 | mkSources = config: 125 | mapAttrs ( 126 | name: spec: 127 | if builtins.hasAttr "outPath" spec 128 | then abort 129 | "The values in sources.json should not have an 'outPath' attribute" 130 | else 131 | spec // { outPath = replace name (fetch config.pkgs name spec); } 132 | ) config.sources; 133 | 134 | # The "config" used by the fetchers 135 | mkConfig = 136 | { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null 137 | , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) 138 | , pkgs ? mkPkgs sources 139 | }: rec { 140 | # The sources, i.e. the attribute set of spec name to spec 141 | inherit sources; 142 | 143 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 144 | inherit pkgs; 145 | }; 146 | 147 | in 148 | mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } 149 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # monadoptics 2 | 3 | ## Description 4 | Experiment with using profunctor optics (NB: not `Profunctor` optics!) to adjust the effect layers of monadic computations. Not a usable library, but the concepts might be interesting to folks working on effect systems and the like. I recommend looking through the README below (including the aside if interested in the guts), then looking through the code (which might be slightly out of sync with the README in naming conventions etc.). 5 | 6 | ## Examples 7 | 8 | ### Running an abstract stateful computation with global state 9 | 10 | Suppose we have a stateful, IO-ful computation written using `mtl` style: 11 | 12 | ```hs 13 | computation :: (MonadState String m, MonadIO m) => m () 14 | computation = do 15 | put "this stuff is left over!" 16 | liftIO $ print "foo" 17 | pure () 18 | ``` 19 | 20 | Since we're already in (at least) IO, we may reason that it's just as well to use IO to model our state. To do this, we can use a getter that discharges the `MonadState s m` constraint and adds an additional `MonadIO` constraint: 21 | 22 | ```hs 23 | inIORef :: MonadIO m => IORef s -> HGetter' (StateT s m) m 24 | ``` 25 | 26 | Now we can edit our original computation and run it in IO (being left with nothing more than a `MonadIO m` constraint): 27 | 28 | ```hs 29 | checkIORef :: Show a => IORef a -> IO () 30 | checkIORef ior = readIORef ior >>= print 31 | 32 | test :: IO () 33 | test = do 34 | x <- newIORef "" 35 | 36 | computation ^. inIORef x 37 | -- > "foo" 38 | 39 | checkIORef x 40 | -- > "this stuff is left over!" 41 | ``` 42 | 43 | PS: Having the original computation actually depend on `MonadIO` isn't necessary to make this work, it's just there as an (admittedly tenuous) motivating circumstance. 44 | 45 | ### Editing parts of a computation 46 | 47 | Let's say we're using the free monad of a functor to model computations on a stack: 48 | 49 | ```hs 50 | data StackF k 51 | = Push Int k 52 | | Top (Int -> k) 53 | | Pop k 54 | | Add k 55 | deriving Functor 56 | 57 | type Stack = Free StackF 58 | 59 | -- ... @Free@ boilerplate 60 | ``` 61 | 62 | Here is a sample computation: 63 | 64 | ```hs 65 | calc :: Stack Int 66 | calc = do 67 | push 3 68 | push 4 69 | add 70 | x <- top 71 | return x 72 | ``` 73 | 74 | Let's write (far more explicitly than is actually necessary) an interpreter for this computation: 75 | 76 | ```hs 77 | runStack :: (MonadState [Int] m, MonadFail m, MonadIO m) => Stack a -> m a 78 | runStack = \case 79 | (Pure x) -> do 80 | liftIO $ putStrLn "Done!" 81 | pure x 82 | (Free f) -> 83 | case f of 84 | Push n k -> do 85 | liftIO $ putStrLn $ "Push " ++ show n 86 | modify ((:) n) 87 | runStack k 88 | Top ik -> do 89 | (t : _) <- get 90 | liftIO $ putStrLn $ "Top: " ++ show t 91 | runStack $ ik t 92 | Pop k -> do 93 | liftIO $ putStrLn "Pop" 94 | modify tail 95 | runStack k 96 | Add k -> do 97 | (x : y : r) <- get 98 | liftIO $ putStrLn $ "Add " ++ show x ++ " to " ++ show y 99 | put (x + y : r) 100 | runStack k 101 | ``` 102 | 103 | The interpreter interprets into some abstract monad that implements `MonadState [Int]` (for holding the actual stack), `MonadFail` (for rejecting invalid operations), and `MonadIO` (for logging messages). 104 | 105 | We can start with an empty stack in an `IORef`, and use the `inIORef` optic to evaluate the computation on the stack: 106 | 107 | ```hs 108 | test :: IO () 109 | test = do 110 | x <- newIORef [] 111 | 112 | runStack calc ^. inIORef x 113 | -- > Push 3 114 | -- > Push 4 115 | -- > Add 4 to 3 116 | -- > Top: 7 117 | -- > Done! 118 | 119 | checkIORef x 120 | -- > [7] 121 | ``` 122 | 123 | Fairly standard stuff. Now suppose for some reason we want to edit parts of the computation. For example, let's say we want to double every number that the computation pushes onto the stack. 124 | 125 | The approach for doing so is shown below, but explaining the concept of a "descent" requires a regrettably lengthy aside. 126 | 127 |
Aside 128 | 129 | #### Traversable ~monad~ functor transformers 130 | 131 | One way to think about a computation in the free monad is as a "list" of functor layers. The layers are built up by recursively composing a coproduct of functors (our `StackF` type) with itself, and at the "bottommost" layer lies the identity functor. 132 | 133 | You can envision an analogy with a standard list where the elements are a sum type. The list is built up by recursively tupling together elements from the sum type, with a unit element terminating the list. Of course the analogy only works up to a point: precisely the point where composition of functors differs from tupling of elements. 134 | 135 | Now, standard lists are traversable "with respect to tupling" (as are many other containers). This is witnessed by their instance of the `Traversable` typeclass: 136 | 137 | ```hs 138 | class Functor t => Traversable t 139 | where 140 | traverse :: Applicative f => (a -> f b) -> (t a -> f (t b)) 141 | ``` 142 | 143 | Wherefore the "with respect to tupling" qualifer? It is from the mention of the `Applicative` typeclass, shown below with the tupling revealed by uncurrying [1]: 144 | 145 | ```hs 146 | class Functor f => Applicative f 147 | where 148 | pure :: a -> f a 149 | liftA2 :: ((a, b) -> c) -> ((f a, f b) -> f c) 150 | ``` 151 | 152 | So there is an analogy between lists (the free "monoid of tupling") and the free monad (the free "monoid of layering"). 153 | 154 | Since lists are traversable "with respect to tupling", might it be the case that the free monad is traversable "with respect to layering"? 155 | 156 | To answer this question, we must cook up a class analogous to `Traversable` that represents traversability with respect to layering. In turn, this task demands that we find an appropriate substitute for the `Applicative` typeclass `Traversable` refers to. What `Applicative` is to tupling, the new class must be to layering. 157 | 158 | Let's first remember that what we are layering is functors `* -> *`, whereas what we tuple is proper types `*`. Keeping this in mind, here is an appropriately "elevated" substitute for the `Functor` superclass of `Applicative`: 159 | 160 | ```hs 161 | type f ~> g = forall x. f x -> g x -- [2] 162 | 163 | -- [3] 164 | class HFunctor f 165 | where 166 | hfmap :: (Functor a, Functor b) => (a ~> b) -> f a ~> f b 167 | ``` 168 | 169 | Here then is our `Composeative` class, which describes "~monad~ functor transformers" that are to functor composition what `Applicative` is to tupling: 170 | 171 | ```hs 172 | type (:.:) = Compose 173 | 174 | -- [4] 175 | class HFunctor t => Composeative t 176 | where 177 | lift :: Functor f => f ~> t f 178 | collect :: (Functor f, Functor g, Functor h) => (f :.: g ~> h) -> (t f :.: t g ~> t h) 179 | ``` 180 | 181 | Ignoring the functor constraints, perhaps you can see the analogy to the types of `pure` and `liftA2` in the explicitly tupled `Applicative` typeclass. 182 | 183 | Now we can return to traversability in layers. Here is a `Descendable` typeclass that shows what it means for a functor transformer to be traversable in the layers it "contains": 184 | 185 | ```hs 186 | class HFunctor t => Descendable t 187 | where 188 | descend :: (Composeative f, Functor a, Functor b) => (a ~> f b) -> (t a ~> f (t b)) 189 | ``` 190 | 191 | Once again, you might notice here how this rhymes with the type of `traverse`. 192 | 193 | So finally we ask ourselves: is `Free :: (* -> *) -> * -> *` `Descendable` in the functor layers it "contains"? And the answer is yes (look through the codebase for the implementation). 194 | 195 | An example of a `Composeative` monad transformer we might consider is `StateT s :: (* -> *) -> * -> *`. Thus one useful specialization of `descend` might be: 196 | 197 | ```hs 198 | descend :: (f ~> StateT s f) -> Free f ~> StateT s (Free f) 199 | ``` 200 | 201 | This allows us to splice access to state into each layer of our computation `Free f a`, and end up with a stateful computation of the form `s -> Free f (a, s)`. The overall computation depends on an initial state, and terminates with a result and a final state, having evaluated all state transitions grafted onto the intermediate layers. 202 | 203 | I suspect (but haven't had the time or motivation to extensively investigate) that a lot of the monad transformers we work with day to day are `Composeative`, or at the very least support an instance of a class similar to `Composeative` with heavier constraints than `Functor`. 204 | 205 | #### Traversables and traversals, descendables and descents 206 | In profunctor optics libraries we have a notion of "traversals" (which represent a generalization of traversable instances) [5]: 207 | 208 | ```hs 209 | type Bazaar a b t = forall f. Applicative f => (a -> f b) -> f t 210 | 211 | class Traversing p 212 | where 213 | wander :: (s -> Bazaar a b t) -> p a b -> p s t 214 | 215 | type Traversal s t a b = forall p. Traversing p => p a b -> p s t 216 | ``` 217 | 218 | Note that `Bazaar a b t` is equivalent to the following `FunList a b t` type for this purpose [6]: 219 | 220 | ```hs 221 | data FunList a b t = Done t 222 | | More a (FunList a b (b -> t)) 223 | ``` 224 | 225 | Because of various issues with higher rank quantification and impredicativity that start cropping up when we try to take `Bazaar` "one level up", we're going to work with `FunList` instead. 226 | 227 | One way to think about `FunList`/`Bazaar` is that the `Traversable` typeclass is equivalent to: 228 | 229 | ```hs 230 | class Functor t => Traversable t 231 | where 232 | traverse :: Applicative f => t a -> (a -> f b) -> f (t b) 233 | -- which is the same as 234 | traverse :: t a -> Bazaar a b (t b) 235 | -- which is the same as 236 | traverse :: t a -> FunList a b (t b) 237 | ``` 238 | 239 | Ok, good, so we know what the profunctor constraint for traversals is (`Traversing`), and we know a slight simplification of it (swap `Bazaar` for `FunList`). Let's find the appropriate "tupling to layering substitute" for `FunList` first. 240 | 241 | By a sequence of reasoning that I won't get into here [7], I believe that what `FunList` is to tupling, the following `OnionList` is to layering: 242 | 243 | ```hs 244 | -- Singleton natural numbers 245 | data SNat n 246 | where 247 | SZ :: SNat Z 248 | SS :: SNat n -> SNat (S n) 249 | 250 | -- @Onion n x@ is to layering functors what @Vec n x@ is to tupling elements 251 | data Onion n f a 252 | where 253 | Core :: a -> Onion Z f a 254 | Layer :: f (Onion n f a) -> Onion (S n) f a 255 | 256 | data OnionList a b t x 257 | where 258 | OnionList :: Onion n a r -> (Onion n b r -> t x) -> OnionList a b t x 259 | ``` 260 | 261 | Great, so now we know how to swap out the `Bazaar`/`FunList`. Now to our equivalent of the `Traversing` profunctor class, which we imaginatively call `Descending`. 262 | 263 | First we need a higher order profunctor typeclass: 264 | 265 | ```hs 266 | class HProfunctor (p :: (* -> *) -> (* -> *) -> *) 267 | where 268 | hdimap :: (a' ~> a) -> (b ~> b') -> p a b -> p a' b' 269 | ``` 270 | 271 | Here is its subclass `Descending`, for which hopefully the similarities with `Traversing` are readily apparent: 272 | 273 | ```hs 274 | class HProfunctor p => Descending p 275 | where 276 | spelunk :: (Functor s, Functor t, Functor a, Functor b) => (s ~> OnionList a b t) -> (p a b -> p s t) 277 | ``` 278 | 279 | And FINALLY we come to the point. Just as in "ground floor" profunctor optics we have traversals to generalize the `traverse` operation of traversable containers, in our monad optics library we have descents to generalize `descend`: 280 | 281 | ```hs 282 | type Descent s t a b = forall p. Descending p => p a b -> p s t 283 | ``` 284 | 285 | Now to return to the poor `Free` monad computation we were discussing a lifetime ago. Just as there is an `each :: Traversal [a] [b] a b` optic for traversing lists, we can have an optic for traversing the layers of a `Free` computation. 286 | 287 | ```hs 288 | each :: (Functor a, Functor b) => Descent (Free a) (Free b) a b 289 | ``` 290 | 291 | And this at last is the magic that enables the code snippet that follows. [8] [9] 292 | 293 | --- 294 | 295 | [1]: In other words, to be an `Applicative f` is to be a lax monoidal functor from `Hask` under tupling to `Hask` under tupling. The `pure`, `liftA2` representation more closely aligns with the equivalent statement that an `Applicative f` is a monoid object with respect to Day convolution in the `(,)` tensor. 296 | 297 | [2]: Ideally, we would bake the constraints describing the subcategory of functors into the `~>` type. Sadly, the various approaches I've tried for doing this (newtyping, GADT-ing, dictionary passing) are all extremely unergonomic. 298 | 299 | [3]: The laws for this are just the functor laws. I've tried various approaches to recognize a single unified representation of functors in Haskell, but the seams of all the obvious approaches start to come apart at one point or another. The disadvantages of Haskell for this kind of programming are a topic of discussion for a different day. 300 | 301 | [4]: Monoid with respect to appropriate Day convolution/lax monoidal functor again. Once again, difficult to unify in Haskell what is mathematically a single concept. 302 | 303 | [5]: This is a somewhat roundabout way of expressing traversals; a more direct representation probably involves something like a model of finitary containers. Unfortunately modeling finitary containers in Haskell is hard enough at the ground floor, so this approximation will have to do for the purposes of this exploratory post. 304 | 305 | [6]: https://bartoszmilewski.com/2018/10/12/trading-funlists-at-a-bazaar-with-yoneda/ 306 | 307 | [7]: Because it is embarassingly vague, ask me if you're interested 308 | 309 | [8]: 310 | The story for all the other families of optics is not explained here, but they align more closely with the standard story of an optic being a function parametric over a family of Tambara modules for some act (e.g. the act for the profunctor subclass ). 311 | 312 | I wanted to explain traversals in more detail because the painfulness of dealing with a weird dependently typed representation of finitary containers forced me into copying the `wander` approach that I don't understand the theoretical basis of. So this only works to the extent that `Descending` appropriately imitates the `Traversing` typeclass: what extent that is you can judge for yourself. 313 | 314 | I'm nevertheless fairly confident that given a typesystem more suited to the task, I could model the `Descending` class as a family of Tambara modules over an appropriate monoidal act (in fact we might already consider `Onion :: Nat -> [[Hask, Hask], [Hask, Hask]]` to be a polynomial "container" of a trivial shape). 315 | 316 | [9]: The happy accident in the category of sets where profunctors suited for traversals are automatically suited for prisms and lenses doesn't occur here, because the endofunctor category has *three* interesting tensors instead of two. 317 | 318 | --- 319 | 320 |
321 | 322 | We have the following "descent" for digging into the functor layers of a `Free` computation: 323 | 324 | ```hs 325 | each :: (Functor a, Functor b) => Descent (Free a) (Free b) a b 326 | ``` 327 | 328 | We can also create a prism for focusing into the `Push` case of our `StackF` coproduct: 329 | 330 | ```hs 331 | _Push :: HPrism' StackF ((,) Int) 332 | ``` 333 | 334 | And finally we have a lens for focusing onto the contents of that tuple: 335 | 336 | ```hs 337 | _1 :: HLens ((,) a) ((,) b) (Const a) (Const b) 338 | ``` 339 | 340 | Composing all of these, we have the optic: 341 | 342 | ```hs 343 | each . _Push . _1 :: (HStrong p, HChoice p, HDescending p) => HOptic' p (Free StackF) (Const Int) 344 | ``` 345 | 346 | Since `~>` supports instances of all these typeclasses, this optic can be used as a setter, meaning we can specialize this to: 347 | 348 | ```hs 349 | each . _Push . _1 :: (Const Int ~> Const Int) -> (Free StackF ~> Free StackF) 350 | ``` 351 | 352 | We can use the traditional infix convenience for this: 353 | 354 | ```hs 355 | (%~) :: HSetter s t a b -> (a ~> b) -> s ~> t 356 | ``` 357 | 358 | Here it is in action: 359 | 360 | ```hs 361 | test :: IO () 362 | test = do 363 | x <- newIORef [] 364 | 365 | let pushes = each . _Push . _1 366 | let calc' = calc & pushes %~ (* 2) -- Lucky for us, @Num n => Num (Const n x)@! 367 | 368 | runStack calc' ^. inIORef x 369 | -- > Push 6 370 | -- > Push 8 371 | -- > Add 8 to 6 372 | -- > Top: 14 373 | -- > Done! 374 | 375 | checkIORef x 376 | -- > [14] 377 | ``` 378 | 379 | In case you've forgotten at this point what the objective was, it was to double all the pushed numbers in the original computation (which pushes `3` and `4` onto the stack). 380 | -------------------------------------------------------------------------------- /lib/MTL.hs: -------------------------------------------------------------------------------- 1 | module MTL where 2 | 3 | import Data.Functor.Compose (Compose(..)) 4 | 5 | import Data.Bifunctor (first) 6 | import Data.Bifunctor.Flip (Flip(..)) 7 | import Data.Monoid (Endo(..)) 8 | 9 | import Control.Monad.Trans.Class (MonadTrans(..)) 10 | import Control.Monad.Reader (ReaderT(..)) 11 | import Control.Monad.Except (ExceptT(..), runExceptT) 12 | import Control.Monad.State (StateT(..)) 13 | 14 | import Classes (HLeftComposing(..), HRightComposing(..), HBifunctor(..), HProfunctor(..), hmap) 15 | import Optics (Parametric, HOptic, hcoerce, _1', _2') 16 | 17 | -- We want to solve the n × m instances problem in MTL, where: 18 | -- - Adding a new class necessitates writing "lifting" instances for each existing transformer (often with manual finagling in the negative positions) 19 | -- - Adding a new transformer necessitates witnessing "lifting" instances for every class (again, often with special logic for operations that refer to 20 | -- the monad in the negative position) 21 | 22 | -- As a case study, we will look at the MonadWriter class: 23 | 24 | -- class (Monoid w, Monad m) => MonadWriter w m | m -> w 25 | -- where 26 | -- writer :: (a,w) -> m a 27 | -- tell :: w -> m () 28 | -- listen :: m a -> m (a, w) 29 | -- pass :: m (a, w -> w) -> m a 30 | 31 | -- To simulate independence of the class and the transformers, we will work with the following three *non*-WriterT monad transformers: 32 | -- - ExceptT 33 | -- - ReaderT 34 | -- - StateT 35 | 36 | -- First we will fix the problem of "negative" positions. The mixed variance of the `m` parameter in various MonadXYZ classes makes 37 | -- things confusing. To address this, we will introduce two separate parameters, a "negative" m variable and a "positive" n variable. 38 | 39 | -- Moreover, in order to understand the structure of the problem more easily, we will treat the evidence corresponding to the class as 40 | -- a simple datatype (i..e we will "scrap our typeclasses"). 41 | 42 | -- This data type would look something like this: 43 | 44 | -- data MonadWriter w m n 45 | -- = MonadWriter 46 | -- { write :: forall a. (a, w) -> n a 47 | -- , tell :: w -> n () 48 | -- , listen :: forall a. m a -> n (a, w) 49 | -- , pass :: forall a. m (a, w -> w) -> n a 50 | -- } 51 | 52 | -- However, in order to futher zoom in on and understand the behavior of the different operations, we will treat each operation in the 53 | -- record as its own independent type. 54 | 55 | -- Hence we will have: 56 | 57 | newtype Write w m n = Write { getWrite :: forall x. (x, w) -> n x } 58 | newtype Tell w m n = Tell { getTell :: w -> n () } 59 | newtype Listen w m n = Listen { getListen :: forall x. m x -> n (x, w) } 60 | newtype Pass w m n = Pass { getPass :: forall x. m (x, w -> w) -> n x } 61 | 62 | -- And then we will glue them all together into a dictionary like so: 63 | 64 | data MonadWriter w m n 65 | = MonadWriter 66 | { write :: Write w m n 67 | , tell :: Tell w m n 68 | , listen :: Listen w m n 69 | , pass :: Pass w m n 70 | } 71 | 72 | -- Now the first interesting thing to note about these operations is that they all form profunctors. In other words, they have instances 73 | -- for the class `HProfunctor :: (* -> *) -> (* -> *) -> *`. 74 | 75 | instance HProfunctor (Write w) 76 | where 77 | hdimap _ g (Write w) = Write $ g . w 78 | 79 | instance HProfunctor (Tell w) 80 | where 81 | hdimap _ g (Tell t) = Tell $ g . t 82 | 83 | instance HProfunctor (Listen w) 84 | where 85 | hdimap f g (Listen l) = Listen $ g . l . f 86 | 87 | instance HProfunctor (Pass w) 88 | where 89 | hdimap f g (Pass p') = Pass $ g . p' . f 90 | 91 | instance HProfunctor (MonadWriter w) 92 | where 93 | hdimap f g (MonadWriter w t l p) = MonadWriter (hdimap f g w) (hdimap f g t) (hdimap f g l) (hdimap f g p) 94 | 95 | -- These instances allow us to use provided natural transformations to independently modify the "output" and "input" occurrences of the monad 96 | -- to be transformed in the signature of the operation. For example, when we implement an operation like this: 97 | 98 | -- writer = lift . writer 99 | 100 | -- We would like to instead be able to abstractly map the `lift` operation in the covariant position, thus being able to hide differences 101 | -- in the structure of different operations. 102 | 103 | -- The first two operations are phantom in their negative parameter (i.e. are totally covariant), which means we can also witness a bifunctor 104 | -- instance. The contradiction in the variance of the first parameter can be used to introduce arbitrary evidence to change the phantom type 105 | -- in the negative position. 106 | 107 | -- Here are the bifunctor instances for the first two operations. 108 | 109 | instance HBifunctor (Write w) 110 | where 111 | hbimap _ g (Write w) = Write $ g . w 112 | 113 | instance HBifunctor (Tell w) 114 | where 115 | hbimap _ g (Tell t) = Tell $ g . t 116 | 117 | -- And here is the resulting operation (which is stronger than dimap, since the negative type can be varied without having to provide a 118 | -- reverse natural transformation) 119 | 120 | -- hmap :: (HBifunctor p, HProfunctor p) => (b ~> b') -> p a b -> p a' b' 121 | 122 | -- We can use `hmap` to generically `lift` the occurrences of a monad in an operation signature that only refers to it in positive position. 123 | 124 | liftOp :: (MonadTrans f, Monad a, Monad b, HProfunctor p, HBifunctor p) => p a b -> p (f a) (f b) 125 | liftOp = hmap lift 126 | 127 | -- Now we can take the `write` and `tell` of an arbitrary monad, and promote them to implementations of `write` and `tell` for an arbitrary 128 | -- transformation of that monad. Moreover, the promotion process is fully generalized, and no longer cares about the shape of the operation 129 | -- (provided you have witnessed `HProfunctor` and `HBifunctor`). 130 | 131 | -- To convince you that the single definition above works for all six combinations of `write`, `tell` with the transformers `ExceptT`, `ReaderT`, `StateT` 132 | 133 | writeExcept :: (Monad m, Monad n) => Write w m n -> Write w (ExceptT e m) (ExceptT e n) 134 | writeExcept = liftOp 135 | 136 | tellExcept :: (Monad m, Monad n) => Tell w m n -> Tell w (ExceptT e m) (ExceptT e n) 137 | tellExcept = liftOp 138 | 139 | writeReader :: (Monad m, Monad n) => Write w m n -> Write w (ReaderT r m) (ReaderT r n) 140 | writeReader = liftOp 141 | 142 | tellReader :: (Monad m, Monad n) => Tell w m n -> Tell w (ReaderT r m) (ReaderT r n) 143 | tellReader = liftOp 144 | 145 | writeState :: (Monad m, Monad n) => Write w m n -> Write w (StateT s m) (StateT s n) 146 | writeState = liftOp 147 | 148 | tellState :: (Monad m, Monad n) => Tell w m n -> Tell w (StateT s m) (StateT s n) 149 | tellState = liftOp 150 | 151 | -- Where there are profunctors, there are optics. The eagle-eyed reader might notice that the previous definitions are actually examples of profunctor optics: 152 | 153 | -- type HOptic p s t a b = p a b -> p s t 154 | -- type HReview s t a b = forall p. (HProfunctor p, HBifunctor p) => p a b -> p s t 155 | 156 | -- liftOp :: (MonadTrans f, Monad a, Monad b) => HReview (f a) (f b) a b 157 | 158 | -- Profunctor optics will keep cropping up in the ensuing discussion. In some cases we might explicitly write `P a b -> P s t` instead of using the type 159 | -- synonym `HOptic`, so keep an eye out. 160 | 161 | -- So far so good. The ease with which we dealt with the covariant operations leads one to wonder what the point of the weird `n` `m` parameter split 162 | -- is in the first place. Surely we can dispense with the "phantom" profunctor in favor of a simple covariant functor? 163 | 164 | -- Unfortunately, unlike `write` and `tell`, some operations are in the habit of eating up a term in an effectful context in addition to producing one. 165 | -- These operations not phantom in their negative type parameter, and so we cannot witness an HBifunctor for them. 166 | 167 | -- Thus we must give up our habit of shouting `liftOp` at various monad transformers, and come up with new tools to deal with `listen` and `pass`. 168 | 169 | -- Let's first state what our goal is: 170 | 171 | ourGoal :: (Functor m, Functor n) => HOptic (Listen w) (ExceptT e m) (ExceptT e n) m n 172 | 173 | -- Without referring to any abstractions for the moment, let's just try implementing the concrete combination where 174 | -- we promote the `listen` operation for the `ExceptT` transformer. 175 | 176 | ourGoal (Listen l) = Listen $ ExceptT . fmap (\(fa, w) -> fmap (, w) fa) . l . runExceptT 177 | 178 | -- So far so good. Now if we forget about `listen` specifically, we can try and imagine what we need from a `listen`-like 179 | -- operation in order to be able to promote it over `ExceptT`. 180 | 181 | -- To start with, we'll need at least an HProfunctor, so that we can unwrap and rewrap `ExceptT` at the edges, as seen in the concrete implementation above. 182 | 183 | -- Since we can only map an `HProfunctor` using natural transformations, we need to unpack `ExceptT e m a` into something of the form `??? a`. `ExceptT e m a` 184 | -- unpacks into `m (Either e a)`. In order to unify it with `??? a`, we can use the `Compose` newtype to get `Compose m (Either e) a`. 185 | 186 | abstractlyPromoteOverExceptT :: (Functor m, Functor n, HProfunctor p) => HOptic p (ExceptT e m) (ExceptT e n) m n 187 | abstractlyPromoteOverExceptT = 188 | hdimap (Compose . runExceptT) (ExceptT . getCompose) . undefined 189 | 190 | -- The type of the missing piece is now: 191 | 192 | -- ??? :: HOptic p (m :.: Either e) (n :.: Either e) m n 193 | 194 | -- (where `f :.: g` is `Compose f g`) 195 | 196 | -- If you're familiar with the `Strong` typeclass from regular profunctor optics, you might see the parallel with: 197 | 198 | -- first' :: Strong p => Optic p (m, x) (n, x) m n 199 | 200 | -- The operation we want is essentially like `first`, but with type variables of kind `* -> *` instead of kind `*`, and functor 201 | -- composition taking the place of tupling. 202 | 203 | -- We will call the requisite subclass of `HProfunctor` "HLeftComposing": 204 | 205 | -- class HProfunctor p => HLeftComposing p 206 | -- where 207 | -- type Inside p = (* -> *) -> Constraint 208 | -- type Inside p = Functor 209 | -- 210 | -- houtside :: (Functor m, Functor n, Inside p x) => HOptic p (m :.: x) (n :.: x) m n 211 | 212 | -- Having postulated the missing piece using an additional constraint, we can complete the puzzle: 213 | 214 | abstractlyPromoteOverExceptT' :: (Functor m, Functor n, Inside p (Either e), HLeftComposing p) => HOptic p (ExceptT e m) (ExceptT e n) m n 215 | abstractlyPromoteOverExceptT' = 216 | hdimap (Compose . runExceptT) (ExceptT . getCompose) . houtside 217 | 218 | -- As we would expect, the relevant bits from the `listen`-specific implementation factor out into an instance of this class: 219 | 220 | rstrength :: Functor f => (f a, b) -> f (a, b) 221 | rstrength (fa, b) = fmap (, b) fa 222 | 223 | instance HLeftComposing (Listen w) 224 | where 225 | houtside (Listen l) = Listen $ Compose . fmap rstrength . l . getCompose 226 | 227 | -- Unlike tupling, functor composition is not symmetric. While there is an isomorphism `(a , b) ≅ (b , a)`, there is no analogous 228 | -- isomorphism in general between `a :.: b` and `b :.: a`. So while `first'` and `second'` are equivalent minimal definitions in a 229 | -- single `Strong` class, when it comes to functor composition we will need a separate class for the reverse notion of focusing on 230 | -- a functor on the "inside" of a functor composition. 231 | 232 | -- Enter `HRightComposing` and its operation `hinside`: 233 | 234 | -- class HProfunctor p => HRightComposing p 235 | -- where 236 | -- type Outside p = (* -> *) -> Constraint 237 | -- type Outside p = Functor 238 | -- 239 | -- hinside :: (Functor m, Functor n, Outside p x) => HOptic p (x :.: m) (x :.: n) m n 240 | 241 | -- And the `listen` operation has an instance for this as well: 242 | 243 | instance HRightComposing (Listen w) 244 | where 245 | hinside (Listen l) = Listen $ Compose . fmap l . getCompose 246 | 247 | -- The `pass` operation likewise has instances for these two classes: 248 | 249 | instance HLeftComposing (Pass w) 250 | where 251 | type Inside (Pass w) = Traversable 252 | houtside (Pass f) = Pass $ Compose . f . fmap annoyingSequenceA . getCompose 253 | where 254 | swap :: (a, b) -> (b, a) 255 | swap (a, b) = (b, a) 256 | 257 | annoyingSequenceA :: Traversable f => f (a, w -> w) -> (f a, w -> w) 258 | annoyingSequenceA = swap . first appEndo . traverse (first Endo . swap) 259 | 260 | 261 | instance HRightComposing (Pass w) 262 | where 263 | hinside (Pass p') = Pass $ Compose . fmap p' . getCompose 264 | 265 | -- We've now decoupled the set of instances from the set of operations. The broad idea is this: for each monad transformer, we need to implement an 266 | -- optic that focuses on its inner monad. The optic should be abstract, and should refer to `HProfunctor` and any necessary subclasses instead of 267 | -- any specific `MonadXYZ` operations. 268 | 269 | -- For clarity, we will ignore the scattered bits and pieces we've already defined in the preceding discussion, and implement each transformer's optic 270 | -- from whole cloth below. In what follows `_1'` and `_2'` are respectively aliases for `houtside` and `hinside`, just quantified for more convenient 271 | -- type application: 272 | 273 | focusExceptT :: forall e m n p. 274 | ( Functor m 275 | , Functor n 276 | , Inside p (Either e) 277 | , HLeftComposing p 278 | ) => 279 | HOptic p (ExceptT e m) (ExceptT e n) m n 280 | focusExceptT = hcoerce . _1' @(Either e) 281 | 282 | focusReaderT :: forall r m n p. 283 | ( Functor m 284 | , Functor n 285 | , Outside p ((->) r) 286 | , HRightComposing p 287 | ) => 288 | HOptic p (ReaderT r m) (ReaderT r n) m n 289 | focusReaderT = hcoerce . _2' @((->) r) 290 | 291 | focusStateT :: forall s m n p. 292 | ( Functor m 293 | , Parametric m 294 | , Functor n 295 | , Parametric n 296 | , Outside p ((->) s) 297 | , Inside p (Flip (,) s) 298 | , HLeftComposing p 299 | , HRightComposing p 300 | ) => 301 | HOptic p (StateT s m) (StateT s n) m n 302 | focusStateT = hcoerce . _2' @((->) s) . _1' @(Flip (,) s) 303 | 304 | -- For the operations themselves, we just need to witness instances of `HProfunctor` and any instantiable subclasses. Given a monad transformer whose optic demands 305 | -- constraints satisfied by an operation, we can specialize the optic to the operation. The result is a function that takes an instance of the operation for the 306 | -- inner monad, and produces an instance of the operation for the transformed monad. 307 | 308 | -- Since we've already witnessed the requisite instances for `listen`, and `pass`, here (selected at random), are some illustrative specializations of the monad 309 | -- transformer optics 310 | 311 | listenStateT :: 312 | ( Functor m 313 | , Parametric m 314 | , Functor n 315 | , Parametric n 316 | ) => 317 | Listen w m n -> Listen w (StateT s m) (StateT s n) 318 | listenStateT = focusStateT 319 | 320 | passReaderT :: (Functor m, Functor n) => Listen w m n -> Listen w (ReaderT w m) (ReaderT w n) 321 | passReaderT = focusReaderT 322 | 323 | listenExceptT :: (Functor m, Functor n) => Listen w m n -> Listen w (ExceptT w m) (ExceptT w n) 324 | listenExceptT = focusExceptT 325 | 326 | -- Finally, given a way to promote each operation, we obtain a way to promote a complete set of operations. I.e. we have: 327 | 328 | mapMonadWriter :: HOptic (Write w) s t a b -> HOptic (Tell w) s t a b -> HOptic (Listen w) s t a b -> HOptic (Pass w) s t a b -> HOptic (MonadWriter w) s t a b 329 | mapMonadWriter w t l p (MonadWriter wv tv lv pv) = MonadWriter (w wv) (t tv) (l lv) (p pv) 330 | 331 | -- Thus the overall formula for writing the "lifting" instances we are familiar with in MTL is: 332 | 333 | -- MonadWriter w m => MonadWriter w (ExceptT e m) 334 | mwriterExceptT :: Monad m => MonadWriter w m m -> MonadWriter w (ExceptT e m) (ExceptT e m) 335 | mwriterExceptT = mapMonadWriter liftOp liftOp focusExceptT focusExceptT 336 | 337 | -- MonadWriter w m => MonadWriter w (ReaderT r m) 338 | mwriterReaderT :: Monad m => MonadWriter w m m -> MonadWriter w (ReaderT r m) (ReaderT r m) 339 | mwriterReaderT = mapMonadWriter liftOp liftOp focusReaderT focusReaderT 340 | 341 | -- MonadWriter w m => MonadWriter w (StateT s m) 342 | mwriterStateT :: (Parametric m, Monad m) => MonadWriter w m m -> MonadWriter w (StateT s m) (StateT s m) 343 | mwriterStateT = mapMonadWriter liftOp liftOp focusStateT focusStateT 344 | 345 | -- Additionally, when some new `MonadXYZ` class comes along with its own set of operations, e.g: 346 | 347 | newtype Ask r m n = Ask { getAsk :: n r } 348 | 349 | instance HProfunctor (Ask r) 350 | where 351 | hdimap _ g (Ask v) = Ask $ g v 352 | 353 | instance HBifunctor (Ask r) 354 | where 355 | hbimap _ g (Ask v) = Ask $ g v 356 | 357 | newtype Local r m n = Local { getLocal :: forall x. (r -> r) -> m x -> n x } 358 | 359 | instance HProfunctor (Local r) 360 | where 361 | hdimap f g (Local l) = Local $ \r v -> g $ l r $ f v 362 | 363 | instance HLeftComposing (Local r) 364 | where 365 | houtside (Local l) = Local $ \r (Compose v) -> Compose $ l r $ v 366 | 367 | instance HRightComposing (Local r) 368 | where 369 | hinside (Local l) = Local $ \r (Compose v) -> Compose $ fmap (l r) v 370 | 371 | newtype Read' r m n = Read { getRead :: forall a. (r -> a) -> n a } 372 | 373 | instance HProfunctor (Read' r) 374 | where 375 | hdimap _ g (Read r) = Read $ g . r 376 | 377 | instance HBifunctor (Read' r) 378 | where 379 | hbimap _ g (Read r) = Read $ g . r 380 | 381 | data MonadReader r m n 382 | = MonadReader 383 | { ask :: Ask r m n 384 | , local :: Local r m n 385 | , read :: Read' r m n 386 | } 387 | 388 | mapMonadReader :: HOptic (Ask r) s t a b -> HOptic (Local r) s t a b -> HOptic (Read' r) s t a b -> HOptic (MonadReader r) s t a b 389 | mapMonadReader a l r (MonadReader av lv rv) = MonadReader (a av) (l lv) (r rv) 390 | 391 | -- We are well prepared to give "lifting" instances for our existing transformers: 392 | 393 | mreaderExceptT :: (Monad m, Monad n) => MonadReader r m n -> MonadReader r (ExceptT e m) (ExceptT e n) 394 | mreaderExceptT = mapMonadReader liftOp focusExceptT liftOp 395 | 396 | mreaderStateT :: (Monad m, Parametric m, Monad n, Parametric n) => MonadReader r m n -> MonadReader r (StateT s m) (StateT s n) 397 | mreaderStateT = mapMonadReader liftOp focusStateT liftOp 398 | --------------------------------------------------------------------------------