├── .gitattributes ├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── objective.cabal ├── proofs └── composition.md └── src └── Control ├── Object.hs └── Object ├── Instance.hs ├── Mortal.hs └── Object.hs /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | *.sln merge=union 7 | *.csproj merge=union 8 | *.vbproj merge=union 9 | *.fsproj merge=union 10 | *.dbproj merge=union 11 | 12 | # Standard to msysgit 13 | *.doc diff=astextplain 14 | *.DOC diff=astextplain 15 | *.docx diff=astextplain 16 | *.DOCX diff=astextplain 17 | *.dot diff=astextplain 18 | *.DOT diff=astextplain 19 | *.pdf diff=astextplain 20 | *.PDF diff=astextplain 21 | *.rtf diff=astextplain 22 | *.RTF diff=astextplain 23 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | build: 7 | 8 | runs-on: ubuntu-latest 9 | strategy: 10 | matrix: 11 | ghc: [ '8.6.5', '8.8.4', '8.10.4', '9.0.1' ] 12 | steps: 13 | - uses: actions/checkout@v2 14 | - uses: haskell/actions/setup@v1 15 | with: 16 | ghc-version: ${{ matrix.ghc }} 17 | cabal-version: '3.4' 18 | 19 | - name: cabal Cache 20 | uses: actions/cache@v1 21 | env: 22 | cache-name: cache-cabal 23 | with: 24 | path: ~/.cabal 25 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 26 | restore-keys: | 27 | ${{ runner.os }}-build-${{ env.cache-name }}- 28 | ${{ runner.os }}-build- 29 | ${{ runner.os }}- 30 | - name: Install dependencies 31 | run: | 32 | cabal update 33 | cabal build --only-dependencies --enable-tests --enable-benchmarks all 34 | - name: Build 35 | run: cabal build --enable-tests --enable-benchmarks all 36 | - name: Run tests 37 | run: cabal test --enable-tests --enable-benchmarks all -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virtualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | cabal.sandbox.config 11 | cabal.config 12 | .stack-work 13 | dist-newstyle 14 | 15 | # ========================= 16 | # Operating System Files 17 | # ========================= 18 | 19 | # OSX 20 | # ========================= 21 | 22 | .DS_Store 23 | .AppleDouble 24 | .LSOverride 25 | 26 | # Icon must ends with two \r. 27 | Icon 28 | 29 | 30 | # Thumbnails 31 | ._* 32 | 33 | # Files that might appear on external disk 34 | .Spotlight-V100 35 | .Trashes 36 | 37 | # Windows 38 | # ========================= 39 | 40 | # Windows image file caches 41 | Thumbs.db 42 | ehthumbs.db 43 | 44 | # Folder config file 45 | Desktop.ini 46 | 47 | # Recycle Bin used on file shares 48 | $RECYCLE.BIN/ 49 | 50 | # Windows Installer files 51 | *.cab 52 | *.msi 53 | *.msm 54 | *.msp 55 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 1.3 2 | ---- 3 | * Supported GHC 9.0 4 | * Removed `unfoldOM` 5 | * Removed `apprisesOf` 6 | * Removed `withBuilder` 7 | * Trimmed unnecessary dependencies 8 | 9 | 1.2 10 | ---- 11 | 12 | * Removed `iterObject` and `iterative` 13 | * Removed `Data.Functor.Request` 14 | 15 | 1.1.2 16 | ---- 17 | 18 | * Removed `either` dependency 19 | 20 | 1.1 21 | ---- 22 | * Removed `HProfunctor`, `(..-)`, `invokeOnSTM`, `newSTM`, `snapshot` 23 | * Added `(?-)` 24 | 25 | 1.0.5 26 | ---- 27 | * Added `filterO` and `filteredO` 28 | * Renamed `announcesOf` to `invokesOf` 29 | * Added `invokes` 30 | * Added `(@!=)` 31 | * Shaved unnecessary `Monoid r` off in `apprisesOf` 32 | 33 | 1.0.4 34 | ---- 35 | * Simplified `Instance` 36 | * Added `snapshot` 37 | * Added `cascade`, `cascadeObject` 38 | * Added `announcesOf` 39 | * Added `(@||@)` 40 | * Safe Haskell 41 | 42 | 1.0.3 43 | ---- 44 | * Added `apprisesOf` 45 | * Added `(@~)` 46 | 47 | 1.0.2 48 | ---- 49 | * Made `(.-)` exception-safe 50 | 51 | 1.0.1 52 | ---- 53 | * Switched to use TMVar for instances 54 | * Added atomic operations 55 | * Add `apprises` 56 | * Re-added `accept` 57 | * Added `(>~~>)` 58 | * Added `accumulator` 59 | 60 | 1.0 61 | ---- 62 | * No longer support `extensible`, `elevator`, and `minioperational` 63 | * Removed `Data.Functor.PushPull` 64 | * Removed `Control.Object.Process` 65 | * Removed `Control.Object.Stream` 66 | * Removed `Control.Monad.Objective` 67 | * Added `apprise` 68 | * Generalized `(^>>@)` and `(@>>^)` so that they also work on instances 69 | 70 | 0.6.5 71 | ---- 72 | * Supported `elevator >= 0.2`. 73 | 74 | 0.6.3.1 75 | ---- 76 | * Reverted the fixity. 77 | 78 | 0.6.3 79 | ---- 80 | * Added `Variable`, an alias for `variable` objects. 81 | * Added `Mortal`. 82 | * Increased fixity of invocation operators to 5. 83 | * Added stream connection operators. 84 | * Added `transit` and `animate`. 85 | 86 | 0.6.2 87 | ---- 88 | * Added `announce`, `announceMaybe` and `announceMaybeT` which invoke a method for every objects in a container. 89 | * Added `(@**@)` and `(@||@)`. 90 | * Renamed `(.>>.)` to `(@>>@)`, `.|>.` to `(@|>@)` for consistency. 91 | * Added `filterPush`, `bipush`, `bipull`. 92 | * Added `iterObject`, `iterTObject`, `iterative`, `iterativeT` for free monads. 93 | * Renamed `runSequential` to `(@!)`. 94 | * Added combinators for `ReifiedProgramT`: `(@!!)` and `sequentialT`. 95 | * Changed the semantics of `variable` to accept `StateT`. 96 | * Added `flyweight'` that relies on HashMap. 97 | * Added `MonadObjective` constraint 98 | 99 | 0.6.1 100 | ----- 101 | * Fixed the wrong constraints of `request` 102 | 103 | 0.6 104 | ----- 105 | * `PushPull` has more `Floors` 106 | * Added `Applicative` instance for `Request` 107 | * Reformed around Control.Monad.Objective 108 | * Instance f g m ==> Inst m f g 109 | * `invoke` takes two transformations for lifting 110 | * Added lifted versions of `new`: `newIO` and `newST` 111 | 112 | 0.5.2 113 | ----- 114 | * Added Process 115 | * Added `runSequential`, `sequential` for operational monad 116 | * Added `flyweight` 117 | 118 | 0.5.1 119 | ----- 120 | * Added PushPull functor 121 | * Removed `sequential` 122 | 123 | 0.5 124 | ----- 125 | * Lift has gone 126 | * Use elevator instead of Lift 127 | * Moved Request to a separate module 128 | 129 | 0.4 130 | ----- 131 | * Added Request functor along with Lift 132 | * Supported "extensible" objects using open unions 133 | * AccessT is now obsolete 134 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Fumiaki Kinoshita 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Fumiaki Kinoshita nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | objective 2 | ==== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/objective.svg)](https://hackage.haskell.org/package/objective) [![Build Status](https://secure.travis-ci.org/fumieval/objective.png?branch=master)](http://travis-ci.org/fumieval/objective) 5 | 6 | Paper: https://fumieval.github.io/papers/en/2015-Haskell-objects.html 7 | 8 | This package provides composable objects and instances. 9 | 10 | Introduction 11 | ---- 12 | 13 | The primal construct, `Object`, models _object-oriented_ objects. `Object f g` represents an object. 14 | 15 | ```haskell 16 | newtype Object f g = Object { runObject :: forall x. f x -> g (x, Object f g) } 17 | ``` 18 | 19 | An object interprets a message `f a` and returns the result `a` and the next object `Object f g`, on `g`. 20 | 21 | ```haskell 22 | data Counter a where 23 | Increment :: Counter () 24 | Print :: Counter Int 25 | 26 | counter :: Int -> Object Counter IO 27 | counter n = Object $ \case 28 | Increment -> return ((), counter (n + 1)) 29 | Print -> print n >> return (n, counter n) 30 | ``` 31 | 32 | `new :: Object f g -> IO (Instance f g)` creates an instance of an object. 33 | 34 | `(.-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m a` sends a message to an instance. This can be used to handle instances in the typical OOP fashion. 35 | 36 | ```haskell 37 | > i <- new (counter 0) 38 | > i .- Increment 39 | > i .- Print 40 | 1 41 | > i .- Increment 42 | > i .- Print 43 | 2 44 | ``` 45 | 46 | Interestingly, `Object (Skeleton t) m` and `Object t m` are isomorphic (`Skeleton` is an operational monad). `cascading` lets objects to handle an operational monad. 47 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ 2 | -------------------------------------------------------------------------------- /objective.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: objective 3 | version: 1.3 4 | synopsis: Composable objects 5 | description: Composable objects 6 | homepage: https://github.com/fumieval/objective 7 | bug-reports: http://github.com/fumieval/objective/issues 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | author: Fumiaki Kinoshita 11 | maintainer: Fumiaki Kinoshita 12 | copyright: Copyright (c) 2014-2021 Fumiaki Kinoshita 13 | category: Control 14 | build-type: Simple 15 | extra-source-files: 16 | CHANGELOG.md 17 | README.md 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/fumieval/objective.git 22 | 23 | library 24 | exposed-modules: 25 | Control.Object 26 | , Control.Object.Object 27 | , Control.Object.Instance 28 | , Control.Object.Mortal 29 | other-extensions: MultiParamTypeClasses, KindSignatures, TypeFamilies 30 | build-depends: base >=4.9 && <5 31 | , exceptions >= 0.8 32 | , transformers >= 0.3 && <0.6 33 | , witherable ^>= 0.4 34 | , monad-skeleton >= 0.1.1 && <0.3 35 | ghc-options: -Wall -Wcompat 36 | hs-source-dirs: src 37 | default-language: Haskell2010 38 | -------------------------------------------------------------------------------- /proofs/composition.md: -------------------------------------------------------------------------------- 1 | For readability, `Object` and `runObject` are abbreviated as `inO`, `outO`. 2 | 3 | Associativity 4 | ------------------------------- 5 | 6 | For every type of action `e`, `f`, `g`, 7 | Functor `h`, and for every object `a :: Object e f`, 8 | `b :: Object f g`, 9 | `c :: Object g h`, 10 | 11 | ```haskell 12 | a @>>@ (b @>> c) == (a @>>@ b) @>>@ c 13 | ``` 14 | 15 | Proof: 16 | 17 | ```haskell 18 | outO (a @>>@ (b @>>@ c)) 19 | = { Definition of (@>>@) } 20 | fmap joinO . fmap joinO . outO c . outO b . outO a) f 21 | = { fmap fusion } 22 | fmap (joinO . joinO) . outO c . outO b . outO a 23 | = { Expanding (joinO . joinO) } 24 | = fmap (\(((x, ef), fg), gh) -> (x, ef @>>@ (fg @>>@ gh))) 25 | . outO c . outO b . outO a 26 | ``` 27 | 28 | ```haskell 29 | outO ((a @>>@ b) @>>@ c) 30 | = { Definition of (@>>@) } 31 | fmap joinO . outO c . (fmap joinO . outO b . outO a) f 32 | = { outO . inO = id } 33 | fmap joinO . outO c . fmap joinO . outO b . outO a 34 | = { Naturality } 35 | fmap joinO . fmap (first joinO) . outO c . outO b . outO a 36 | = { fmap fusion } 37 | fmap (joinO . first joinO) . outO c . outO b . outO a 38 | = { Expansion } 39 | = fmap (\(((x, ef), fg), gh) -> (x, (ef @>>@ fg) @>>@ gh)) 40 | . outO c . outO b . outO a 41 | = { Coinduction } 42 | = fmap (\(((x, ef), fg), gh) -> (x, ef @>>@ (fg @>>@ gh))) 43 | . outO c . outO b . outO a 44 | = { LHS } 45 | outO (a @>>@ (b @>>@ c)) 46 | ``` 47 | 48 | Left identity 49 | ------------------------------- 50 | 51 | ```haskell 52 | outO (echo @>>@ obj) 53 | = { Definition of echo } 54 | fmap (\x -> (x, echo))) @>>@ obj 55 | = { Definition of (@>>@) } 56 | fmap joinO . outO obj . fmap (\x -> (x, echo)) 57 | = { Naturality } 58 | fmap joinO . fmap (first (\x -> (x, echo))) . outO obj 59 | = { fmap fusion } 60 | fmap (joinO . first (\x -> (x, echo))) . outO obj 61 | = { Definition of joinO } 62 | fmap (\(x, m) -> (x, echo @>>@ m)) . outO obj 63 | = { Coinduction } 64 | fmap (\(x, m) -> (x, m)) . outO obj 65 | = { fmap id = id } 66 | outO obj 67 | ``` 68 | 69 | Right identity 70 | ------------------------------- 71 | For every object `obj :: Object f g`, `obj @>>@ echo = obj` 72 | 73 | ```haskell 74 | outO (obj @>>@ echo) 75 | = { Definition of echo } 76 | outO (obj @>>@ Object (fmap (\x -> (x, echo)))) 77 | = { Definition of (@>>@) } 78 | fmap joinO . fmap (\x -> (x, echo)) . outO obj 79 | = { Naturality } 80 | fmap (joinO . (\x -> (x, echo))) . outO obj 81 | = { fmap fusion } 82 | fmap (\(x, m) -> (x, m @>>@ echo)) . outO obj 83 | = { Coinduction } 84 | fmap (\(x, m) -> (x, m)) . outO obj 85 | = { fmap id = id } 86 | outO obj 87 | ``` 88 | -------------------------------------------------------------------------------- /src/Control/Object.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Object 4 | -- Copyright : (c) Fumiaki Kinoshita 2015 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Fumiaki Kinoshita 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | ----------------------------------------------------------------------------- 12 | module Control.Object 13 | ( module Control.Object.Object, 14 | module Control.Object.Mortal, 15 | module Control.Object.Instance, 16 | ) where 17 | 18 | import Control.Object.Object 19 | import Control.Object.Mortal 20 | import Control.Object.Instance -------------------------------------------------------------------------------- /src/Control/Object/Instance.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, Rank2Types, LambdaCase #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Control.Object.Instance 5 | -- Copyright : (c) Fumiaki Kinoshita 2015 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Fumiaki Kinoshita 9 | -- Stability : provisional 10 | -- Portability : GADTs, Rank2Types 11 | -- 12 | ----------------------------------------------------------------------------- 13 | module Control.Object.Instance ( 14 | -- * Instantiation 15 | Instance 16 | , new 17 | , newSettle 18 | -- * Invocation 19 | , invokeOnUsing 20 | , invokeOn 21 | , (.-) 22 | , (..-) 23 | , (?-) 24 | ) where 25 | import Control.Concurrent 26 | import Control.Exception (evaluate) 27 | import Control.Object.Object 28 | import Control.Monad.IO.Class 29 | import Control.Monad.Catch 30 | import Control.Monad.Skeleton 31 | 32 | type Instance f g = MVar (Object f g) 33 | 34 | invokeOnUsing :: (MonadIO m, MonadMask m) 35 | => (Object f g -> t a -> g (a, Object f g)) 36 | -> (forall x. g x -> m x) -> Instance f g -> t a -> m a 37 | invokeOnUsing run m v f = mask $ \restore -> do 38 | obj <- liftIO $ takeMVar v 39 | (a, obj') <- restore (m (run obj f) >>= liftIO . evaluate) `onException` liftIO (putMVar v obj) 40 | liftIO $ putMVar v obj' 41 | return a 42 | 43 | -- | Invoke a method with an explicit landing function. 44 | -- In case of exception, the original object will be set. 45 | invokeOn :: (MonadIO m, MonadMask m) 46 | => (forall x. g x -> m x) -> Instance f g -> f a -> m a 47 | invokeOn = invokeOnUsing (\o f -> runObject o f) 48 | {-# INLINE invokeOn #-} 49 | 50 | -- | Invoke a method. 51 | (.-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m a 52 | (.-) = invokeOn id 53 | {-# INLINE (.-) #-} 54 | infixr 3 .- 55 | 56 | (..-) :: (MonadIO m, MonadMask m) 57 | => Instance t m -> Skeleton t a -> m a 58 | (..-) = invokeOnUsing cascadeObject id 59 | {-# INLINE (..-) #-} 60 | infixr 3 ..- 61 | 62 | -- | Try to invoke a method. If the instance is unavailable, it returns Nothing. 63 | (?-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m (Maybe a) 64 | v ?- f = mask $ \restore -> liftIO (tryTakeMVar v) >>= \case 65 | Just obj -> do 66 | (a, obj') <- restore (runObject obj f >>= liftIO . evaluate) `onException` liftIO (putMVar v obj) 67 | liftIO $ putMVar v obj' 68 | return (Just a) 69 | Nothing -> return Nothing 70 | 71 | -- | Create a new instance. This can be used inside 'unsafePerformIO' to create top-level instances. 72 | new :: MonadIO m => Object f g -> m (Instance f g) 73 | new = liftIO . newMVar 74 | {-# INLINE new #-} 75 | 76 | -- | Create a new instance, having it sitting on the current environment. 77 | newSettle :: MonadIO m => Object f m -> m (Instance f m) 78 | newSettle = new 79 | {-# INLINE newSettle #-} 80 | -------------------------------------------------------------------------------- /src/Control/Object/Mortal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Control.Object.Mortal 8 | -- Copyright : (c) Fumiaki Kinoshita 2015 9 | -- License : BSD3 10 | -- 11 | -- Maintainer : Fumiaki Kinoshita 12 | -- Stability : provisional 13 | -- Portability : GADTs, Rank2Types 14 | -- 15 | ----------------------------------------------------------------------------- 16 | module Control.Object.Mortal ( 17 | Mortal(..), 18 | mortal, 19 | mortal_, 20 | runMortal, 21 | immortal, 22 | apprises, 23 | apprise 24 | ) where 25 | 26 | import Control.Object.Object 27 | import Control.Monad.Trans.Except 28 | import Control.Monad 29 | import Control.Monad.Trans.Class 30 | import Control.Monad.Trans.State.Strict 31 | import Control.Monad.Trans.Writer.Strict 32 | import Data.Bifunctor 33 | import Data.Monoid 34 | import Witherable 35 | import Data.Tuple (swap) 36 | 37 | -- | A 'Mortal' is an object that may die. 38 | -- A mortal yields a final result upon death. 39 | -- @'Mortal' f g@ forms a 'Monad': 40 | -- 'return' is a dead object and ('>>=') prolongs the life of the left object. 41 | -- 42 | -- @Object f g ≡ Mortal f g Void@ 43 | -- 44 | newtype Mortal f g a = Mortal { unMortal :: Object f (ExceptT a g) } 45 | 46 | instance Monad m => Functor (Mortal f m) where 47 | fmap f (Mortal obj) = Mortal (obj @>>^ mapExceptT (fmap (first f))) 48 | {-# INLINE fmap #-} 49 | 50 | instance Monad m => Applicative (Mortal f m) where 51 | pure a = mortal $ const $ throwE a 52 | {-# INLINE pure #-} 53 | (<*>) = ap 54 | {-# INLINE (<*>) #-} 55 | 56 | instance Monad m => Monad (Mortal f m) where 57 | m >>= k = mortal $ \f -> lift (runExceptT $ runMortal m f) >>= \case 58 | Left a -> runMortal (k a) f 59 | Right (x, m') -> return (x, m' >>= k) 60 | 61 | instance MonadTrans (Mortal f) where 62 | lift m = mortal $ const $ ExceptT $ fmap Left m 63 | {-# INLINE lift #-} 64 | 65 | -- | Construct a mortal in a 'Object' construction manner. 66 | mortal :: Monad m => (forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a 67 | mortal f = Mortal (Object (fmap (fmap unMortal) . f)) 68 | {-# INLINE mortal #-} 69 | 70 | -- | Send a message to a mortal. 71 | runMortal :: Monad m => Mortal f m a -> f x -> ExceptT a m (x, Mortal f m a) 72 | runMortal m f = fmap Mortal <$> runObject (unMortal m) f 73 | {-# INLINE runMortal #-} 74 | 75 | -- | A smart constructor of 'Mortal' where the result type is restricted to () 76 | mortal_ :: Object f (ExceptT () g) -> Mortal f g () 77 | mortal_ = Mortal 78 | {-# INLINE mortal_ #-} 79 | 80 | -- | Turn an object into a mortal without death. 81 | immortal :: Monad m => Object f m -> Mortal f m x 82 | immortal obj = Mortal (obj @>>^ lift) 83 | {-# INLINE immortal #-} 84 | 85 | -- | Send a message to mortals in a 'Witherable' container. 86 | apprises :: (Witherable t, Monad m, Monoid r) => f a -> (a -> r) -> (b -> r) -> StateT (t (Mortal f m b)) m r 87 | apprises f p q = StateT $ \t -> fmap swap $ runWriterT $ flip wither t 88 | $ \obj -> WriterT $ runExceptT (runMortal obj f) >>= \case 89 | Left r -> return (Nothing, q r) 90 | Right (x, obj') -> return (Just obj', p x) 91 | {-# INLINE apprises #-} 92 | 93 | -- | Send a message to mortals in a container. 94 | apprise :: (Witherable t, Monad m) => f a -> StateT (t (Mortal f m r)) m ([a], [r]) 95 | apprise f = bimap (`appEndo` []) (`appEndo` []) 96 | <$> apprises f (\a -> (Endo (a:), mempty)) (\b -> (mempty, Endo (b:))) 97 | {-# INLINE apprise #-} 98 | -------------------------------------------------------------------------------- /src/Control/Object/Object.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, TupleSections, TypeOperators #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE Safe #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Control.Object.Object 8 | -- Copyright : (c) Fumiaki Kinoshita 2015 9 | -- License : BSD3 10 | -- 11 | -- Maintainer : Fumiaki Kinoshita 12 | -- Stability : provisional 13 | -- Portability : GADTs, Rank2Types 14 | -- 15 | ----------------------------------------------------------------------------- 16 | module Control.Object.Object (Object(..) 17 | , echo 18 | , (@>>@) 19 | , (@<<@) 20 | , liftO 21 | , (^>>@) 22 | , (@>>^) 23 | , (@||@) 24 | -- * Stateful construction 25 | , unfoldO 26 | , stateful 27 | , (@~) 28 | , variable 29 | -- * Method cascading 30 | , (@-) 31 | , cascadeObject 32 | , cascading 33 | -- * Filtering 34 | , Fallible(..) 35 | , filteredO 36 | , filterO 37 | -- * Manipulation on StateT 38 | , invokesOf 39 | , invokes 40 | , (@!=) 41 | , announce 42 | ) where 43 | import Control.Monad.Trans.State.Strict 44 | import Control.Monad.Skeleton 45 | import Control.Monad.Trans.Writer.Strict 46 | import Data.Monoid 47 | import Data.Tuple (swap) 48 | import qualified Data.Functor.Sum as Functor 49 | 50 | -- | The type @Object f g@ represents objects which can handle messages @f@, perform actions in the environment @g@. 51 | -- It can be thought of as an automaton that transforms effects. 52 | -- 'Object's can be composed just like functions using '@>>@'; the identity element is 'echo'. 53 | -- Objects are morphisms of the category of actions. 54 | -- 55 | -- [/Naturality/] 56 | -- @runObject obj . fmap f ≡ fmap f . runObject obj@ 57 | -- 58 | newtype Object f g = Object { runObject :: forall x. f x -> g (x, Object f g) } 59 | 60 | -- | An infix alias for 'runObject' 61 | (@-) :: Object f g -> f x -> g (x, Object f g) 62 | a @- b = runObject a b 63 | {-# INLINE (@-) #-} 64 | infixr 3 @- 65 | 66 | infixr 1 ^>>@ 67 | infixr 1 @>>^ 68 | 69 | (^>>@) :: Functor h => (forall x. f x -> g x) -> Object g h -> Object f h 70 | f ^>>@ m0 = go m0 where go (Object m) = Object $ fmap (fmap go) . m . f 71 | {-# INLINE (^>>@) #-} 72 | 73 | (@>>^) :: Functor h => Object f g -> (forall x. g x -> h x) -> Object f h 74 | m0 @>>^ g = go m0 where go (Object m) = Object $ fmap (fmap go) . g . m 75 | {-# INLINE (@>>^) #-} 76 | 77 | -- | The trivial object 78 | echo :: Functor f => Object f f 79 | echo = Object $ fmap (,echo) 80 | 81 | -- | Lift a natural transformation into an object. 82 | liftO :: Functor g => (forall x. f x -> g x) -> Object f g 83 | liftO f = go where go = Object $ fmap (\x -> (x, go)) . f 84 | {-# INLINE liftO #-} 85 | 86 | -- | The categorical composition of objects. 87 | (@>>@) :: Functor h => Object f g -> Object g h -> Object f h 88 | Object m @>>@ Object n = Object $ fmap (\((x, m'), n') -> (x, m' @>>@ n')) . n . m 89 | infixr 1 @>>@ 90 | 91 | -- | Reversed '(@>>@)' 92 | (@<<@) :: Functor h => Object g h -> Object f g -> Object f h 93 | (@<<@) = flip (@>>@) 94 | {-# INLINE (@<<@) #-} 95 | infixl 1 @<<@ 96 | 97 | -- | Combine objects so as to handle a 'Functor.Sum' of interfaces. 98 | (@||@) :: Functor h => Object f h -> Object g h -> Object (f `Functor.Sum` g) h 99 | a @||@ b = Object $ \case 100 | Functor.InL f -> fmap (fmap (@||@b)) (runObject a f) 101 | Functor.InR g -> fmap (fmap (a@||@)) (runObject b g) 102 | 103 | -- | An unwrapped analog of 'stateful' 104 | -- @id = unfoldO runObject@ 105 | -- @'iterative' = unfoldO 'iterObject'@ 106 | -- @'cascading' = unfoldO 'cascadeObject'@ 107 | unfoldO :: Functor g => (forall a. r -> f a -> g (a, r)) -> r -> Object f g 108 | unfoldO h = go where go r = Object $ fmap (fmap go) . h r 109 | {-# INLINE unfoldO #-} 110 | 111 | -- | Build a stateful object. 112 | -- 113 | -- @stateful t s = t ^>>\@ variable s@ 114 | -- 115 | stateful :: Monad m => (forall a. t a -> StateT s m a) -> s -> Object t m 116 | stateful h = go where 117 | go s = Object $ \f -> runStateT (h f) s >>= \(a, s') -> s' `seq` return (a, go s') 118 | {-# INLINE stateful #-} 119 | 120 | -- | Flipped 'stateful'. 121 | -- it is super convenient to use with the LambdaCase extension. 122 | (@~) :: Monad m => s -> (forall a. t a -> StateT s m a) -> Object t m 123 | s @~ h = stateful h s 124 | {-# INLINE (@~) #-} 125 | infix 1 @~ 126 | 127 | -- | A mutable variable. 128 | -- 129 | -- @variable = stateful id@ 130 | -- 131 | variable :: Monad m => s -> Object (StateT s m) m 132 | variable = stateful id 133 | {-# INLINE variable #-} 134 | 135 | -- | Pass zero or more messages to an object. 136 | cascadeObject :: Monad m => Object t m -> Skeleton t a -> m (a, Object t m) 137 | cascadeObject obj sk = case debone sk of 138 | Return a -> return (a, obj) 139 | t :>>= k -> runObject obj t >>= \(a, obj') -> cascadeObject obj' (k a) 140 | 141 | -- | Add capability to handle multiple messages at once. 142 | cascading :: Monad m => Object t m -> Object (Skeleton t) m 143 | cascading = unfoldO cascadeObject 144 | {-# INLINE cascading #-} 145 | 146 | -- | Send a message to an object through a lens. 147 | invokesOf :: Monad m 148 | => ((Object t m -> WriterT r m (Object t m)) -> s -> WriterT r m s) 149 | -> t a -> (a -> r) -> StateT s m r 150 | invokesOf t f c = StateT $ fmap swap . runWriterT 151 | . t (\obj -> WriterT $ runObject obj f >>= \(x, obj') -> return (obj', c x)) 152 | {-# INLINABLE invokesOf #-} 153 | 154 | invokes :: (Traversable t, Monad m, Monoid r) 155 | => f a -> (a -> r) -> StateT (t (Object f m)) m r 156 | invokes = invokesOf traverse 157 | {-# INLINE invokes #-} 158 | 159 | -- | Send a message to objects in a traversable container. 160 | announce :: (Traversable t, Monad m) => f a -> StateT (t (Object f m)) m [a] 161 | announce f = withListBuilder (invokes f) 162 | {-# INLINABLE announce #-} 163 | 164 | -- | A method invocation operator on 'StateT'. 165 | (@!=) :: Monad m 166 | => ((Object t m -> WriterT a m (Object t m)) -> s -> WriterT a m s) 167 | -> t a -> StateT s m a 168 | l @!= f = invokesOf l f id 169 | {-# INLINE (@!=) #-} 170 | 171 | withListBuilder :: Functor f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a] 172 | withListBuilder f = fmap (flip appEndo []) (f (Endo . (:))) 173 | {-# INLINABLE withListBuilder #-} 174 | 175 | data Fallible t a where 176 | Fallible :: t a -> Fallible t (Maybe a) 177 | 178 | filteredO :: Monad m 179 | => (forall x. t x -> Bool) 180 | -> Object t m -> Object (Fallible t) m 181 | filteredO p obj = Object $ \(Fallible t) -> if p t 182 | then runObject obj t >>= \(a, obj') -> return (Just a, filteredO p obj') 183 | else return (Nothing, filteredO p obj) 184 | 185 | filterO :: (forall x. t x -> Bool) -> Object (Fallible t) (Skeleton t) 186 | filterO p = filteredO p (liftO bone) 187 | {-# INLINE filterO #-} 188 | --------------------------------------------------------------------------------