├── .gitignore ├── .hlint.hs ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── changelog.md ├── examples ├── applicative │ ├── bankers │ │ ├── Main.hs │ │ ├── MainMinimalBug.hs │ │ └── bankers.cabal │ └── ll1-parser │ │ ├── Main.hs │ │ ├── MainSuperapplicative.hs │ │ └── ll1-parser-example.cabal ├── monad │ ├── constrained │ │ ├── .gitignore │ │ ├── MainSet.hs │ │ └── constrained-example.cabal │ ├── effect │ │ ├── .gitignore │ │ ├── Main.hs │ │ ├── Main2.hs │ │ ├── Main3.hs │ │ ├── MainSupermonad.hs │ │ ├── MainSupermonad2.hs │ │ ├── MainSupermonad3.hs │ │ ├── Vector.hs │ │ └── effect-example.cabal │ ├── hmtc │ │ ├── monad-param │ │ │ ├── .gitignore │ │ │ ├── AST.hs │ │ │ ├── CodeGenMonad.hs │ │ │ ├── CodeGenerator.hs │ │ │ ├── Diagnostics.hs │ │ │ ├── Env.hs │ │ │ ├── LibMT.hs │ │ │ ├── MTIR.hs │ │ │ ├── MTStdEnv.hs │ │ │ ├── Main.hs │ │ │ ├── Makefile │ │ │ ├── Name.hs │ │ │ ├── PPAST.hs │ │ │ ├── PPMTIR.hs │ │ │ ├── PPTAMCode.hs │ │ │ ├── PPUtilities.hs │ │ │ ├── ParseMonad.hs │ │ │ ├── Parser.y │ │ │ ├── Scanner.hs │ │ │ ├── ScopeLevel.hs │ │ │ ├── SrcPos.hs │ │ │ ├── Symbol.hs │ │ │ ├── TAMCode.hs │ │ │ ├── TAMCodeParser.y │ │ │ ├── TAMInterpreter.hs │ │ │ ├── Token.hs │ │ │ ├── Type.hs │ │ │ ├── TypeChecker.hs │ │ │ └── hmtc-monad-param.cabal │ │ ├── original │ │ │ ├── .gitignore │ │ │ ├── AST.hs │ │ │ ├── CodeGenMonad.hs │ │ │ ├── CodeGenerator.hs │ │ │ ├── Diagnostics.hs │ │ │ ├── Env.hs │ │ │ ├── LibMT.hs │ │ │ ├── MTIR.hs │ │ │ ├── MTStdEnv.hs │ │ │ ├── Main.hs │ │ │ ├── Makefile │ │ │ ├── Name.hs │ │ │ ├── PPAST.hs │ │ │ ├── PPMTIR.hs │ │ │ ├── PPTAMCode.hs │ │ │ ├── PPUtilities.hs │ │ │ ├── ParseMonad.hs │ │ │ ├── Parser.y │ │ │ ├── Scanner.hs │ │ │ ├── ScopeLevel.hs │ │ │ ├── SrcPos.hs │ │ │ ├── Symbol.hs │ │ │ ├── TAMCode.hs │ │ │ ├── TAMCodeParser.y │ │ │ ├── TAMInterpreter.hs │ │ │ ├── Token.hs │ │ │ ├── Type.hs │ │ │ ├── TypeChecker.hs │ │ │ └── hmtc-orig.cabal │ │ ├── supermonad │ │ │ ├── .gitignore │ │ │ ├── AST.hs │ │ │ ├── CodeGenMonad.hs │ │ │ ├── CodeGenerator.hs │ │ │ ├── Diagnostics.hs │ │ │ ├── Env.hs │ │ │ ├── LibMT.hs │ │ │ ├── MTIR.hs │ │ │ ├── MTStdEnv.hs │ │ │ ├── Main.hs │ │ │ ├── Makefile │ │ │ ├── Name.hs │ │ │ ├── PPAST.hs │ │ │ ├── PPMTIR.hs │ │ │ ├── PPTAMCode.hs │ │ │ ├── PPUtilities.hs │ │ │ ├── ParseMonad.hs │ │ │ ├── Parser.y │ │ │ ├── Scanner.hs │ │ │ ├── ScopeLevel.hs │ │ │ ├── SrcPos.hs │ │ │ ├── Symbol.hs │ │ │ ├── TAMCode.hs │ │ │ ├── TAMCodeParser.y │ │ │ ├── TAMInterpreter.hs │ │ │ ├── TestTAM.hs │ │ │ ├── Token.hs │ │ │ ├── Type.hs │ │ │ ├── TypeChecker.hs │ │ │ └── hmtc-supermonad.cabal │ │ └── test-files │ │ │ ├── fac.mt │ │ │ ├── incdec.mt │ │ │ ├── matmult.mt │ │ │ ├── overloading.mt │ │ │ ├── records.mt │ │ │ ├── sort.mt │ │ │ ├── test1.mt │ │ │ ├── test2.mt │ │ │ ├── test3.mt │ │ │ ├── test4.mt │ │ │ ├── test5.mt │ │ │ └── test6.mt │ ├── minimal │ │ ├── MinimalMain.hs │ │ └── minimal.cabal │ ├── session-chat │ │ ├── original │ │ │ ├── .gitignore │ │ │ ├── Client.hs │ │ │ ├── Main.hs │ │ │ ├── Server.hs │ │ │ ├── Types.hs │ │ │ ├── Utility.hs │ │ │ └── session-chat-orig-example.cabal │ │ └── supermonad │ │ │ ├── .gitignore │ │ │ ├── Client.hs │ │ │ ├── Main.hs │ │ │ ├── Server.hs │ │ │ ├── Types.hs │ │ │ ├── Utility.hs │ │ │ └── session-chat-supermonad-example.cabal │ └── session │ │ ├── .gitignore │ │ ├── Main.hs │ │ ├── MainSupermonad.hs │ │ ├── MainSupermonadTrans.hs │ │ └── session-example.cabal └── test │ └── missing-functions │ ├── Main.hs │ └── missing-functions.cabal ├── hcar ├── Supermonads-JS.tex ├── entry.tex └── hcar.sty ├── src └── Control │ ├── Super │ ├── Monad.hs │ ├── Monad │ │ ├── Alternative.hs │ │ ├── Constrained.hs │ │ ├── Constrained │ │ │ ├── Alternative.hs │ │ │ ├── Functions.hs │ │ │ ├── Functor.hs │ │ │ ├── MonadPlus.hs │ │ │ └── Prelude.hs │ │ ├── Functions.hs │ │ ├── MonadPlus.hs │ │ ├── Plugin.hs │ │ ├── Prelude.hs │ │ └── PreludeWithoutMonad.hs │ └── Plugin │ │ ├── ClassDict.hs │ │ ├── Collection │ │ ├── Map.hs │ │ └── Set.hs │ │ ├── Constraint.hs │ │ ├── Debug.hs │ │ ├── Detect.hs │ │ ├── Environment.hs │ │ ├── Environment │ │ └── Lift.hs │ │ ├── Evidence.hs │ │ ├── Instance.hs │ │ ├── InstanceDict.hs │ │ ├── Log.hs │ │ ├── Names.hs │ │ ├── Prototype.hs │ │ ├── Separation.hs │ │ ├── Solving.hs │ │ ├── Utils.hs │ │ └── Wrapper.hs │ ├── Supermonad.hs │ └── Supermonad │ ├── Constrained.hs │ ├── Constrained │ └── Prelude.hs │ ├── Functions.hs │ ├── Plugin.hs │ └── Prelude.hs ├── supermonad.cabal └── tests ├── Main.hs └── Test ├── Control └── Super │ └── Plugin │ └── Collection │ ├── Map.hs │ └── Set.hs └── Utils.hs /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | # Backup files 3 | *.bak 4 | ~* 5 | *~ 6 | *.backup 7 | 8 | # LaTeX build products for HCAR 9 | /hcar/*.aux 10 | /hcar/*.log 11 | /hcar/*.out 12 | /hcar/*.pdf 13 | /hcar/*.synctex.gz 14 | 15 | # Temporary files 16 | *.o 17 | *.tmp 18 | *.log 19 | *.kate-swp 20 | *.cache 21 | 22 | # Build products 23 | *.hi 24 | *.o 25 | *.dyn_hi 26 | *.dyn_o 27 | dist/ 28 | 29 | # Cabal Sandbox 30 | /.cabal-sandbox 31 | /cabal.sandbox.config 32 | -------------------------------------------------------------------------------- /.hlint.hs: -------------------------------------------------------------------------------- 1 | import "hint" HLint.HLint 2 | 3 | ignore "Use <=<" 4 | ignore "Use <$>" 5 | ignore "Use first" 6 | ignore "Use second" 7 | ignore "Use const" 8 | ignore "Redundant $" 9 | ignore "Redundant bracket" 10 | ignore "Redundant do" 11 | ignore "Eta reduce" 12 | ignore "Avoid lambda" -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | 2 | # Don't use a specific environment we install everything ourselves. 3 | language: generic 4 | 5 | # Don't use sudo so the environment boots faster on travis. 6 | # We can get around sudo, because we are using apt addons to install 7 | # custom packages. 8 | sudo: false 9 | 10 | # What environments we want to build for. 11 | matrix: 12 | include: 13 | #- env: GHCVER=7.10.2 CABALVER=1.22 ALEXVER=3.1.4 HAPPYVER=1.19.5 14 | # addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} 15 | - env: GHCVER=7.10.3 CABALVER=1.22 ALEXVER=3.1.4 HAPPYVER=1.19.5 16 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} 17 | - env: GHCVER=8.0.2 CABALVER=1.24 ALEXVER=3.1.4 HAPPYVER=1.19.5 18 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} 19 | - env: GHCVER=8.2.1 CABALVER=2.0 ALEXVER=3.1.4 HAPPYVER=1.19.5 20 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} 21 | - env: GHCVER=8.4.2 CABALVER=2.2 ALEXVER=3.1.4 HAPPYVER=1.19.5 22 | addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} 23 | 24 | before_install: 25 | install: 26 | # Setup the path to find the custom installed executables. 27 | - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$PATH 28 | # Update cabal so it can find all of the packages that are required. 29 | - travis_retry cabal update 30 | 31 | before_script: 32 | # Work in a sandbox 33 | - cabal sandbox init 34 | # Setup the library dependency of the ebba-example 35 | - git clone https://github.com/glutamate/gnewplot.git ./examples/arrow/ebba/gnewplot 36 | - cabal sandbox add-source ./examples/arrow/ebba/gnewplot 37 | 38 | script: 39 | # Print version information 40 | - ghc --version 41 | - cabal --version 42 | - alex --version 43 | - happy --version 44 | # Build the supermonad library. 45 | # According to travis documentation we can use 2 cores: 46 | # https://docs.travis-ci.com/user/ci-environment/#Overview 47 | - cabal install -j2 48 | # Find the example directories that contain a cabal project and builds them in the current context. 49 | - find ./examples -type f -iname '*.cabal' -exec dirname {} \; | xargs -n1 cabal install -j2 50 | 51 | notifications: 52 | email: true 53 | 54 | branches: 55 | only: 56 | - master 57 | - dev 58 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Jan Bracker 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 Jan Bracker 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 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | DIR:=$(shell pwd) 3 | 4 | install: init 5 | cabal install 6 | 7 | clean: init 8 | cabal clean 9 | 10 | rm -fR ./examples/test/missing-functions/dist 11 | 12 | rm -fR ./examples/monad/session/dist 13 | rm -fR ./examples/monad/effect/dist 14 | rm -fR ./examples/monad/constrained/dist 15 | rm -fR ./examples/monad/minimal/dist 16 | 17 | rm -fR ./examples/monad/session-chat/original/dist 18 | rm -fR ./examples/monad/session-chat/supermonad/dist 19 | 20 | rm -fR ./examples/monad/hmtc/original/dist 21 | rm -fR ./examples/monad/hmtc/supermonad/dist 22 | rm -fR ./examples/monad/hmtc/monad-param/dist 23 | 24 | rm -fR ./examples/applicative/ll1-parser/dist 25 | 26 | rm -fR ./dist 27 | rm -f ./*.eps 28 | 29 | clean-sandbox: 30 | rm -fR ./.cabal-sandbox 31 | rm -f ./cabal.sandbox.config 32 | 33 | test: init 34 | cabal install --only-dependencies --enable-tests 35 | cabal test 36 | 37 | doc: init 38 | cabal configure && cabal haddock --internal --executables 39 | 40 | opendoc: 41 | xdg-open ./dist/doc/html/supermonad/index.html 42 | 43 | init: 44 | [ -f ./cabal.sandbox.config ] || [ -d ./.cabal-sandbox ] || cabal sandbox init 45 | 46 | hlint: 47 | find src/ -iname '*.hs' -exec hlint --hint=.hlint.hs {} \; 48 | 49 | 50 | missing-function-test: 51 | cabal install ./examples/test/missing-functions 52 | 53 | examples: non-super-examples supermonad-examples superapplicative-examples 54 | 55 | non-super-examples: install session-chat-orig-example hmtc-orig-example hmtc-monad-param-example 56 | 57 | supermonad-examples: install minimal-example session-example session-chat-supermonad-example effect-example constrained-example hmtc-supermonad-example 58 | 59 | superapplicative-examples: install ll1-parser-example bankers-example 60 | 61 | # Compilation of (super)monad examples. 62 | minimal-example: install 63 | cabal install ./examples/monad/minimal 64 | 65 | session-example: install 66 | cabal install ./examples/monad/session 67 | 68 | session-chat-orig-example: init 69 | cabal install ./examples/monad/session-chat/original 70 | 71 | session-chat-supermonad-example: init 72 | cabal install ./examples/monad/session-chat/supermonad 73 | 74 | effect-example: install 75 | cabal install ./examples/monad/effect 76 | 77 | constrained-example: install 78 | cabal install ./examples/monad/constrained 79 | 80 | hmtc-orig-example: init 81 | cabal install ./examples/monad/hmtc/original 82 | 83 | hmtc-supermonad-example: install 84 | cabal install ./examples/monad/hmtc/supermonad 85 | 86 | hmtc-monad-param-example: init 87 | cabal install ./examples/monad/hmtc/monad-param 88 | 89 | # Compilation of (super)applicative examples. 90 | ll1-parser-example: install 91 | cabal install ./examples/applicative/ll1-parser 92 | 93 | bankers-example: install 94 | cabal install ./examples/applicative/bankers 95 | 96 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Supermonads and superapplicatives for GHC 2 | 3 | Implementation of supermonads for GHC. See the 4 | [Supermonads: One Notion to Bind Them All](http://jbracker.de/publications/2016-BrackerNilsson-Supermonads.pdf) 5 | paper for detailed explanation of version 0.1. 6 | An [updated version of the paper](http://jbracker.de/publications/2017-BrackerNilsson-SupermonadsAndSuperapplicatives-UnderConsideration.pdf) 7 | that also explains superapplicatives has been submitted to JFP. 8 | 9 | ## Supermonads 10 | 11 | The library offers two definitions for supermonads. The version 12 | in `Control.Super.Monad` does not have support for constrained 13 | monads. The version in `Control.Super.Monad.Constrained` has 14 | support for constrained monads. The different versions are 15 | provided, because working with the additional constraints 16 | required for constrained monads can be cumbersome sometimes. 17 | We want to offer people a possibility to experiment with supermonads 18 | without having to bother with these constraints, if they don't need 19 | constrained monads. If you have any feedback or suggestions for 20 | improvement from you usage of supermonads, please leave them on 21 | the GitHub bug tracker or write an email to the maintainer. 22 | These parallel structures will not be maintained indefinitely and 23 | at some point we will probably only offer supermonads with support 24 | for constrained monads. 25 | 26 | ## Superapplicatives 27 | 28 | Support for generalized applicatives was added in version 0.2. 29 | For users this does not change anything. 30 | 31 | ## Build Status 32 | 33 | `master` | `dev` 34 | ---------|--------- 35 | [![build status master][TravisBuildMaster]](https://travis-ci.org/jbracker/supermonad) | [![build status dev][TravisBuildDev]](https://travis-ci.org/jbracker/supermonad) 36 | 37 | ## GHC Version 38 | 39 | The implementation has been tested with GHC in version 7.10.3, 8.0.2 and 8.2.1. 40 | 41 | Versions of GHC prior to version 7.10.1 will most certainly not work, 42 | because the plugin mechanism was still in development. 43 | 44 | Newer version of GHC may work. If you encounter problems with a newer version 45 | of GHC, please file a bug report so it can be fixed. 46 | 47 | ## Usage 48 | 49 | To use supermonads in a module you need to do the following: 50 | 51 | * Enable `RebindableSyntax` in your module by using the `LANGUAGE` pragma: 52 | 53 | ```{-# LANGUAGE RebindableSyntax #-}``` 54 | 55 | * Enable the plugin in that modules using the the `OPTIONS_GHC` pragma: 56 | 57 | ```{-# OPTIONS_GHC -fplugin Control.Super.Monad.Plugin #-}``` 58 | 59 | * Import the supermonad prelude `Control.Super.Monad.Prelude`. 60 | If you choose to work with constrained monads you will need to 61 | import `Control.Super.Monad.Constrained.Prelude` instead. 62 | * Make sure to compile the module with the `-dynamic` flag. 63 | This is required for GHC's plugin mechanism to work properly. 64 | 65 | ## Bug Reports 66 | 67 | If you file a bug report, please always include the version of GHC 68 | you are working with and a minimal example that shows the problem. 69 | 70 | ## Examples 71 | 72 | Examples for the use of the plugin with different kinds of monad generalizations 73 | are provided in the `examples` directory. All examples have their own separate 74 | cabal file and offer a version of the code with and without the use of supermonads. 75 | 76 | A minimal example of how to use supermonads can be found under `examples/monad/minimal`. 77 | It is a good entry point to play around with supermonads. 78 | 79 | 80 | [TravisBuildMaster]: https://travis-ci.org/jbracker/supermonad.svg?branch=master 81 | [TravisBuildDev]: https://travis-ci.org/jbracker/supermonad.svg?branch=dev 82 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # Supermonads package changelog 2 | 3 | ## 0.2.0.1 4 | 5 | * Additional examples of supermonads and superapplicatives. 6 | * Reference the papers explaining supermonads and -applicatves 7 | in the readme. 8 | 9 | ## 0.2.0 10 | 11 | * Introduced super-applicatives through the `Applicative` class. 12 | This is a natural broadening of our approach. 13 | * Renamed the constrained `CFunctor` to `Functor` so it can act as a 14 | drop in replacement for the standard functor type class. 15 | * Introduced support for superarrows through the `ArrowArr`, `ArrowSequence`, 16 | `ArrowSelect` and `ArrowCombine` type classes. 17 | * Added `ebba` examples that uses superarrows. 18 | * Restructure modules to put common plugin code into a module that is not 19 | associated with supermonad or superarrows specifically. The old modules 20 | are still provided so that people coming from the paper can still rely on 21 | those instructions. 22 | * Fixed effect monad examples by using the new version of the `effect-monad` 23 | package that supports GHC 8+. 24 | * Generalized and fixed issue with the constrained `WrappedMonad` instances. 25 | 26 | ## 0.1 27 | 28 | * Initial release. 29 | -------------------------------------------------------------------------------- /examples/applicative/bankers/MainMinimalBug.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | {-# LANGUAGE GADTs #-} 5 | 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | 13 | -- Needed for programming on the type level... 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | -- Use the supermonad plugin. 17 | {-# LANGUAGE RebindableSyntax #-} 18 | {-# OPTIONS_GHC -fplugin Control.Super.Monad.Plugin #-} 19 | 20 | {-# LANGUAGE PartialTypeSignatures #-} 21 | 22 | import Control.Super.Monad.Prelude 23 | 24 | main :: IO () 25 | main = return () 26 | 27 | -- Natural numbers on the type level. 28 | data Nat = Z | S Nat 29 | 30 | -- Internal function used to compute the maximum of two numbers on the type-level. 31 | type family MaxInternal (nRec :: Nat) (mRec :: Nat) (n :: Nat) (m :: Nat) where 32 | MaxInternal 'Z mRec n m = m 33 | MaxInternal ('S nRec) ('Z) n m = n 34 | MaxInternal ('S nRec) ('S mRec) n m = MaxInternal nRec mRec n m 35 | 36 | -- Compute the maximum of two numbers on the type-level. 37 | type family Max (n :: Nat) (m :: Nat) :: Nat where 38 | Max n m = MaxInternal n m n m 39 | 40 | -- Check if n is lesser or equal to m. 41 | type family Leq (n :: Nat) (m :: Nat) :: Bool where 42 | Leq 'Z m = 'True -- zero is less or equal to anything 43 | Leq ('S n) 'Z = 'False -- succ of n cannot be smaller then zero. 44 | Leq ('S n) ('S m) = Leq n m 45 | 46 | data MaxRes = MaxRes Nat Nat 47 | 48 | data Exec (i :: MaxRes) a = Exec a 49 | 50 | instance Functor (Exec i) where 51 | fmap f (Exec a) = Exec (f a) 52 | 53 | instance Return (Exec ('MaxRes 'Z 'Z)) where 54 | return = Exec 55 | 56 | -- This is how it should look: 57 | instance ( Max ma1 ma2 ~ maR, Max mb1 mb2 ~ mbR 58 | ) => Applicative (Exec ('MaxRes ma1 mb1)) (Exec ('MaxRes ma2 mb2)) (Exec ('MaxRes maR mbR)) where 59 | Exec f <*> Exec a = Exec (f a) 60 | -- But with this we get problems because the plugin panics during unification. 61 | -- I will have to look into this. 62 | {- 63 | -- The applicative schedules/executes two given processes in parallel. 64 | instance ( 'MaxRes ma1 mb1 ~ m1, 'MaxRes ma2 mb2 ~ m2, 'MaxRes maR mbR ~ mR 65 | , Max ma1 ma2 ~ maR, Max mb1 mb2 ~ mbR 66 | ) => Applicative (Exec m1) (Exec m2) (Exec mR) where 67 | Exec f <*> Exec a = Exec (f a) 68 | -} 69 | 70 | type Zero = 'Z 71 | type One = 'S Zero 72 | type Two = 'S One 73 | type Three = 'S Two 74 | type Four = 'S Three 75 | type Five = 'S Four 76 | type Six = 'S Five 77 | 78 | exec1 :: Exec ('MaxRes Three Zero) (a -> a) 79 | exec1 = Exec id 80 | 81 | exec2 :: Exec ('MaxRes Five Three) () 82 | exec2 = Exec () 83 | 84 | -- This is where the unification error emerges. 85 | exec = (exec1 <*> exec2) :: Exec ('MaxRes _ _) _ 86 | -------------------------------------------------------------------------------- /examples/applicative/bankers/bankers.cabal: -------------------------------------------------------------------------------- 1 | name: bankers-example 2 | version: 0.2.0 3 | synopsis: Example 4 | category: 5 | description: Example 6 | author: Jan Bracker 7 | maintainer: Jan Bracker 8 | stability: experimental 9 | copyright: Copyright (c) 2017, Jan Bracker 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable bankers-sm 14 | build-depends: base >=4.8 15 | , supermonad == 0.2.* 16 | main-is: Main.hs 17 | hs-source-dirs: . 18 | default-language: Haskell2010 19 | ghc-options: -Wall -dynamic -dcore-lint 20 | 21 | executable bankers-minimal-bug-sm 22 | build-depends: base >=4.8 23 | , supermonad == 0.2.* 24 | main-is: MainMinimalBug.hs 25 | hs-source-dirs: . 26 | default-language: Haskell2010 27 | ghc-options: -Wall -dynamic -dcore-lint -------------------------------------------------------------------------------- /examples/applicative/ll1-parser/ll1-parser-example.cabal: -------------------------------------------------------------------------------- 1 | name: ll1-parser-example 2 | version: 0.2.0 3 | synopsis: Example 4 | category: 5 | description: Example 6 | author: Jan Bracker 7 | maintainer: Jan Bracker 8 | stability: experimental 9 | copyright: Copyright (c) 2016, Jan Bracker 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable ll1-parser 14 | build-depends: base >= 4.8 15 | main-is: Main.hs 16 | hs-source-dirs: . 17 | default-language: Haskell2010 18 | ghc-options: -Wall -dynamic -dcore-lint 19 | 20 | executable ll1-parser-sm 21 | build-depends: base >= 4.8 22 | , supermonad == 0.2.* 23 | main-is: MainSuperapplicative.hs 24 | hs-source-dirs: . 25 | default-language: Haskell2010 26 | ghc-options: -Wall -dynamic -dcore-lint -------------------------------------------------------------------------------- /examples/monad/constrained/.gitignore: -------------------------------------------------------------------------------- 1 | 2 | dist/ -------------------------------------------------------------------------------- /examples/monad/constrained/MainSet.hs: -------------------------------------------------------------------------------- 1 | 2 | -- Requires for instances 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | 5 | -- Use the supermonad plugin. 6 | {-# LANGUAGE RebindableSyntax #-} 7 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 8 | 9 | -- Remove this so compilation creates a proper executable. 10 | --module MainSet ( main ) where 11 | 12 | import Control.Supermonad.Constrained.Prelude 13 | 14 | import qualified Data.Set as S 15 | 16 | main :: IO () 17 | main = do 18 | putStrLn $ show $ do 19 | let s = S.fromList ['a', 'b', 'c'] 20 | a <- s 21 | b <- s 22 | c <- fmap (const 'd') s 23 | return [a, b, c] 24 | -------------------------------------------------------------------------------- /examples/monad/constrained/constrained-example.cabal: -------------------------------------------------------------------------------- 1 | name: constrained-example 2 | version: 0.2.0 3 | synopsis: Example 4 | category: 5 | description: Example 6 | author: Jan Bracker 7 | maintainer: Jan Bracker 8 | stability: experimental 9 | copyright: Copyright (c) 2015, Jan Bracker 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable constrained-example-set 14 | build-depends: base >=4.8 15 | , containers >=0.5 && <0.6 16 | , supermonad ==0.2.* 17 | main-is: MainSet.hs 18 | hs-source-dirs: . 19 | default-language: Haskell2010 20 | ghc-options: -Wall -dynamic -dcore-lint 21 | -------------------------------------------------------------------------------- /examples/monad/effect/.gitignore: -------------------------------------------------------------------------------- 1 | 2 | dist/ -------------------------------------------------------------------------------- /examples/monad/effect/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | 8 | module Main ( main, write ) where 9 | 10 | import Prelude 11 | import qualified Control.Effect as E 12 | import Control.Effect.State 13 | 14 | ifThenElse :: Bool -> a -> a -> a 15 | ifThenElse True t e = t 16 | ifThenElse False t e = e 17 | 18 | main :: IO () 19 | main = do 20 | putStrLn $ show $ runState 21 | ( write "abc" ) 22 | ( Ext (Var :-> 0 :! Eff) (Ext (Var :-> [] :! Eff) Empty) ) 23 | 24 | varC :: Var "count" 25 | varC = Var 26 | varS :: Var "out" 27 | varS = Var 28 | 29 | incC :: State '["count" :-> Int :! 'RW] Int 30 | incC = do { x <- get varC; put varC (x + 1); return (x + 1) } 31 | where (>>=) :: (E.Inv State f g) => State f a -> (a -> State g b) -> State (E.Plus State f g) b 32 | (>>=) = (E.>>=) 33 | (>>) :: (E.Inv State f g) => State f a -> State g b -> State (E.Plus State f g) b 34 | (>>) = (E.>>) 35 | return :: a -> State '[] a 36 | return = E.return 37 | fail = E.fail 38 | 39 | writeS :: [a] -> State '["out" :-> [a] :! 'RW] () 40 | writeS y = do { x <- get varS; put varS (x ++ y) } 41 | where (>>=) :: (E.Inv State f g) => State f a -> (a -> State g b) -> State (E.Plus State f g) b 42 | (>>=) = (E.>>=) 43 | (>>) :: (E.Inv State f g) => State f a -> State g b -> State (E.Plus State f g) b 44 | (>>) = (E.>>) 45 | return :: a -> State '[] a 46 | return = E.return 47 | fail = E.fail 48 | 49 | write :: [a] -> State '["count" :-> Int :! 'RW, "out" :-> [a] :! 'RW] () 50 | write x = do { writeS x; _ <- incC; return () } 51 | where (>>=) :: (E.Inv State f g) => State f a -> (a -> State g b) -> State (E.Plus State f g) b 52 | (>>=) = (E.>>=) 53 | (>>) :: (E.Inv State f g) => State f a -> State g b -> State (E.Plus State f g) b 54 | (>>) = (E.>>) 55 | return :: a -> State '[] a 56 | return = E.return 57 | fail = E.fail 58 | -------------------------------------------------------------------------------- /examples/monad/effect/Main2.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | import Prelude 7 | import Prelude as P 8 | 9 | import Control.Effect as E 10 | import Control.Effect.Reader 11 | 12 | ifThenElse :: Bool -> a -> a -> a 13 | ifThenElse True t e = t 14 | ifThenElse False t e = e 15 | 16 | main :: IO () 17 | main = do 18 | let l = runReader (flatFilter tree) (Ext vThres 3 Empty) 19 | print l 20 | print (sum l) 21 | where (>>) = (P.>>) 22 | return :: a -> IO a 23 | return = P.return 24 | 25 | vThres :: Var "thres" 26 | vThres = Var 27 | 28 | data Tree = Leaf Int 29 | | Branch Tree Tree 30 | deriving Show 31 | 32 | tree :: Tree 33 | tree = Branch (Branch (Leaf 1) (Leaf 4)) (Leaf 5) 34 | 35 | flatFilter :: Tree -> Reader '["thres" ':-> Int] [Int] 36 | flatFilter ( Leaf i ) = do 37 | thres <- ask vThres 38 | return (if i < thres then [] else [i]) 39 | where 40 | (>>=) :: (E.Inv Reader f g) => Reader f a -> (a -> Reader g b) -> Reader (E.Plus Reader f g) b 41 | (>>=) = (E.>>=) 42 | return = E.return 43 | fail = E.fail 44 | flatFilter ( Branch l r ) = do 45 | ls <- flatFilter l 46 | rs <- flatFilter r 47 | return (ls ++ rs) 48 | where 49 | (>>=) :: (E.Inv Reader f g) => Reader f a -> (a -> Reader g b) -> Reader (E.Plus Reader f g) b 50 | (>>=) = (E.>>=) 51 | return = E.return 52 | fail = E.fail 53 | -------------------------------------------------------------------------------- /examples/monad/effect/Main3.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RebindableSyntax #-} 3 | 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | import Prelude 9 | import Prelude as P 10 | 11 | import Control.Effect as E 12 | import Control.Effect.CounterNat 13 | 14 | import GHC.TypeLits ( type (+) ) 15 | 16 | ifThenElse :: Bool -> a -> a -> a 17 | ifThenElse True t e = t 18 | ifThenElse False t e = e 19 | 20 | main :: IO () 21 | main = do 22 | print $ forget (limitedOp 1 2 3 4) -- 10 23 | where return :: (Monad m) => a -> m a 24 | return = P.return 25 | 26 | specialOp :: Int -> Int -> Counter 1 Int 27 | specialOp n m = tick (n + m) 28 | 29 | limitedOp :: Int -> Int -> Int -> Int -> Counter 3 Int 30 | limitedOp a b c d = do 31 | ab <- specialOp a b 32 | abc <- specialOp ab c 33 | specialOp abc d 34 | where (>>=) :: Counter n a -> (a -> Counter m b) -> Counter (n + m) b 35 | (>>=) = (E.>>=) 36 | fail = E.fail 37 | return :: a -> Counter 0 a 38 | return = E.return 39 | -------------------------------------------------------------------------------- /examples/monad/effect/MainSupermonad.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE CPP #-} 3 | 4 | {-# LANGUAGE RebindableSyntax #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | 12 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0) 13 | -- Required for the 'Bind' instance since GHC 8.0.1 14 | {-# LANGUAGE UndecidableInstances #-} 15 | #endif 16 | 17 | -- Ignore our orphan instance in this file. 18 | {-# OPTIONS_GHC -fno-warn-orphans #-} 19 | 20 | -- Use the supermonad plugin. 21 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 22 | 23 | import Control.Supermonad.Prelude 24 | 25 | import Control.Effect ( Plus, Inv ) 26 | import qualified Control.Effect as E 27 | import Control.Effect.State 28 | 29 | instance Functor (State (s :: [*])) where 30 | fmap f ma = State $ \s -> let (a, s') = runState ma s in (f a, s') 31 | 32 | instance ( h ~ Plus State f g ) => Applicative (State (f :: [*])) (State (g :: [*])) (State (h :: [*])) where 33 | type ApplicativeCts (State (f :: [*])) (State (g :: [*])) (State (h :: [*])) = Inv State f g 34 | mf <*> ma = mf E.>>= \f -> fmap f ma 35 | 36 | instance ( h ~ Plus State f g ) => Bind (State (f :: [*])) (State (g :: [*])) (State (h :: [*])) where 37 | type BindCts (State (f :: [*])) (State (g :: [*])) (State (h :: [*])) = Inv State f g 38 | (>>=) = (E.>>=) 39 | 40 | instance Return (State '[]) where 41 | return = E.return 42 | 43 | instance Fail (State (h :: [*])) where 44 | fail = E.fail 45 | 46 | main :: IO () 47 | main = do 48 | putStrLn $ show $ runState 49 | ( write "abc" ) 50 | ( Ext (Var :-> 0 :! Eff) (Ext (Var :-> [] :! Eff) Empty) ) 51 | 52 | varC :: Var "count" 53 | varC = Var 54 | varS :: Var "out" 55 | varS = Var 56 | 57 | incC :: State '["count" :-> Int :! 'RW] Int 58 | incC = do 59 | x <- get varC 60 | put varC (x + 1) 61 | return (x + 1) 62 | 63 | writeS :: [a] -> State '["out" :-> [a] :! 'RW] () 64 | writeS y = do 65 | x <- get varS 66 | put varS (x ++ y) 67 | 68 | write :: [a] -> State '["count" :-> Int :! 'RW, "out" :-> [a] :! 'RW] () 69 | write x = do 70 | writeS x 71 | _ <- incC 72 | return () 73 | -------------------------------------------------------------------------------- /examples/monad/effect/MainSupermonad2.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE CPP #-} 3 | 4 | {-# LANGUAGE RebindableSyntax #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | 12 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0) 13 | -- Required for the 'Bind' instance since GHC 8.0.1 14 | {-# LANGUAGE UndecidableInstances #-} 15 | #endif 16 | 17 | -- Ignore our orphan instance in this file. 18 | {-# OPTIONS_GHC -fno-warn-orphans #-} 19 | 20 | -- Use the supermonad plugin. 21 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 22 | 23 | import Control.Supermonad.Prelude 24 | 25 | import qualified Control.Effect as E 26 | import Control.Effect ( Plus, Inv ) 27 | import Control.Effect.Reader 28 | 29 | import GHC.TypeLits ( Symbol ) 30 | 31 | instance Functor (Reader (s :: [Mapping Symbol *])) where 32 | fmap f ma = IxR $ \s -> f $ runReader ma s 33 | 34 | instance ( h ~ Plus Reader f g) => Bind (Reader (f :: [Mapping Symbol *])) (Reader (g :: [Mapping Symbol *])) (Reader (h :: [Mapping Symbol *])) where 35 | type BindCts (Reader (f :: [Mapping Symbol *])) (Reader (g :: [Mapping Symbol *])) (Reader (h :: [Mapping Symbol *])) = Inv Reader f g 36 | (>>=) = (E.>>=) 37 | 38 | instance Return (Reader '[]) where 39 | return = E.return 40 | 41 | instance ( h ~ Plus Reader f g) => Applicative (Reader (f :: [Mapping Symbol *])) (Reader (g :: [Mapping Symbol *])) (Reader (h :: [Mapping Symbol *])) where 42 | type ApplicativeCts (Reader (f :: [Mapping Symbol *])) (Reader (g :: [Mapping Symbol *])) (Reader (h :: [Mapping Symbol *])) = Inv Reader f g 43 | mf <*> ma = mf E.>>= \f -> fmap f ma 44 | 45 | instance Fail (Reader (h :: [Mapping Symbol *])) where 46 | fail = E.fail 47 | 48 | main :: IO () 49 | main = do 50 | let l = runReader (flatFilter tree) (Ext vThres 3 Empty) 51 | print l 52 | print (sum l) 53 | 54 | vThres :: Var "thres" 55 | vThres = Var 56 | 57 | data Tree = Leaf Int 58 | | Branch Tree Tree 59 | deriving Show 60 | 61 | tree :: Tree 62 | tree = Branch (Branch (Leaf 1) (Leaf 4)) (Leaf 5) 63 | 64 | flatFilter :: Tree -> Reader '["thres" ':-> Int] [Int] 65 | flatFilter ( Leaf i ) = do 66 | thres <- ask vThres 67 | return (if i < thres then [] else [i]) 68 | flatFilter ( Branch l r ) = do 69 | ls <- flatFilter l 70 | rs <- flatFilter r 71 | return (ls ++ rs) 72 | -------------------------------------------------------------------------------- /examples/monad/effect/MainSupermonad3.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE DataKinds #-} 5 | --{-# LANGUAGE TypeOperators #-} 6 | 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | 10 | -- Ignore our orphan instance in this file. 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | -- Use the supermonad plugin. 14 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 15 | 16 | import Control.Supermonad.Prelude 17 | 18 | import qualified Control.Effect as E 19 | import Control.Effect ( Plus, Inv ) 20 | import Control.Effect.CounterNat 21 | 22 | import GHC.TypeLits 23 | 24 | instance Functor (Counter (s :: Nat)) where 25 | fmap f ma = ma E.>>= (E.return . f) 26 | 27 | instance (h ~ Plus Counter f g) => Bind (Counter (f :: Nat)) (Counter (g :: Nat)) (Counter (h :: Nat)) where 28 | type BindCts (Counter (f :: Nat)) (Counter (g :: Nat)) (Counter (h :: Nat)) = Inv Counter f g 29 | (>>=) = (E.>>=) 30 | 31 | instance Return (Counter (0 :: Nat)) where 32 | return = E.return 33 | 34 | instance (h ~ Plus Counter f g) => Applicative (Counter (f :: Nat)) (Counter (g :: Nat)) (Counter (h :: Nat)) where 35 | type ApplicativeCts (Counter (f :: Nat)) (Counter (g :: Nat)) (Counter (h :: Nat)) = Inv Counter f g 36 | mf <*> ma = mf E.>>= \f -> fmap f ma 37 | 38 | instance Fail (Counter (h :: Nat)) where 39 | fail = E.fail 40 | 41 | main :: IO () 42 | main = do 43 | print $ forget (limitedOp 1 2 3 4) -- 10 44 | 45 | specialOp :: Int -> Int -> Counter 1 Int 46 | specialOp n m = tick (n + m) 47 | 48 | limitedOp :: Int -> Int -> Int -> Int -> Counter 3 Int 49 | limitedOp a b c d = do 50 | ab <- specialOp a b 51 | abc <- specialOp ab c 52 | specialOp abc d 53 | -------------------------------------------------------------------------------- /examples/monad/effect/Vector.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE GADTs #-} 7 | --{-# LANGUAGE TypeOperators #-} 8 | 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | -- Ignore our orphan instance in this file. 14 | {-# OPTIONS_GHC -fno-warn-orphans #-} 15 | 16 | -- Use the supermonad plugin. 17 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 18 | 19 | import Control.Supermonad.Prelude hiding ( concatMap, map ) 20 | 21 | import qualified Control.Effect as E 22 | import Control.Effect ( Plus, Inv ) 23 | 24 | data Nat = Z | S Nat 25 | 26 | data Vector (n :: Nat) a where 27 | Nil :: Vector Z a 28 | Cons :: a -> Vector n a -> Vector (S n) a 29 | 30 | type family Add (n :: Nat) (m :: Nat) :: Nat where 31 | Add Z m = m 32 | Add (S n) m = S (Add n m) 33 | 34 | type family Mult (n :: Nat) (m :: Nat) :: Nat where 35 | Mult Z m = Z 36 | Mult (S n) m = Add m (Mult n m) 37 | 38 | map :: (a -> b) -> Vector n a -> Vector n b 39 | map f Nil = Nil 40 | map f (Cons x xs) = Cons (f x) (map f xs) 41 | 42 | append :: Vector n a -> Vector m a -> Vector (Add n m) a 43 | append Nil ys = ys 44 | append (Cons x xs) ys = Cons x (append xs ys) 45 | 46 | concatMap :: Vector n a -> (a -> Vector m b) -> Vector (Mult n m) b 47 | concatMap Nil f = Nil 48 | concatMap (Cons x xs) f = append (f x) (concatMap xs f) 49 | 50 | singleton :: a -> Vector (S Z) a 51 | singleton a = Cons a Nil 52 | 53 | instance E.Effect Vector where 54 | type Unit Vector = S Z 55 | type Plus Vector n m = Mult n m 56 | type Inv Vector n m = () 57 | 58 | return = singleton 59 | (>>=) = concatMap 60 | 61 | instance Functor (Vector (n :: Nat)) where 62 | fmap f xs = map f xs 63 | 64 | instance ( nm ~ Plus Vector n m 65 | ) => Bind (Vector (n :: Nat)) (Vector (m :: Nat)) (Vector (nm :: Nat)) where 66 | type BindCts (Vector (n :: Nat)) (Vector (m :: Nat)) (Vector (nm :: Nat)) = Inv Vector n m 67 | (>>=) = (E.>>=) 68 | 69 | instance Return (Vector (S Z)) where 70 | return = E.return 71 | 72 | instance ( nm ~ Plus Vector n m 73 | ) => Applicative (Vector (n :: Nat)) (Vector (m :: Nat)) (Vector (nm :: Nat)) where 74 | type ApplicativeCts (Vector (n:: Nat)) (Vector (m :: Nat)) (Vector (nm :: Nat)) = Inv Vector n m 75 | mf <*> ma = mf E.>>= \f -> fmap f ma 76 | 77 | instance Fail (Vector (n :: Nat)) where 78 | fail = E.fail 79 | 80 | main :: IO () 81 | main = return () -------------------------------------------------------------------------------- /examples/monad/effect/effect-example.cabal: -------------------------------------------------------------------------------- 1 | name: effect-example 2 | version: 0.2.0 3 | synopsis: Example 4 | category: 5 | description: Example 6 | author: Jan Bracker 7 | maintainer: Jan Bracker 8 | stability: experimental 9 | copyright: Copyright (c) 2015, Jan Bracker 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable effect-example 14 | build-depends: base >= 4.8, 15 | effect-monad == 0.7.* 16 | main-is: Main.hs 17 | hs-source-dirs: . 18 | default-language: Haskell2010 19 | ghc-options: -Wall -dynamic -dcore-lint 20 | -fno-warn-unused-binds -fno-warn-unused-matches 21 | -fno-warn-name-shadowing 22 | 23 | executable effect-example-pm 24 | build-depends: base >= 4.8, 25 | effect-monad == 0.7.*, 26 | supermonad == 0.2.* 27 | main-is: MainSupermonad.hs 28 | hs-source-dirs: . 29 | default-language: Haskell2010 30 | ghc-options: -Wall -dynamic -dcore-lint -fno-opt-coercion 31 | 32 | executable effect-example2 33 | build-depends: base >= 4.8, 34 | effect-monad == 0.7.* 35 | main-is: Main2.hs 36 | hs-source-dirs: . 37 | default-language: Haskell2010 38 | ghc-options: -Wall -dynamic -dcore-lint 39 | -fno-warn-unused-binds -fno-warn-unused-matches 40 | -fno-warn-name-shadowing 41 | 42 | executable effect-example2-pm 43 | build-depends: base >= 4.8, 44 | effect-monad == 0.7.*, 45 | supermonad == 0.2.* 46 | main-is: MainSupermonad2.hs 47 | hs-source-dirs: . 48 | default-language: Haskell2010 49 | ghc-options: -Wall -dynamic -dcore-lint -fno-opt-coercion 50 | -- -dcore-lint 51 | 52 | executable effect-example3 53 | build-depends: base >= 4.8, 54 | effect-monad == 0.7.* 55 | main-is: Main3.hs 56 | hs-source-dirs: . 57 | default-language: Haskell2010 58 | ghc-options: -Wall -dynamic -dcore-lint 59 | -fno-warn-unused-binds -fno-warn-unused-matches 60 | -fno-warn-name-shadowing 61 | 62 | executable effect-example3-pm 63 | build-depends: base >= 4.8, 64 | effect-monad == 0.7.*, 65 | supermonad == 0.2.* 66 | main-is: MainSupermonad3.hs 67 | hs-source-dirs: . 68 | default-language: Haskell2010 69 | ghc-options: -Wall -dynamic -dcore-lint -fno-opt-coercion 70 | 71 | executable effect-example-vector 72 | build-depends: base >= 4.8, 73 | effect-monad == 0.7.*, 74 | supermonad == 0.2.* 75 | main-is: Vector.hs 76 | hs-source-dirs: . 77 | default-language: Haskell2010 78 | ghc-options: -Wall -dynamic -dcore-lint -fno-opt-coercion -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/.gitignore: -------------------------------------------------------------------------------- 1 | 2 | dist/ -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/LibMT.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: LibMT * 6 | * Purpose: TAM code for LibMT: the MiniTriangle std library. * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | LibMT: MiniTriangle Standard Library 15 | 16 | module LibMT ( 17 | libMT -- :: [TAMInst] 18 | ) where 19 | 20 | import Data.Char (ord) 21 | 22 | -- HMTC module imports 23 | import Name 24 | import TAMCode 25 | 26 | 27 | -- | The MiniTriangle standard library: code for functions and procedures 28 | -- declared in the standard environment as well as for internal use by the 29 | -- TAM \"runtime\" system. Note that the code generator makes assumptions 30 | -- about the meaning of many of these routines (\"add\" etc.) based on their 31 | -- names for optimization purposes. 32 | 33 | libMT :: [TAMInst] 34 | libMT = [ 35 | -- preinc 36 | Label "preinc", 37 | LOAD (LB (-1)), 38 | LOADI 0, 39 | LOADL 1, 40 | ADD, 41 | LOAD (ST (-1)), 42 | LOAD (LB (-1)), 43 | STOREI 0, 44 | RETURN 1 1, 45 | 46 | -- predec 47 | Label "predec", 48 | LOAD (LB (-1)), 49 | LOADI 0, 50 | LOADL 1, 51 | SUB, 52 | LOAD (ST (-1)), 53 | LOAD (LB (-1)), 54 | STOREI 0, 55 | RETURN 1 1, 56 | 57 | -- postinc 58 | Label "postinc", 59 | LOAD (LB (-1)), 60 | LOADI 0, 61 | LOAD (ST (-1)), 62 | LOADL 1, 63 | ADD, 64 | LOAD (LB (-1)), 65 | STOREI 0, 66 | RETURN 1 1, 67 | 68 | -- postdec 69 | Label "postdec", 70 | LOAD (LB (-1)), 71 | LOADI 0, 72 | LOAD (ST (-1)), 73 | LOADL 1, 74 | SUB, 75 | LOAD (LB (-1)), 76 | STOREI 0, 77 | RETURN 1 1, 78 | 79 | -- add 80 | Label "add", 81 | LOAD (LB (-2)), 82 | LOAD (LB (-1)), 83 | ADD, 84 | RETURN 1 2, 85 | 86 | -- sub 87 | Label "sub", 88 | LOAD (LB (-2)), 89 | LOAD (LB (-1)), 90 | SUB, 91 | RETURN 1 2, 92 | 93 | -- mul 94 | Label "mul", 95 | LOAD (LB (-2)), 96 | LOAD (LB (-1)), 97 | MUL, 98 | RETURN 1 2, 99 | 100 | -- div 101 | Label "div", 102 | LOAD (LB (-2)), 103 | LOAD (LB (-1)), 104 | DIV, 105 | RETURN 1 2, 106 | 107 | -- pow 108 | Label "pow", 109 | LOADL 1, 110 | Label "pow_loop", 111 | LOAD (LB (-1)), 112 | LOADL 0, 113 | GTR, 114 | JUMPIFZ "pow_out", 115 | LOAD (LB (-1)), 116 | LOADL 1, 117 | SUB, 118 | STORE (LB (-1)), 119 | LOAD (LB (-2)), 120 | MUL, 121 | JUMP "pow_loop", 122 | Label "pow_out", 123 | RETURN 1 2, 124 | 125 | -- neg 126 | Label "neg", 127 | LOAD (LB (-1)), 128 | NEG, 129 | RETURN 1 1, 130 | 131 | -- lt 132 | Label "lt", 133 | LOAD (LB (-2)), 134 | LOAD (LB (-1)), 135 | LSS, 136 | RETURN 1 2, 137 | 138 | -- le 139 | Label "le", 140 | LOAD (LB (-2)), 141 | LOAD (LB (-1)), 142 | GTR, 143 | NOT, 144 | RETURN 1 2, 145 | 146 | -- eq 147 | Label "eq", 148 | LOAD (LB (-2)), 149 | LOAD (LB (-1)), 150 | EQL, 151 | RETURN 1 2, 152 | 153 | -- ne 154 | Label "ne", 155 | LOAD (LB (-2)), 156 | LOAD (LB (-1)), 157 | EQL, 158 | NOT, 159 | RETURN 1 2, 160 | 161 | -- ge 162 | Label "ge", 163 | LOAD (LB (-2)), 164 | LOAD (LB (-1)), 165 | LSS, 166 | NOT, 167 | RETURN 1 2, 168 | 169 | -- gt 170 | Label "gt", 171 | LOAD (LB (-2)), 172 | LOAD (LB (-1)), 173 | GTR, 174 | RETURN 1 2, 175 | 176 | -- and 177 | Label "and", 178 | LOAD (LB (-2)), 179 | LOAD (LB (-1)), 180 | AND, 181 | RETURN 1 2, 182 | 183 | -- or 184 | Label "or", 185 | LOAD (LB (-2)), 186 | LOAD (LB (-1)), 187 | OR, 188 | RETURN 1 2, 189 | 190 | -- not 191 | Label "not", 192 | LOAD (LB (-1)), 193 | NOT, 194 | RETURN 1 1, 195 | 196 | -- getchr 197 | Label "getchr", 198 | GETCHR, 199 | LOAD (LB (-1)), 200 | STOREI 0, 201 | RETURN 0 1, 202 | 203 | -- putchr 204 | Label "putchr", 205 | LOAD (LB (-1)), 206 | PUTCHR, 207 | RETURN 0 1, 208 | 209 | -- getint 210 | Label "getint", 211 | GETINT, 212 | LOAD (LB (-1)), 213 | STOREI 0, 214 | RETURN 0 1, 215 | 216 | -- putint 217 | Label "putint", 218 | LOAD (LB (-1)), 219 | PUTINT, 220 | RETURN 0 1, 221 | 222 | -- skip 223 | Label "skip", 224 | RETURN 0 0, 225 | 226 | -- ixerror 227 | Label "ixerror", 228 | LOADL (chr 'I'), 229 | PUTCHR, 230 | LOADL (chr 'x'), 231 | PUTCHR, 232 | LOADL (chr ':'), 233 | PUTCHR, 234 | LOADL (chr ' '), 235 | PUTCHR, 236 | LOAD (LB (-1)), 237 | PUTINT, 238 | HALT 239 | ] 240 | 241 | 242 | chr :: Char -> MTInt 243 | chr c = fromIntegral (ord c) 244 | -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/MTStdEnv.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: MTStdEnv * 6 | * Purpose: MiniTriangle Initial Environment * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | MiniTriangle initial environment 15 | 16 | module MTStdEnv ( 17 | Env, -- Re-exported 18 | mtStdEnv -- :: Env 19 | ) where 20 | 21 | 22 | -- HMTC module imports 23 | import Name 24 | import TAMCode (MTInt) 25 | import Type 26 | import Symbol (ExtSymVal (..)) 27 | import Env 28 | 29 | 30 | -- | The MiniTriangle initial environment. 31 | -- 32 | -- [Types:] Boolean, Character, Integer 33 | -- 34 | -- [Constants:] 35 | -- 36 | -- * false, true : Boolean 37 | -- 38 | -- * minint, maxint : Integer 39 | -- 40 | -- [Functions (binary (infix) and unary (prefix/postfix) operators):] 41 | -- 42 | -- * (++_), (--_), (_++), (_--) : (Ref Integer) -> Integer 43 | -- 44 | -- * (_+_), (_-_), (_*_), (_\/_), (_\^_) : (Integer, Integer) -> Integer 45 | -- 46 | -- * (-_) : Integer -> Integer 47 | -- 48 | -- * (_\<_), (_\<=_), (_==_), (_!=_), (_>=_), (_>_) : 49 | -- (Integer, Integer) -> Boolean, 50 | -- (Boolan, Boolean) -> Boolean 51 | -- 52 | -- * (_&&_), (_||_) : (Boolean, Boolean) -> Boolean 53 | -- 54 | -- * (!_) : Boolean -> Boolean 55 | -- 56 | -- [Procedures:] 57 | -- 58 | -- * getchr : (Snk Character) -> Void 59 | -- 60 | -- * putchr : Character -> Void 61 | -- 62 | -- * getint : (Snk Integer) -> Void 63 | -- 64 | -- * putint : Integer -> Void 65 | -- 66 | -- * skip : () -> Void 67 | -- 68 | -- Note the naming convention for infix/prefix/postfix operators with 69 | -- underscore indicating the argument position(s). Parser assumes this. 70 | -- Note that labels have to agree with the code in "LibMT". 71 | 72 | mtStdEnv :: Env 73 | mtStdEnv = 74 | mkTopLvlEnv 75 | [("Boolean", Boolean), 76 | ("Character", Character), 77 | ("Integer", Integer)] 78 | [("false", Boolean, ESVBool False), 79 | ("true", Boolean, ESVBool True), 80 | ("minint", Integer, ESVInt (minBound :: MTInt)), 81 | ("maxint", Integer, ESVInt (maxBound :: MTInt)), 82 | ("++_", Arr [Ref Integer] Integer, ESVLbl "preinc"), 83 | ("--_", Arr [Ref Integer] Integer, ESVLbl "predec"), 84 | ("_++", Arr [Ref Integer] Integer, ESVLbl "postinc"), 85 | ("_--", Arr [Ref Integer] Integer, ESVLbl "postdec"), 86 | ("_+_", Arr [Integer, Integer] Integer, ESVLbl "add"), 87 | ("_-_", Arr [Integer, Integer] Integer, ESVLbl "sub"), 88 | ("_*_", Arr [Integer, Integer] Integer, ESVLbl "mul"), 89 | ("_/_", Arr [Integer, Integer] Integer, ESVLbl "div"), 90 | ("_^_", Arr [Integer, Integer] Integer, ESVLbl "pow"), 91 | ("-_", Arr [Integer] Integer, ESVLbl "neg"), 92 | -- The comparison operators are overloaded, but their impl. shared. 93 | ("_<_", Arr [Integer, Integer] Boolean, ESVLbl "lt"), 94 | ("_<=_", Arr [Integer, Integer] Boolean, ESVLbl "le"), 95 | ("_==_", Arr [Integer, Integer] Boolean, ESVLbl "eq"), 96 | ("_!=_", Arr [Integer, Integer] Boolean, ESVLbl "ne"), 97 | ("_>=_", Arr [Integer, Integer] Boolean, ESVLbl "ge"), 98 | ("_>_", Arr [Integer, Integer] Boolean, ESVLbl "gt"), 99 | ("_<_", Arr [Boolean, Boolean] Boolean, ESVLbl "lt"), 100 | ("_<=_", Arr [Boolean, Boolean] Boolean, ESVLbl "le"), 101 | ("_==_", Arr [Boolean, Boolean] Boolean, ESVLbl "eq"), 102 | ("_!=_", Arr [Boolean, Boolean] Boolean, ESVLbl "ne"), 103 | ("_>=_", Arr [Boolean, Boolean] Boolean, ESVLbl "ge"), 104 | ("_>_", Arr [Boolean, Boolean] Boolean, ESVLbl "gt"), 105 | ("_&&_", Arr [Boolean, Boolean] Boolean, ESVLbl "and"), 106 | ("_||_", Arr [Boolean, Boolean] Boolean, ESVLbl "or"), 107 | ("!_", Arr [Boolean] Boolean, ESVLbl "not"), 108 | ("getchr", Arr [Snk Character] Void, ESVLbl "getchr"), 109 | ("putchr", Arr [Character] Void, ESVLbl "putchr"), 110 | ("getint", Arr [Snk Integer] Void, ESVLbl "getint"), 111 | ("putint", Arr [Integer] Void, ESVLbl "putint"), 112 | ("skip", Arr [] Void, ESVLbl "skip")] 113 | -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/Makefile: -------------------------------------------------------------------------------- 1 | ############################################################################## 2 | # 3 | # Makefile for HMTC 4 | # Copyright (c) Henrik Nilsson, 2006 5 | # 6 | ############################################################################## 7 | 8 | # Initial "all" target: 9 | # This goes first to make it the default target. 10 | 11 | .PHONY: all doc clean really-clean 12 | 13 | all: hmtc 14 | 15 | 16 | #----------------------------------------------------------------------------- 17 | # Source files: 18 | #----------------------------------------------------------------------------- 19 | 20 | # Haskell sources. 21 | hs_sources = \ 22 | AST.hs \ 23 | CodeGenerator.hs \ 24 | CodeGenMonad.hs \ 25 | Diagnostics.hs \ 26 | Env.hs \ 27 | LibMT.hs \ 28 | Main.hs \ 29 | MTIR.hs \ 30 | MTStdEnv.hs \ 31 | Name.hs \ 32 | ParseMonad.hs \ 33 | Parser.hs \ 34 | PPAST.hs \ 35 | PPMTIR.hs \ 36 | PPTAMCode.hs \ 37 | PPUtilities.hs \ 38 | Scanner.hs \ 39 | ScopeLevel.hs \ 40 | SrcPos.hs \ 41 | Symbol.hs \ 42 | TAMCode.hs \ 43 | TAMCodeParser.hs \ 44 | TAMInterpreter.hs \ 45 | Token.hs \ 46 | TypeChecker.hs \ 47 | Type.hs 48 | 49 | 50 | #----------------------------------------------------------------------------- 51 | # Tools, arguments, and auxiliary files 52 | #----------------------------------------------------------------------------- 53 | 54 | SHELL = /bin/sh 55 | 56 | HS_OPTS += -O $(HS_PACKAGES) $(HS_EXTRA_IMPORTS) $(HS_USER_OPTS) 57 | MAKE.hs = ghc --make $(HS_OPTS) -o $@ 58 | 59 | # ghc-specific (for now) 60 | HAPPY = happy -agc 61 | 62 | 63 | #----------------------------------------------------------------------------- 64 | # Auxiliary variables 65 | #----------------------------------------------------------------------------- 66 | 67 | hs_interfaces := $(hs_sources:.hs=.hi) 68 | hs_objects := $(hs_sources:.hs=.o) 69 | 70 | #----------------------------------------------------------------------------- 71 | # Implicit rules for Haskell 72 | #----------------------------------------------------------------------------- 73 | 74 | # Happy: Run CPP on the output from Happy to make Haddock happy! :-) 75 | %.hs: %.y 76 | $(HAPPY) --outfile=happy-output.hs $< 77 | ghc -cpp -E -optP-P -o $@ happy-output.hs 78 | rm happy-output.hs 79 | 80 | 81 | #----------------------------------------------------------------------------- 82 | # Compilation of the Haskell Mini Triangle Compiler 83 | #----------------------------------------------------------------------------- 84 | 85 | hmtc: $(hs_sources) 86 | $(MAKE.hs) Main 87 | 88 | 89 | #----------------------------------------------------------------------------- 90 | # Generating documentation 91 | #----------------------------------------------------------------------------- 92 | 93 | doc: Doc $(hs_sources) 94 | haddock --html --odir=Doc $(hs_sources) --title=HMTC 95 | 96 | Doc: 97 | mkdir Doc 98 | 99 | 100 | #----------------------------------------------------------------------------- 101 | # Cleaning 102 | #----------------------------------------------------------------------------- 103 | 104 | clean: 105 | -$(RM) $(hs_interfaces) $(hs_objects) hmtc 106 | 107 | really-clean: clean 108 | -$(RM) Parser.hs 109 | -$(RM) TAMCodeParser.hs 110 | -rm -rf Doc 111 | -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/Name.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: Name * 6 | * Purpose: Representation of names * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2012 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | Representation of names. Types, variables, procedures, operators ... 15 | 16 | module Name where 17 | 18 | type Name = String 19 | -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/PPUtilities.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: PPUtilities * 6 | * Purpose: Pretty-printing utilities * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2012 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | Pretty-printing utilities. 15 | 16 | module PPUtilities ( 17 | ppName, -- :: Name -> ShowS 18 | ppSrcPos, -- :: SrcPos -> ShowS 19 | ppOpt, -- :: Int -> (Int -> a -> ShowS) -> Maybe a -> ShowS 20 | ppSeq, -- :: Int -> (Int -> a -> ShowS) -> [a] -> ShowS 21 | indent, -- :: Int -> ShowS 22 | nl, -- :: ShowS 23 | spc, -- :: ShowS 24 | spcs, -- :: Int -> ShowS 25 | leftJust, -- :: Int -> String -> ShowS 26 | rightJust -- :: Int -> String -> ShowS 27 | ) where 28 | 29 | -- HMTC module imports 30 | import Name (Name) 31 | import SrcPos (SrcPos) 32 | 33 | ------------------------------------------------------------------------------ 34 | -- Utilities 35 | ------------------------------------------------------------------------------ 36 | 37 | -- | Pretty-prints a name. 38 | ppName :: Name -> ShowS 39 | ppName n = showChar '\"' . showString n . showChar '\"' 40 | 41 | 42 | -- | Pretty-prints a source code position. 43 | ppSrcPos :: SrcPos -> ShowS 44 | ppSrcPos sp = showChar '<' . showString (show sp) . showChar '>' 45 | 46 | 47 | -- | Pretty-prints an optional item. Arguments: 48 | -- 49 | -- (1) Indentation level. 50 | -- 51 | -- (2) Pretty-printing function for the item. 52 | -- 53 | -- (3) The optional item to print. 54 | ppOpt :: Int -> (Int -> a -> ShowS) -> Maybe a -> ShowS 55 | ppOpt _ _ Nothing = id 56 | ppOpt n pp (Just x) = pp n x 57 | 58 | 59 | -- | Pretty-prints a sequence of items. Arguments: 60 | -- 61 | -- (1) Indentation level. 62 | -- 63 | -- (2) Pretty-printing function for each item. 64 | -- 65 | -- (3) Sequence of items to print. 66 | ppSeq :: Int -> (Int -> a -> ShowS) -> [a] -> ShowS 67 | ppSeq _ _ [] = id 68 | ppSeq n pp (x:xs) = pp n x . ppSeq n pp xs 69 | 70 | 71 | -- | Indent to specified level by printing spaces. 72 | indent :: Int -> ShowS 73 | indent n = spcs (2 * n) 74 | 75 | 76 | -- | Start a new line. 77 | nl :: ShowS 78 | nl = showChar '\n' 79 | 80 | 81 | -- | Print a space. 82 | spc :: ShowS 83 | spc = showChar ' ' 84 | 85 | 86 | -- | Print n spaces. 87 | spcs :: Int -> ShowS 88 | spcs n = showString (take n (repeat ' ')) 89 | 90 | 91 | -- | Left justify in field of width n 92 | leftJust :: Int -> String -> ShowS 93 | leftJust n s = showString s . spcs (max 0 (n - length s)) 94 | 95 | 96 | -- | Right justify in field of width n 97 | rightJust :: Int -> String -> ShowS 98 | rightJust n s = spcs (max 0 (n - length s)) . showString s 99 | -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/ParseMonad.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: ParseMonad * 6 | * Purpose: Monad for scanning and parsing * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | Monad for scanning and parsing. 15 | -- The scanner and parser are both monadic, following the design outlined 16 | -- in the Happy documentation on monadic parsers. The parse monad P 17 | -- is built on top of the diagnostics monad D, additionally keeping track 18 | -- of the input and current source code position, and exploiting that 19 | -- the source code position is readily available to avoid having to pass 20 | -- the position as an explicit argument. 21 | 22 | -- Updated 2015 in view of revised monad class hierarchy. 23 | 24 | module ParseMonad ( 25 | -- The parse monad 26 | P (..), -- Not abstract. Instances: Monad. 27 | unP, -- :: P a -> (Int -> Int -> String -> DF a) 28 | emitInfoP, -- :: String -> P () 29 | emitWngP, -- :: String -> P () 30 | emitErrP, -- :: String -> P () 31 | failP, -- :: String -> P a 32 | getSrcPosP, -- :: P SrcPos 33 | runP -- :: String -> P a -> DF a 34 | ) where 35 | 36 | -- Standard library imports 37 | import Control.Applicative -- Backwards compatibibility 38 | 39 | 40 | -- HMTC module imports 41 | import SrcPos 42 | import Diagnostics 43 | 44 | 45 | newtype P a = P (Int -> Int -> String -> DF a) 46 | 47 | 48 | unP :: P a -> (Int -> Int -> String -> DF a) 49 | unP (P x) = x 50 | 51 | 52 | instance Functor P where 53 | fmap f p = P (\l c s -> fmap f (unP p l c s)) 54 | 55 | a <$ p = P (\l c s -> a <$ (unP p l c s)) 56 | 57 | 58 | instance Applicative P where 59 | pure a = P (\_ _ _ -> pure a) 60 | 61 | pf <*> pa = P (\l c s -> unP pf l c s <*> unP pa l c s) 62 | 63 | 64 | instance Monad P where 65 | return = pure -- Backwards compatibility 66 | 67 | p >>= f = P (\l c s -> unP p l c s >>= \a -> unP (f a) l c s) 68 | 69 | 70 | -- Liftings of useful computations from the underlying DF monad, taking 71 | -- advantage of the fact that source code positions are available. 72 | 73 | -- | Emits an information message. 74 | emitInfoP :: String -> P () 75 | emitInfoP msg = P (\l c _ -> emitInfoD (SrcPos l c) msg) 76 | 77 | 78 | -- | Emits a warning message. 79 | emitWngP :: String -> P () 80 | emitWngP msg = P (\l c _ -> emitWngD (SrcPos l c) msg) 81 | 82 | 83 | -- | Emits an error message. 84 | emitErrP :: String -> P () 85 | emitErrP msg = P (\l c _ -> emitErrD (SrcPos l c) msg) 86 | 87 | 88 | -- | Emits an error message and fails. 89 | failP :: String -> P a 90 | failP msg = P (\l c _ -> failD (SrcPos l c) msg) 91 | 92 | 93 | -- | Gets the current source code position. 94 | getSrcPosP :: P SrcPos 95 | getSrcPosP = P (\l c _ -> return (SrcPos l c)) 96 | 97 | 98 | -- | Runs parser (and scanner), yielding a result in the diagnostics monad DF. 99 | runP :: P a -> String -> DF a 100 | runP p s = unP p 1 1 s 101 | -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/ScopeLevel.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: ScopeLevel * 6 | * Purpose: Definition of and operation on scope level. * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2013 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | ScopeLevel: Definition of and operation on scope level 15 | 16 | module ScopeLevel ( 17 | ScopeLvl, -- Scope level 18 | topMajScopeLvl, -- :: Int 19 | topScopeLvl, -- :: ScopeLvl 20 | majScopeLvl, -- :: ScopeLvl -> Int 21 | minScopeLvl, -- :: ScopeLvl -> Int 22 | incMajScopeLvl, -- :: ScopeLvl -> ScopeLvl 23 | incMinScopeLvl -- :: ScopeLvl -> ScopeLvl 24 | ) where 25 | 26 | 27 | ------------------------------------------------------------------------------ 28 | -- Scope level 29 | ------------------------------------------------------------------------------ 30 | 31 | -- | Scope level. 32 | 33 | -- Pair of major (depth of procedure/function) nesting 34 | -- and minor (depth of let-command nesting) levels. 35 | type ScopeLvl = (Int, Int) 36 | 37 | 38 | topMajScopeLvl :: Int 39 | topMajScopeLvl = 0 40 | 41 | 42 | topScopeLvl :: ScopeLvl 43 | topScopeLvl = (topMajScopeLvl, 0) 44 | 45 | 46 | majScopeLvl :: ScopeLvl -> Int 47 | majScopeLvl = fst 48 | 49 | 50 | minScopeLvl :: ScopeLvl -> Int 51 | minScopeLvl = fst 52 | 53 | 54 | incMajScopeLvl :: ScopeLvl -> ScopeLvl 55 | incMajScopeLvl (majl, _) = (majl + 1, 0) 56 | 57 | 58 | incMinScopeLvl :: ScopeLvl -> ScopeLvl 59 | incMinScopeLvl (majl, minl) = (majl, minl + 1) 60 | -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/SrcPos.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: SrcPos * 6 | * Purpose: Source-code positions and related definitions * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2012 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- |Source-code positions and related definitions 15 | 16 | module SrcPos ( 17 | SrcPos (..), -- Not abstract. Instances: Eq, Ord, Show. 18 | HasSrcPos (..) 19 | ) where 20 | 21 | -- | Representation of source-code positions 22 | data SrcPos 23 | = NoSrcPos -- ^ Unknown source-code position 24 | | SrcPos { 25 | spLine :: Int, -- ^ Line number 26 | spCol :: Int -- ^ Character column number 27 | } 28 | deriving (Eq, Ord) 29 | 30 | 31 | instance Show SrcPos where 32 | showsPrec _ NoSrcPos = showString "unknown position" 33 | showsPrec _ (SrcPos {spLine = l, spCol = c }) = 34 | showString "line " 35 | . shows l 36 | . showString ", column " 37 | . shows c 38 | 39 | -- | Class of types that have a source-code position as a stored or computed 40 | -- attribute. 41 | class HasSrcPos a where 42 | srcPos :: a -> SrcPos 43 | 44 | 45 | -- A list of entities that have source positions also has a source position. 46 | instance HasSrcPos a => HasSrcPos [a] where 47 | srcPos [] = NoSrcPos 48 | srcPos (x:_) = srcPos x 49 | 50 | 51 | -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/TAMCode.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: TAMCode * 6 | * Purpose: Triangle Abstract Machine (TAM) Code * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2013 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | Triangle Abstract Machine (TAM) Code. 15 | 16 | module TAMCode ( 17 | MTInt, -- TAM integer type 18 | Addr(..), -- Address 19 | TAMInst(..) 20 | ) where 21 | 22 | -- HMTC module imports 23 | import Name 24 | import Type (MTInt) 25 | 26 | 27 | -- | TAM stack addresses 28 | data Addr 29 | = SB MTInt -- ^ SB (Stack base) + displacement: [SB + d] 30 | | LB MTInt -- ^ LB (Local Base) + displacement: [LB + d] 31 | | ST MTInt -- ^ ST (Stack Top) + displacement: [ST + d] 32 | deriving (Eq, Show) 33 | 34 | -- | TAM instruction type. 35 | data TAMInst 36 | -- Label 37 | = Label Name -- ^ Symbolic location (pseudo instruction) 38 | 39 | -- Load and store 40 | | LOADL MTInt -- ^ Push literal integer onto stack 41 | | LOADCA Name -- ^ Push code address onto stack 42 | | LOAD Addr -- ^ Push contents at addres onto stack 43 | | LOADA Addr -- ^ Push address onto stack 44 | | LOADI MTInt -- ^ Load indirectly; addr = top elem.+displ. 45 | | STORE Addr -- ^ Pop elem. from stack and store at address 46 | | STOREI MTInt -- ^ Store indirectly; addr = top elem.+displ. 47 | 48 | -- Block operations 49 | | LOADLB MTInt MTInt -- ^ Push block of literal integer onto stack 50 | | LOADIB MTInt -- ^ Load block indirectly; addr = top elem. 51 | | STOREIB MTInt -- ^ Store block indirectly; addr = top elem. 52 | | POP MTInt MTInt -- ^ POP m n: pop n elements below top m elems. 53 | 54 | -- Aritmetic operations 55 | | ADD -- ^ [b, a, ...] => [a + b, ...] 56 | | SUB -- ^ [b, a, ...] => [a - b, ...] 57 | | MUL -- ^ [b, a, ...] => [a * b, ...] 58 | | DIV -- ^ [b, a, ...] => [a / b, ...] 59 | | NEG -- ^ [a, ...] => [-a, ...] 60 | 61 | -- Comparison & logical ops: false = 0, true = 1 (as arg., anything /= 0) 62 | | LSS -- ^ [b, a, ...] => [a < b, ...] 63 | | EQL -- ^ [b, a, ...] => [a == b, ...] 64 | | GTR -- ^ [b, a, ...] => [a > b, ...] 65 | | AND -- ^ [b, a, ...] => [a && b, ...] 66 | | OR -- ^ [b, a, ...] => [a || b, ...] 67 | | NOT -- ^ [a, ...] => [!a, ...] 68 | 69 | -- Control transfer 70 | | JUMP Name -- ^ Jump unconditionally 71 | | JUMPIFZ Name -- ^ Pop top value, jump if zero (false) 72 | | JUMPIFNZ Name -- ^ Pop top value, jump if not zero (true) 73 | | CALL Name -- ^ Call global subroutine 74 | | CALLI -- ^ Call indirectly; addr & static lnk on stk 75 | | RETURN MTInt MTInt -- ^ RETURN m n: result size m, args size n. 76 | 77 | -- I/O 78 | | PUTINT -- ^ Pop and print top element to terminal 79 | | PUTCHR -- ^ Pop and print top element interp. as char. 80 | | GETINT -- ^ Read an integer and push onto stack 81 | | GETCHR -- ^ Read a character and push onto stack 82 | 83 | -- TAM Control 84 | | HALT -- ^ Stop TAM 85 | deriving (Eq, Show) 86 | -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/Token.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: Token * 6 | * Purpose: Representation of tokens (lexical symbols) * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | Representation of tokens (lexical symbols). 15 | 16 | module Token where 17 | 18 | -- HMTC module imports 19 | import Name 20 | 21 | 22 | -- | Token type. 23 | 24 | data Token 25 | -- Graphical tokens 26 | = LPar -- ^ \"(\" 27 | | RPar -- ^ \")\" 28 | | LBrk -- ^ \"[\" 29 | | RBrk -- ^ \"]\" 30 | | LBrc -- ^ \"{\" 31 | | RBrc -- ^ \"}\" 32 | | Comma -- ^ \",\" 33 | | Period -- ^ \".\" 34 | | Semicol -- ^ \";\" 35 | | Colon -- ^ \":\" 36 | | ColEq -- ^ \":=\" 37 | | Equals -- ^ \"=\" 38 | | Cond -- ^ \"?\" 39 | 40 | -- Keywords 41 | | Begin -- ^ \"begin\" 42 | | Const -- ^ \"const\" 43 | | Do -- ^ \"do\" 44 | | Else -- ^ \"else\" 45 | | Elsif -- ^ \"elsif\" 46 | | End -- ^ \"end\" 47 | | Fun -- ^ \"fun\" 48 | | If -- ^ \"if\" 49 | | In -- ^ \"in\" 50 | | Let -- ^ \"let\" 51 | | Out -- ^ \"out\" 52 | | Overloaded -- ^ \"overloaded\" 53 | | Proc -- ^ \"proc\" 54 | | Repeat -- ^ \"repeat\" 55 | | Then -- ^ \"then\" 56 | | Until -- ^ \"until\" 57 | | Var -- ^ \"var\" 58 | | While -- ^ \"while\" 59 | 60 | -- Tokens with variable spellings 61 | | LitInt {liVal :: Integer} -- ^ Integer literals 62 | | LitChr {lcVal :: Char} -- ^ Character literals 63 | | Id {idName :: Name} -- ^ Identifiers 64 | | Op {opName :: Name} -- ^ Operators 65 | 66 | -- End Of File marker 67 | | EOF -- ^ End of file (input) marker. 68 | deriving (Eq, Show) 69 | -------------------------------------------------------------------------------- /examples/monad/hmtc/monad-param/hmtc-monad-param.cabal: -------------------------------------------------------------------------------- 1 | name: hmtc-monad-param 2 | version: 0.2.0 3 | synopsis: A small teaching compiler for an imperative toy language. 4 | category: Type System, Plugin, Monad 5 | description: A small teaching compiler for an imperative toy language. 6 | This version contains a sample modules that uses the 7 | generalized monads from Kmetts monad-param package in 8 | the 'TypeChecker' module to see the differences without 9 | a plugin. 10 | author: Henrik Nilsson 11 | maintainer: Henrik Nilsson 12 | stability: experimental 13 | copyright: Copyright (c) 2016, Henrik Nilsson 14 | build-type: Simple 15 | cabal-version: >=1.10 16 | 17 | executable hmtc-monad-param 18 | build-depends: base >= 4.8 19 | , containers >= 0.5 && < 0.6 20 | , array >= 0.5 && < 0.6 21 | , monad-param == 0.0.4 22 | main-is: Main.hs 23 | other-modules: AST 24 | , CodeGenerator 25 | , CodeGenMonad 26 | , Diagnostics 27 | , Env 28 | , LibMT 29 | , MTIR 30 | , MTStdEnv 31 | , Name 32 | , ParseMonad 33 | , Parser 34 | , PPAST 35 | , PPMTIR 36 | , PPTAMCode 37 | , PPUtilities 38 | , Scanner 39 | , ScopeLevel 40 | , SrcPos 41 | , Symbol 42 | , TAMCode 43 | , TAMCodeParser 44 | , TAMInterpreter 45 | , Token 46 | , TypeChecker 47 | , Type 48 | hs-source-dirs: . 49 | default-language: Haskell2010 50 | build-tools: happy 51 | ghc-options: -Wall 52 | -fno-warn-name-shadowing -fno-warn-missing-signatures 53 | -fno-warn-unused-imports -fno-warn-unused-binds 54 | -fno-warn-unused-matches -------------------------------------------------------------------------------- /examples/monad/hmtc/original/.gitignore: -------------------------------------------------------------------------------- 1 | 2 | dist/ -------------------------------------------------------------------------------- /examples/monad/hmtc/original/LibMT.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: LibMT * 6 | * Purpose: TAM code for LibMT: the MiniTriangle std library. * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | LibMT: MiniTriangle Standard Library 15 | 16 | module LibMT ( 17 | libMT -- :: [TAMInst] 18 | ) where 19 | 20 | import Data.Char (ord) 21 | 22 | -- HMTC module imports 23 | import Name 24 | import TAMCode 25 | 26 | 27 | -- | The MiniTriangle standard library: code for functions and procedures 28 | -- declared in the standard environment as well as for internal use by the 29 | -- TAM \"runtime\" system. Note that the code generator makes assumptions 30 | -- about the meaning of many of these routines (\"add\" etc.) based on their 31 | -- names for optimization purposes. 32 | 33 | libMT :: [TAMInst] 34 | libMT = [ 35 | -- preinc 36 | Label "preinc", 37 | LOAD (LB (-1)), 38 | LOADI 0, 39 | LOADL 1, 40 | ADD, 41 | LOAD (ST (-1)), 42 | LOAD (LB (-1)), 43 | STOREI 0, 44 | RETURN 1 1, 45 | 46 | -- predec 47 | Label "predec", 48 | LOAD (LB (-1)), 49 | LOADI 0, 50 | LOADL 1, 51 | SUB, 52 | LOAD (ST (-1)), 53 | LOAD (LB (-1)), 54 | STOREI 0, 55 | RETURN 1 1, 56 | 57 | -- postinc 58 | Label "postinc", 59 | LOAD (LB (-1)), 60 | LOADI 0, 61 | LOAD (ST (-1)), 62 | LOADL 1, 63 | ADD, 64 | LOAD (LB (-1)), 65 | STOREI 0, 66 | RETURN 1 1, 67 | 68 | -- postdec 69 | Label "postdec", 70 | LOAD (LB (-1)), 71 | LOADI 0, 72 | LOAD (ST (-1)), 73 | LOADL 1, 74 | SUB, 75 | LOAD (LB (-1)), 76 | STOREI 0, 77 | RETURN 1 1, 78 | 79 | -- add 80 | Label "add", 81 | LOAD (LB (-2)), 82 | LOAD (LB (-1)), 83 | ADD, 84 | RETURN 1 2, 85 | 86 | -- sub 87 | Label "sub", 88 | LOAD (LB (-2)), 89 | LOAD (LB (-1)), 90 | SUB, 91 | RETURN 1 2, 92 | 93 | -- mul 94 | Label "mul", 95 | LOAD (LB (-2)), 96 | LOAD (LB (-1)), 97 | MUL, 98 | RETURN 1 2, 99 | 100 | -- div 101 | Label "div", 102 | LOAD (LB (-2)), 103 | LOAD (LB (-1)), 104 | DIV, 105 | RETURN 1 2, 106 | 107 | -- pow 108 | Label "pow", 109 | LOADL 1, 110 | Label "pow_loop", 111 | LOAD (LB (-1)), 112 | LOADL 0, 113 | GTR, 114 | JUMPIFZ "pow_out", 115 | LOAD (LB (-1)), 116 | LOADL 1, 117 | SUB, 118 | STORE (LB (-1)), 119 | LOAD (LB (-2)), 120 | MUL, 121 | JUMP "pow_loop", 122 | Label "pow_out", 123 | RETURN 1 2, 124 | 125 | -- neg 126 | Label "neg", 127 | LOAD (LB (-1)), 128 | NEG, 129 | RETURN 1 1, 130 | 131 | -- lt 132 | Label "lt", 133 | LOAD (LB (-2)), 134 | LOAD (LB (-1)), 135 | LSS, 136 | RETURN 1 2, 137 | 138 | -- le 139 | Label "le", 140 | LOAD (LB (-2)), 141 | LOAD (LB (-1)), 142 | GTR, 143 | NOT, 144 | RETURN 1 2, 145 | 146 | -- eq 147 | Label "eq", 148 | LOAD (LB (-2)), 149 | LOAD (LB (-1)), 150 | EQL, 151 | RETURN 1 2, 152 | 153 | -- ne 154 | Label "ne", 155 | LOAD (LB (-2)), 156 | LOAD (LB (-1)), 157 | EQL, 158 | NOT, 159 | RETURN 1 2, 160 | 161 | -- ge 162 | Label "ge", 163 | LOAD (LB (-2)), 164 | LOAD (LB (-1)), 165 | LSS, 166 | NOT, 167 | RETURN 1 2, 168 | 169 | -- gt 170 | Label "gt", 171 | LOAD (LB (-2)), 172 | LOAD (LB (-1)), 173 | GTR, 174 | RETURN 1 2, 175 | 176 | -- and 177 | Label "and", 178 | LOAD (LB (-2)), 179 | LOAD (LB (-1)), 180 | AND, 181 | RETURN 1 2, 182 | 183 | -- or 184 | Label "or", 185 | LOAD (LB (-2)), 186 | LOAD (LB (-1)), 187 | OR, 188 | RETURN 1 2, 189 | 190 | -- not 191 | Label "not", 192 | LOAD (LB (-1)), 193 | NOT, 194 | RETURN 1 1, 195 | 196 | -- getchr 197 | Label "getchr", 198 | GETCHR, 199 | LOAD (LB (-1)), 200 | STOREI 0, 201 | RETURN 0 1, 202 | 203 | -- putchr 204 | Label "putchr", 205 | LOAD (LB (-1)), 206 | PUTCHR, 207 | RETURN 0 1, 208 | 209 | -- getint 210 | Label "getint", 211 | GETINT, 212 | LOAD (LB (-1)), 213 | STOREI 0, 214 | RETURN 0 1, 215 | 216 | -- putint 217 | Label "putint", 218 | LOAD (LB (-1)), 219 | PUTINT, 220 | RETURN 0 1, 221 | 222 | -- skip 223 | Label "skip", 224 | RETURN 0 0, 225 | 226 | -- ixerror 227 | Label "ixerror", 228 | LOADL (chr 'I'), 229 | PUTCHR, 230 | LOADL (chr 'x'), 231 | PUTCHR, 232 | LOADL (chr ':'), 233 | PUTCHR, 234 | LOADL (chr ' '), 235 | PUTCHR, 236 | LOAD (LB (-1)), 237 | PUTINT, 238 | HALT 239 | ] 240 | 241 | 242 | chr :: Char -> MTInt 243 | chr c = fromIntegral (ord c) 244 | -------------------------------------------------------------------------------- /examples/monad/hmtc/original/MTStdEnv.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: MTStdEnv * 6 | * Purpose: MiniTriangle Initial Environment * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | MiniTriangle initial environment 15 | 16 | module MTStdEnv ( 17 | Env, -- Re-exported 18 | mtStdEnv -- :: Env 19 | ) where 20 | 21 | 22 | -- HMTC module imports 23 | import Name 24 | import TAMCode (MTInt) 25 | import Type 26 | import Symbol (ExtSymVal (..)) 27 | import Env 28 | 29 | 30 | -- | The MiniTriangle initial environment. 31 | -- 32 | -- [Types:] Boolean, Character, Integer 33 | -- 34 | -- [Constants:] 35 | -- 36 | -- * false, true : Boolean 37 | -- 38 | -- * minint, maxint : Integer 39 | -- 40 | -- [Functions (binary (infix) and unary (prefix/postfix) operators):] 41 | -- 42 | -- * (++_), (--_), (_++), (_--) : (Ref Integer) -> Integer 43 | -- 44 | -- * (_+_), (_-_), (_*_), (_\/_), (_\^_) : (Integer, Integer) -> Integer 45 | -- 46 | -- * (-_) : Integer -> Integer 47 | -- 48 | -- * (_\<_), (_\<=_), (_==_), (_!=_), (_>=_), (_>_) : 49 | -- (Integer, Integer) -> Boolean, 50 | -- (Boolan, Boolean) -> Boolean 51 | -- 52 | -- * (_&&_), (_||_) : (Boolean, Boolean) -> Boolean 53 | -- 54 | -- * (!_) : Boolean -> Boolean 55 | -- 56 | -- [Procedures:] 57 | -- 58 | -- * getchr : (Snk Character) -> Void 59 | -- 60 | -- * putchr : Character -> Void 61 | -- 62 | -- * getint : (Snk Integer) -> Void 63 | -- 64 | -- * putint : Integer -> Void 65 | -- 66 | -- * skip : () -> Void 67 | -- 68 | -- Note the naming convention for infix/prefix/postfix operators with 69 | -- underscore indicating the argument position(s). Parser assumes this. 70 | -- Note that labels have to agree with the code in "LibMT". 71 | 72 | mtStdEnv :: Env 73 | mtStdEnv = 74 | mkTopLvlEnv 75 | [("Boolean", Boolean), 76 | ("Character", Character), 77 | ("Integer", Integer)] 78 | [("false", Boolean, ESVBool False), 79 | ("true", Boolean, ESVBool True), 80 | ("minint", Integer, ESVInt (minBound :: MTInt)), 81 | ("maxint", Integer, ESVInt (maxBound :: MTInt)), 82 | ("++_", Arr [Ref Integer] Integer, ESVLbl "preinc"), 83 | ("--_", Arr [Ref Integer] Integer, ESVLbl "predec"), 84 | ("_++", Arr [Ref Integer] Integer, ESVLbl "postinc"), 85 | ("_--", Arr [Ref Integer] Integer, ESVLbl "postdec"), 86 | ("_+_", Arr [Integer, Integer] Integer, ESVLbl "add"), 87 | ("_-_", Arr [Integer, Integer] Integer, ESVLbl "sub"), 88 | ("_*_", Arr [Integer, Integer] Integer, ESVLbl "mul"), 89 | ("_/_", Arr [Integer, Integer] Integer, ESVLbl "div"), 90 | ("_^_", Arr [Integer, Integer] Integer, ESVLbl "pow"), 91 | ("-_", Arr [Integer] Integer, ESVLbl "neg"), 92 | -- The comparison operators are overloaded, but their impl. shared. 93 | ("_<_", Arr [Integer, Integer] Boolean, ESVLbl "lt"), 94 | ("_<=_", Arr [Integer, Integer] Boolean, ESVLbl "le"), 95 | ("_==_", Arr [Integer, Integer] Boolean, ESVLbl "eq"), 96 | ("_!=_", Arr [Integer, Integer] Boolean, ESVLbl "ne"), 97 | ("_>=_", Arr [Integer, Integer] Boolean, ESVLbl "ge"), 98 | ("_>_", Arr [Integer, Integer] Boolean, ESVLbl "gt"), 99 | ("_<_", Arr [Boolean, Boolean] Boolean, ESVLbl "lt"), 100 | ("_<=_", Arr [Boolean, Boolean] Boolean, ESVLbl "le"), 101 | ("_==_", Arr [Boolean, Boolean] Boolean, ESVLbl "eq"), 102 | ("_!=_", Arr [Boolean, Boolean] Boolean, ESVLbl "ne"), 103 | ("_>=_", Arr [Boolean, Boolean] Boolean, ESVLbl "ge"), 104 | ("_>_", Arr [Boolean, Boolean] Boolean, ESVLbl "gt"), 105 | ("_&&_", Arr [Boolean, Boolean] Boolean, ESVLbl "and"), 106 | ("_||_", Arr [Boolean, Boolean] Boolean, ESVLbl "or"), 107 | ("!_", Arr [Boolean] Boolean, ESVLbl "not"), 108 | ("getchr", Arr [Snk Character] Void, ESVLbl "getchr"), 109 | ("putchr", Arr [Character] Void, ESVLbl "putchr"), 110 | ("getint", Arr [Snk Integer] Void, ESVLbl "getint"), 111 | ("putint", Arr [Integer] Void, ESVLbl "putint"), 112 | ("skip", Arr [] Void, ESVLbl "skip")] 113 | -------------------------------------------------------------------------------- /examples/monad/hmtc/original/Makefile: -------------------------------------------------------------------------------- 1 | ############################################################################## 2 | # 3 | # Makefile for HMTC 4 | # Copyright (c) Henrik Nilsson, 2006 5 | # 6 | ############################################################################## 7 | 8 | # Initial "all" target: 9 | # This goes first to make it the default target. 10 | 11 | .PHONY: all doc clean really-clean 12 | 13 | all: hmtc 14 | 15 | 16 | #----------------------------------------------------------------------------- 17 | # Source files: 18 | #----------------------------------------------------------------------------- 19 | 20 | # Haskell sources. 21 | hs_sources = \ 22 | AST.hs \ 23 | CodeGenerator.hs \ 24 | CodeGenMonad.hs \ 25 | Diagnostics.hs \ 26 | Env.hs \ 27 | LibMT.hs \ 28 | Main.hs \ 29 | MTIR.hs \ 30 | MTStdEnv.hs \ 31 | Name.hs \ 32 | ParseMonad.hs \ 33 | Parser.hs \ 34 | PPAST.hs \ 35 | PPMTIR.hs \ 36 | PPTAMCode.hs \ 37 | PPUtilities.hs \ 38 | Scanner.hs \ 39 | ScopeLevel.hs \ 40 | SrcPos.hs \ 41 | Symbol.hs \ 42 | TAMCode.hs \ 43 | TAMCodeParser.hs \ 44 | TAMInterpreter.hs \ 45 | Token.hs \ 46 | TypeChecker.hs \ 47 | Type.hs 48 | 49 | 50 | #----------------------------------------------------------------------------- 51 | # Tools, arguments, and auxiliary files 52 | #----------------------------------------------------------------------------- 53 | 54 | SHELL = /bin/sh 55 | 56 | HS_OPTS += -O $(HS_PACKAGES) $(HS_EXTRA_IMPORTS) $(HS_USER_OPTS) 57 | MAKE.hs = ghc --make $(HS_OPTS) -o $@ 58 | 59 | # ghc-specific (for now) 60 | HAPPY = happy -agc 61 | 62 | 63 | #----------------------------------------------------------------------------- 64 | # Auxiliary variables 65 | #----------------------------------------------------------------------------- 66 | 67 | hs_interfaces := $(hs_sources:.hs=.hi) 68 | hs_objects := $(hs_sources:.hs=.o) 69 | 70 | #----------------------------------------------------------------------------- 71 | # Implicit rules for Haskell 72 | #----------------------------------------------------------------------------- 73 | 74 | # Happy: Run CPP on the output from Happy to make Haddock happy! :-) 75 | %.hs: %.y 76 | $(HAPPY) --outfile=happy-output.hs $< 77 | ghc -cpp -E -optP-P -o $@ happy-output.hs 78 | rm happy-output.hs 79 | 80 | 81 | #----------------------------------------------------------------------------- 82 | # Compilation of the Haskell Mini Triangle Compiler 83 | #----------------------------------------------------------------------------- 84 | 85 | hmtc: $(hs_sources) 86 | $(MAKE.hs) Main 87 | 88 | 89 | #----------------------------------------------------------------------------- 90 | # Generating documentation 91 | #----------------------------------------------------------------------------- 92 | 93 | doc: Doc $(hs_sources) 94 | haddock --html --odir=Doc $(hs_sources) --title=HMTC 95 | 96 | Doc: 97 | mkdir Doc 98 | 99 | 100 | #----------------------------------------------------------------------------- 101 | # Cleaning 102 | #----------------------------------------------------------------------------- 103 | 104 | clean: 105 | -$(RM) $(hs_interfaces) $(hs_objects) hmtc 106 | 107 | really-clean: clean 108 | -$(RM) Parser.hs 109 | -$(RM) TAMCodeParser.hs 110 | -rm -rf Doc 111 | -------------------------------------------------------------------------------- /examples/monad/hmtc/original/Name.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: Name * 6 | * Purpose: Representation of names * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2012 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | Representation of names. Types, variables, procedures, operators ... 15 | 16 | module Name where 17 | 18 | type Name = String 19 | -------------------------------------------------------------------------------- /examples/monad/hmtc/original/PPUtilities.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: PPUtilities * 6 | * Purpose: Pretty-printing utilities * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2012 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | Pretty-printing utilities. 15 | 16 | module PPUtilities ( 17 | ppName, -- :: Name -> ShowS 18 | ppSrcPos, -- :: SrcPos -> ShowS 19 | ppOpt, -- :: Int -> (Int -> a -> ShowS) -> Maybe a -> ShowS 20 | ppSeq, -- :: Int -> (Int -> a -> ShowS) -> [a] -> ShowS 21 | indent, -- :: Int -> ShowS 22 | nl, -- :: ShowS 23 | spc, -- :: ShowS 24 | spcs, -- :: Int -> ShowS 25 | leftJust, -- :: Int -> String -> ShowS 26 | rightJust -- :: Int -> String -> ShowS 27 | ) where 28 | 29 | -- HMTC module imports 30 | import Name (Name) 31 | import SrcPos (SrcPos) 32 | 33 | ------------------------------------------------------------------------------ 34 | -- Utilities 35 | ------------------------------------------------------------------------------ 36 | 37 | -- | Pretty-prints a name. 38 | ppName :: Name -> ShowS 39 | ppName n = showChar '\"' . showString n . showChar '\"' 40 | 41 | 42 | -- | Pretty-prints a source code position. 43 | ppSrcPos :: SrcPos -> ShowS 44 | ppSrcPos sp = showChar '<' . showString (show sp) . showChar '>' 45 | 46 | 47 | -- | Pretty-prints an optional item. Arguments: 48 | -- 49 | -- (1) Indentation level. 50 | -- 51 | -- (2) Pretty-printing function for the item. 52 | -- 53 | -- (3) The optional item to print. 54 | ppOpt :: Int -> (Int -> a -> ShowS) -> Maybe a -> ShowS 55 | ppOpt _ _ Nothing = id 56 | ppOpt n pp (Just x) = pp n x 57 | 58 | 59 | -- | Pretty-prints a sequence of items. Arguments: 60 | -- 61 | -- (1) Indentation level. 62 | -- 63 | -- (2) Pretty-printing function for each item. 64 | -- 65 | -- (3) Sequence of items to print. 66 | ppSeq :: Int -> (Int -> a -> ShowS) -> [a] -> ShowS 67 | ppSeq _ _ [] = id 68 | ppSeq n pp (x:xs) = pp n x . ppSeq n pp xs 69 | 70 | 71 | -- | Indent to specified level by printing spaces. 72 | indent :: Int -> ShowS 73 | indent n = spcs (2 * n) 74 | 75 | 76 | -- | Start a new line. 77 | nl :: ShowS 78 | nl = showChar '\n' 79 | 80 | 81 | -- | Print a space. 82 | spc :: ShowS 83 | spc = showChar ' ' 84 | 85 | 86 | -- | Print n spaces. 87 | spcs :: Int -> ShowS 88 | spcs n = showString (take n (repeat ' ')) 89 | 90 | 91 | -- | Left justify in field of width n 92 | leftJust :: Int -> String -> ShowS 93 | leftJust n s = showString s . spcs (max 0 (n - length s)) 94 | 95 | 96 | -- | Right justify in field of width n 97 | rightJust :: Int -> String -> ShowS 98 | rightJust n s = spcs (max 0 (n - length s)) . showString s 99 | -------------------------------------------------------------------------------- /examples/monad/hmtc/original/ParseMonad.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: ParseMonad * 6 | * Purpose: Monad for scanning and parsing * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | Monad for scanning and parsing. 15 | -- The scanner and parser are both monadic, following the design outlined 16 | -- in the Happy documentation on monadic parsers. The parse monad P 17 | -- is built on top of the diagnostics monad D, additionally keeping track 18 | -- of the input and current source code position, and exploiting that 19 | -- the source code position is readily available to avoid having to pass 20 | -- the position as an explicit argument. 21 | 22 | -- Updated 2015 in view of revised monad class hierarchy. 23 | 24 | module ParseMonad ( 25 | -- The parse monad 26 | P (..), -- Not abstract. Instances: Monad. 27 | unP, -- :: P a -> (Int -> Int -> String -> DF a) 28 | emitInfoP, -- :: String -> P () 29 | emitWngP, -- :: String -> P () 30 | emitErrP, -- :: String -> P () 31 | failP, -- :: String -> P a 32 | getSrcPosP, -- :: P SrcPos 33 | runP -- :: String -> P a -> DF a 34 | ) where 35 | 36 | -- Standard library imports 37 | import Control.Applicative -- Backwards compatibibility 38 | 39 | 40 | -- HMTC module imports 41 | import SrcPos 42 | import Diagnostics 43 | 44 | 45 | newtype P a = P (Int -> Int -> String -> DF a) 46 | 47 | 48 | unP :: P a -> (Int -> Int -> String -> DF a) 49 | unP (P x) = x 50 | 51 | 52 | instance Functor P where 53 | fmap f p = P (\l c s -> fmap f (unP p l c s)) 54 | 55 | a <$ p = P (\l c s -> a <$ (unP p l c s)) 56 | 57 | 58 | instance Applicative P where 59 | pure a = P (\_ _ _ -> pure a) 60 | 61 | pf <*> pa = P (\l c s -> unP pf l c s <*> unP pa l c s) 62 | 63 | 64 | instance Monad P where 65 | return = pure -- Backwards compatibility 66 | 67 | p >>= f = P (\l c s -> unP p l c s >>= \a -> unP (f a) l c s) 68 | 69 | 70 | -- Liftings of useful computations from the underlying DF monad, taking 71 | -- advantage of the fact that source code positions are available. 72 | 73 | -- | Emits an information message. 74 | emitInfoP :: String -> P () 75 | emitInfoP msg = P (\l c _ -> emitInfoD (SrcPos l c) msg) 76 | 77 | 78 | -- | Emits a warning message. 79 | emitWngP :: String -> P () 80 | emitWngP msg = P (\l c _ -> emitWngD (SrcPos l c) msg) 81 | 82 | 83 | -- | Emits an error message. 84 | emitErrP :: String -> P () 85 | emitErrP msg = P (\l c _ -> emitErrD (SrcPos l c) msg) 86 | 87 | 88 | -- | Emits an error message and fails. 89 | failP :: String -> P a 90 | failP msg = P (\l c _ -> failD (SrcPos l c) msg) 91 | 92 | 93 | -- | Gets the current source code position. 94 | getSrcPosP :: P SrcPos 95 | getSrcPosP = P (\l c _ -> return (SrcPos l c)) 96 | 97 | 98 | -- | Runs parser (and scanner), yielding a result in the diagnostics monad DF. 99 | runP :: P a -> String -> DF a 100 | runP p s = unP p 1 1 s 101 | -------------------------------------------------------------------------------- /examples/monad/hmtc/original/ScopeLevel.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: ScopeLevel * 6 | * Purpose: Definition of and operation on scope level. * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2013 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | ScopeLevel: Definition of and operation on scope level 15 | 16 | module ScopeLevel ( 17 | ScopeLvl, -- Scope level 18 | topMajScopeLvl, -- :: Int 19 | topScopeLvl, -- :: ScopeLvl 20 | majScopeLvl, -- :: ScopeLvl -> Int 21 | minScopeLvl, -- :: ScopeLvl -> Int 22 | incMajScopeLvl, -- :: ScopeLvl -> ScopeLvl 23 | incMinScopeLvl -- :: ScopeLvl -> ScopeLvl 24 | ) where 25 | 26 | 27 | ------------------------------------------------------------------------------ 28 | -- Scope level 29 | ------------------------------------------------------------------------------ 30 | 31 | -- | Scope level. 32 | 33 | -- Pair of major (depth of procedure/function) nesting 34 | -- and minor (depth of let-command nesting) levels. 35 | type ScopeLvl = (Int, Int) 36 | 37 | 38 | topMajScopeLvl :: Int 39 | topMajScopeLvl = 0 40 | 41 | 42 | topScopeLvl :: ScopeLvl 43 | topScopeLvl = (topMajScopeLvl, 0) 44 | 45 | 46 | majScopeLvl :: ScopeLvl -> Int 47 | majScopeLvl = fst 48 | 49 | 50 | minScopeLvl :: ScopeLvl -> Int 51 | minScopeLvl = fst 52 | 53 | 54 | incMajScopeLvl :: ScopeLvl -> ScopeLvl 55 | incMajScopeLvl (majl, _) = (majl + 1, 0) 56 | 57 | 58 | incMinScopeLvl :: ScopeLvl -> ScopeLvl 59 | incMinScopeLvl (majl, minl) = (majl, minl + 1) 60 | -------------------------------------------------------------------------------- /examples/monad/hmtc/original/SrcPos.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: SrcPos * 6 | * Purpose: Source-code positions and related definitions * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2012 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- |Source-code positions and related definitions 15 | 16 | module SrcPos ( 17 | SrcPos (..), -- Not abstract. Instances: Eq, Ord, Show. 18 | HasSrcPos (..) 19 | ) where 20 | 21 | -- | Representation of source-code positions 22 | data SrcPos 23 | = NoSrcPos -- ^ Unknown source-code position 24 | | SrcPos { 25 | spLine :: Int, -- ^ Line number 26 | spCol :: Int -- ^ Character column number 27 | } 28 | deriving (Eq, Ord) 29 | 30 | 31 | instance Show SrcPos where 32 | showsPrec _ NoSrcPos = showString "unknown position" 33 | showsPrec _ (SrcPos {spLine = l, spCol = c }) = 34 | showString "line " 35 | . shows l 36 | . showString ", column " 37 | . shows c 38 | 39 | -- | Class of types that have a source-code position as a stored or computed 40 | -- attribute. 41 | class HasSrcPos a where 42 | srcPos :: a -> SrcPos 43 | 44 | 45 | -- A list of entities that have source positions also has a source position. 46 | instance HasSrcPos a => HasSrcPos [a] where 47 | srcPos [] = NoSrcPos 48 | srcPos (x:_) = srcPos x 49 | 50 | 51 | -------------------------------------------------------------------------------- /examples/monad/hmtc/original/TAMCode.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: TAMCode * 6 | * Purpose: Triangle Abstract Machine (TAM) Code * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2013 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | Triangle Abstract Machine (TAM) Code. 15 | 16 | module TAMCode ( 17 | MTInt, -- TAM integer type 18 | Addr(..), -- Address 19 | TAMInst(..) 20 | ) where 21 | 22 | -- HMTC module imports 23 | import Name 24 | import Type (MTInt) 25 | 26 | 27 | -- | TAM stack addresses 28 | data Addr 29 | = SB MTInt -- ^ SB (Stack base) + displacement: [SB + d] 30 | | LB MTInt -- ^ LB (Local Base) + displacement: [LB + d] 31 | | ST MTInt -- ^ ST (Stack Top) + displacement: [ST + d] 32 | deriving (Eq, Show) 33 | 34 | -- | TAM instruction type. 35 | data TAMInst 36 | -- Label 37 | = Label Name -- ^ Symbolic location (pseudo instruction) 38 | 39 | -- Load and store 40 | | LOADL MTInt -- ^ Push literal integer onto stack 41 | | LOADCA Name -- ^ Push code address onto stack 42 | | LOAD Addr -- ^ Push contents at addres onto stack 43 | | LOADA Addr -- ^ Push address onto stack 44 | | LOADI MTInt -- ^ Load indirectly; addr = top elem.+displ. 45 | | STORE Addr -- ^ Pop elem. from stack and store at address 46 | | STOREI MTInt -- ^ Store indirectly; addr = top elem.+displ. 47 | 48 | -- Block operations 49 | | LOADLB MTInt MTInt -- ^ Push block of literal integer onto stack 50 | | LOADIB MTInt -- ^ Load block indirectly; addr = top elem. 51 | | STOREIB MTInt -- ^ Store block indirectly; addr = top elem. 52 | | POP MTInt MTInt -- ^ POP m n: pop n elements below top m elems. 53 | 54 | -- Aritmetic operations 55 | | ADD -- ^ [b, a, ...] => [a + b, ...] 56 | | SUB -- ^ [b, a, ...] => [a - b, ...] 57 | | MUL -- ^ [b, a, ...] => [a * b, ...] 58 | | DIV -- ^ [b, a, ...] => [a / b, ...] 59 | | NEG -- ^ [a, ...] => [-a, ...] 60 | 61 | -- Comparison & logical ops: false = 0, true = 1 (as arg., anything /= 0) 62 | | LSS -- ^ [b, a, ...] => [a < b, ...] 63 | | EQL -- ^ [b, a, ...] => [a == b, ...] 64 | | GTR -- ^ [b, a, ...] => [a > b, ...] 65 | | AND -- ^ [b, a, ...] => [a && b, ...] 66 | | OR -- ^ [b, a, ...] => [a || b, ...] 67 | | NOT -- ^ [a, ...] => [!a, ...] 68 | 69 | -- Control transfer 70 | | JUMP Name -- ^ Jump unconditionally 71 | | JUMPIFZ Name -- ^ Pop top value, jump if zero (false) 72 | | JUMPIFNZ Name -- ^ Pop top value, jump if not zero (true) 73 | | CALL Name -- ^ Call global subroutine 74 | | CALLI -- ^ Call indirectly; addr & static lnk on stk 75 | | RETURN MTInt MTInt -- ^ RETURN m n: result size m, args size n. 76 | 77 | -- I/O 78 | | PUTINT -- ^ Pop and print top element to terminal 79 | | PUTCHR -- ^ Pop and print top element interp. as char. 80 | | GETINT -- ^ Read an integer and push onto stack 81 | | GETCHR -- ^ Read a character and push onto stack 82 | 83 | -- TAM Control 84 | | HALT -- ^ Stop TAM 85 | deriving (Eq, Show) 86 | -------------------------------------------------------------------------------- /examples/monad/hmtc/original/Token.hs: -------------------------------------------------------------------------------- 1 | {- 2 | ****************************************************************************** 3 | * H M T C * 4 | * * 5 | * Module: Token * 6 | * Purpose: Representation of tokens (lexical symbols) * 7 | * Authors: Henrik Nilsson * 8 | * * 9 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 10 | * * 11 | ****************************************************************************** 12 | -} 13 | 14 | -- | Representation of tokens (lexical symbols). 15 | 16 | module Token where 17 | 18 | -- HMTC module imports 19 | import Name 20 | 21 | 22 | -- | Token type. 23 | 24 | data Token 25 | -- Graphical tokens 26 | = LPar -- ^ \"(\" 27 | | RPar -- ^ \")\" 28 | | LBrk -- ^ \"[\" 29 | | RBrk -- ^ \"]\" 30 | | LBrc -- ^ \"{\" 31 | | RBrc -- ^ \"}\" 32 | | Comma -- ^ \",\" 33 | | Period -- ^ \".\" 34 | | Semicol -- ^ \";\" 35 | | Colon -- ^ \":\" 36 | | ColEq -- ^ \":=\" 37 | | Equals -- ^ \"=\" 38 | | Cond -- ^ \"?\" 39 | 40 | -- Keywords 41 | | Begin -- ^ \"begin\" 42 | | Const -- ^ \"const\" 43 | | Do -- ^ \"do\" 44 | | Else -- ^ \"else\" 45 | | Elsif -- ^ \"elsif\" 46 | | End -- ^ \"end\" 47 | | Fun -- ^ \"fun\" 48 | | If -- ^ \"if\" 49 | | In -- ^ \"in\" 50 | | Let -- ^ \"let\" 51 | | Out -- ^ \"out\" 52 | | Overloaded -- ^ \"overloaded\" 53 | | Proc -- ^ \"proc\" 54 | | Repeat -- ^ \"repeat\" 55 | | Then -- ^ \"then\" 56 | | Until -- ^ \"until\" 57 | | Var -- ^ \"var\" 58 | | While -- ^ \"while\" 59 | 60 | -- Tokens with variable spellings 61 | | LitInt {liVal :: Integer} -- ^ Integer literals 62 | | LitChr {lcVal :: Char} -- ^ Character literals 63 | | Id {idName :: Name} -- ^ Identifiers 64 | | Op {opName :: Name} -- ^ Operators 65 | 66 | -- End Of File marker 67 | | EOF -- ^ End of file (input) marker. 68 | deriving (Eq, Show) 69 | -------------------------------------------------------------------------------- /examples/monad/hmtc/original/hmtc-orig.cabal: -------------------------------------------------------------------------------- 1 | name: hmtc-orig 2 | version: 0.2.0 3 | synopsis: A small teaching compiler for an imperative toy language. 4 | category: Type System, Plugin, Monad 5 | description: A small teaching compiler for an imperative toy language. 6 | author: Henrik Nilsson 7 | maintainer: Henrik Nilsson 8 | stability: experimental 9 | copyright: Copyright (c) 2016, Henrik Nilsson 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable hmtc-orig 14 | build-depends: base >= 4.8 15 | , containers >= 0.5 && < 0.6 16 | , array >= 0.5 && < 0.6 17 | main-is: Main.hs 18 | other-modules: AST 19 | , CodeGenerator 20 | , CodeGenMonad 21 | , Diagnostics 22 | , Env 23 | , LibMT 24 | , MTIR 25 | , MTStdEnv 26 | , Name 27 | , ParseMonad 28 | , Parser 29 | , PPAST 30 | , PPMTIR 31 | , PPTAMCode 32 | , PPUtilities 33 | , Scanner 34 | , ScopeLevel 35 | , SrcPos 36 | , Symbol 37 | , TAMCode 38 | , TAMCodeParser 39 | , TAMInterpreter 40 | , Token 41 | , TypeChecker 42 | , Type 43 | hs-source-dirs: . 44 | default-language: Haskell2010 45 | build-tools: happy 46 | ghc-options: -Wall 47 | -fno-warn-name-shadowing -fno-warn-missing-signatures 48 | -fno-warn-unused-imports -fno-warn-unused-binds 49 | -fno-warn-unused-matches -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/.gitignore: -------------------------------------------------------------------------------- 1 | 2 | dist/ -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/MTStdEnv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 3 | 4 | {- 5 | ****************************************************************************** 6 | * H M T C * 7 | * * 8 | * Module: MTStdEnv * 9 | * Purpose: MiniTriangle Initial Environment * 10 | * Authors: Henrik Nilsson * 11 | * * 12 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 13 | * * 14 | ****************************************************************************** 15 | -} 16 | 17 | -- | MiniTriangle initial environment 18 | 19 | module MTStdEnv ( 20 | Env, -- Re-exported 21 | mtStdEnv -- :: Env 22 | ) where 23 | 24 | import Control.Supermonad.Prelude 25 | 26 | 27 | -- HMTC module imports 28 | import Name 29 | import TAMCode (MTInt) 30 | import Type 31 | import Symbol (ExtSymVal (..)) 32 | import Env 33 | 34 | 35 | -- | The MiniTriangle initial environment. 36 | -- 37 | -- [Types:] Boolean, Character, Integer 38 | -- 39 | -- [Constants:] 40 | -- 41 | -- * false, true : Boolean 42 | -- 43 | -- * minint, maxint : Integer 44 | -- 45 | -- [Functions (binary (infix) and unary (prefix/postfix) operators):] 46 | -- 47 | -- * (++_), (--_), (_++), (_--) : (Ref Integer) -> Integer 48 | -- 49 | -- * (_+_), (_-_), (_*_), (_\/_), (_\^_) : (Integer, Integer) -> Integer 50 | -- 51 | -- * (-_) : Integer -> Integer 52 | -- 53 | -- * (_\<_), (_\<=_), (_==_), (_!=_), (_>=_), (_>_) : 54 | -- (Integer, Integer) -> Boolean, 55 | -- (Boolan, Boolean) -> Boolean 56 | -- 57 | -- * (_&&_), (_||_) : (Boolean, Boolean) -> Boolean 58 | -- 59 | -- * (!_) : Boolean -> Boolean 60 | -- 61 | -- [Procedures:] 62 | -- 63 | -- * getchr : (Snk Character) -> Void 64 | -- 65 | -- * putchr : Character -> Void 66 | -- 67 | -- * getint : (Snk Integer) -> Void 68 | -- 69 | -- * putint : Integer -> Void 70 | -- 71 | -- * skip : () -> Void 72 | -- 73 | -- Note the naming convention for infix/prefix/postfix operators with 74 | -- underscore indicating the argument position(s). Parser assumes this. 75 | -- Note that labels have to agree with the code in "LibMT". 76 | 77 | mtStdEnv :: Env 78 | mtStdEnv = 79 | mkTopLvlEnv 80 | [("Boolean", Boolean), 81 | ("Character", Character), 82 | ("Integer", Integer)] 83 | [("false", Boolean, ESVBool False), 84 | ("true", Boolean, ESVBool True), 85 | ("minint", Integer, ESVInt (minBound :: MTInt)), 86 | ("maxint", Integer, ESVInt (maxBound :: MTInt)), 87 | ("++_", Arr [Ref Integer] Integer, ESVLbl "preinc"), 88 | ("--_", Arr [Ref Integer] Integer, ESVLbl "predec"), 89 | ("_++", Arr [Ref Integer] Integer, ESVLbl "postinc"), 90 | ("_--", Arr [Ref Integer] Integer, ESVLbl "postdec"), 91 | ("_+_", Arr [Integer, Integer] Integer, ESVLbl "add"), 92 | ("_-_", Arr [Integer, Integer] Integer, ESVLbl "sub"), 93 | ("_*_", Arr [Integer, Integer] Integer, ESVLbl "mul"), 94 | ("_/_", Arr [Integer, Integer] Integer, ESVLbl "div"), 95 | ("_^_", Arr [Integer, Integer] Integer, ESVLbl "pow"), 96 | ("-_", Arr [Integer] Integer, ESVLbl "neg"), 97 | -- The comparison operators are overloaded, but their impl. shared. 98 | ("_<_", Arr [Integer, Integer] Boolean, ESVLbl "lt"), 99 | ("_<=_", Arr [Integer, Integer] Boolean, ESVLbl "le"), 100 | ("_==_", Arr [Integer, Integer] Boolean, ESVLbl "eq"), 101 | ("_!=_", Arr [Integer, Integer] Boolean, ESVLbl "ne"), 102 | ("_>=_", Arr [Integer, Integer] Boolean, ESVLbl "ge"), 103 | ("_>_", Arr [Integer, Integer] Boolean, ESVLbl "gt"), 104 | ("_<_", Arr [Boolean, Boolean] Boolean, ESVLbl "lt"), 105 | ("_<=_", Arr [Boolean, Boolean] Boolean, ESVLbl "le"), 106 | ("_==_", Arr [Boolean, Boolean] Boolean, ESVLbl "eq"), 107 | ("_!=_", Arr [Boolean, Boolean] Boolean, ESVLbl "ne"), 108 | ("_>=_", Arr [Boolean, Boolean] Boolean, ESVLbl "ge"), 109 | ("_>_", Arr [Boolean, Boolean] Boolean, ESVLbl "gt"), 110 | ("_&&_", Arr [Boolean, Boolean] Boolean, ESVLbl "and"), 111 | ("_||_", Arr [Boolean, Boolean] Boolean, ESVLbl "or"), 112 | ("!_", Arr [Boolean] Boolean, ESVLbl "not"), 113 | ("getchr", Arr [Snk Character] Void, ESVLbl "getchr"), 114 | ("putchr", Arr [Character] Void, ESVLbl "putchr"), 115 | ("getint", Arr [Snk Integer] Void, ESVLbl "getint"), 116 | ("putint", Arr [Integer] Void, ESVLbl "putint"), 117 | ("skip", Arr [] Void, ESVLbl "skip")] 118 | -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/Makefile: -------------------------------------------------------------------------------- 1 | ############################################################################## 2 | # 3 | # Makefile for HMTC 4 | # Copyright (c) Henrik Nilsson, 2006 5 | # 6 | ############################################################################## 7 | 8 | # Initial "all" target: 9 | # This goes first to make it the default target. 10 | 11 | .PHONY: all doc clean really-clean 12 | 13 | all: hmtc 14 | 15 | 16 | #----------------------------------------------------------------------------- 17 | # Source files: 18 | #----------------------------------------------------------------------------- 19 | 20 | # Haskell sources. 21 | hs_sources = \ 22 | AST.hs \ 23 | CodeGenerator.hs \ 24 | CodeGenMonad.hs \ 25 | Diagnostics.hs \ 26 | Env.hs \ 27 | LibMT.hs \ 28 | Main.hs \ 29 | MTIR.hs \ 30 | MTStdEnv.hs \ 31 | Name.hs \ 32 | ParseMonad.hs \ 33 | Parser.hs \ 34 | PPAST.hs \ 35 | PPMTIR.hs \ 36 | PPTAMCode.hs \ 37 | PPUtilities.hs \ 38 | Scanner.hs \ 39 | ScopeLevel.hs \ 40 | SrcPos.hs \ 41 | Symbol.hs \ 42 | TAMCode.hs \ 43 | TAMCodeParser.hs \ 44 | TAMInterpreter.hs \ 45 | Token.hs \ 46 | TypeChecker.hs \ 47 | Type.hs \ 48 | TestTAM.hs 49 | 50 | 51 | #----------------------------------------------------------------------------- 52 | # Tools, arguments, and auxiliary files 53 | #----------------------------------------------------------------------------- 54 | 55 | SHELL = /bin/sh 56 | 57 | HS_OPTS += -O $(HS_PACKAGES) $(HS_EXTRA_IMPORTS) $(HS_USER_OPTS) 58 | MAKE.hs = ghc --make $(HS_OPTS) -o $@ 59 | 60 | # ghc-specific (for now) 61 | HAPPY = happy -agc 62 | 63 | 64 | #----------------------------------------------------------------------------- 65 | # Auxiliary variables 66 | #----------------------------------------------------------------------------- 67 | 68 | hs_interfaces := $(hs_sources:.hs=.hi) 69 | hs_objects := $(hs_sources:.hs=.o) 70 | 71 | #----------------------------------------------------------------------------- 72 | # Implicit rules for Haskell 73 | #----------------------------------------------------------------------------- 74 | 75 | # Happy: Run CPP on the output from Happy to make Haddock happy! :-) 76 | %.hs: %.y 77 | $(HAPPY) --outfile=happy-output.hs $< 78 | ghc -cpp -E -optP-P -o $@ happy-output.hs 79 | rm happy-output.hs 80 | 81 | 82 | #----------------------------------------------------------------------------- 83 | # Compilation of the Haskell Mini Triangle Compiler 84 | #----------------------------------------------------------------------------- 85 | 86 | hmtc: $(hs_sources) 87 | $(MAKE.hs) Main 88 | 89 | 90 | #----------------------------------------------------------------------------- 91 | # Generating documentation 92 | #----------------------------------------------------------------------------- 93 | 94 | doc: Doc $(hs_sources) 95 | haddock --html --odir=Doc $(hs_sources) --title=HMTC 96 | 97 | Doc: 98 | mkdir Doc 99 | 100 | 101 | #----------------------------------------------------------------------------- 102 | # Cleaning 103 | #----------------------------------------------------------------------------- 104 | 105 | clean: 106 | -$(RM) $(hs_interfaces) $(hs_objects) hmtc 107 | 108 | really-clean: clean 109 | -$(RM) Parser.hs 110 | -$(RM) TAMCodeParser.hs 111 | -rm -rf Doc 112 | -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 3 | 4 | {- 5 | ****************************************************************************** 6 | * H M T C * 7 | * * 8 | * Module: Name * 9 | * Purpose: Representation of names * 10 | * Authors: Henrik Nilsson * 11 | * * 12 | * Copyright (c) Henrik Nilsson, 2006 - 2012 * 13 | * * 14 | ****************************************************************************** 15 | -} 16 | 17 | -- | Representation of names. Types, variables, procedures, operators ... 18 | 19 | module Name where 20 | 21 | import Control.Supermonad.Prelude 22 | 23 | type Name = String 24 | -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/PPUtilities.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 3 | 4 | {- 5 | ****************************************************************************** 6 | * H M T C * 7 | * * 8 | * Module: PPUtilities * 9 | * Purpose: Pretty-printing utilities * 10 | * Authors: Henrik Nilsson * 11 | * * 12 | * Copyright (c) Henrik Nilsson, 2006 - 2012 * 13 | * * 14 | ****************************************************************************** 15 | -} 16 | 17 | -- | Pretty-printing utilities. 18 | 19 | module PPUtilities ( 20 | ppName, -- :: Name -> ShowS 21 | ppSrcPos, -- :: SrcPos -> ShowS 22 | ppOpt, -- :: Int -> (Int -> a -> ShowS) -> Maybe a -> ShowS 23 | ppSeq, -- :: Int -> (Int -> a -> ShowS) -> [a] -> ShowS 24 | indent, -- :: Int -> ShowS 25 | nl, -- :: ShowS 26 | spc, -- :: ShowS 27 | spcs, -- :: Int -> ShowS 28 | leftJust, -- :: Int -> String -> ShowS 29 | rightJust -- :: Int -> String -> ShowS 30 | ) where 31 | 32 | import Control.Supermonad.Prelude 33 | 34 | -- HMTC module imports 35 | import Name (Name) 36 | import SrcPos (SrcPos) 37 | 38 | ------------------------------------------------------------------------------ 39 | -- Utilities 40 | ------------------------------------------------------------------------------ 41 | 42 | -- | Pretty-prints a name. 43 | ppName :: Name -> ShowS 44 | ppName n = showChar '\"' . showString n . showChar '\"' 45 | 46 | 47 | -- | Pretty-prints a source code position. 48 | ppSrcPos :: SrcPos -> ShowS 49 | ppSrcPos sp = showChar '<' . showString (show sp) . showChar '>' 50 | 51 | 52 | -- | Pretty-prints an optional item. Arguments: 53 | -- 54 | -- (1) Indentation level. 55 | -- 56 | -- (2) Pretty-printing function for the item. 57 | -- 58 | -- (3) The optional item to print. 59 | ppOpt :: Int -> (Int -> a -> ShowS) -> Maybe a -> ShowS 60 | ppOpt _ _ Nothing = id 61 | ppOpt n pp (Just x) = pp n x 62 | 63 | 64 | -- | Pretty-prints a sequence of items. Arguments: 65 | -- 66 | -- (1) Indentation level. 67 | -- 68 | -- (2) Pretty-printing function for each item. 69 | -- 70 | -- (3) Sequence of items to print. 71 | ppSeq :: Int -> (Int -> a -> ShowS) -> [a] -> ShowS 72 | ppSeq _ _ [] = id 73 | ppSeq n pp (x:xs) = pp n x . ppSeq n pp xs 74 | 75 | 76 | -- | Indent to specified level by printing spaces. 77 | indent :: Int -> ShowS 78 | indent n = spcs (2 * n) 79 | 80 | 81 | -- | Start a new line. 82 | nl :: ShowS 83 | nl = showChar '\n' 84 | 85 | 86 | -- | Print a space. 87 | spc :: ShowS 88 | spc = showChar ' ' 89 | 90 | 91 | -- | Print n spaces. 92 | spcs :: Int -> ShowS 93 | spcs n = showString (take n (repeat ' ')) 94 | 95 | 96 | -- | Left justify in field of width n 97 | leftJust :: Int -> String -> ShowS 98 | leftJust n s = showString s . spcs (max 0 (n - length s)) 99 | 100 | 101 | -- | Right justify in field of width n 102 | rightJust :: Int -> String -> ShowS 103 | rightJust n s = spcs (max 0 (n - length s)) . showString s 104 | -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/ParseMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 4 | 5 | {- 6 | ****************************************************************************** 7 | * H M T C * 8 | * * 9 | * Module: ParseMonad * 10 | * Purpose: Monad for scanning and parsing * 11 | * Authors: Henrik Nilsson * 12 | * * 13 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 14 | * * 15 | ****************************************************************************** 16 | -} 17 | 18 | -- | Monad for scanning and parsing. 19 | -- The scanner and parser are both monadic, following the design outlined 20 | -- in the Happy documentation on monadic parsers. The parse monad P 21 | -- is built on top of the diagnostics monad D, additionally keeping track 22 | -- of the input and current source code position, and exploiting that 23 | -- the source code position is readily available to avoid having to pass 24 | -- the position as an explicit argument. 25 | 26 | -- Updated 2015 in view of revised monad class hierarchy. 27 | 28 | module ParseMonad ( 29 | -- The parse monad 30 | P (..), -- Not abstract. Instances: Monad. 31 | unP, -- :: P a -> (Int -> Int -> String -> DF a) 32 | emitInfoP, -- :: String -> P () 33 | emitWngP, -- :: String -> P () 34 | emitErrP, -- :: String -> P () 35 | failP, -- :: String -> P a 36 | getSrcPosP, -- :: P SrcPos 37 | runP -- :: String -> P a -> DF a 38 | ) where 39 | 40 | import Control.Supermonad.Prelude 41 | import qualified Prelude as P 42 | 43 | -- Standard library imports 44 | --import Control.Applicative -- Backwards compatibibility 45 | 46 | 47 | -- HMTC module imports 48 | import SrcPos 49 | import Diagnostics 50 | 51 | 52 | newtype P a = P (Int -> Int -> String -> DF a) 53 | 54 | 55 | unP :: P a -> (Int -> Int -> String -> DF a) 56 | unP (P x) = x 57 | 58 | 59 | instance Functor P where 60 | fmap f p = P (\l c s -> fmap f (unP p l c s)) 61 | 62 | a <$ p = P (\l c s -> a <$ (unP p l c s)) 63 | 64 | 65 | instance Applicative P P P where 66 | pf <*> pa = P (\l c s -> unP pf l c s <*> unP pa l c s) 67 | 68 | {- 69 | instance Monad P where 70 | return = pure -- Backwards compatibility 71 | 72 | p >>= f = P (\l c s -> unP p l c s >>= \a -> unP (f a) l c s) 73 | -} 74 | instance Bind P P P where 75 | p >>= f = P (\l c s -> unP p l c s >>= \a -> unP (f a) l c s) 76 | instance Return P where 77 | return a = P (\_ _ _ -> pure a) 78 | instance Fail P where 79 | fail = error 80 | -- NOTE: This instance is not required by any module except the one generated by happy. 81 | instance P.Applicative P where 82 | pure = pure 83 | (<*>) = (<*>) 84 | instance P.Monad P where 85 | return = return 86 | (>>=) = (>>=) 87 | 88 | -- Liftings of useful computations from the underlying DF monad, taking 89 | -- advantage of the fact that source code positions are available. 90 | 91 | -- | Emits an information message. 92 | emitInfoP :: String -> P () 93 | emitInfoP msg = P (\l c _ -> emitInfoD (SrcPos l c) msg) 94 | 95 | 96 | -- | Emits a warning message. 97 | emitWngP :: String -> P () 98 | emitWngP msg = P (\l c _ -> emitWngD (SrcPos l c) msg) 99 | 100 | 101 | -- | Emits an error message. 102 | emitErrP :: String -> P () 103 | emitErrP msg = P (\l c _ -> emitErrD (SrcPos l c) msg) 104 | 105 | 106 | -- | Emits an error message and fails. 107 | failP :: String -> P a 108 | failP msg = P (\l c _ -> failD (SrcPos l c) msg) 109 | 110 | 111 | -- | Gets the current source code position. 112 | getSrcPosP :: P SrcPos 113 | getSrcPosP = P (\l c _ -> return (SrcPos l c)) 114 | 115 | 116 | -- | Runs parser (and scanner), yielding a result in the diagnostics monad DF. 117 | runP :: P a -> String -> DF a 118 | runP p s = unP p 1 1 s 119 | -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/ScopeLevel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 3 | 4 | {- 5 | ****************************************************************************** 6 | * H M T C * 7 | * * 8 | * Module: ScopeLevel * 9 | * Purpose: Definition of and operation on scope level. * 10 | * Authors: Henrik Nilsson * 11 | * * 12 | * Copyright (c) Henrik Nilsson, 2013 * 13 | * * 14 | ****************************************************************************** 15 | -} 16 | 17 | -- | ScopeLevel: Definition of and operation on scope level 18 | 19 | module ScopeLevel ( 20 | ScopeLvl, -- Scope level 21 | topMajScopeLvl, -- :: Int 22 | topScopeLvl, -- :: ScopeLvl 23 | majScopeLvl, -- :: ScopeLvl -> Int 24 | minScopeLvl, -- :: ScopeLvl -> Int 25 | incMajScopeLvl, -- :: ScopeLvl -> ScopeLvl 26 | incMinScopeLvl -- :: ScopeLvl -> ScopeLvl 27 | ) where 28 | 29 | import Control.Supermonad.Prelude 30 | 31 | 32 | ------------------------------------------------------------------------------ 33 | -- Scope level 34 | ------------------------------------------------------------------------------ 35 | 36 | -- | Scope level. 37 | 38 | -- Pair of major (depth of procedure/function) nesting 39 | -- and minor (depth of let-command nesting) levels. 40 | type ScopeLvl = (Int, Int) 41 | 42 | 43 | topMajScopeLvl :: Int 44 | topMajScopeLvl = 0 45 | 46 | 47 | topScopeLvl :: ScopeLvl 48 | topScopeLvl = (topMajScopeLvl, 0) 49 | 50 | 51 | majScopeLvl :: ScopeLvl -> Int 52 | majScopeLvl = fst 53 | 54 | 55 | minScopeLvl :: ScopeLvl -> Int 56 | minScopeLvl = fst 57 | 58 | 59 | incMajScopeLvl :: ScopeLvl -> ScopeLvl 60 | incMajScopeLvl (majl, _) = (majl + 1, 0) 61 | 62 | 63 | incMinScopeLvl :: ScopeLvl -> ScopeLvl 64 | incMinScopeLvl (majl, minl) = (majl, minl + 1) 65 | -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/SrcPos.hs: -------------------------------------------------------------------------------- 1 | 2 | {- 3 | ****************************************************************************** 4 | * H M T C * 5 | * * 6 | * Module: SrcPos * 7 | * Purpose: Source-code positions and related definitions * 8 | * Authors: Henrik Nilsson * 9 | * * 10 | * Copyright (c) Henrik Nilsson, 2006 - 2012 * 11 | * * 12 | ****************************************************************************** 13 | -} 14 | 15 | -- |Source-code positions and related definitions 16 | 17 | module SrcPos ( 18 | SrcPos (..), -- Not abstract. Instances: Eq, Ord, Show. 19 | HasSrcPos (..) 20 | ) where 21 | 22 | -- | Representation of source-code positions 23 | data SrcPos 24 | = NoSrcPos -- ^ Unknown source-code position 25 | | SrcPos { 26 | spLine :: Int, -- ^ Line number 27 | spCol :: Int -- ^ Character column number 28 | } 29 | deriving (Eq, Ord) 30 | 31 | 32 | instance Show SrcPos where 33 | showsPrec _ NoSrcPos = showString "unknown position" 34 | showsPrec _ (SrcPos {spLine = l, spCol = c }) = 35 | showString "line " 36 | . shows l 37 | . showString ", column " 38 | . shows c 39 | 40 | -- | Class of types that have a source-code position as a stored or computed 41 | -- attribute. 42 | class HasSrcPos a where 43 | srcPos :: a -> SrcPos 44 | 45 | 46 | -- A list of entities that have source positions also has a source position. 47 | instance HasSrcPos a => HasSrcPos [a] where 48 | srcPos [] = NoSrcPos 49 | srcPos (x:_) = srcPos x 50 | 51 | 52 | -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/TAMCode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 3 | 4 | {- 5 | ****************************************************************************** 6 | * H M T C * 7 | * * 8 | * Module: TAMCode * 9 | * Purpose: Triangle Abstract Machine (TAM) Code * 10 | * Authors: Henrik Nilsson * 11 | * * 12 | * Copyright (c) Henrik Nilsson, 2006 - 2013 * 13 | * * 14 | ****************************************************************************** 15 | -} 16 | 17 | -- | Triangle Abstract Machine (TAM) Code. 18 | 19 | module TAMCode ( 20 | MTInt, -- TAM integer type 21 | Addr(..), -- Address 22 | TAMInst(..) 23 | ) where 24 | 25 | import Control.Supermonad.Prelude 26 | 27 | -- HMTC module imports 28 | import Name 29 | import Type (MTInt) 30 | 31 | 32 | -- | TAM stack addresses 33 | data Addr 34 | = SB MTInt -- ^ SB (Stack base) + displacement: [SB + d] 35 | | LB MTInt -- ^ LB (Local Base) + displacement: [LB + d] 36 | | ST MTInt -- ^ ST (Stack Top) + displacement: [ST + d] 37 | deriving (Eq, Show) 38 | 39 | -- | TAM instruction type. 40 | data TAMInst 41 | -- Label 42 | = Label Name -- ^ Symbolic location (pseudo instruction) 43 | 44 | -- Load and store 45 | | LOADL MTInt -- ^ Push literal integer onto stack 46 | | LOADCA Name -- ^ Push code address onto stack 47 | | LOAD Addr -- ^ Push contents at addres onto stack 48 | | LOADA Addr -- ^ Push address onto stack 49 | | LOADI MTInt -- ^ Load indirectly; addr = top elem.+displ. 50 | | STORE Addr -- ^ Pop elem. from stack and store at address 51 | | STOREI MTInt -- ^ Store indirectly; addr = top elem.+displ. 52 | 53 | -- Block operations 54 | | LOADLB MTInt MTInt -- ^ Push block of literal integer onto stack 55 | | LOADIB MTInt -- ^ Load block indirectly; addr = top elem. 56 | | STOREIB MTInt -- ^ Store block indirectly; addr = top elem. 57 | | POP MTInt MTInt -- ^ POP m n: pop n elements below top m elems. 58 | 59 | -- Aritmetic operations 60 | | ADD -- ^ [b, a, ...] => [a + b, ...] 61 | | SUB -- ^ [b, a, ...] => [a - b, ...] 62 | | MUL -- ^ [b, a, ...] => [a * b, ...] 63 | | DIV -- ^ [b, a, ...] => [a / b, ...] 64 | | NEG -- ^ [a, ...] => [-a, ...] 65 | 66 | -- Comparison & logical ops: false = 0, true = 1 (as arg., anything /= 0) 67 | | LSS -- ^ [b, a, ...] => [a < b, ...] 68 | | EQL -- ^ [b, a, ...] => [a == b, ...] 69 | | GTR -- ^ [b, a, ...] => [a > b, ...] 70 | | AND -- ^ [b, a, ...] => [a && b, ...] 71 | | OR -- ^ [b, a, ...] => [a || b, ...] 72 | | NOT -- ^ [a, ...] => [!a, ...] 73 | 74 | -- Control transfer 75 | | JUMP Name -- ^ Jump unconditionally 76 | | JUMPIFZ Name -- ^ Pop top value, jump if zero (false) 77 | | JUMPIFNZ Name -- ^ Pop top value, jump if not zero (true) 78 | | CALL Name -- ^ Call global subroutine 79 | | CALLI -- ^ Call indirectly; addr & static lnk on stk 80 | | RETURN MTInt MTInt -- ^ RETURN m n: result size m, args size n. 81 | 82 | -- I/O 83 | | PUTINT -- ^ Pop and print top element to terminal 84 | | PUTCHR -- ^ Pop and print top element interp. as char. 85 | | GETINT -- ^ Read an integer and push onto stack 86 | | GETCHR -- ^ Read a character and push onto stack 87 | 88 | -- TAM Control 89 | | HALT -- ^ Stop TAM 90 | deriving (Eq, Show) 91 | -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/Token.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 3 | 4 | {- 5 | ****************************************************************************** 6 | * H M T C * 7 | * * 8 | * Module: Token * 9 | * Purpose: Representation of tokens (lexical symbols) * 10 | * Authors: Henrik Nilsson * 11 | * * 12 | * Copyright (c) Henrik Nilsson, 2006 - 2015 * 13 | * * 14 | ****************************************************************************** 15 | -} 16 | 17 | -- | Representation of tokens (lexical symbols). 18 | 19 | module Token where 20 | 21 | import Control.Supermonad.Prelude 22 | 23 | -- HMTC module imports 24 | import Name 25 | 26 | 27 | -- | Token type. 28 | 29 | data Token 30 | -- Graphical tokens 31 | = LPar -- ^ \"(\" 32 | | RPar -- ^ \")\" 33 | | LBrk -- ^ \"[\" 34 | | RBrk -- ^ \"]\" 35 | | LBrc -- ^ \"{\" 36 | | RBrc -- ^ \"}\" 37 | | Comma -- ^ \",\" 38 | | Period -- ^ \".\" 39 | | Semicol -- ^ \";\" 40 | | Colon -- ^ \":\" 41 | | ColEq -- ^ \":=\" 42 | | Equals -- ^ \"=\" 43 | | Cond -- ^ \"?\" 44 | 45 | -- Keywords 46 | | Begin -- ^ \"begin\" 47 | | Const -- ^ \"const\" 48 | | Do -- ^ \"do\" 49 | | Else -- ^ \"else\" 50 | | Elsif -- ^ \"elsif\" 51 | | End -- ^ \"end\" 52 | | Fun -- ^ \"fun\" 53 | | If -- ^ \"if\" 54 | | In -- ^ \"in\" 55 | | Let -- ^ \"let\" 56 | | Out -- ^ \"out\" 57 | | Overloaded -- ^ \"overloaded\" 58 | | Proc -- ^ \"proc\" 59 | | Repeat -- ^ \"repeat\" 60 | | Then -- ^ \"then\" 61 | | Until -- ^ \"until\" 62 | | Var -- ^ \"var\" 63 | | While -- ^ \"while\" 64 | 65 | -- Tokens with variable spellings 66 | | LitInt {liVal :: Integer} -- ^ Integer literals 67 | | LitChr {lcVal :: Char} -- ^ Character literals 68 | | Id {idName :: Name} -- ^ Identifiers 69 | | Op {opName :: Name} -- ^ Operators 70 | 71 | -- End Of File marker 72 | | EOF -- ^ End of file (input) marker. 73 | deriving (Eq, Show) 74 | -------------------------------------------------------------------------------- /examples/monad/hmtc/supermonad/hmtc-supermonad.cabal: -------------------------------------------------------------------------------- 1 | name: hmtc-supermonad 2 | version: 0.2.0 3 | synopsis: A small teaching compiler for an imperative toy language. 4 | category: Type System, Plugin, Monad 5 | description: A small teaching compiler for an imperative toy language. 6 | author: Henrik Nilsson , Jan Bracker 7 | maintainer: Henrik Nilsson 8 | stability: experimental 9 | copyright: Copyright (c) 2016, Henrik Nilsson 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable hmtc-supermonad 14 | build-depends: base >= 4.8 15 | , containers >= 0.5 && < 0.6 16 | , array >= 0.5 && < 0.6 17 | , supermonad == 0.2.* 18 | main-is: Main.hs 19 | other-modules: AST 20 | , CodeGenerator 21 | , CodeGenMonad 22 | , Diagnostics 23 | , Env 24 | , LibMT 25 | , MTIR 26 | , MTStdEnv 27 | , Name 28 | , ParseMonad 29 | , Parser 30 | , PPAST 31 | , PPMTIR 32 | , PPTAMCode 33 | , PPUtilities 34 | , Scanner 35 | , ScopeLevel 36 | , SrcPos 37 | , Symbol 38 | , TAMCode 39 | , TAMCodeParser 40 | , TAMInterpreter 41 | , Token 42 | , TypeChecker 43 | , Type 44 | --, TestTAM 45 | hs-source-dirs: . 46 | default-language: Haskell2010 47 | build-tools: happy 48 | ghc-options: -Wall -dynamic -dcore-lint 49 | -fno-warn-name-shadowing -fno-warn-missing-signatures 50 | -fno-warn-unused-imports -fno-warn-unused-binds 51 | -fno-warn-unused-matches -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/fac.mt: -------------------------------------------------------------------------------- 1 | let 2 | proc fac(n : Integer, var r : Integer) 3 | if n <= 1 then 4 | r := 1 5 | else begin 6 | fac(n + (-1), r); 7 | r := n * r 8 | end; 9 | var x : Integer 10 | in begin 11 | fac(8, x); 12 | putint(x) 13 | end 14 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/incdec.mt: -------------------------------------------------------------------------------- 1 | // Basic tests for pre and post increment and decrement operators. 2 | 3 | let 4 | var x : Integer := 7; 5 | var y : Integer := x++; 6 | const z : Integer = --y 7 | in begin 8 | putint(x); 9 | putint(y); 10 | putint(z); 11 | while (x-- > 0) do 12 | putint(x); 13 | while (++y < 10) do 14 | putint(y) 15 | end 16 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/matmult.mt: -------------------------------------------------------------------------------- 1 | let 2 | // Matrix multiplication by constant matrix y 3 | proc matmult(x : Integer[2][4], out z : Integer[3][4]) 4 | let 5 | var i : Integer; 6 | var j : Integer 7 | in begin 8 | i := 0; 9 | while i < 4 do begin 10 | j := 0; 11 | while j < 3 do begin 12 | let 13 | var s : Integer := 0; 14 | var k : Integer := 0 15 | in begin 16 | while k < 2 do begin 17 | s := s + x[i][k] * y[k][j]; 18 | k := k + 1 19 | end; 20 | z[i][j] := s 21 | end; 22 | j := j + 1 23 | end; 24 | i := i + 1 25 | end 26 | end; 27 | const y : Integer[3][2] = [[1,2,3],[4,5,6]] 28 | in let 29 | var i : Integer; 30 | var j : Integer; 31 | var r : Integer[3][4]; 32 | var s : Integer[3][4]; 33 | var t : Integer[3][4] 34 | in begin 35 | matmult([[1,2],[3,4],[5,6],[7,8]], r); 36 | // Some gratuitous copying to make sure block operations work 37 | i := 0; 38 | while i < 4 do begin 39 | s[i] := r[i]; 40 | i := i + 1 41 | end; 42 | t := s; 43 | i := 0; 44 | // The right result is: 45 | // [[9, 12, 15], [19, 26, 33], [29, 40, 51], [39, 54, 69]] 46 | while i < 4 do begin 47 | j := 0; 48 | while j < 3 do begin 49 | putint(t[i][j]); 50 | j := j + 1 51 | end; 52 | i := i + 1 53 | end 54 | end 55 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/overloading.mt: -------------------------------------------------------------------------------- 1 | let 2 | var a : Boolean := true; 3 | const b : Boolean = false; 4 | var c : Integer := 3; 5 | overloaded proc put(n1 : Integer, n2 : Integer, n3 : Integer) 6 | let 7 | overloaded proc put(n1 : Integer, n2 : Integer) 8 | begin 9 | put(n1 * n2) 10 | end 11 | in 12 | begin 13 | put(n1, n2); 14 | put(n3) 15 | end; 16 | overloaded proc put(n1 : Integer, n2 : Integer) 17 | begin 18 | put(n1); 19 | put(n2) 20 | end; 21 | overloaded proc put(n : Integer) 22 | putint(n) 23 | in begin 24 | if b < a && c >= 2 then 25 | putint(1) 26 | else 27 | putint(2); 28 | put(10); 29 | put(11,12); 30 | put(13,14,15) 31 | end 32 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/records.mt: -------------------------------------------------------------------------------- 1 | let var x : {b : {a : Integer, b : {x : Boolean, y : Integer}, c : Boolean}, 2 | a : {z : Integer}, 3 | c : Integer} 4 | := { c = 1, a = {z = 99}, b = {c = true, a = 5, b = {x = false, y = 17}}}; 5 | var r1 : {b : {y : Integer, x : Boolean}, a : Integer, c : Boolean}; 6 | const y : Integer = 44; 7 | var r2 : {c : Integer, 8 | b : {a : Integer, c : Boolean, b : {y : Integer, x : Boolean}}, 9 | a : {z : Integer}} 10 | in begin 11 | r2 := x; 12 | r1 := r2.b; 13 | putint(x.b.b.y + x.c + x.b.a + y); 14 | putint(r1.b.y + r1.a) 15 | end 16 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/sort.mt: -------------------------------------------------------------------------------- 1 | // Reads 10 numbers, sorts them, then prints them. 2 | let 3 | proc sort(var a : Integer[10]) 4 | let 5 | proc swap(var x : Integer, var y : Integer) 6 | let 7 | var t : Integer 8 | in begin 9 | t := x; 10 | x := y; 11 | y := t 12 | end; 13 | var i : Integer; 14 | var j : Integer 15 | in begin 16 | i := 0; 17 | while i < 9 do begin 18 | j := i + 1; 19 | while j < 10 do begin 20 | if a[i] > a[j] then swap(a[i], a[j]) else skip(); 21 | j := j + 1 22 | end; 23 | i := i + 1 24 | end 25 | end; 26 | var x : Integer[10]; 27 | var i : Integer 28 | in begin 29 | i := 0; 30 | while i < 10 do begin 31 | getint(x[i]); 32 | i := i + 1 33 | end; 34 | sort(x); 35 | i := 0; 36 | while i < 10 do begin 37 | putint(x[i]); 38 | i := i + 1 39 | end 40 | end 41 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/test1.mt: -------------------------------------------------------------------------------- 1 | // This is a comment. It continues to the end of the line. 2 | let 3 | var m: Integer; 4 | const n: Integer = 9 5 | in 6 | begin 7 | m := 1 + 2 * (n + 1); 8 | putint(m) 9 | end 10 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/test2.mt: -------------------------------------------------------------------------------- 1 | // This is a comment. It continues to the end of the line. 2 | let 3 | const d1: Integer = 2; 4 | var d2: Integer; 5 | var n: Integer 6 | in 7 | begin 8 | d2 := 1; 9 | n := 1; 10 | while n < (25 + 1) do 11 | begin 12 | putint(n); 13 | d2 := d2 + d1; 14 | n := n + d2 15 | end 16 | end 17 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/test3.mt: -------------------------------------------------------------------------------- 1 | let 2 | var x : Boolean := false; 3 | proc p(x : Integer, out n : Integer) begin 4 | if x < 1000 then 5 | begin 6 | putint(x); 7 | p(f(x,c), n) 8 | end 9 | else 10 | n := x 11 | end; 12 | fun f(x : Integer, y : Integer) : Integer = x * x + y * y; 13 | const c : Integer = 2; 14 | var r : Integer 15 | in begin 16 | p(1,r); 17 | putint(r) 18 | end 19 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/test4.mt: -------------------------------------------------------------------------------- 1 | let 2 | var x : Boolean := false; 3 | const z : Integer = 1; 4 | proc p(in x : Integer, out n : Integer) begin 5 | let 6 | fun readT() : Boolean = t; 7 | var t : Boolean := true; 8 | fun foo(t : Integer) : Integer = t + (-d); 9 | const d : Integer = 6; 10 | const e : Integer = 7 11 | in 12 | if x < 1000 && readT() then 13 | let 14 | proc putint2(in x : Integer) begin 15 | let 16 | const y : Integer = x; 17 | const z : Integer = 3; 18 | fun fie(x : Integer) : Integer = x * e * z; 19 | proc q(x : Integer) putint(foo(x)) 20 | in begin 21 | putint(x); 22 | putint(y); 23 | putint(fie(2)); 24 | let const z : Integer = 105 in 25 | q(z) 26 | end 27 | end 28 | in 29 | begin 30 | putint2(x); 31 | let 32 | var t : Integer := f(x,foo(c)) 33 | in 34 | p(t, n) 35 | end 36 | else 37 | n := x 38 | end; 39 | fun f(x : Integer, y : Integer) : Integer = x * x + y * y; 40 | const c : Integer = 4; 41 | var r : Integer 42 | in begin 43 | p(z,r); 44 | putint(r) 45 | end 46 | 47 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/test5.mt: -------------------------------------------------------------------------------- 1 | // An expression used to define a constant or initizlize a variable must 2 | // not make use a function referring to a constant or variable that has not 3 | // been (or had a chance to be) initialized yet. Thus, initializing 4 | // expressions making use of a function defined in the same let block 5 | // are not considered "well-initialized" and should be rejected. 6 | // (This is overly strict, but a simple rule.) 7 | // 8 | // The following program is thus erroneous, even though some some 9 | // of the uses of functions is safe. 10 | 11 | let 12 | fun f(x : Integer) : Integer = x * x; 13 | const m : Integer = f(3); // This is actually OK; f is "safe" 14 | fun g(y : Integer) : Integer = p * y; 15 | const n : Integer = g(4); // But using g here is definitely problematic. 16 | const p : Integer = 10 17 | in 18 | putint(m + n + p) 19 | -------------------------------------------------------------------------------- /examples/monad/hmtc/test-files/test6.mt: -------------------------------------------------------------------------------- 1 | // Basic tests for the Part I and Part II extensions. 2 | 3 | let 4 | var c : Character := 'x'; 5 | var n : Integer; 6 | fun odd(n : Integer) : Boolean = !((n / 2) * 2 == n) 7 | in begin 8 | if false then 9 | putint(1) 10 | elsif false then 11 | putint(2) 12 | else 13 | getint(n); 14 | repeat 15 | begin 16 | n := odd(n) ? n * 3 + 1 : n / 2; 17 | putint(n) 18 | end 19 | until n == 1; 20 | putchr(c) 21 | end 22 | 23 | 24 | -------------------------------------------------------------------------------- /examples/monad/minimal/MinimalMain.hs: -------------------------------------------------------------------------------- 1 | 2 | -- Use the supermonad plugin. 3 | {-# LANGUAGE RebindableSyntax #-} 4 | {-# OPTIONS_GHC -fplugin Control.Super.Monad.Plugin #-} 5 | 6 | import Control.Super.Monad.Prelude 7 | 8 | main :: IO () 9 | main = return () 10 | -------------------------------------------------------------------------------- /examples/monad/minimal/minimal.cabal: -------------------------------------------------------------------------------- 1 | name: minimal-example 2 | version: 0.2.0 3 | synopsis: Example 4 | category: 5 | description: Example 6 | author: Jan Bracker 7 | maintainer: Jan Bracker 8 | stability: experimental 9 | copyright: Copyright (c) 2015, Jan Bracker 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable minimal-sm 14 | build-depends: base >=4.8 15 | , supermonad == 0.2.* 16 | main-is: MinimalMain.hs 17 | hs-source-dirs: . 18 | default-language: Haskell2010 19 | ghc-options: -Wall -dynamic -dcore-lint 20 | -------------------------------------------------------------------------------- /examples/monad/session-chat/original/.gitignore: -------------------------------------------------------------------------------- 1 | 2 | dist/ -------------------------------------------------------------------------------- /examples/monad/session-chat/original/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main ( main ) where 3 | 4 | import System.IO 5 | ( hSetBuffering, stdout 6 | , BufferMode(NoBuffering) ) 7 | 8 | import Control.Monad ( when ) 9 | import Control.Concurrent ( forkIO ) 10 | import Control.Concurrent.STM ( atomically ) 11 | import Control.Concurrent.STM.TVar 12 | ( newTVarIO, readTVar, modifyTVar ) 13 | 14 | import Types ( User, Connection, mkConnection ) 15 | import Server ( server ) 16 | import Client 17 | ( clientShell 18 | , BotClient, mkBotClient 19 | , sendMessageBot, terminateBot ) 20 | 21 | main :: IO () 22 | main = do 23 | hSetBuffering stdout NoBuffering 24 | 25 | bots <- sequence 26 | $ fmap (\bot -> mkConnection >>= \conn -> bot conn >>= \b -> return (conn, b) ) 27 | $ [ responseBot "RB1" 28 | , rageBot "Rage" ] 29 | 30 | clientConn <- mkConnection 31 | 32 | _serverThread <- forkIO $ do 33 | _serverEnv <- server $ clientConn : fmap fst bots 34 | return () 35 | 36 | clientShell clientConn 37 | 38 | -- | Never use more then one! 39 | -- Weirdly, he does not respond to users that begin with the letter R. 40 | responseBot :: User -> Connection -> IO BotClient 41 | responseBot name conn = mkBotClient conn name 42 | (const $ return ()) 43 | (\bot u -> sendMessageBot bot $ "Goodbye, " ++ u ++ "!") 44 | (\bot u msg -> when (head u /= 'R') $ do 45 | if msg == ("die " ++ name) then do 46 | sendMessageBot bot $ "I obey and die now..." 47 | terminateBot bot 48 | else do 49 | sendMessageBot bot $ "I don't understand but I still respond, " ++ u ++ "!" 50 | ) 51 | (const $ return ()) 52 | 53 | rageBot :: User -> Connection -> IO BotClient 54 | rageBot name conn = do 55 | counterVar <- newTVarIO (0 :: Int) 56 | mkBotClient conn name 57 | (const $ return ()) 58 | (\bot u -> sendMessageBot bot $ "Finally you are gone, " ++ u ++ "!") 59 | (\bot u _msg -> do 60 | counter <- atomically $ readTVar counterVar 61 | if counter >= 5 then do 62 | sendMessageBot bot $ "I have had enough of this, " ++ u ++ "!" 63 | terminateBot bot 64 | else do 65 | sendMessageBot bot $ "Be quiet, " ++ u ++ "!" 66 | atomically $ modifyTVar counterVar (+1) 67 | ) 68 | (const $ return ()) 69 | 70 | 71 | 72 | 73 | 74 | -------------------------------------------------------------------------------- /examples/monad/session-chat/original/Types.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Types 6 | ( Message, User 7 | , Update(..), Request(..), Response(..) 8 | , UpdateS, RequestS, EndS 9 | , ServerInit, ServerProtocol 10 | , ClientInit, ClientProtocol 11 | , Connection(..), mkConnection 12 | ) where 13 | 14 | import Control.Concurrent.SimpleSession.SessionTypes 15 | ( Eps, Var, Rec, (:&:), (:+:), (:!:), (:?:) 16 | , Z ) 17 | import Control.Concurrent.SimpleSession.Implicit 18 | ( Rendezvous, newRendezvous ) 19 | 20 | -- | Type of the user identifier. 21 | type User = String 22 | 23 | -- | Type of messages. 24 | type Message = String 25 | 26 | -- | Updates from the server. 27 | data Update 28 | = UserLeftChat User 29 | | NewMessage User Message 30 | | NoUpdate 31 | deriving ( Eq, Show ) 32 | 33 | -- | Requests from the client. 34 | data Request 35 | = SendMessage Message 36 | | ShutdownServer 37 | | FetchUserList 38 | | NoRequest 39 | deriving ( Eq, Show ) 40 | 41 | -- | Responses from the server to the client 'Request's. 42 | data Response 43 | = EmptyResponse 44 | | UserListResponse [User] 45 | deriving ( Eq, Show ) 46 | 47 | -- | Type of a connection between server and client (View from server-side). 48 | data Connection = Connection { unwrapConnection :: Rendezvous (ServerInit (ServerProtocol (Var Z))) } 49 | 50 | -- | Create a new connection. 51 | mkConnection :: IO Connection 52 | mkConnection = Connection <$> newRendezvous 53 | 54 | -- | The server send the most current 'Update's to the client. 55 | type UpdateS r = [Update] :!: r 56 | 57 | -- | The client sends a 'Request' and receives a 'Response' from the server. 58 | type RequestS r = Request :?: (Response :!: r) 59 | 60 | -- | The server and the client have a choice to end communication... 61 | type EndS r = Eps :+: (Eps :&: r) 62 | 63 | -- | Initially the client has to introduce itself by name. 64 | type ServerInit r = User :?: (Rec r) 65 | 66 | -- | After the introduction we repeat the steps: 67 | -- 1. End of communication? 2. Updates from server; 3. Requests from the client; 68 | type ServerProtocol r = EndS (UpdateS (RequestS r)) 69 | 70 | type EndC r = Eps :&: (Eps :+: r) 71 | type RequestC r = Request :!: (Response :?: r) 72 | type UpdateC r = [Update] :?: r 73 | 74 | -- | The client-side version of the 'ServerInit'. 75 | type ClientInit r = User :!: (Rec r) 76 | 77 | -- | The client-side version of the 'ServerProtocol'. 78 | type ClientProtocol r = EndC (UpdateC (RequestC r)) 79 | 80 | 81 | 82 | 83 | -------------------------------------------------------------------------------- /examples/monad/session-chat/original/Utility.hs: -------------------------------------------------------------------------------- 1 | 2 | module Utility 3 | ( ifThenElse 4 | , stm 5 | , trim 6 | , isValidUserName 7 | ) where 8 | 9 | import Data.Char ( isSpace, isAscii, isAlpha, isNumber ) 10 | import Data.List ( dropWhileEnd ) 11 | 12 | import Control.Concurrent.STM 13 | ( STM, atomically ) 14 | 15 | import Control.Concurrent.SimpleSession.Implicit 16 | ( Session, io ) 17 | 18 | -- | Standard semantics for if-then-else to be used with rebindable syntax. 19 | ifThenElse :: Bool -> a -> a -> a 20 | ifThenElse True t _ = t 21 | ifThenElse False _ f = f 22 | 23 | -- | Execute an atomic portion of 'STM' within the 'Session' monad. 24 | stm :: STM a -> Session s s a 25 | stm = io . atomically 26 | 27 | -- | Remove whitespaces from beginning and end of string. 28 | trim :: String -> String 29 | trim str = dropWhile isSpace $ dropWhileEnd isSpace str 30 | 31 | -- | Check if the given username is valid. 32 | isValidUserName :: String -> Bool 33 | isValidUserName = all (\c -> isAscii c && (isAlpha c || isNumber c)) -------------------------------------------------------------------------------- /examples/monad/session-chat/original/session-chat-orig-example.cabal: -------------------------------------------------------------------------------- 1 | name: session-chat-orig-example 2 | version: 0.2.0 3 | synopsis: Example 4 | category: 5 | description: Example 6 | author: Jan Bracker 7 | maintainer: Jan Bracker 8 | stability: experimental 9 | copyright: Copyright (c) 2016, Jan Bracker 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable session-chat-orig 14 | build-depends: base >= 4.8 15 | , indexed == 0.1 16 | , stm >= 2.4 17 | , simple-sessions == 0.1.3 18 | main-is: Main.hs 19 | hs-source-dirs: . 20 | other-modules: Server 21 | , Client 22 | , Types 23 | , Utility 24 | default-language: Haskell2010 25 | ghc-options: -Wall -dcore-lint 26 | -fno-warn-name-shadowing -------------------------------------------------------------------------------- /examples/monad/session-chat/supermonad/.gitignore: -------------------------------------------------------------------------------- 1 | 2 | dist/ -------------------------------------------------------------------------------- /examples/monad/session-chat/supermonad/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 4 | 5 | module Main ( main ) where 6 | 7 | import Control.Supermonad.Prelude 8 | import Control.Supermonad.Functions ( when ) 9 | 10 | import System.IO 11 | ( hSetBuffering, stdout 12 | , BufferMode(NoBuffering) ) 13 | 14 | import Control.Concurrent ( forkIO ) 15 | import Control.Concurrent.STM ( atomically ) 16 | import Control.Concurrent.STM.TVar 17 | ( newTVarIO, readTVar, modifyTVar ) 18 | 19 | import Types ( User, Connection, mkConnection ) 20 | import Server ( server ) 21 | import Client 22 | ( clientShell 23 | , BotClient, mkBotClient 24 | , sendMessageBot, terminateBot ) 25 | 26 | main :: IO () 27 | main = do 28 | hSetBuffering stdout NoBuffering 29 | 30 | bots <- sequence 31 | $ fmap (\bot -> mkConnection >>= \conn -> bot conn >>= \b -> return (conn, b) ) 32 | $ [ responseBot "RB1" 33 | , rageBot "Rage" ] 34 | 35 | clientConn <- mkConnection 36 | 37 | _serverThread <- forkIO $ do 38 | _serverEnv <- server $ clientConn : fmap fst bots 39 | return () 40 | 41 | clientShell clientConn 42 | 43 | -- | Never use more then one! 44 | -- Weirdly, he does not respond to users that begin with the letter R. 45 | responseBot :: User -> Connection -> IO BotClient 46 | responseBot name conn = mkBotClient conn name 47 | (const $ return ()) 48 | (\bot u -> sendMessageBot bot $ "Goodbye, " ++ u ++ "!") 49 | (\bot u msg -> when (head u /= 'R') $ do 50 | if msg == ("die " ++ name) then do 51 | sendMessageBot bot $ "I obey and die now..." 52 | terminateBot bot 53 | else do 54 | sendMessageBot bot $ "I don't understand but I still respond, " ++ u ++ "!" 55 | ) 56 | (const $ return ()) 57 | 58 | rageBot :: User -> Connection -> IO BotClient 59 | rageBot name conn = do 60 | counterVar <- newTVarIO (0 :: Int) 61 | mkBotClient conn name 62 | (const $ return ()) 63 | (\bot u -> sendMessageBot bot $ "Finally you are gone, " ++ u ++ "!") 64 | (\bot u _msg -> do 65 | counter <- atomically $ readTVar counterVar 66 | if counter >= 5 then do 67 | sendMessageBot bot $ "I have had enough of this, " ++ u ++ "!" 68 | terminateBot bot 69 | else do 70 | sendMessageBot bot $ "Be quiet, " ++ u ++ "!" 71 | atomically $ modifyTVar counterVar (+1) 72 | ) 73 | (const $ return ()) 74 | 75 | 76 | 77 | 78 | 79 | -------------------------------------------------------------------------------- /examples/monad/session-chat/supermonad/Types.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 4 | 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-# OPTIONS_GHC -fno-warn-orphans #-} 11 | 12 | module Types 13 | ( Message, User 14 | , Update(..), Request(..), Response(..) 15 | , UpdateS, RequestS, EndS 16 | , ServerInit, ServerProtocol 17 | , ClientInit, ClientProtocol 18 | , Connection(..), mkConnection 19 | ) where 20 | 21 | import Control.Supermonad.Prelude 22 | 23 | import Control.Concurrent.SimpleSession.SessionTypes 24 | ( Eps, Var, Rec, (:&:), (:+:), (:!:), (:?:) 25 | , Z ) 26 | import Control.Concurrent.SimpleSession.Implicit 27 | ( Session 28 | , Rendezvous, newRendezvous ) 29 | 30 | import Control.Monad.Indexed ( (>>>=), ireturn, imap ) 31 | 32 | instance Functor (Session i j) where 33 | fmap = imap 34 | 35 | instance Bind (Session i j) (Session j k) (Session i k) where 36 | (>>=) = (>>>=) 37 | 38 | instance Applicative (Session i j) (Session j k) (Session i k) where 39 | mf <*> ma = mf >>= \f -> fmap f ma 40 | 41 | instance Return (Session i i) where 42 | return = ireturn 43 | 44 | instance Fail (Session i j) where 45 | fail = error 46 | 47 | -- | Type of the user identifier. 48 | type User = String 49 | 50 | -- | Type of messages. 51 | type Message = String 52 | 53 | -- | Updates from the server. 54 | data Update 55 | = UserLeftChat User 56 | | NewMessage User Message 57 | | NoUpdate 58 | deriving ( Eq, Show ) 59 | 60 | -- | Requests from the client. 61 | data Request 62 | = SendMessage Message 63 | | ShutdownServer 64 | | FetchUserList 65 | | NoRequest 66 | deriving ( Eq, Show ) 67 | 68 | -- | Responses from the server to the client 'Request's. 69 | data Response 70 | = EmptyResponse 71 | | UserListResponse [User] 72 | deriving ( Eq, Show ) 73 | 74 | -- | Type of a connection between server and client (View from server-side). 75 | data Connection = Connection { unwrapConnection :: Rendezvous (ServerInit (ServerProtocol (Var Z))) } 76 | 77 | -- | Create a new connection. 78 | mkConnection :: IO Connection 79 | mkConnection = Connection <$> newRendezvous 80 | 81 | -- | The server send the most current 'Update's to the client. 82 | type UpdateS r = [Update] :!: r 83 | 84 | -- | The client sends a 'Request' and receives a 'Response' from the server. 85 | type RequestS r = Request :?: (Response :!: r) 86 | 87 | -- | The server and the client have a choice to end communication... 88 | type EndS r = Eps :+: (Eps :&: r) 89 | 90 | -- | Initially the client has to introduce itself by name. 91 | type ServerInit r = User :?: (Rec r) 92 | 93 | -- | After the introduction we repeat the steps: 94 | -- 1. End of communication? 2. Updates from server; 3. Requests from the client; 95 | type ServerProtocol r = EndS (UpdateS (RequestS r)) 96 | 97 | type EndC r = Eps :&: (Eps :+: r) 98 | type RequestC r = Request :!: (Response :?: r) 99 | type UpdateC r = [Update] :?: r 100 | 101 | -- | The client-side version of the 'ServerInit'. 102 | type ClientInit r = User :!: (Rec r) 103 | 104 | -- | The client-side version of the 'ServerProtocol'. 105 | type ClientProtocol r = EndC (UpdateC (RequestC r)) 106 | 107 | 108 | 109 | 110 | -------------------------------------------------------------------------------- /examples/monad/session-chat/supermonad/Utility.hs: -------------------------------------------------------------------------------- 1 | 2 | module Utility 3 | ( stm 4 | , trim 5 | , isValidUserName 6 | ) where 7 | 8 | import Data.Char ( isSpace, isAscii, isAlpha, isNumber ) 9 | import Data.List ( dropWhileEnd ) 10 | 11 | import Control.Concurrent.STM 12 | ( STM, atomically ) 13 | 14 | import Control.Concurrent.SimpleSession.Implicit 15 | ( Session, io ) 16 | 17 | -- | Execute an atomic portion of 'STM' within the 'Session' monad. 18 | stm :: STM a -> Session s s a 19 | stm = io . atomically 20 | 21 | -- | Remove whitespaces from beginning and end of string. 22 | trim :: String -> String 23 | trim str = dropWhile isSpace $ dropWhileEnd isSpace str 24 | 25 | -- | Check if the given username is valid. 26 | isValidUserName :: String -> Bool 27 | isValidUserName = all (\c -> isAscii c && (isAlpha c || isNumber c)) -------------------------------------------------------------------------------- /examples/monad/session-chat/supermonad/session-chat-supermonad-example.cabal: -------------------------------------------------------------------------------- 1 | name: session-chat-supermonad-example 2 | version: 0.2.0 3 | synopsis: Example 4 | category: 5 | description: Example 6 | author: Jan Bracker 7 | maintainer: Jan Bracker 8 | stability: experimental 9 | copyright: Copyright (c) 2016, Jan Bracker 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable session-chat-supermonad 14 | build-depends: base >= 4.8 15 | , indexed == 0.1 16 | , stm >= 2.4 17 | , simple-sessions == 0.1.3 18 | , supermonad == 0.2.* 19 | main-is: Main.hs 20 | hs-source-dirs: . 21 | other-modules: Server 22 | , Client 23 | , Types 24 | , Utility 25 | default-language: Haskell2010 26 | ghc-options: -Wall -dynamic -dcore-lint 27 | -fno-warn-name-shadowing -------------------------------------------------------------------------------- /examples/monad/session/.gitignore: -------------------------------------------------------------------------------- 1 | 2 | dist/ -------------------------------------------------------------------------------- /examples/monad/session/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 6 | 7 | module Main ( main ) where 8 | 9 | import Prelude 10 | ( String, IO, Int 11 | , ($), (==), (-) 12 | , fromInteger 13 | , putStrLn ) 14 | 15 | import Control.Monad 16 | ( Monad (..) ) 17 | 18 | import Control.Monad.Indexed 19 | ( (>>>=) ) 20 | 21 | import Control.Concurrent 22 | ( forkIO ) 23 | 24 | import Control.Concurrent.SimpleSession.Implicit 25 | ( Session, Cap 26 | , io, send, recv, close, sel1, sel2, zero, offer, enter 27 | , newRendezvous, accept, request ) 28 | import Control.Concurrent.SimpleSession.SessionTypes 29 | ( Var, Eps 30 | , (:&:), (:+:), (:!:), (:?:) 31 | , Z ) 32 | 33 | type Ping = Eps :+: (String :!: String :?: Var Z) 34 | type Pong = Eps :&: (String :?: String :!: Var Z) 35 | 36 | ping :: Int -> Session (Cap (Ping, ()) Ping) () () 37 | pong :: Session (Cap (Pong, ()) Pong) () () 38 | main :: IO () 39 | 40 | main = do 41 | rv <- newRendezvous 42 | _ <- forkIO $ accept rv 43 | $ enter >>>= \_ -> ping 3 44 | request rv $ enter >>>= \_ -> pong 45 | 46 | ping 0 = do 47 | sel1; close 48 | where ma >> mb = ma >>>= \_ -> mb 49 | ping n = do 50 | sel2; send "Ping" 51 | rsp <- recv 52 | io $ putStrLn rsp 53 | zero; ping (n - 1) 54 | where (>>=) = (>>>=) 55 | ma >> mb = ma >>>= \_ -> mb 56 | 57 | pong = offer close $ do 58 | rsp <- recv 59 | io $ putStrLn rsp 60 | send "Pong" 61 | zero; pong 62 | where (>>=) = (>>>=) 63 | ma >> mb = ma >>>= \_ -> mb 64 | 65 | 66 | {- 67 | main = do 68 | rv <- newRendezvous 69 | _ <- forkIO $ accept rv 70 | $ enter >> ping 3 71 | request rv $ enter >> pong 72 | 73 | ping 0 = do 74 | sel1; close 75 | ping n = do 76 | sel2; send "Ping" 77 | rsp <- recv 78 | io $ putStrLn rsp 79 | zero; ping (n - 1) 80 | 81 | pong = offer close $ do 82 | rsp <- recv 83 | io $ putStrLn rsp 84 | send "Pong" 85 | zero; pong 86 | 87 | -} 88 | -------------------------------------------------------------------------------- /examples/monad/session/MainSupermonad.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE RebindableSyntax #-} 4 | 5 | -- Requires for instances 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | 9 | -- Use the supermonad plugin. 10 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | -- Remove this so compilation creates a proper executable. 14 | --module MainPolymonad ( main ) where 15 | 16 | import Control.Supermonad.Prelude 17 | 18 | 19 | import Control.Monad.Indexed 20 | ( IxPointed(..), (>>>=) ) 21 | import Data.Functor.Indexed 22 | ( IxApplicative(..) ) 23 | 24 | import Control.Concurrent 25 | ( forkIO ) 26 | 27 | import Control.Concurrent.SimpleSession.Implicit 28 | ( Session, Cap 29 | , io, send, recv, close, sel1, sel2, zero, offer, enter 30 | , newRendezvous, accept, request ) 31 | import Control.Concurrent.SimpleSession.SessionTypes 32 | ( Var, Eps 33 | , (:&:), (:+:), (:!:), (:?:) 34 | , Z ) 35 | 36 | instance Functor (Session i j) where 37 | fmap = fmap 38 | 39 | instance Applicative (Session i j) (Session j k) (Session i k) where 40 | (<*>) = iap 41 | 42 | instance Bind (Session i j) (Session j k) (Session i k) where 43 | (>>=) = (>>>=) 44 | 45 | instance Return (Session i i) where 46 | return = ireturn 47 | 48 | instance Fail (Session i j) where 49 | fail = error 50 | 51 | type Ping = Eps :+: (String :!: String :?: Var Z) 52 | type Pong = Eps :&: (String :?: String :!: Var Z) 53 | 54 | main :: IO () 55 | main = do 56 | rv <- newRendezvous 57 | _ <- forkIO $ accept rv 58 | $ enter >> ping 3 59 | request rv $ enter >> pong 60 | 61 | ping :: Int -> Session (Cap (Ping, ()) Ping) () () 62 | ping 0 = do 63 | sel1; close 64 | ping n = do 65 | sel2; send "Ping" 66 | rsp <- recv 67 | io $ putStrLn rsp 68 | zero; ping (n - 1) 69 | 70 | pong :: Session (Cap (Pong, ()) Pong) () () 71 | pong = offer close $ do 72 | rsp <- recv 73 | io $ putStrLn rsp 74 | send "Pong" 75 | zero; pong 76 | 77 | -------------------------------------------------------------------------------- /examples/monad/session/MainSupermonadTrans.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE RebindableSyntax #-} 4 | 5 | -- Requires for instances 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | 9 | -- Use the supermonad plugin. 10 | {-# OPTIONS_GHC -fplugin Control.Supermonad.Plugin #-} 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | -- Remove this so compilation creates a proper executable. 14 | --module MainPolymonad ( main ) where 15 | 16 | import Control.Supermonad.Prelude 17 | 18 | 19 | import Control.Monad.Indexed 20 | ( IxPointed(..), (>>>=) ) 21 | import Data.Functor.Indexed 22 | ( IxApplicative(..) ) 23 | import Control.Monad.Trans.State ( StateT(..) ) 24 | 25 | import Control.Concurrent 26 | ( forkIO ) 27 | 28 | import Control.Concurrent.SimpleSession.Implicit 29 | ( Session, Cap 30 | , io, send, recv, close, sel1, sel2, zero, offer, enter 31 | , newRendezvous, accept, request ) 32 | import Control.Concurrent.SimpleSession.SessionTypes 33 | ( Var, Eps 34 | , (:&:), (:+:), (:!:), (:?:) 35 | , Z ) 36 | 37 | instance Functor (Session i j) where 38 | fmap = fmap 39 | 40 | instance Applicative (Session i j) (Session j k) (Session i k) where 41 | (<*>) = iap 42 | 43 | instance Bind (Session i j) (Session j k) (Session i k) where 44 | (>>=) = (>>>=) 45 | 46 | instance Return (Session i i) where 47 | return = ireturn 48 | 49 | instance Fail (Session i j) where 50 | fail = error 51 | 52 | type Ping = Eps :+: (String :!: String :?: Var Z) 53 | type Pong = Eps :&: (String :?: String :!: Var Z) 54 | 55 | liftS :: ( BindCts (Session i j) (Session j j) (Session i j) 56 | --, ReturnCts (Session j j) 57 | ) => Session i j a -> StateT s (Session i j) a 58 | liftS sess = StateT $ \s -> sess >>= \a -> return (a, s) 59 | 60 | liftOffer :: StateT st (Session (Cap e r) u) a 61 | -> StateT st (Session (Cap e s) u) a 62 | -> StateT st (Session (Cap e (r :&: s)) u) a 63 | liftOffer ma mb = StateT $ \s -> offer (runStateT ma s) (runStateT mb s) 64 | 65 | modify :: ( Return m, ReturnCts m 66 | ) => (s -> s) -> StateT s m () 67 | modify f = StateT $ \s -> return ((), f s) 68 | 69 | 70 | main :: IO () 71 | main = do 72 | rv <- newRendezvous 73 | _ <- forkIO $ do 74 | res <- accept rv $ runStateT (liftS enter >> ping 3) 0 75 | putStrLn $ "Server: " ++ show res 76 | res <- request rv $ runStateT (liftS enter >> pong) 0 77 | putStrLn $ "Client: " ++ show res 78 | 79 | -- Use an Int state to count how often the send command is called. 80 | 81 | ping :: Int -> StateT Int (Session (Cap (Ping, ()) Ping) ()) () 82 | ping 0 = do 83 | liftS $ sel1 84 | liftS $ close 85 | ping n = do 86 | liftS $ sel2 87 | liftS $ send "Ping" 88 | modify (+1) 89 | rsp <- liftS $ recv 90 | liftS $ io $ putStrLn rsp 91 | liftS $ zero 92 | ping (n - 1) 93 | 94 | pong :: StateT Int (Session (Cap (Pong, ()) Pong) ()) () 95 | pong = liftOffer (liftS close) $ do 96 | rsp <- liftS $ recv 97 | liftS $ io $ putStrLn rsp 98 | liftS $ send "Pong" 99 | modify (+1) 100 | liftS $ zero 101 | pong 102 | 103 | -------------------------------------------------------------------------------- /examples/monad/session/session-example.cabal: -------------------------------------------------------------------------------- 1 | name: session-example 2 | version: 0.2.0 3 | synopsis: Example 4 | category: 5 | description: Example 6 | author: Jan Bracker 7 | maintainer: Jan Bracker 8 | stability: experimental 9 | copyright: Copyright (c) 2015, Jan Bracker 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable session-example 14 | build-depends: base >= 4.8, 15 | indexed == 0.1, 16 | simple-sessions == 0.1.3 17 | main-is: Main.hs 18 | hs-source-dirs: . 19 | default-language: Haskell2010 20 | ghc-options: -Wall -dcore-lint 21 | 22 | executable session-example-pm 23 | build-depends: base >= 4.8, 24 | indexed == 0.1, 25 | simple-sessions == 0.1.3, 26 | supermonad == 0.2.* 27 | main-is: MainSupermonad.hs 28 | hs-source-dirs: . 29 | default-language: Haskell2010 30 | ghc-options: -Wall -dynamic -dcore-lint 31 | 32 | executable session-example-pm-trans 33 | build-depends: base >= 4.8, 34 | indexed == 0.1, 35 | simple-sessions == 0.1.3, 36 | supermonad == 0.2.*, 37 | transformers >= 0.4 && < 0.6 38 | main-is: MainSupermonadTrans.hs 39 | hs-source-dirs: . 40 | default-language: Haskell2010 41 | ghc-options: -Wall -dynamic -dcore-lint -------------------------------------------------------------------------------- /examples/test/missing-functions/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | {- 3 | This module does nothing else them to import several standard library 4 | functions from the different supermonad modules to ensure they are all 5 | defined. 6 | 7 | This serves as a list of which functions are still missing by looking 8 | at those that are currently commented out. 9 | 10 | The main purpose of this file is to get an overview of how in sync 11 | the constrained and unconstrained versions are. 12 | -} 13 | 14 | -- There will be many of these... 15 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 16 | 17 | import qualified Prelude as P 18 | 19 | -- Base supermonad modules ----------------------------------------------------- 20 | import Control.Super.Monad 21 | ( Bind( (>>=), (>>), BindCts ) 22 | , Return( return, ReturnCts ) 23 | , Fail( fail, FailCts ) 24 | , Functor( fmap, (<$) ) 25 | , Applicative( (<*>), (*>), (<*), ApplicativeCts ) 26 | , Monad 27 | , pure 28 | ) 29 | import Control.Super.Monad.Constrained 30 | ( Bind( (>>=), (>>), BindCts ) 31 | , Return( return, ReturnCts ) 32 | , Fail( fail, FailCts ) 33 | , Functor( fmap, (<$), FunctorCts ) -- DIFF: FunctorCts 34 | , Applicative( (<*>), (*>), (<*), ApplicativeCts ) 35 | , Monad 36 | , pure 37 | ) 38 | 39 | -- Base superarrow modules ----------------------------------------------------- 40 | {- 41 | import Control.Super.Arrow 42 | ( ArrowArr( arr, ArrowArrCts ) 43 | , ArrowSequence( (>>>), (<<<), ArrowSequenceCts ) 44 | , ArrowSelect( first, second, ArrowSelectCts ) -- DIFF: ArrowSelectCts 45 | , ArrowParallel( (***), ArrowParallelCts ) 46 | , ArrowFanOut( (&&&), ArrowFanOutCts ) 47 | ) 48 | import Control.Super.Arrow.Constrained 49 | ( ArrowArr( arr, ArrowArrCts ) 50 | , ArrowSequence( (>>>), (<<<), ArrowSequenceCts ) 51 | , ArrowSelect( first, second, ArrowSelectFstCts, ArrowSelectSndCts ) -- DIFF: ArrowSelectFstCts, ArrowSelectSndCts 52 | , ArrowParallel( (***), ArrowParallelCts ) 53 | , ArrowFanOut( (&&&), ArrowFanOutCts ) 54 | ) 55 | -} 56 | -- Base functor modules -------------------------------------------------------- 57 | import Data.Functor 58 | ( Functor( fmap, (<$) ) 59 | ) 60 | import Control.Super.Monad.Constrained.Functor 61 | ( Functor( fmap, (<$), FunctorCts ) -- DIFF: FunctorCts 62 | ) 63 | 64 | -- Base supermonad standard library module ------------------------------------- 65 | import Control.Super.Monad.Functions 66 | ( mapM, mapM_ 67 | , forM, forM_ 68 | , sequence, sequence_ 69 | , (=<<), (>=>), (<=<) 70 | , forever, void, voidM 71 | , join 72 | -- , msum, mfilter -- FIXME: Requires an alternative of 'MonadPlus'. 73 | , filterM 74 | , mapAndUnzipM 75 | , zipWithM, zipWithM_ 76 | , foldM, foldM_ 77 | , replicateM, replicateM_ 78 | -- , guard -- FIXME: Requires an alternative of 'Alternative' 79 | , when, unless 80 | , liftM, liftM', liftM2, liftM3 81 | -- , liftM4, liftM5 -- TODO 82 | , ap 83 | , (<$!>), (<$>) 84 | , ifThenElse 85 | 86 | , liftA3, liftA2, liftA 87 | , voidA 88 | , (<**>) 89 | , mapA, mapA_ 90 | , forA, forA_ 91 | , filterA 92 | , sequenceA, sequenceA_ 93 | , traverse 94 | , zipWithA, zipWithA_ 95 | , mapAndUnzipA 96 | , replicateA, replicateA_ 97 | , whenA, unlessA 98 | ) 99 | import Control.Super.Monad.Constrained.Functions 100 | ( mapM, mapM_ 101 | , forM, forM_ 102 | , sequence, sequence_ 103 | , (=<<), (>=>), (<=<) 104 | , forever, void, voidM 105 | , join 106 | -- , msum, mfilter -- FIXME: Requires an alternative of 'MonadPlus'. 107 | , filterM 108 | , mapAndUnzipM 109 | , zipWithM, zipWithM_ 110 | , foldM, foldM_ 111 | , replicateM, replicateM_ 112 | -- , guard -- FIXME: Requires an alternative of 'Alternative' 113 | , when, unless 114 | , liftM, liftM', liftM2, liftM3 115 | -- , liftM4, liftM5 -- TODO 116 | , ap 117 | , (<$!>), (<$>) 118 | , ifThenElse 119 | 120 | , liftA3, liftA2, liftA 121 | , voidA 122 | , (<**>) 123 | , mapA, mapA_ 124 | , forA, forA_ 125 | , filterA 126 | , sequenceA, sequenceA_ 127 | , traverse 128 | , zipWithA, zipWithA_ 129 | , mapAndUnzipA 130 | , replicateA, replicateA_ 131 | , whenA, unlessA 132 | ) 133 | 134 | main :: P.IO () 135 | main = P.return () 136 | -------------------------------------------------------------------------------- /examples/test/missing-functions/missing-functions.cabal: -------------------------------------------------------------------------------- 1 | name: missing-functions 2 | version: 0.2.0 3 | synopsis: Example 4 | category: 5 | description: Example 6 | author: Jan Bracker 7 | maintainer: Jan Bracker 8 | stability: experimental 9 | copyright: Copyright (c) 2015, Jan Bracker 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable missing-functions 14 | build-depends: base >= 4.8 15 | , supermonad == 0.2.* 16 | main-is: Main.hs 17 | hs-source-dirs: . 18 | default-language: Haskell2010 19 | ghc-options: -Wall -dynamic -dcore-lint 20 | -------------------------------------------------------------------------------- /hcar/Supermonads-JS.tex: -------------------------------------------------------------------------------- 1 | % Supermonads-JS.tex 2 | \begin{hcarentry}[updated]{Supermonads} 3 | \report{Jan Bracker}%05/18 4 | \status{Experimental fully working version} 5 | \participants{Jan Bracker and Henrik Nilsson} 6 | \label{supermonads} 7 | \makeheader 8 | 9 | The supermonad package provides a unified way to represent different monadic 10 | and applicative notions. In other words, it provides a way to use standard and 11 | generalized monads and applicative functors (with additional indices or 12 | constraints) without having to manually disambiguate which notion is referred 13 | to in every context. This allows the reuse of code, such as standard library 14 | functions, across all of the notions. 15 | 16 | To achieve this, the library splits the monad and applicative type classes 17 | such that they are general enough to allow instances for all of the 18 | generalized notions and then aids constraint checking through a GHC plugin to 19 | ensure that everything type checks properly. Due to the plugin the library can 20 | only be used with GHC. 21 | 22 | If you are interested in using the library, we have a few examples of 23 | different size in the repository to show how it can be utilized. The generated 24 | Haddock documentation also has full coverage and can be seen on the libraries 25 | Hackage page. 26 | 27 | The project had its first release shortly before ICFP and the Haskell 28 | Symposium 2016. Since then we have added support for applicative functors in 29 | addition to monads. 30 | 31 | A comprehensive explanation of all aspects of the project 32 | and its theoretical foundations can be found in Jan Brackers PhD thesis. 33 | 34 | If you are interested in contributing, found a bug or have a suggestion to 35 | improve the project we are happy to hear from you in person, by email or over 36 | the projects bug tracker on GitHub. 37 | 38 | \FurtherReading 39 | \begin{compactitem} 40 | \item Hackage:\\ \url{http://hackage.haskell.org/package/supermonad} 41 | \item Repository:\\ \url{https://github.com/jbracker/supermonad} 42 | \item Paper:\\ 43 | \url{https://jbracker.de/publications/2016-BrackerNilsson-Supermonads.pdf} 44 | \item Bug-Tracker:\\ \url{https://github.com/jbracker/supermonad/issues} 45 | \item Haskell Symposium presentation:\\ \url{https://youtu.be/HRofw58sySw} 46 | \end{compactitem} 47 | \end{hcarentry} 48 | -------------------------------------------------------------------------------- /hcar/entry.tex: -------------------------------------------------------------------------------- 1 | \documentclass[DIV16,twocolumn,10pt]{scrreprt} 2 | \usepackage{paralist} 3 | \usepackage{graphicx} 4 | \usepackage[final]{hcar} 5 | 6 | %include polycode.fmt 7 | 8 | \begin{document} 9 | 10 | \input{Supermonads-JS.tex} 11 | 12 | \end{document} 13 | -------------------------------------------------------------------------------- /src/Control/Super/Monad/Constrained/Prelude.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Custom prelude to use if supermonads need to support constrained monads as well. 3 | module Control.Super.Monad.Constrained.Prelude 4 | ( -- * Supermonads 5 | module Control.Super.Monad.Constrained 6 | -- ** Replacement functions 7 | , F.mapM_, F.sequence_, (F.=<<) 8 | -- ** Traversable replacement functions 9 | , F.mapM, F.sequence 10 | -- * Fix rebindable syntax 11 | , F.ifThenElse 12 | -- * Prelude functions 13 | , module Control.Super.Monad.PreludeWithoutMonad 14 | ) where 15 | 16 | import Control.Super.Monad.PreludeWithoutMonad hiding ( Functor(..) ) 17 | import Control.Super.Monad.Constrained 18 | import qualified Control.Super.Monad.Constrained.Functions as F 19 | 20 | -------------------------------------------------------------------------------- /src/Control/Super/Monad/Prelude.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | -- | A replacement of the standard "Prelude" for supermonads. Should provide 5 | -- all of the functions also provided in the original prelude without 6 | -- the functions related specifically to 'P.Monad's. The functions related 7 | -- to 'P.Monad's are replaced with their supermonad counterparts. 8 | -- 9 | -- A replacement for the functions in "Control.Monad" can be found 10 | -- in "Control.Super.Monad.Functions". 11 | module Control.Super.Monad.Prelude 12 | ( -- * Supermonads 13 | module Control.Super.Monad 14 | -- ** Replacement functions 15 | , F.mapM_, F.sequence_, (F.=<<) 16 | -- ** Traversable replacement functions 17 | , F.mapM, F.sequence 18 | -- * Fix rebindable syntax 19 | , F.ifThenElse 20 | -- * Prelude functions 21 | , module Control.Super.Monad.PreludeWithoutMonad 22 | ) where 23 | 24 | 25 | import Control.Super.Monad 26 | import Control.Super.Monad.PreludeWithoutMonad 27 | import qualified Control.Super.Monad.Functions as F 28 | -------------------------------------------------------------------------------- /src/Control/Super/Monad/PreludeWithoutMonad.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | A verson of the standard prelude that does not export anything that 3 | -- involves standard monads. 4 | module Control.Super.Monad.PreludeWithoutMonad 5 | ( -- * Prelude 6 | -- ** Standard types, classes and related functions 7 | -- *** Basic data types 8 | P.Bool(..) 9 | , (P.&&), (P.||), P.not, P.otherwise 10 | , P.Maybe(..) 11 | , P.maybe 12 | , P.Either(..) 13 | , P.either 14 | , P.Ordering(..) 15 | , P.Char, P.String 16 | -- **** Tuples 17 | , P.fst, P.snd, P.curry, P.uncurry 18 | -- *** Basic type classes 19 | , P.Eq(..), P.Ord(..), P.Enum(..), P.Bounded(..) 20 | -- *** Numbers 21 | -- **** Numeric types 22 | , P.Int, P.Integer, P.Float, P.Double, P.Rational, P.Word 23 | -- **** Numeric type classes 24 | , P.Num(..), P.Real(..), P.Integral(..) 25 | , P.Fractional(..), P.Floating(..) 26 | , P.RealFrac(..), P.RealFloat(..) 27 | -- **** Numeric functions 28 | , P.subtract, P.even, P.odd, P.gcd, P.lcm 29 | , (P.^), (P.^^) 30 | , P.fromIntegral, P.realToFrac 31 | -- *** Monoids 32 | , P.Monoid(..) 33 | -- *** (Monads and) functors 34 | , P.Functor(..), (P.<$>) 35 | -- , P.Applicative(..) -- Nope not this one! 36 | -- , P.Monad(..) -- Nope not this one! 37 | -- *** Folds and traversals 38 | , P.Foldable(..) 39 | , P.Traversable(traverse, sequenceA) -- Only export the non-monad functions. 40 | -- *** Miscellaneous functions 41 | , P.id, P.const, P.flip, P.until, P.asTypeOf, P.error, P.undefined, P.seq 42 | , (P..), (P.$), (P.$!) 43 | -- ** List operations 44 | , P.map, P.filter, P.head, P.last, P.tail, P.init, P.reverse 45 | , (P.++), (P.!!) 46 | -- *** Special folds 47 | , P.and, P.or, P.any, P.all 48 | , P.concat, P.concatMap 49 | -- *** Building lists 50 | -- **** Scans 51 | , P.scanl, P.scanl1, P.scanr, P.scanr1 52 | -- **** Infinite lists 53 | , P.iterate, P.repeat, P.replicate, P.cycle 54 | -- *** Sublists 55 | , P.take, P.drop, P.splitAt, P.takeWhile, P.dropWhile, P.span, P.break 56 | -- *** Searching lists 57 | , P.notElem, P.lookup 58 | -- *** Zipping and unzipping lists 59 | , P.zip, P.zip3, P.zipWith, P.zipWith3, P.unzip, P.unzip3 60 | -- *** Functions on strings 61 | , P.lines, P.words, P.unlines, P.unwords 62 | -- ** Converting from and to @String@ 63 | -- *** Converting to @String@ 64 | , P.ShowS, P.Show(..) 65 | , P.shows, P.showChar, P.showString, P.showParen 66 | -- *** Converting from @String@ 67 | , P.ReadS, P.Read(..) 68 | , P.reads, P.readParen, P.read, P.lex 69 | -- ** Basic input and output 70 | , P.IO 71 | -- *** Simple I/O operations 72 | -- **** Output functions 73 | , P.putChar, P.putStr, P.putStrLn, P.print 74 | -- **** Input functions 75 | , P.getChar, P.getLine, P.getContents, P.interact 76 | -- **** Files 77 | , P.FilePath 78 | , P.readFile, P.writeFile, P.appendFile, P.readIO, P.readLn 79 | -- *** Exception handing in the I/O monad 80 | , P.IOError 81 | , P.ioError, P.userError 82 | ) where 83 | 84 | import qualified Prelude as P -------------------------------------------------------------------------------- /src/Control/Super/Plugin/ClassDict.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE CPP #-} 3 | 4 | -- | Provides the type to store classes and instances used by the plugin. 5 | module Control.Super.Plugin.ClassDict 6 | ( ClassDict 7 | , Optional 8 | , emptyClsDict 9 | , insertClsDict, insertOptionalClsDict 10 | , lookupClsDict 11 | , isOptionalClass 12 | , lookupClsDictClass, lookupClsDictInstances 13 | , allClsDictKeys, allClsDictEntries ) where 14 | 15 | import qualified Data.Set as S 16 | import qualified Data.Map.Strict as M 17 | 18 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0) 19 | import Data.Semigroup ( Semigroup(..) ) 20 | #endif 21 | 22 | import Control.Monad ( join ) 23 | 24 | import Class ( Class ) 25 | import InstEnv ( ClsInst(..) ) 26 | import qualified Outputable as O 27 | 28 | -- | Flag to indicate if a class is optional. 29 | type Optional = Bool 30 | 31 | -- | Dictionary type to lookup classes and their available instances based 32 | -- on string identifiers. 33 | newtype ClassDict = ClassDict (M.Map String (Optional, Maybe (Class, [ClsInst]))) 34 | 35 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0) 36 | -- | Semigroup based on union. 37 | instance Semigroup ClassDict where 38 | (<>) (ClassDict clsDictA) (ClassDict clsDictB) = ClassDict $ mappend clsDictA clsDictB 39 | #endif 40 | 41 | -- | See 'M.union'. 42 | instance Monoid ClassDict where 43 | mempty = emptyClsDict 44 | mappend (ClassDict clsDictA) (ClassDict clsDictB) = ClassDict $ mappend clsDictA clsDictB 45 | 46 | instance O.Outputable ClassDict where 47 | ppr (ClassDict clsDict) = O.text "ClassDict " O.<> O.parens (O.ppr clsDict) 48 | 49 | -- | The empty class dictionary. 50 | emptyClsDict :: ClassDict 51 | emptyClsDict = ClassDict $ M.empty 52 | 53 | -- | Insert an entry into a class dictionary. 54 | insertClsDict :: String -> Optional -> Class -> [ClsInst] -> ClassDict -> ClassDict 55 | insertClsDict key opt cls insts (ClassDict dict) = ClassDict $ M.insert key (opt, Just (cls, insts)) dict 56 | 57 | -- | Insert the entry of an optional missing class into the dictionary. 58 | insertOptionalClsDict :: String -> ClassDict -> ClassDict 59 | insertOptionalClsDict key (ClassDict dict) = ClassDict $ M.insert key (True, Nothing) dict 60 | 61 | -- | Check if the given class is optional for solving. 62 | isOptionalClass :: String -> ClassDict -> Bool 63 | isOptionalClass key (ClassDict dict) = case M.lookup key dict of 64 | Nothing -> False 65 | Just (opt, _) -> opt 66 | 67 | -- | Try to lookup an entry in a class dictionary. 68 | lookupClsDict :: String -> ClassDict -> Maybe (Class, [ClsInst]) 69 | lookupClsDict key (ClassDict dict) = join $ fmap snd $ M.lookup key dict 70 | 71 | -- | Try to lookup the class in a class dictionary. 72 | lookupClsDictClass :: String -> ClassDict -> Maybe Class 73 | lookupClsDictClass key dict = fmap fst $ lookupClsDict key dict 74 | 75 | -- | Try to lookup the 'Control.Supermonad.Applicative' instance of the type constructor. 76 | lookupClsDictInstances :: String -> ClassDict -> Maybe [ClsInst] 77 | lookupClsDictInstances key dict = fmap snd $ lookupClsDict key dict 78 | 79 | -- | Retrieve the 'S.Set' of all type constructors in that have an entry in 80 | -- the supermonad dictionary. 81 | allClsDictKeys :: ClassDict -> S.Set String 82 | allClsDictKeys (ClassDict dict) = M.keysSet dict 83 | 84 | -- | Retrives all of the entries stored in the class dictionary. 85 | allClsDictEntries :: ClassDict -> [(Optional, Maybe (Class, [ClsInst]))] 86 | allClsDictEntries (ClassDict dict) = M.elems dict 87 | -------------------------------------------------------------------------------- /src/Control/Super/Plugin/Collection/Map.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE CPP #-} 3 | 4 | --{-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | -- | Provides a internal implementation of 'Data.Map.Map's that can be used 9 | -- with GHC types that are 'Uniquable' but not 'Ord'erable. 10 | module Control.Super.Plugin.Collection.Map 11 | ( Map 12 | , empty 13 | , null, size 14 | , insert, lookup, delete 15 | , member, notMember 16 | , map, filter 17 | , union, unions 18 | , fromList, toList 19 | , elems 20 | , keysSet, keys 21 | ) where 22 | 23 | import Prelude hiding ( null, lookup, map, filter ) 24 | 25 | import Data.Data ( Data ) 26 | 27 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0) 28 | import Data.Semigroup ( Semigroup(..) ) 29 | #endif 30 | 31 | import Unique ( Uniquable, getUnique ) 32 | import UniqFM ( UniqFM ) 33 | import qualified UniqFM as U 34 | import qualified Outputable as O 35 | 36 | import qualified Control.Super.Plugin.Collection.Set as S 37 | 38 | -- | A map with keys of type @k@ and elements of type @a@. 39 | newtype Map k a = Map { unMap :: UniqFM (k, a) } deriving Data 40 | 41 | -- | Maps can be checked for equality if their elements and keys allow it. 42 | instance (Eq k, Eq a) => Eq (Map k a) where 43 | ma == mb = unMap ma == unMap mb 44 | ma /= mb = unMap ma /= unMap mb 45 | 46 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0) 47 | -- | Semigroup based on union. 48 | instance Semigroup (Map k a) where 49 | (<>) = union 50 | #endif 51 | 52 | -- | Monoid based on union and the empty map. 53 | instance Monoid (Map k a) where 54 | mempty = empty 55 | mappend = union 56 | mconcat = unions 57 | 58 | instance (O.Outputable a, O.Outputable k) => O.Outputable (Map k a) where 59 | ppr = (O.ppr) . unMap 60 | 61 | -- | The empty map. 62 | empty :: Map k a 63 | empty = Map $ U.emptyUFM 64 | 65 | -- | Is the map empty? 66 | null :: Map k a -> Bool 67 | null ma = U.isNullUFM $ unMap ma 68 | 69 | -- | Count the number of entries in the map. 70 | size :: Map k a -> Int 71 | size ma = U.sizeUFM $ unMap ma 72 | 73 | -- | Check if the given key has an entry in the map. 74 | member :: Uniquable k => k -> Map k a -> Bool 75 | member k ma = U.elemUFM k $ unMap ma 76 | 77 | -- | Check if the given key does not have an entry in the map. 78 | notMember :: Uniquable k => k -> Map k a -> Bool 79 | notMember k ma = not $ member k ma 80 | 81 | -- | Insert the given key value pair in the map. Any preexisting 82 | -- entry with the same key will be replaced. 83 | insert :: forall k a. Uniquable k => k -> a -> Map k a -> Map k a 84 | insert k e m = Map $ U.alterUFM (Just . f) (unMap m) k 85 | where f :: Maybe (k , a) -> (k , a) 86 | -- Insert a new key and value in the map 87 | f Nothing = (k, e) 88 | -- If the key is already present in the map, the associated value is replaced with the supplied value 89 | f (Just (k', _e)) | getUnique k' == getUnique k = (k', e) 90 | -- Ignore non matching keys 91 | f (Just entry) = entry 92 | 93 | -- | Retrieve the associated entry of the given key, if there is one. 94 | lookup :: Uniquable k => k -> Map k a -> Maybe a 95 | lookup k m = fmap snd $ U.lookupUFM (unMap m) k 96 | 97 | -- | Remove the entry with the given key, if it exists. 98 | delete :: Uniquable k => k -> Map k a -> Map k a 99 | delete k m = Map $ U.delFromUFM (unMap m) k 100 | 101 | -- | Merge together two maps. If there are two entries with the 102 | -- same key, the left (first) map will be prefered (left bias). 103 | union :: Map k a -> Map k a -> Map k a 104 | union ma mb = Map $ U.plusUFM_C (\a _ -> a) (unMap ma) (unMap mb) 105 | 106 | -- | Merge several maps together. If there are two entries with the 107 | -- same key, the left-most map in the list will be prefered (left bias). 108 | unions :: [Map k a] -> Map k a 109 | unions ms = foldl union empty ms 110 | 111 | -- | Maps the entries of a map using the given function. 112 | map :: (a -> b) -> Map k a -> Map k b 113 | map f ma = Map $ U.mapUFM (\(k,e) -> (k,f e)) $ unMap ma 114 | 115 | -- | Filter the value of a map using the given predicate. 116 | -- Only thoes entries that the predicate yields 'True' for 117 | -- will be kept. 118 | filter :: (a -> Bool) -> Map k a -> Map k a 119 | filter p ma = Map $ U.filterUFM (p . snd) $ unMap ma 120 | 121 | -- | Convert the map into a list of key value pairs. 122 | toList :: Map k a -> [(k, a)] 123 | toList m = U.eltsUFM $ unMap m 124 | 125 | -- | Create a map from a list of key value pairs. 126 | -- If there are several pairs with the same key the entry 127 | -- of the last pair in the list with that key will be kept. 128 | fromList :: Uniquable k => [(k, a)] -> Map k a 129 | fromList l = Map $ U.listToUFM $ fmap (\(k, a) -> (k , (k , a))) l 130 | 131 | -- | Create a list of all entries in the map. There is no 132 | -- guarenteed order for the list. 133 | elems :: Map k a -> [a] 134 | elems ma = fmap snd $ toList ma 135 | 136 | -- | Create a 'Set' containing all the keys in the map. 137 | keysSet :: Uniquable k => Map k a -> S.Set k 138 | keysSet ma = S.fromList $ keys ma 139 | 140 | -- | Create a list containing all the keys in the map. 141 | -- There is no guarenteed order for the list. 142 | keys :: Map k a -> [k] 143 | keys ma = fmap fst $ toList ma 144 | -------------------------------------------------------------------------------- /src/Control/Super/Plugin/Collection/Set.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE CPP #-} 3 | 4 | -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | 7 | -- | Provides a internal implementation of 'Data.Set.Set's that can be used 8 | -- with GHC types that are 'Uniquable' but not 'Ord'erable. 9 | module Control.Super.Plugin.Collection.Set 10 | ( Set 11 | , empty, singleton 12 | , null, size, member, notMember 13 | , isSubsetOf, isProperSubsetOf 14 | , insert, delete 15 | , filter, map 16 | , union, unions, intersection, difference, (\\) 17 | , toList, fromList 18 | ) where 19 | 20 | import Prelude hiding ( null, filter, map ) 21 | 22 | import Data.Data ( Data ) 23 | 24 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0) 25 | import Data.Semigroup ( Semigroup(..) ) 26 | #endif 27 | 28 | import Unique ( Uniquable ) 29 | import UniqSet ( UniqSet ) 30 | import qualified UniqSet as U 31 | import qualified Outputable as O 32 | import Control.Super.Plugin.Wrapper ( uniqSetToList ) 33 | 34 | -- | A set with elements of type @a@. 35 | newtype Set a = Set { unSet :: UniqSet a } deriving Data 36 | 37 | -- | Sets can be checked for equality if their elements allow it. 38 | instance (Eq a) => Eq (Set a) where 39 | sa == sb = unSet sa == unSet sb 40 | sa /= sb = unSet sa /= unSet sb 41 | 42 | 43 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0) 44 | -- | Semigroup based on union. 45 | instance Semigroup (Set a) where 46 | (<>) = union 47 | #endif 48 | 49 | -- | Monoid based on union and the empty set. 50 | instance Monoid (Set a) where 51 | mempty = empty 52 | mappend = union 53 | mconcat = unions 54 | 55 | instance (O.Outputable a) => O.Outputable (Set a) where 56 | ppr = (O.ppr) . unSet 57 | 58 | -- | The empty set. 59 | empty :: Set a 60 | empty = Set $ U.emptyUniqSet 61 | 62 | -- | Create a set with exactly one element. 63 | singleton :: Uniquable a => a -> Set a 64 | singleton a = Set $ U.unitUniqSet a 65 | 66 | -- | Is the set empty? 67 | null :: Set a -> Bool 68 | null s = U.isEmptyUniqSet $ unSet s 69 | 70 | -- | Compute the number of elements in the set. 71 | size :: Set a -> Int 72 | size s = U.sizeUniqSet $ unSet s 73 | 74 | -- | Check if a given element is in a set. 75 | member :: Uniquable a => a -> Set a -> Bool 76 | member a s = U.elementOfUniqSet a $ unSet s 77 | 78 | -- | Check if a given element is not in a set. 79 | notMember :: Uniquable a => a -> Set a -> Bool 80 | notMember a s = not $ member a s 81 | 82 | -- | Check if the first set is a subset of the second. 83 | -- The sets may be equal. 84 | isSubsetOf :: Ord a => Set a -> Set a -> Bool 85 | isSubsetOf sub super = intersection sub super == sub 86 | 87 | -- | Check if the first set is a subset of the second. 88 | -- The sets may not be equal. 89 | isProperSubsetOf :: Ord a => Set a -> Set a -> Bool 90 | isProperSubsetOf sub super = let i = intersection sub super in i == sub && i /= super 91 | 92 | -- | Insert a given element into a set. This will replace any 93 | -- preexisting element with the same unique reprentation in 94 | -- the set. 95 | insert :: Uniquable a => a -> Set a -> Set a 96 | insert a s = Set $ U.addOneToUniqSet (unSet s) a 97 | 98 | -- | Delete a given element from a set. This will remove 99 | -- any preexisting element with the same unique reprentation in 100 | -- the set. 101 | delete :: Uniquable a => a -> Set a -> Set a 102 | delete a s = Set $ U.delOneFromUniqSet (unSet s) a 103 | 104 | -- | Map the element of a set using the given function. 105 | map :: Uniquable b => (a -> b) -> Set a -> Set b 106 | -- We need to use a custom implementation of "U.mapUniqSet", 107 | -- because back in GHC 7.10 it was implemented wrong. 108 | map f s = Set $ (U.mkUniqSet . fmap f . uniqSetToList) $ unSet s 109 | 110 | -- | Filter the elements of a set using the given predicate. 111 | -- Only those elements where the predicate yields 'True' are kept. 112 | filter :: (a -> Bool) -> Set a -> Set a 113 | filter p s = Set $ U.filterUniqSet p $ unSet s 114 | 115 | -- | Merge two sets into one with a union. 116 | union :: Set a -> Set a -> Set a 117 | union sa sb = Set $ U.unionUniqSets (unSet sa) (unSet sb) 118 | 119 | -- | Merge a list of sets into one using a union. 120 | unions :: [Set a] -> Set a 121 | unions ss = Set $ U.unionManyUniqSets $ fmap unSet ss 122 | 123 | -- | Merge two set, but only keep those elements that 124 | -- were present in both sets. 125 | intersection :: Set a -> Set a -> Set a 126 | intersection sa sb = Set $ U.intersectUniqSets (unSet sa) (unSet sb) 127 | 128 | -- | Remove all element that are in the second set from the first one. 129 | difference :: Set a -> Set a -> Set a 130 | difference sa sb = Set $ U.minusUniqSet (unSet sa) (unSet sb) 131 | 132 | -- | Remove all element that are in the second set from the first one. 133 | (\\) :: Set a -> Set a -> Set a 134 | (\\) = difference 135 | 136 | -- | Convert the set into a list. There is not guarenteed order for the 137 | -- elements to appear in. 138 | toList :: Set a -> [a] 139 | toList s = uniqSetToList $ unSet s 140 | 141 | -- | Convert a list into a set. If there are several elements with the 142 | -- same unique representation only one of them will be kept. 143 | fromList :: Uniquable a => [a] -> Set a 144 | fromList l = Set $ U.mkUniqSet l 145 | -------------------------------------------------------------------------------- /src/Control/Super/Plugin/Debug.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Utility functions useful for debugging the plugin. Some of these 3 | -- may be unsafe to use in general. 4 | module Control.Super.Plugin.Debug 5 | ( containsAnyOf 6 | , containsAllOf 7 | , containsNoneOf 8 | , pprToStr, sDocToStr 9 | ) where 10 | 11 | import Data.List ( isInfixOf ) 12 | 13 | import Outputable 14 | ( Outputable(..), SDoc 15 | , showSDocUnsafe ) 16 | 17 | -- | Convert some generic outputable to a string (potentially unsafe). 18 | pprToStr :: Outputable o => o -> String 19 | pprToStr = sDocToStr . ppr 20 | 21 | -- | Convert an 'SDoc' to a string (potentially unsafe). 22 | sDocToStr :: SDoc -> String 23 | sDocToStr = showSDocUnsafe 24 | 25 | -- | Check if the string reprentation of the given 'Outputable' 26 | -- contains __any__ of the given strings. 27 | containsAnyOf :: (Outputable o) => o -> [String] -> Bool 28 | containsAnyOf obj = any (`isInfixOf` pprToStr obj) 29 | 30 | -- | Check if the string reprentation of the given 'Outputable' 31 | -- contains __all__ of the given strings. 32 | containsAllOf :: (Outputable o) => o -> [String] -> Bool 33 | containsAllOf obj = all (`isInfixOf` pprToStr obj) 34 | 35 | -- | Check if the string reprentation of the given 'Outputable' 36 | -- contains __none__ of the given strings. 37 | containsNoneOf :: (Outputable o) => o -> [String] -> Bool 38 | containsNoneOf obj = not . (obj `containsAnyOf`) 39 | -------------------------------------------------------------------------------- /src/Control/Super/Plugin/Environment/Lift.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Provides versions of functions written for 'TcPluginM' 3 | -- that are lifted into 'SupermonadPluginM'. 4 | module Control.Super.Plugin.Environment.Lift 5 | ( 6 | -- * From "Control.Supermonad.Plugin.Evidence" 7 | produceEvidenceForCt 8 | , produceEvidenceFor 9 | , isPotentiallyInstantiatedCt 10 | -- * From "Control.Supermonad.Plugin.Utils" 11 | , partiallyApplyTyCons 12 | -- * From "Control.Supermonad.Plugin.Detect" 13 | , findClassesAndInstancesInScope 14 | ) where 15 | 16 | import TcRnTypes ( Ct ) 17 | import TcEvidence ( EvTerm ) 18 | import Outputable ( SDoc ) 19 | import Type ( Type, TyVar ) 20 | import TyCon ( TyCon ) 21 | import InstEnv ( ClsInst ) 22 | 23 | import Control.Super.Plugin.Environment 24 | ( SupermonadPluginM 25 | , runTcPlugin 26 | , getGivenConstraints 27 | , throwPluginErrorSDoc 28 | ) 29 | import Control.Super.Plugin.ClassDict ( ClassDict, insertClsDict, insertOptionalClsDict ) 30 | 31 | import qualified Control.Super.Plugin.Utils as U 32 | import qualified Control.Super.Plugin.Detect as D 33 | import qualified Control.Super.Plugin.Evidence as E 34 | 35 | -- | See 'E.produceEvidenceForCt'. 36 | produceEvidenceForCt :: Ct -> SupermonadPluginM s (Either SDoc EvTerm) 37 | produceEvidenceForCt ct = do 38 | givenCts <- getGivenConstraints 39 | runTcPlugin $ E.produceEvidenceForCt givenCts ct 40 | 41 | -- | See 'E.produceEvidenceFor'. 42 | produceEvidenceFor :: ClsInst -> [Type] -> SupermonadPluginM s (Either SDoc EvTerm) 43 | produceEvidenceFor inst instArgs = do 44 | givenCts <- getGivenConstraints 45 | runTcPlugin $ E.produceEvidenceFor givenCts inst instArgs 46 | 47 | -- | See 'E.isPotentiallyInstantiatedCt'. 48 | isPotentiallyInstantiatedCt :: Ct -> [(TyVar, Either TyCon TyVar)] -> SupermonadPluginM s Bool 49 | isPotentiallyInstantiatedCt ct assoc = do 50 | givenCts <- getGivenConstraints 51 | runTcPlugin $ E.isPotentiallyInstantiatedCt givenCts ct assoc 52 | 53 | -- | See 'U.partiallyApplyTyCons'. 54 | partiallyApplyTyCons :: [(TyVar, Either TyCon TyVar)] -> SupermonadPluginM s (Either SDoc [(TyVar, Type, [TyVar])]) 55 | partiallyApplyTyCons = runTcPlugin . U.partiallyApplyTyCons 56 | 57 | -- | See 'D.findClassesAndInstancesInScope'. In addition to calling the 58 | -- function from the @Detect@ module it also throws an error if the call 59 | -- fails. Otherwise, inserts the found classes and instances into the provided 60 | -- class dictionary and returns the updated dictionary. 61 | findClassesAndInstancesInScope :: D.ClassQuery -> ClassDict -> SupermonadPluginM s ClassDict 62 | findClassesAndInstancesInScope clsQuery oldClsDict = do 63 | let optQuery = D.isOptionalClassQuery clsQuery 64 | eFoundClsInsts <- runTcPlugin $ D.findClassesAndInstancesInScope clsQuery 65 | case eFoundClsInsts of 66 | Right [] | optQuery -> 67 | return $ foldr insertOptionalClsDict oldClsDict $ D.queriedClasses clsQuery 68 | Right clsInsts -> 69 | return $ foldr (\(clsName, cls, insts) -> insertClsDict clsName optQuery cls insts) oldClsDict clsInsts 70 | Left errMsg -> throwPluginErrorSDoc errMsg -------------------------------------------------------------------------------- /src/Control/Super/Plugin/Instance.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Functions and utilities to work with and inspect class instances 3 | -- of the GHC API. 4 | module Control.Super.Plugin.Instance 5 | ( instanceClass 6 | , instanceClassTyCon 7 | , instanceTopTyCons 8 | , instanceTyArgs 9 | , isClassInstance 10 | , isMonoTyConInstance 11 | , isPolyTyConInstance 12 | ) where 13 | 14 | import InstEnv 15 | ( ClsInst(..) 16 | , instanceHead ) 17 | import Type ( Type ) 18 | import Class ( Class, classTyCon ) 19 | import TyCon ( TyCon ) 20 | 21 | import qualified Control.Super.Plugin.Collection.Set as S 22 | import Control.Super.Plugin.Utils ( collectTopTyCons ) 23 | 24 | -- | Checks if the given instance is of the given type class. 25 | isClassInstance :: Class -> ClsInst -> Bool 26 | isClassInstance cls inst = instanceClass inst == cls 27 | 28 | -- | Returns the type class of the given instance. 29 | instanceClass :: ClsInst -> Class 30 | instanceClass = is_cls 31 | 32 | -- | Returns the type constructors of the class is instance instantiates. 33 | instanceClassTyCon :: ClsInst -> TyCon 34 | instanceClassTyCon inst = classTyCon $ instanceClass inst 35 | 36 | -- | Collects the top type constructors of the instance arguments. 37 | instanceTopTyCons :: ClsInst -> S.Set TyCon 38 | instanceTopTyCons = collectTopTyCons . instanceTyArgs 39 | 40 | -- | Returns the arguments of the given instance head. 41 | instanceTyArgs :: ClsInst -> [Type] 42 | instanceTyArgs inst = args 43 | where (_, _, args) = instanceHead inst 44 | 45 | -- | Check if the given instance has the following head 46 | -- @C (M ...) ... (M ...)@ where @M@ is the given type 47 | -- constructor and @C@ is the given class. The arguments of the @M@s 48 | -- do not have to be equal to each other. 49 | isMonoTyConInstance :: TyCon -> Class -> ClsInst -> Bool 50 | isMonoTyConInstance tc cls inst 51 | = isClassInstance cls inst 52 | && all (== S.singleton tc) argTopTcs 53 | where 54 | argTopTcs :: [S.Set TyCon] 55 | argTopTcs = fmap ( collectTopTyCons . (: []) ) $ instanceTyArgs inst 56 | 57 | -- | Checks if the given instance is from the given class, but does not form 58 | -- a mono type constructor instance as in 'isMonoTyConInstance'. 59 | isPolyTyConInstance :: Class -> ClsInst -> Bool 60 | isPolyTyConInstance cls inst = isClassInstance cls inst && allNotEmpty && not (allEqual argTopTcs) 61 | where 62 | argTopTcs :: [S.Set TyCon] 63 | argTopTcs = fmap ( collectTopTyCons . (: []) ) $ instanceTyArgs inst 64 | 65 | allNotEmpty = all (not . S.null) argTopTcs 66 | 67 | allEqual [] = True 68 | allEqual (a:as) = all (a ==) as 69 | 70 | 71 | 72 | 73 | 74 | 75 | -------------------------------------------------------------------------------- /src/Control/Super/Plugin/InstanceDict.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE CPP #-} 3 | 4 | -- | Provides the type for instance dictionaries. 5 | module Control.Super.Plugin.InstanceDict 6 | ( InstanceDict 7 | , emptyInstDict, insertInstDict 8 | , lookupInstDict, lookupInstDictByTyCon 9 | , allInstDictTyCons 10 | , instDictToList ) where 11 | 12 | import Data.Maybe ( maybeToList, fromMaybe ) 13 | 14 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0) 15 | import Data.Semigroup ( Semigroup(..) ) 16 | #endif 17 | 18 | import Class ( Class ) 19 | import InstEnv ( ClsInst ) 20 | import TyCon ( TyCon ) 21 | import qualified Outputable as O 22 | 23 | import qualified Control.Super.Plugin.Collection.Set as S 24 | import qualified Control.Super.Plugin.Collection.Map as M 25 | 26 | -- | A dictionary associating supermonad type constructors and classes with 27 | -- their instances. 28 | -- This is essentially a lookup table for instances associated with a 29 | -- given type constructor and class. 30 | newtype InstanceDict = InstanceDict (M.Map TyCon (M.Map Class ClsInst)) 31 | 32 | instance Monoid InstanceDict where 33 | mappend (InstanceDict dictA) (InstanceDict dictB) = InstanceDict $ foldr (\tc dictAB -> M.insert tc (combineClsMaps tc) dictAB) M.empty keysAB -- mappend dictA dictB 34 | where 35 | keysAB :: [TyCon] 36 | keysAB = S.toList $ M.keysSet dictA `S.union` M.keysSet dictB 37 | 38 | combineClsMaps :: TyCon -> M.Map Class ClsInst 39 | combineClsMaps tc = (fromMaybe M.empty $ M.lookup tc dictA) `M.union` (fromMaybe M.empty $ M.lookup tc dictB) 40 | 41 | mempty = emptyInstDict 42 | 43 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0) 44 | instance Semigroup InstanceDict where 45 | (<>) = mappend 46 | #endif 47 | 48 | instance O.Outputable InstanceDict where 49 | ppr (InstanceDict instDict) = O.text "InstanceDict " O.<> O.parens (O.ppr instDict) 50 | 51 | -- | The empty instance dictionary. 52 | emptyInstDict :: InstanceDict 53 | emptyInstDict = InstanceDict $ M.empty 54 | 55 | -- | Insert an entry into a instance dictionary. 56 | insertInstDict :: TyCon -> Class -> ClsInst -> InstanceDict -> InstanceDict 57 | insertInstDict tc cls inst (InstanceDict instDict) 58 | = InstanceDict $ M.insert tc (M.insert cls inst (fromMaybe M.empty $ M.lookup tc instDict)) instDict 59 | 60 | -- | Try to lookup an entry in a instance dictionary. 61 | lookupInstDict :: TyCon -> Class -> InstanceDict -> Maybe ClsInst 62 | lookupInstDict tc cls (InstanceDict instDict) = do 63 | clsDict <- M.lookup tc instDict 64 | M.lookup cls clsDict 65 | 66 | -- | Retrieve the 'S.Set' of all type constructors in that have an entry in 67 | -- the supermonad dictionary. 68 | allInstDictTyCons :: InstanceDict -> S.Set TyCon 69 | allInstDictTyCons (InstanceDict instDict) = M.keysSet instDict 70 | 71 | -- | Looks up all entries with the given type constructor as key. 72 | -- Returns a mapping between the classes and their instances for that 73 | -- type constructor. 74 | lookupInstDictByTyCon :: TyCon -> InstanceDict -> M.Map Class ClsInst 75 | lookupInstDictByTyCon tc (InstanceDict instDict) = fromMaybe M.empty $ M.lookup tc instDict 76 | 77 | -- | Convert the instance dictionary into a list of key value pairs for inspection. 78 | instDictToList :: InstanceDict -> [((TyCon, Class), ClsInst)] 79 | instDictToList dict@(InstanceDict instDict) = do 80 | tc <- M.keys instDict 81 | cls <- M.keys $ fromMaybe M.empty $ M.lookup tc instDict 82 | clsInst <- maybeToList $ lookupInstDict tc cls dict 83 | return ( (tc , cls) , clsInst ) 84 | -------------------------------------------------------------------------------- /src/Control/Super/Plugin/Names.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Constant names that are used throughout the plugin. 3 | module Control.Super.Plugin.Names 4 | ( -- * Types 5 | PluginModuleName 6 | , PluginClassName 7 | -- * Supermonad Module Names 8 | , supermonadModuleName 9 | , supermonadCtModuleName 10 | , legacySupermonadModuleName 11 | , legacySupermonadCtModuleName 12 | , supermonadPreludeModuleName 13 | , supermonadCtPreludeModuleName 14 | , legacySupermonadPreludeModuleName 15 | , legacySupermonadCtPreludeModuleName 16 | , functorModuleName 17 | -- * Supermonad Class Names 18 | , bindClassName 19 | , returnClassName 20 | , functorClassName 21 | , applicativeClassName 22 | -- * Superarrow Module Names 23 | , superarrowModuleName 24 | , superarrowCtModuleName 25 | -- * Superarrow Class Names 26 | , arrowArrClassName 27 | , arrowSequenceClassName 28 | , arrowSelectClassName 29 | , arrowParallelClassName 30 | , arrowFanOutClassName 31 | ) where 32 | 33 | -- | Type of module names the plugin uses. 34 | type PluginModuleName = String 35 | 36 | -- | Type of class names the plugin uses. 37 | type PluginClassName = String 38 | 39 | -- ----------------------------------------------------------------------------- 40 | -- Constant Supermonad Names (Magic Numbers...) 41 | -- ----------------------------------------------------------------------------- 42 | 43 | -- | Name of the "Control.Supermonad" module. 44 | legacySupermonadModuleName :: PluginModuleName 45 | legacySupermonadModuleName = "Control.Supermonad" 46 | 47 | -- | Name of the "Control.Super.Monad" module. 48 | supermonadModuleName :: PluginModuleName 49 | supermonadModuleName = "Control.Super.Monad" 50 | 51 | -- | Name of the "Control.Supermonad.Constrained" module. 52 | legacySupermonadCtModuleName :: PluginModuleName 53 | legacySupermonadCtModuleName = "Control.Supermonad.Constrained" 54 | 55 | -- | Name of the "Control.Super.Monad.Constrained" module. 56 | supermonadCtModuleName :: PluginModuleName 57 | supermonadCtModuleName = "Control.Super.Monad.Constrained" 58 | 59 | -- | Name of the @Bind@ type class. 60 | -- Also used as dictionary key for the @Bind@ class. 61 | bindClassName :: PluginClassName 62 | bindClassName = "Bind" 63 | 64 | -- | Name of the @Return@ type class. 65 | -- Also used as dictionary key for the @Return@ class. 66 | returnClassName :: PluginClassName 67 | returnClassName = "Return" 68 | 69 | -- | Name of the @Functor@ class. 70 | -- Also used as dictionary key for the @Functor@ class. 71 | functorClassName :: PluginClassName 72 | functorClassName = "Functor" 73 | 74 | -- | Name of the @Applicative@ type class. 75 | -- Also used as dictionary key for the @Applicative@ class. 76 | applicativeClassName :: PluginClassName 77 | applicativeClassName = "Applicative" 78 | 79 | -- | Name of the "Control.Supermonad.Prelude" module. 80 | legacySupermonadPreludeModuleName :: PluginModuleName 81 | legacySupermonadPreludeModuleName = "Control.Supermonad.Prelude" 82 | 83 | -- | Name of the "Control.Super.Monad.Prelude" module. 84 | supermonadPreludeModuleName :: PluginModuleName 85 | supermonadPreludeModuleName = "Control.Super.Monad.Prelude" 86 | 87 | -- | Name of the "Control.Supermonad.Constrained.Prelude" module. 88 | legacySupermonadCtPreludeModuleName :: PluginModuleName 89 | legacySupermonadCtPreludeModuleName = "Control.Supermonad.Constrained.Prelude" 90 | 91 | -- | Name of the "Control.Super.Monad.Constrained.Prelude" module. 92 | supermonadCtPreludeModuleName :: PluginModuleName 93 | supermonadCtPreludeModuleName = "Control.Super.Monad.Constrained.Prelude" 94 | 95 | -- | Name of the "Data.Functor" module. 96 | functorModuleName :: PluginModuleName 97 | functorModuleName = "Data.Functor" 98 | 99 | -- ----------------------------------------------------------------------------- 100 | -- Constant Superarrow Names (Magic Numbers...) 101 | -- ----------------------------------------------------------------------------- 102 | 103 | -- | Name of the "Control.Super.Arrow" module. 104 | superarrowModuleName :: PluginModuleName 105 | superarrowModuleName = "Control.Super.Arrow" 106 | 107 | -- | Name of the "Control.Super.Arrow.Constrained" module. 108 | superarrowCtModuleName :: PluginModuleName 109 | superarrowCtModuleName = "Control.Super.Arrow.Constrained" 110 | 111 | -- | Name of the @ArrowArr@ type class. 112 | -- Also used as dictionary key for the @ArrowArr@ class. 113 | arrowArrClassName :: PluginClassName 114 | arrowArrClassName = "ArrowArr" 115 | 116 | -- | Name of the @ArrowSequence@ class. 117 | -- Also used as dictionary key for the @ArrowSequence@ class. 118 | arrowSequenceClassName :: PluginClassName 119 | arrowSequenceClassName = "ArrowSequence" 120 | 121 | -- | Name of the @ArrowSelect@ type class. 122 | -- Also used as dictionary key for the @ArrowSelect@ class. 123 | arrowSelectClassName :: PluginClassName 124 | arrowSelectClassName = "ArrowSelect" 125 | 126 | -- | Name of the @ArrowParallel@ class. 127 | -- Also used as dictionary key for the @ArrowParallel@ class. 128 | arrowParallelClassName :: PluginClassName 129 | arrowParallelClassName = "ArrowParallel" 130 | 131 | -- | Name of the @ArrowFanOut@ class. 132 | -- Also used as dictionary key for the @ArrowFanOut@ class. 133 | arrowFanOutClassName :: PluginClassName 134 | arrowFanOutClassName = "ArrowFanOut" 135 | 136 | 137 | 138 | 139 | -------------------------------------------------------------------------------- /src/Control/Supermonad.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | See "Control.Super.Monad". 3 | module Control.Supermonad 4 | ( module Control.Super.Monad 5 | ) where 6 | 7 | import Control.Super.Monad -------------------------------------------------------------------------------- /src/Control/Supermonad/Constrained.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | See "Control.Super.Monad.Constrained". 3 | module Control.Supermonad.Constrained 4 | ( module Control.Super.Monad.Constrained 5 | ) where 6 | 7 | import Control.Super.Monad.Constrained -------------------------------------------------------------------------------- /src/Control/Supermonad/Constrained/Prelude.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | See "Control.Super.Monad.Constrained.Prelude". 3 | module Control.Supermonad.Constrained.Prelude 4 | ( module Control.Super.Monad.Constrained.Prelude 5 | ) where 6 | 7 | import Control.Super.Monad.Constrained.Prelude 8 | -------------------------------------------------------------------------------- /src/Control/Supermonad/Functions.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | See "Control.Super.Monad.Functions". 3 | module Control.Supermonad.Functions 4 | ( module Control.Super.Monad.Functions 5 | ) where 6 | 7 | import Control.Super.Monad.Functions 8 | -------------------------------------------------------------------------------- /src/Control/Supermonad/Plugin.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | See "Control.Super.Monad.Plugin". 3 | module Control.Supermonad.Plugin 4 | ( module Control.Super.Monad.Plugin 5 | ) where 6 | 7 | import Control.Super.Monad.Plugin -------------------------------------------------------------------------------- /src/Control/Supermonad/Prelude.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | See "Control.Super.Monad.Prelude". 3 | module Control.Supermonad.Prelude 4 | ( module Control.Super.Monad.Prelude 5 | ) where 6 | 7 | import Control.Super.Monad.Prelude -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main ( main ) where 3 | {- 4 | import qualified Data.Map as M 5 | import qualified Data.Set as S 6 | import qualified Control.Super.Plugin.Collection.Map as UM 7 | import qualified Control.Super.Plugin.Collection.Set as US 8 | -} 9 | import Test.Utils 10 | import qualified Test.Control.Super.Plugin.Collection.Map as Map 11 | import qualified Test.Control.Super.Plugin.Collection.Set as Set 12 | 13 | main :: IO () 14 | main = do 15 | putStrLn "=== Set Tests ===" 16 | runTests (Set.tests) 17 | putStrLn "=== Map Tests ===" 18 | runTests (Map.tests) 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /tests/Test/Utils.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE GADTs #-} 3 | 4 | module Test.Utils 5 | ( Test(..) 6 | , runTest, runTests 7 | ) where 8 | 9 | import System.Exit ( exitFailure ) 10 | 11 | import Test.QuickCheck 12 | 13 | data Test where 14 | Test :: (Testable p) => String -> p -> Test 15 | 16 | runTests :: [Test] -> IO () 17 | runTests = sequence_ . fmap runTest 18 | 19 | runTest :: Test -> IO () 20 | runTest (Test name p) = do 21 | putStrLn $ "+++ " ++ name 22 | res <- quickCheckResult p 23 | case res of 24 | Success {} -> return () 25 | GaveUp {} -> return () 26 | _ -> exitFailure 27 | --------------------------------------------------------------------------------