├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .travis.yml ├── Changelog.md ├── LICENSE ├── README.md ├── Setup.hs ├── benchmarks ├── BenchLam.hs └── benchmark-main.hs ├── examples ├── CanonicalLF.lhs ├── F.hs ├── LC.hs └── Nanevski.lhs ├── src └── Unbound │ └── Generics │ ├── LocallyNameless.hs │ ├── LocallyNameless │ ├── Alpha.hs │ ├── Bind.hs │ ├── Embed.hs │ ├── Fresh.hs │ ├── Ignore.hs │ ├── Internal │ │ ├── Fold.hs │ │ ├── GSubst.hs │ │ ├── Iso.hs │ │ └── Lens.hs │ ├── LFresh.hs │ ├── Name.hs │ ├── Operations.hs │ ├── Rebind.hs │ ├── Rec.hs │ ├── Shift.hs │ ├── Subst.hs │ ├── TH.hs │ ├── Types.hs │ └── Unsafe.hs │ └── PermM.hs ├── stack.yaml ├── test ├── AlphaAssertions.hs ├── AlphaProperties.hs ├── Calc.hs ├── ParallelReduction.hs ├── PropOpenClose.hs ├── TestACompare.hs ├── TestCalc.hs ├── TestIgnore.hs ├── TestParallelReduction.hs ├── TestRefine.hs ├── TestShiftEmbed.hs ├── TestSubstBind.hs ├── TestTH.hs ├── TinyLam.hs └── test-main.hs └── unbound-generics.cabal /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Copied from https://github.com/kowainik/.github/blob/main/workflow-templates/ci.yml 4 | # and the blog post https://kodimensional.dev/github-actions by @chshersh 5 | 6 | # Trigger the workflow on push or pull request, but only for the main branch 7 | on: 8 | workflow_dispatch: 9 | pull_request: 10 | types: [synchronize, opened, reopened] 11 | push: 12 | branches: [main] 13 | # schedule: 14 | # # additionally run once per week (At 00:00 on Sunday) to maintain cache 15 | # - cron: '0 0 * * 0' 16 | 17 | jobs: 18 | cabal: 19 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 20 | runs-on: ${{ matrix.os }} 21 | strategy: 22 | fail-fast: false 23 | matrix: 24 | # os: [ubuntu-latest, macOS-latest, windows-latest] 25 | os: [ ubuntu-latest ] 26 | cabal: [latest] 27 | ghc: 28 | - "8.0" 29 | - "8.2" 30 | - "8.4" 31 | - "8.6" 32 | - "8.8" 33 | - "8.10" 34 | - "9.0" 35 | - "9.2" 36 | - "9.4" 37 | - "9.8" 38 | # exclude: 39 | # - os: macOS-latest 40 | # ghc: 8.8 41 | # - os: macOS-latest 42 | # ghc: 8.6 43 | # - os: windows-latest 44 | # ghc: 8.8 45 | # - os: windows-latest 46 | # ghc: 8.6 47 | 48 | steps: 49 | - uses: actions/checkout@v3 50 | 51 | - uses: haskell-actions/setup@v2 52 | id: setup-haskell-cabal 53 | name: Setup Haskell 54 | with: 55 | ghc-version: ${{ matrix.ghc }} 56 | cabal-version: ${{ matrix.cabal }} 57 | 58 | - name: Configure 59 | run: | 60 | cabal configure --enable-tests --enable-benchmarks --enable-documentation --test-show-details=direct --write-ghc-environment-files=always 61 | 62 | - name: Freeze 63 | run: | 64 | cabal freeze 65 | 66 | - uses: actions/cache@v3 67 | name: Cache ~/.cabal/store 68 | with: 69 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 70 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 71 | 72 | - name: Install dependencies 73 | run: | 74 | cabal build all --only-dependencies 75 | 76 | - name: Build 77 | run: | 78 | cabal build all 79 | 80 | - name: Test 81 | run: | 82 | cabal test all 83 | 84 | - name: Documentation 85 | run: | 86 | cabal haddock 87 | 88 | # stack: 89 | # name: stack / ghc ${{ matrix.ghc }} 90 | # runs-on: ubuntu-latest 91 | # strategy: 92 | # matrix: 93 | # stack: ["2.3.1"] 94 | # ghc: ["8.8.3"] 95 | 96 | # steps: 97 | # - uses: actions/checkout@v2 98 | # if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 99 | 100 | # - uses: actions/setup-haskell@v1.1 101 | # name: Setup Haskell Stack 102 | # with: 103 | # ghc-version: ${{ matrix.ghc }} 104 | # stack-version: ${{ matrix.stack }} 105 | 106 | # - uses: actions/cache@v1 107 | # name: Cache ~/.stack 108 | # with: 109 | # path: ~/.stack 110 | # key: ${{ runner.os }}-${{ matrix.ghc }}-stack 111 | 112 | # - name: Build 113 | # run: | 114 | # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks 115 | 116 | # - name: Test 117 | # run: | 118 | # stack test --system-ghc 119 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.hi 3 | *.ho 4 | .cabal-sandbox/ 5 | cabal.sandbox.config 6 | dist/ 7 | .stack-work/ 8 | dist-newstyle/ 9 | cabal.project.local 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'unbound-generics.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.10 12 | # 13 | version: ~> 1.0 14 | language: c 15 | os: linux 16 | dist: xenial 17 | git: 18 | # whether to recursively clone submodules 19 | submodules: false 20 | cache: 21 | directories: 22 | - $HOME/.cabal/packages 23 | - $HOME/.cabal/store 24 | - $HOME/.hlint 25 | before_cache: 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 27 | # remove files that are regenerated by 'cabal update' 28 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 29 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 30 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 31 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 32 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 33 | - rm -rfv $CABALHOME/packages/head.hackage 34 | jobs: 35 | include: 36 | - compiler: ghc-8.10.1 37 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}} 38 | os: linux 39 | - compiler: ghc-8.8.3 40 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}} 41 | os: linux 42 | - compiler: ghc-8.6.5 43 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}} 44 | os: linux 45 | - compiler: ghc-8.4.4 46 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}} 47 | os: linux 48 | - compiler: ghc-8.2.2 49 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}} 50 | os: linux 51 | - compiler: ghc-8.0.2 52 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}} 53 | os: linux 54 | - compiler: ghc-7.10.3 55 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.3","cabal-install-3.2"]}} 56 | os: linux 57 | - compiler: ghc-7.8.4 58 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.4","cabal-install-3.2"]}} 59 | os: linux 60 | before_install: 61 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 62 | - WITHCOMPILER="-w $HC" 63 | - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') 64 | - HCPKG="$HC-pkg" 65 | - unset CC 66 | - CABAL=/opt/ghc/bin/cabal 67 | - CABALHOME=$HOME/.cabal 68 | - export PATH="$CABALHOME/bin:$PATH" 69 | - TOP=$(pwd) 70 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 71 | - echo $HCNUMVER 72 | - CABAL="$CABAL -vnormal+nowrap" 73 | - set -o pipefail 74 | - TEST=--enable-tests 75 | - BENCH=--enable-benchmarks 76 | - HEADHACKAGE=false 77 | - rm -f $CABALHOME/config 78 | - | 79 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 80 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 81 | echo "write-ghc-environment-files: always" >> $CABALHOME/config 82 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 83 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 84 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 85 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 86 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 87 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 88 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 89 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 90 | echo "install-dirs user" >> $CABALHOME/config 91 | echo " prefix: $CABALHOME" >> $CABALHOME/config 92 | echo "repository hackage.haskell.org" >> $CABALHOME/config 93 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 94 | install: 95 | - ${CABAL} --version 96 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 97 | - | 98 | echo "program-default-options" >> $CABALHOME/config 99 | echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config 100 | - cat $CABALHOME/config 101 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 102 | - travis_retry ${CABAL} v2-update -v 103 | # Generate cabal.project 104 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 105 | - touch cabal.project 106 | - | 107 | echo "packages: ." >> cabal.project 108 | - if [ $HCNUMVER -ge 80200 ] ; then echo 'package unbound-generics' >> cabal.project ; fi 109 | - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" 110 | - | 111 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(unbound-generics)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 112 | - cat cabal.project || true 113 | - cat cabal.project.local || true 114 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 115 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} 116 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 117 | - rm cabal.project.freeze 118 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all 119 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all 120 | script: 121 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 122 | # Packaging... 123 | - ${CABAL} v2-sdist all 124 | # Unpacking... 125 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 126 | - cd ${DISTDIR} || false 127 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 128 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 129 | - PKGDIR_unbound_generics="$(find . -maxdepth 1 -type d -regex '.*/unbound-generics-[0-9.]*')" 130 | # Generate cabal.project 131 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 132 | - touch cabal.project 133 | - | 134 | echo "packages: ${PKGDIR_unbound_generics}" >> cabal.project 135 | - if [ $HCNUMVER -ge 80200 ] ; then echo 'package unbound-generics' >> cabal.project ; fi 136 | - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" 137 | - | 138 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(unbound-generics)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 139 | - cat cabal.project || true 140 | - cat cabal.project.local || true 141 | # Building... 142 | # this builds all libraries and executables (without tests/benchmarks) 143 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 144 | # Building with tests and benchmarks... 145 | # build & run tests, build benchmarks 146 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all 147 | # Testing... 148 | - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all 149 | # cabal check... 150 | - (cd ${PKGDIR_unbound_generics} && ${CABAL} -vnormal check) 151 | # haddock... 152 | - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all 153 | # Building without installed constraints for packages in global-db... 154 | - rm -f cabal.project.local 155 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 156 | 157 | # REGENDATA ("0.10",["unbound-generics.cabal"]) 158 | # EOF 159 | -------------------------------------------------------------------------------- /Changelog.md: -------------------------------------------------------------------------------- 1 | # NEXT 2 | 3 | # 0.4.4 4 | 5 | * Add `Alpha` and `Subst` instances for `NonEmpty`. Thanks Brent Yorgey (byorgey) 6 | * Add GHC 9.8 to CI matrix 7 | * Bump `base` >= 4.9 8 | * Remove `tested-with: 7.x` in `unbound-generics.cabal`. We removed CI testing with GHC 7.x last year. 9 | * Move GSubst from `Unbound.Generics.LocallyNameless.Subst` into a separate `Internal` module that is exported. Now users can write their own generic traversals. 10 | Thanks Bohdan Liesnikov (liesnikov) 11 | * Welcome Austin Erlandson (erlandsona) as a maintainer 12 | 13 | # 0.4.3 14 | 15 | * Add an `instantiate` function that substitutes a list of terms for a collection of bound variables in a toplevel `Bind p t` term. 16 | Thanks to Stephanie Weirich (sweirich). This adds a new `substBvs` function to the `Subst` class. 17 | * Add `substBind` operation that substitutes for the bound variable of a `Bind (Name a) t` term. 18 | This is a specialization of `instantiate` to the case where the pattern is a single `Name a` 19 | * Tests for `substBind` by Mark Lemay (marklemay) Thanks! 20 | * Expose `Rec` constructor of the `Rec` type and the `ctxLevel` function from `AlphaCtx` 21 | * Require `transformers < 0.6`, run CI with GHC 9.4, drop CI with GHC 7.10. 22 | Thanks to Andreas Abel (andreaasabel). 23 | 24 | # 0.4.2 25 | 26 | * Add `Functor` instance for `Unbound.Generics.LocallyNameless.Internal.Iso.Exchange` 27 | Thanks to Emily Pillmore (emilypi) 28 | * Import `MonadPlus` and `MonadFix` explicitly when building with mtl-2.3 29 | * Builds with GHC 9.0, GHC 9.2 30 | 31 | # 0.4.1 32 | 33 | * Add `MonadFail` instances for `LFreshMT` and `FreshMT` 34 | 35 | * Builds with GHC 8.10 36 | 37 | # 0.4.0 38 | 39 | * New binding specification type `Ignore`. 40 | 41 | Any two `Ignore T` terms will always be alpha-equivalent to each other, will 42 | be considered to contain no variables, and will not have any substitution 43 | apply beneath `Ignore`. Useful for attaching annotation terms to your AST. 44 | 45 | ```haskell 46 | import Text.Parsec.Pos (SourcePos) 47 | 48 | data Expr = 49 | ... 50 | | Lambda (Ignore SourcePos) (Bind (Name Expr) Expr) 51 | ``` 52 | 53 | As expected, any two `Lambda` expressions will be considered alpha-equivalent 54 | even if they differ in source position. 55 | 56 | Note that the `Ignore` will block operations on `Name a` for all `a`, which can be a little unexpected: 57 | 58 | ```haskell 59 | data Ty = 60 | TyVar (Name Ty) 61 | | TyArr Ty Ty 62 | 63 | instance Subst Ty Ty where 64 | ... 65 | 66 | data Expr = 67 | ... 68 | | Var (Name Expr) 69 | | Lambda (Ignore Ty) (Bind (Name Expr) Expr) 70 | 71 | instance Subst Ty Expr 72 | ``` 73 | 74 | Applying a substitution of a type for a free type variable to a `Lambda` will 75 | not descend into the `Ignore Ty`. 76 | 77 | Thanks Reed Mullanix (TOTWBF) for the new operation. 78 | 79 | * Fix an issue in substitution where traversal would not continue in 80 | an AST node for which `isvar` or `isCoerceVar` is defined to return 81 | non-`Nothing` but which had additional structure. 82 | 83 | For example, in a language with meta variables and explicit substitutions: 84 | ```haskell 85 | data Expr = 86 | ... 87 | -- normal variables that stand for expressions 88 | | Var (Name Expr) 89 | -- a meta variable occurrence and an explicit substitution 90 | -- of expressions to substitute in for the free variables 91 | | MetaVar (Name Meta) [(Name Expr, Expr)] 92 | -- a meta variable stands for an expression with some free term vars 93 | data Meta = MetaVar Expr 94 | 95 | -- substitution for a meta in an expression 96 | instance Subst Expr Meta where 97 | isCoerceVar (MetaVar u sub) = Just (SubstCoerce u (Just . applyExplicitSubst sub)) 98 | applyExplicitSubst :: [(Name Expr, Expr)] -> Meta -> Expr 99 | applyExplicitSubst s (MetaVar e) = substs s e 100 | ``` 101 | 102 | Given an expression `e1` defined as `MetaVar "u" [("x", 10)]`, we may want to 103 | substitute a `Meta ("x" + "x")` for `"u"` to get `10 + 10` (that is, 104 | we replace `"u"` by the expression `"x" + "x"` and immediately apply 105 | the substitution `10` for `"x"`). 106 | 107 | Now suppose we have an expression `e2` defined as `MetaVar "v" [("y", 108 | e1)]` (that is, an occurrence of meta var "v" together with a 109 | substitution of `e1` from above for `"y"`). If we again try to 110 | substitute `Meta ("x" + "x")` for `"u"` in `e2`, we would expect to 111 | get `MetaVar "v" [("y", 10 + 10)]` (that is, since "v" is not equal to 112 | "u", we leave the meta var alone, but substitute for any occurrences 113 | of "u" in the explicit substitution, so `e1` becomes `10 + 10` as 114 | before). 115 | 116 | The bug in previous versions of `unbound-generics` was that we would 117 | incorrectly leave `MetaVar "v" [("y", e1)]` unchanged as soon as we 118 | saw that `isCoerceVar (MetaVar "v" [("y", e1)])` returned 119 | `Just (SubstCoerce "u" ...)` where `"u" /= "v"`. 120 | 121 | Thanks Reed Mullanix (TOTWBF) for finding and fixing this issue. 122 | https://github.com/lambdageek/unbound-generics/issues/26 123 | 124 | # 0.3.4 125 | 126 | * Bump `containers` upper bound to support `0.6`. 127 | (GHC 8.6.1 support) 128 | Thanks Christiaan Baaij. 129 | 130 | # 0.3.3 131 | 132 | * Bump `exceptions` upper bound to support `0.10.0` 133 | 134 | # 0.3.2 135 | 136 | * Bump `deepseq >= 1.4.0.0` remove benchmark dependency on `deepseq-generics` 137 | * Tested with GHC 8.4.1 138 | * Tested with GHC 8.2.2 139 | * Compile with `-Wcompat` 140 | * Add `Semigroup` instances for all types that were previously `Monoid` instances 141 | * Added more examples to the [examples/ directory](https://github.com/lambdageek/unbound-generics/tree/main/examples) 142 | * Added "exceptions" dependency and `MonadThrow`, `MonadCatch`, `MonadMask` instances for `FreshMT` and `LFreshMT`. 143 | Thanks Alex McKenna. 144 | 145 | # 0.3.1 146 | 147 | * Tested with GHC 8.0.1 148 | * Removed `Generic b` constraint from `Subst b (Name a)` instance. 149 | 150 | 151 | # 0.3 152 | 153 | * Change types of `open` and `close` to take `NthPatFind` and `NamePatFind` instead of generic patterns, update call sites. 154 | * Add newtype wrappers and Monoid instances for `NthPatFind` and `NamePatFind` 155 | * Change `isTerm` to return `All` instead of `Bool` 156 | 157 | # 0.2 158 | 159 | * Incorporating some of the extras/oversights from 160 | [clash-lib Unbound.Generics.LocallyNameless.Extra](https://github.com/clash-lang/clash-compiler/blob/master/clash-lib/src/Unbound/Generics/LocallyNameless/Extra.hs) 161 | 162 | * Make `Embed` an instance of `Ord` 163 | * `NFData` instances (see below) 164 | 165 | * Re-implement `freshen'` and `gfreshen` using a free monad to give 166 | GHC a chance to inline it all away. This changes the type of 167 | `gfreshen`. Major version bump. 168 | 169 | * Expose `FFM`, `liftFFM` and `retractFFM` 170 | 171 | * Provide `NFData` instances for all the combinators. 172 | Depend on 'deepseq' 173 | 174 | * Start benchmarking some of the operations (particularly `unbind`). 175 | 176 | # 0.1.2.1 177 | 178 | * Fix ghc-7.10 build. 179 | * Haddock cleanup. 180 | 181 | # 0.1.2 182 | 183 | * Added `IsEmbed` typeclass 184 | 185 | * Depend on 'profunctors' 186 | 187 | * Changed `embed` and `unembed` to work over any `IsEmbed` type. 188 | 189 | * Added `Shift` type for shifting the scope of embedded terms out one level. 190 | 191 | # 0.1.1 192 | 193 | * Added `isNullDisjointSet` function. 194 | * Implement a TH `makeClosedAlpha` splice for constructing trivial leaf instances. 195 | 196 | # 0.1 197 | 198 | * Add `acompare` functiona and `acompare'` method to `Alpha` typeclass. (christiaanb) 199 | 200 | Handwritten `Alpha` instances will need to define this additional 201 | method now. Major version bump. 202 | 203 | # 0.0.3 204 | 205 | * Add 'name2Integer' method (christiaanb) 206 | * Export internal type-directed `gaeq`, `gopen`, `gclose`, etc 207 | functions from `Unbound.Generics.LocallyNameless.Alpha`. 208 | 209 | Allows definitions like: 210 | 211 | instance Alpha Term where 212 | aeq' _ (Prim t1 _dk1) (Prim t2 _dk2) = t1 == t2 213 | aeq' c t1 t2 = gaeq c (from t1) (from t2) 214 | 215 | 216 | # 0.0.2.1 217 | 218 | * Unconditionally add ErrorT and ExceptT instances using transformers-compat (bergmark) 219 | 220 | # 0.0.2 221 | 222 | * Add 'Rec' pattern and 'TRec' term combinators. 223 | 224 | * Alpha instance for '()' 225 | 226 | # 0.0.1 227 | 228 | * Add 'lunbind2' function. 229 | 230 | * Doc updates. 231 | 232 | * Switch from 'HUnit' to 'Tasty' for testing. 233 | 234 | # 0.0.0.90 235 | 236 | * Initial (re-)implementation effort. 237 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014-2016, Aleksey Kliger 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 Aleksey Kliger nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # unbound-generics 2 | 3 | [![Join the chat at https://gitter.im/lambdageek/unbound-generics](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/lambdageek/unbound-generics?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) 4 | [![Discord](https://img.shields.io/discord/732650960471720076?logo=discord)](https://discord.gg/CRfu93W) 5 | 6 | [![Hackage](https://img.shields.io/hackage/v/unbound-generics.svg)](https://hackage.haskell.org/package/unbound-generics) 7 | [![CI](https://github.com/lambdageek/unbound-generics/workflows/CI/badge.svg)](https://github.com/lambdageek/unbound-generics/actions?query=workflow%3ACI+branch%3Amain) 8 | 9 | 10 | Support for programming with names and binders using GHC Generics. 11 | 12 | ## Summary 13 | 14 | Specify the binding structure of your data type with an expressive set of type combinators, and `unbound-generics` 15 | handles the rest! Automatically derives alpha-equivalence, free variable calculation, capture-avoiding substitution, and more. See [`Unbound.Generics.LocallyNameless`](src/Unbound/Generics/LocallyNameless.hs) to get started. 16 | 17 | This is a reimplementation of (parts of) [unbound](http://hackage.haskell.org/package/unbound) but using [GHC generics](http://www.haskell.org/ghc/docs/latest/html/libraries/base-4.7.0.1/GHC-Generics.html) instead of [RepLib](https://hackage.haskell.org/package/RepLib). 18 | 19 | ## Examples 20 | 21 | Some examples are in the `examples/` directory in the source. And also at [unbound-generics on GitHub Pages](https://lambdageek.github.io/unbound-generics) 22 | 23 | ### Example: Untyped lambda calculus interpreter 24 | Here is how you would implement call by value evaluation for the untyped lambda calculus: 25 | 26 | ```haskell 27 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, MultiParamTypeClasses #-} 28 | module UntypedLambdaCalc where 29 | import Unbound.Generics.LocallyNameless 30 | import GHC.Generics (Generic) 31 | import Data.Typeable (Typeable) 32 | 33 | -- | Variables stand for expressions 34 | type Var = Name Expr 35 | 36 | -- | Expressions 37 | data Expr = V Var -- ^ variables 38 | | Lam (Bind Var Expr) -- ^ lambdas bind a variable within a body expression 39 | | App Expr Expr -- ^ application 40 | deriving (Show, Generic, Typeable) 41 | 42 | -- Automatically construct alpha equivalence, free variable computation and binding operations. 43 | instance Alpha Expr 44 | 45 | -- semi-automatically implement capture avoiding substitution of expressions for expressions 46 | instance Subst Expr Expr where 47 | -- `isvar` identifies the variable case in your AST. 48 | isvar (V x) = Just (SubstName x) 49 | isvar _ = Nothing 50 | 51 | -- evaluation takes an expression and returns a value while using a source of fresh names 52 | eval :: Expr -> FreshM Expr 53 | eval (V x) = error $ "unbound variable " ++ show x 54 | eval e@Lam{} = return e 55 | eval (App e1 e2) = do 56 | v1 <- eval e1 57 | v2 <- eval e2 58 | case v1 of 59 | Lam bnd -> do 60 | -- open the lambda by picking a fresh name for the bound variable x in body 61 | (x, body) <- unbind bnd 62 | let body' = subst x v2 body 63 | eval body' 64 | _ -> error "application of non-lambda" 65 | 66 | example :: Expr 67 | example = 68 | let x = s2n "x" 69 | y = s2n "y" 70 | e = Lam $ bind x (Lam $ bind y (App (V y) (V x))) 71 | in runFreshM $ eval (App (App e e) e) 72 | 73 | -- >>> example 74 | -- Lam ( App (V 0@0) (Lam ( Lam ( App (V 0@0) (V 1@0))))) 75 | 76 | ``` 77 | ## Differences from `unbound` 78 | 79 | For the most part, I tried to keep the same methods with the same signatures. However there are a few differences. 80 | 81 | 1. `fv :: Alpha t => Fold t (Name n)` 82 | 83 | The `fv` method returns a `Fold` (in the sense of the [lens](http://hackage.haskell.org/package/lens) library), 84 | rather than an `Unbound.Util.Collection` instance. That means you will generally have to write `toListOf fv t` or some other summary operation. 85 | 86 | 2. Utility methods in the `Alpha` class have different types. 87 | 88 | You should only notice this if you're implementing an instance of `Alpha` by hand (rather than by using the default 89 | generic instance). 90 | 91 | 1. `isPat :: Alpha t => t -> DisjointSet AnyName` 92 | The original `unbound` returned a `Maybe [AnyName]` here with the same interpretation as `DisjointSet`: `Nothing` means an inconsistency was encountered, or `Just` the free variables of the pattern. 93 | 2. `isTerm :: Alpha t => t -> All` 94 | 3. `open :: Alpha t => AlphaCtx -> NthPatFind -> t -> t`, `close :: Alpha t => AlphaCtx -> NamePatFind -> t -> t` where `NthPatFind` and `NamePatFind` are newtypes 95 | 96 | 3. `embed :: IsEmbed e => Embedded e -> e` and `unembed :: IsEmbed e => e -> Embedded e` 97 | 98 | The typeclass `IsEmbed` has an `Iso` (again in the sense of the `lens` library) as a method instead of the above pair of methods. 99 | 100 | Again, you should only notice this if you're implementing your own types that are instances of `IsEmbed`. The easiest thing to do is to use implement `embedded = iso yourEmbed yourUnembed` where `iso` comes from `lens`. (Although you can also implement it in terms of `dimap` if you don't want to depend on lens) 101 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmarks/BenchLam.hs: -------------------------------------------------------------------------------- 1 | -- | Untyped lambda calc for benchmarking 2 | {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, CPP #-} 3 | module BenchLam where 4 | 5 | import Control.Applicative 6 | import Control.Monad (replicateM) 7 | import Data.List (foldl') 8 | 9 | import GHC.Generics (Generic) 10 | import Data.Typeable (Typeable) 11 | 12 | import Control.DeepSeq (NFData(..), deepseq) 13 | #if MIN_VERSION_deepseq (1,4,0) 14 | #else 15 | import Control.DeepSeq.Generics (genericRnf) 16 | #endif 17 | import Criterion (Benchmark, env, bench, nf) 18 | 19 | import Unbound.Generics.LocallyNameless 20 | 21 | type Var = Name Term 22 | 23 | data Term = 24 | V !Var 25 | | App !Term !Term 26 | | Lam !(Bind Var Term) 27 | deriving (Show, Generic, Typeable) 28 | 29 | instance Alpha Term 30 | #if MIN_VERSION_deepseq (1,4,0) 31 | instance NFData Term 32 | #else 33 | instance NFData Term where rnf = genericRnf 34 | #endif 35 | 36 | 37 | -- | lambda abstract over all the given vars 38 | lams :: [Var] -> Term -> Term 39 | lams [] = id 40 | lams (v:vs) = Lam . bind v . lams vs 41 | 42 | -- | apply the given term to the given terms 43 | apps :: Term -> [Term] -> Term 44 | apps = foldl' App 45 | 46 | -- eta-expand a term a given number of times 47 | etaN :: Fresh m => Term -> Int -> m Term 48 | etaN m n = do 49 | vs <- replicateM n (fresh $ s2n "v") 50 | let ms = map V vs 51 | return (lams vs $ apps m ms) 52 | 53 | -- | While the head is a lambda, descend under it and then do something; 54 | -- then close all the lambdas back up. 55 | workHeadUnderLams :: Fresh m => (Term -> m Term) -> (Term -> m Term) 56 | workHeadUnderLams comp = go 57 | where 58 | go m = 59 | case m of 60 | Lam bnd -> do 61 | (x, m') <- unbind bnd 62 | m'' <- go m' 63 | return $ Lam $ bind x m'' 64 | _ -> comp m 65 | 66 | freshNeutralTermHead :: (Applicative m, Fresh m) => Term -> m Term 67 | freshNeutralTermHead (App m n) = App <$> freshNeutralTermHead m <*> pure n 68 | freshNeutralTermHead (V v) = V <$> fresh v 69 | freshNeutralTermHead lam@(Lam {}) = return lam 70 | 71 | -- | A benchmark that creates an eta expansion of the term "x" of a given size 72 | -- and then freshens the "x" by traversing down below all the lambdas. 73 | -- 74 | -- Every time we go under a lambda, we freshen the body, so to go 75 | -- under N lambdas, we do O(N²) work. 76 | freshenEtaTermBench :: Int -> Benchmark 77 | freshenEtaTermBench n = 78 | let name = "freshen eta term of size " ++ show n 79 | in name `deepseq` env setup $ \m -> 80 | bench name $ nf (runFreshM . workHeadUnderLams freshNeutralTermHead) m 81 | where 82 | setup = return $ runFreshM $ etaN (V $ s2n "x") n 83 | -------------------------------------------------------------------------------- /benchmarks/benchmark-main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | 5 | import BenchLam (freshenEtaTermBench) 6 | 7 | main :: IO () 8 | main = 9 | defaultMain 10 | [ 11 | bgroup "unbound-generics" [ 12 | freshenEtaTermBench 10 13 | , freshenEtaTermBench 20 14 | , freshenEtaTermBench 30 15 | , freshenEtaTermBench 40 16 | , freshenEtaTermBench 50 17 | , freshenEtaTermBench 100 18 | , freshenEtaTermBench 200 19 | ] 20 | ] 21 | -------------------------------------------------------------------------------- /examples/CanonicalLF.lhs: -------------------------------------------------------------------------------- 1 | % Canonical LF using unbound-generics 2 | % Aleksey Kliger 3 | % June 2016 4 | 5 | Canonical LF 6 | ============ 7 | 8 | This is a representation of [LF](http://www.twelf.org/) in which all terms are 9 | automatically in *canonical form*. The key idea is to segregate the type families 10 | and the terms into *atomic* and *normal* forms where the term variables only stand 11 | for atomic terms, and not arbitrary ones. Then, a substitution procedure is defined 12 | that takes terms in normal form and performs a substitution for a variable while 13 | simultaneously normalizing any redices that occur. 14 | 15 | > {-# LANGUAGE DeriveGeneric, StandaloneDeriving, DeriveDataTypeable, 16 | > ViewPatterns, RankNTypes, FlexibleContexts, FlexibleInstances, 17 | > FunctionalDependencies, TypeFamilies 18 | > #-} 19 | > module CanonicalLF where 20 | > import Unbound.Generics.LocallyNameless 21 | > import GHC.Generics (Generic) 22 | > import Data.Typeable (Typeable) 23 | > import qualified Data.Map as M 24 | > import Control.Monad.Reader 25 | > import Control.Monad.Except 26 | > import Data.Functor.Identity 27 | > import Control.Applicative (Const(..)) 28 | 29 | Syntax 30 | ------ 31 | 32 | An LF signature introduces type family atoms and constant terms. 33 | 34 | > data Signature = NilS 35 | > | SnocAtom (Rebind Signature (Atm, Embed Kind)) 36 | > | SnocConst (Rebind Signature (Cnst, Embed Type)) 37 | > deriving (Show, Generic, Typeable) 38 | 39 | The type families are classified by kinds and may either be plain 40 | types, or pi-kinds for families of types indexed by a term 41 | variable. 42 | 43 | > data Kind = TypeK | PiK (Bind (Var, Embed Type) Kind) 44 | > deriving (Show, Generic, Typeable) 45 | 46 | The atomic type families are either type familiy atoms applied to zero 47 | or more terms in normal form. 48 | 49 | > type Atm = Name P 50 | > data P = AtmP Atm | AppP P Term 51 | > deriving (Show, Generic, Typeable) 52 | 53 | Type families in normal form are either atomic type families or dependent product 54 | types indexed by a term variable of normal type. 55 | 56 | > data Type = PT P | PiT (Bind (Var, Embed Type) Type) 57 | > deriving (Show, Generic, Typeable) 58 | 59 | The atomic terms are either variables or constants applied to zero or 60 | more terms in normal form. 61 | 62 | > type Cnst = Name R 63 | > type Var = Name R 64 | > data R = VarR Var | ConstR Cnst | AppR R Term 65 | > deriving (Show, Generic, Typeable) 66 | 67 | A term in normal form is either an atomic term or a lambda abstraction 68 | that binds a term variable. 69 | 70 | > data Term = RM R | LamM (Bind Var Term) 71 | > deriving (Show, Generic, Typeable) 72 | 73 | When typechecking kinds, types or terms, new term variables may come 74 | into scope. They are collected in contexts. 75 | 76 | > data Context = NilC 77 | > | Snoc (Rebind Context (Var, Embed Type)) 78 | > deriving (Show, Generic, Typeable) 79 | 80 | All the syntactic objects are equivalent upto renaming of bound variables. 81 | 82 | > instance Alpha Signature 83 | > instance Alpha Kind 84 | > instance Alpha P 85 | > instance Alpha Type 86 | > instance Alpha R 87 | > instance Alpha Term 88 | > instance Alpha Context 89 | 90 | The metatheory of Canonical LF uses simple types to prove the 91 | termination of hereditary substitution (defined below). But they 92 | aren't needed in the implementation. (Although it would be 93 | interesting to lift them to Haskell kinds and index the terms by the 94 | simple types to disallow some malformed terms.) 95 | 96 | > data SimpleType = AtmS Atm | ArrS SimpleType SimpleType 97 | > deriving (Show, Generic, Typeable) 98 | > 99 | > instance Alpha SimpleType 100 | 101 | Hereditary Substitution 102 | ----------------------- 103 | 104 | Variables in Canonical LF stand for atomic terms, but we will need to 105 | subtitute terms for them. If we used ordinary capture-avoiding 106 | substitution, such substitution would produce redices, which we are 107 | precisely what we don't want. However redices will potentially only 108 | occur when the variable for which we're substituting occurs at the 109 | head of an atomic term. 110 | 111 | > isHeadVarR :: Var -> R -> Bool 112 | > isHeadVarR x (VarR y) = x == y 113 | > isHeadVarR _ (ConstR _) = False 114 | > isHeadVarR x (AppR r _) = isHeadVarR x r 115 | 116 | Just using a boolean to decide if the variable is at the head of an 117 | atomic term is fine, but we can actually partition an atomic term into 118 | its head variable or constant together with a spine of applications. 119 | 120 | > data Spine a = NilSp a | AppSp (Spine a) Term 121 | > data Head = VarH Var | ConstH Cnst 122 | 123 | If the variable for which we'll be substituting is at the head we only 124 | really care about the spine. Otherwise we have some other variable, 125 | or perhaps a constant at the head. 126 | 127 | > headSpine :: Var -> R -> Either (Spine Head) (Spine ()) 128 | > headSpine x (VarR y) | x == y = Right (NilSp ()) 129 | > | otherwise = Left (NilSp (VarH y)) 130 | > headSpine _ (ConstR c) = Left (NilSp (ConstH c)) 131 | > headSpine x (AppR r m) = case headSpine x r of 132 | > Left s -> Left (AppSp s m) 133 | > Right s -> Right (AppSp s m) 134 | 135 | Substitution in a kind just carries out substitution in the types. 136 | Likewise substutition in normal type families. 137 | 138 | > substKind :: Fresh m => Term -> Var -> Kind -> m Kind 139 | > substKind _ _ TypeK = return TypeK 140 | > substKind m x (PiK bnd) = do 141 | > ((y, unembed -> a), k) <- unbind bnd 142 | > a' <- substType m x a 143 | > k' <- substKind m x k 144 | > return $ PiK $ bind (y, embed a') k' 145 | > 146 | > substType :: Fresh m => Term -> Var -> Type -> m Type 147 | > substType m x (PT p) = do 148 | > p' <- substP m x p 149 | > return (PT p') 150 | > substType m x (PiT bnd) = do 151 | > ((y, unembed -> a), b) <- unbind bnd 152 | > a' <- substType m x a 153 | > b' <- substType m x b 154 | > return $ PiT $ bind (y, embed a') b' 155 | 156 | Atomic type family application substitutes a term for a variable in the (normal) index terms. 157 | 158 | > substP :: Fresh m => Term -> Var -> P -> m P 159 | > substP _ _ (AtmP a) = return (AtmP a) 160 | > substP m x (AppP p n) = do 161 | > p' <- substP m x p 162 | > n' <- substTerm m x n 163 | > return (AppP p' n') 164 | 165 | Normal term substitution goes under a lambda (freshness is ensured by 166 | the library) and into the atomic term. 167 | 168 | > substTerm :: Fresh m => Term -> Var -> Term -> m Term 169 | > substTerm m x (RM r) = substR m x r 170 | > substTerm m x (LamM bnd) = do 171 | > (y, n) <- unbind bnd 172 | > n' <- substTerm m x n 173 | > return $ LamM $ bind y n' 174 | 175 | To substitute in an atomic term we separate the head and the spine and 176 | proceed according to whether the variable at the head is the one we 177 | are substituting for. 178 | 179 | > substR :: Fresh m => Term -> Var -> R -> m Term 180 | > substR m x r = 181 | > case headSpine x r of 182 | > Left rsp -> RM <$> substRRsp m x rsp 183 | > Right msp -> substMsp m x msp 184 | 185 | If there is another variable or a constant at the head, we will get 186 | some kind of atomic term out since the head is unchanged and we only 187 | substitute into the index terms. 188 | 189 | > substRRsp :: Fresh m => Term -> Var -> Spine Head -> m R 190 | > substRRsp _ _ (NilSp h) = return (headR h) 191 | > substRRsp m x (AppSp sp n) = do 192 | > n' <- substTerm m x n 193 | > r <- substRRsp m x sp 194 | > return $ AppR r n' 195 | > 196 | > headR :: Head -> R 197 | > headR (VarH y) = VarR y 198 | > headR (ConstH c) = ConstR c 199 | 200 | When the variable we care about is at the head, we apply the 201 | substitution to the rest of the spine to get a normal term (which, by 202 | the metatheory will turn out to be some kind of a lambda), apply the 203 | substitution to the index, and then carry out a new substitution of 204 | the new index for the variable bound by the lambda to the body of the 205 | lambda. This last step is the heredetary part of heredetary 206 | substitution. The metatheory guarantees that this process will 207 | terminate. (Because the simple type of the body of the lambda is 208 | smaller than the simple type of the original term). 209 | 210 | > substMsp :: Fresh m => Term -> Var -> Spine () -> m Term 211 | > substMsp m _ (NilSp ()) = return m 212 | > substMsp m x (AppSp s n) = do 213 | > o_ <- substMsp m x s 214 | > n' <- substTerm m x n 215 | > case o_ of 216 | > LamM bnd -> do 217 | > (y, o) <- unbind bnd 218 | > substTerm n' y o 219 | > _ -> error "can't happen" 220 | 221 | Typechecking 222 | ============ 223 | 224 | We typecheck in an environment that maps type family atoms, term 225 | costants and variables to their respective kinds and types. 226 | 227 | > data Env = Env { _envAtm :: M.Map Atm Kind, 228 | > _envConst :: M.Map Cnst Type, 229 | > _envCtx :: M.Map Var Type } 230 | 231 | > emptyEnv :: Env 232 | > emptyEnv = Env M.empty M.empty M.empty 233 | 234 | Some lenses to work with the environment 235 | 236 | > envAtm :: Lens' Env (M.Map Atm Kind) 237 | > envAtm afb s = fmap (\atms -> s { _envAtm = atms }) $ afb (_envAtm s) 238 | > 239 | > envCtx :: Lens' Env (M.Map Var Type) 240 | > envCtx afb s = fmap (\ctx -> s { _envCtx = ctx } ) $ afb (_envCtx s) 241 | > 242 | > envConst :: Lens' Env (M.Map Cnst Type) 243 | > envConst afb s = fmap (\sig -> s { _envConst = sig} ) $ afb (_envConst s) 244 | 245 | And some combinators to perform lookups. 246 | 247 | > lookupOver :: (MonadReader e m, MonadError String m) => Getting p e p -> String -> (p -> Maybe c) -> m c 248 | > lookupOver l s f = do 249 | > mk <- views l f 250 | > case mk of 251 | > Nothing -> throwError $ "unbound " ++ s 252 | > Just c -> return c 253 | > 254 | > lookupAtom :: (MonadReader Env m, MonadError String m) => Atm -> m Kind 255 | > lookupAtom = lookupOver envAtm "atom" . M.lookup 256 | > 257 | > lookupVar :: (MonadReader Env m, MonadError String m) => Var -> m Type 258 | > lookupVar = lookupOver envCtx "variable" . M.lookup 259 | > 260 | > lookupConst :: (MonadReader Env m, MonadError String m) => Cnst -> m Type 261 | > lookupConst = lookupOver envConst "constant" . M.lookup 262 | 263 | To check a signature we check the kind or type classifying the atom or 264 | constant and then continue in an environment extended with the new 265 | binding. 266 | 267 | > withSigOk :: (Fresh m, MonadReader Env m, MonadError String m) => Signature -> m r -> m r 268 | > withSigOk NilS kont = kont 269 | > withSigOk (SnocAtom (unrebind -> (s, (a, unembed -> k)))) kont = 270 | > withSigOk s $ do 271 | > local (set envCtx M.empty) $ wfk k 272 | > local (over envAtm (M.insert a k)) kont 273 | > withSigOk (SnocConst (unrebind -> (s, (c, unembed -> a)))) kont = 274 | > withSigOk s $ do 275 | > local (set envCtx M.empty) $ wfType a 276 | > local (over envConst (M.insert c a)) kont 277 | 278 | Kind and normal type formation is unsurprising. Note that PT is only 279 | well-formed when the atomic type family is fully applied and is of 280 | base kind. 281 | 282 | > wfk :: (Fresh m, MonadReader Env m, MonadError String m) => Kind -> m () 283 | > wfk TypeK = return () 284 | > wfk (PiK bnd) = do 285 | > ((x, unembed -> t), k) <- unbind bnd 286 | > wfType t 287 | > local (over envCtx (M.insert x t)) $ wfk k 288 | > 289 | > wfType :: (Fresh m, MonadReader Env m, MonadError String m) => Type -> m () 290 | > wfType (PT p) = do 291 | > k <- inferP p 292 | > case k of 293 | > TypeK -> return () 294 | > _ -> throwError "expected a type" 295 | > wfType (PiT bnd) = do 296 | > ((x, unembed -> a), b) <- unbind bnd 297 | > wfType a 298 | > local (over envCtx (M.insert x a)) $ wfType b 299 | 300 | For atomic type families we infer their kinds. For atoms we read the 301 | kind off from the environment. For applications we infer the kind of 302 | the type family (which had better be a pi kind), and then check that 303 | the term argument has the expected type and then return the resulting 304 | kind where we (heredeterily) substitute the term for the index 305 | variable. 306 | 307 | > inferP :: (Fresh m, MonadReader Env m, MonadError String m) => P -> m Kind 308 | > inferP (AtmP atm) = lookupAtom atm 309 | > inferP (AppP p m) = do 310 | > k <- inferP p 311 | > case k of 312 | > TypeK -> throwError "expected a pi kind" 313 | > PiK bnd -> do 314 | > ((x, unembed -> a), k') <- unbind bnd 315 | > checkTerm m a 316 | > substKind m x k' 317 | 318 | To check that a term in normal form has the expected normal type, we 319 | check that its either a lambda of pi type, or an atomic term of atomic 320 | type. The latter ensures that terms are in eta long form by requiring 321 | all variables and constants to be fully applied. 322 | 323 | We infer the type of an atomic term (which had better be atomic) and 324 | then check that it is alpha-equivalent to the given atomic type. 325 | Because the calculus is constructed to only allow terms in normal 326 | form, alpha equivalence suffices and we don't have to do any 327 | normalization. (We paid that price in heredetary substitution.) 328 | 329 | > checkTerm :: (Fresh m, MonadReader Env m, MonadError String m) => Term -> Type -> m () 330 | > checkTerm (LamM bnd) (PiT bnd') = do 331 | > mmatch <- unbind2 bnd bnd' 332 | > case mmatch of 333 | > Just (x, m, (_, unembed -> a), b) -> do 334 | > wfType a 335 | > local (over envCtx (M.insert x a)) $ checkTerm m b 336 | > Nothing -> throwError "did not match" 337 | > checkTerm (RM r) (PT p) = do 338 | > t <- inferTerm r 339 | > case t of 340 | > (PT p') | p `aeq` p' -> return () 341 | > _ -> throwError "atomic term doesn't have the expected atomic type." 342 | > checkTerm (LamM {}) _ = throwError "lambda with no-PI type" 343 | > checkTerm (RM {}) _ = throwError "atomic term with non-atomic type" 344 | 345 | To infer the type of a term, we lookup variables and constants in the 346 | environment. For applications we ensure that the head has some kind 347 | of pi type and then check the index against the argument type, and 348 | then return the result type with the argument substituted for the 349 | index variable. 350 | 351 | > inferTerm :: (Fresh m, MonadReader Env m, MonadError String m) => R -> m Type 352 | > inferTerm (VarR x) = lookupVar x 353 | > inferTerm (ConstR c) = lookupConst c 354 | > inferTerm (AppR r m) = do 355 | > p_ <- inferTerm r 356 | > case p_ of 357 | > PiT bnd -> do 358 | > ((x, unembed -> a), b) <- unbind bnd 359 | > checkTerm m a 360 | > substType m x b 361 | > PT {} -> throwError "expected a function in application position" 362 | 363 | Smart Constructors 364 | ================== 365 | 366 | This section defines a little DSL for writing Canonical LF terms in 367 | Haskell. It's a higher-order encoding that uses haskell variable 368 | binding to represent LF binding constructs. 369 | 370 | We use a higher-kinded repr parameter to allow for different sorts of 371 | interpretations for this DSL. Although in this example we only build 372 | one using the Syn newtype to wrap a fresh-name monad computation that 373 | just builds a term in our original AST, above. 374 | 375 | > class TermSyntax repr r n | r -> n, n -> r where 376 | > lam :: String -> ((repr r) -> (repr n)) -> (repr n) 377 | > app :: repr r -> repr n -> repr r 378 | > rm :: repr r -> repr n 379 | > 380 | > newtype Syn m a = Syn { unSyn :: m a } 381 | > 382 | > instance Fresh m => TermSyntax (Syn m) R Term where 383 | > lam hint f = Syn $ do 384 | > x <- fresh (s2n hint) 385 | > m <- unSyn $ f (Syn $ return $ VarR x) 386 | > return $ LamM (bind x m) 387 | > app r n = Syn (AppR <$> unSyn r <*> unSyn n) 388 | > rm r = Syn (RM <$> unSyn r) 389 | 390 | > class TypeSyntax repr p a | a -> p, p -> a where 391 | > type TermInType repr a :: * 392 | > type RInType repr a :: * 393 | > piT :: String -> repr a -> (repr (RInType repr a) -> repr a) -> repr a 394 | > arrT :: repr a -> repr a -> repr a 395 | > arrT a b = piT "_" a (const b) 396 | > appP :: repr p -> repr (TermInType repr a) -> repr p 397 | > pt :: repr p -> repr a 398 | 399 | > instance Fresh m => TypeSyntax (Syn m) P Type where 400 | > type TermInType (Syn m) Type = Term 401 | > type RInType (Syn m) Type = R 402 | > piT hint sa f = Syn $ do 403 | > x <- fresh (s2n hint) 404 | > b <- unSyn $ f (Syn $ return $ VarR x) 405 | > a <- unSyn sa 406 | > return $ PiT $ bind (x, embed a) b 407 | > appP p m = Syn (AppP <$> unSyn p <*> unSyn m) 408 | > pt p = Syn (PT <$> unSyn p) 409 | 410 | > class KindSyntax repr k where 411 | > type TypeInKind repr k :: * 412 | > type RInKind repr k :: * 413 | > typeK :: repr k 414 | > piK :: String -> repr (TypeInKind repr k) -> (repr (RInKind repr k) -> repr k) -> repr k 415 | > arrK :: repr (TypeInKind repr k) -> repr k -> repr k 416 | > arrK a k = piK "_" a (const k) 417 | 418 | > instance Fresh m => KindSyntax (Syn m) Kind where 419 | > type TypeInKind (Syn m) Kind = Type 420 | > type RInKind (Syn m) Kind = R 421 | > typeK = Syn $ return TypeK 422 | > piK hint sa sk = Syn $ do 423 | > x <- fresh (s2n hint) 424 | > a <- unSyn sa 425 | > k <- unSyn $ sk (Syn $ return $ VarR x) 426 | > return $ PiK $ bind (x, embed a) k 427 | 428 | > class SignatureSyntax repr sig p r | sig -> p r where 429 | > type KindInSig repr sig :: * 430 | > type TypeInSig repr sig :: * 431 | > letAtom :: String -> repr (KindInSig repr sig) -> (repr p -> repr sig) -> repr sig 432 | > letConstant :: String -> repr (TypeInSig repr sig) -> (repr r -> repr sig) -> repr sig 433 | > endSig :: repr sig 434 | > 435 | > instance Fresh m => SignatureSyntax (Syn m) (Signature -> Signature) P R where 436 | > type KindInSig (Syn m) (Signature -> Signature) = Kind 437 | > type TypeInSig (Syn m) (Signature -> Signature) = Type 438 | > 439 | > letAtom hint sk kont = Syn $ do 440 | > a <- fresh (s2n hint) 441 | > k <- unSyn sk 442 | > f <- unSyn $ kont $ Syn $ return $ AtmP a 443 | > return $ \sig -> f (SnocAtom $ rebind sig (a, embed k)) 444 | > 445 | > letConstant hinst st kont = Syn $ do 446 | > c <- fresh (s2n hinst) 447 | > t <- unSyn st 448 | > f <- unSyn $ kont $ Syn $ return $ ConstR c 449 | > return $ \sig -> f (SnocConst $ rebind sig (c, embed t)) 450 | > 451 | > endSig = Syn $ return id 452 | 453 | > infixr 6 `arrT`, `arrK` 454 | > infixl 6 `appP`, `app` 455 | 456 | Example 457 | ------- 458 | 459 | An LF signature fragment for first-order logic. 460 | 461 | > example1 :: Fresh m => Syn m (Signature -> Signature) 462 | > example1 = 463 | > letAtom "o" typeK $ \o -> 464 | > letConstant "tt" (pt o) $ \tt -> 465 | > letConstant "ff" (pt o) $ \ff -> 466 | > letConstant "not" (pt o `arrT` pt o) $ \not -> 467 | > letConstant "and" (pt o `arrT` pt o `arrT` pt o) $ \and -> 468 | > letAtom "nd" (pt o `arrK` typeK) $ \nd -> 469 | > letConstant "tti" (pt (nd `appP` rm tt)) $ \tti -> 470 | > letConstant "ffe" (piT "a" (pt o) $ \a -> 471 | > pt (nd `appP` rm ff) 472 | > `arrT` 473 | > pt (nd `appP` rm a)) $ \ffe -> 474 | > letConstant "noti" (piT "a" (pt o) $ \a -> 475 | > (piT "p" (pt o) $ \p -> 476 | > pt (nd `appP` rm a) 477 | > `arrT` 478 | > pt (nd `appP` rm p)) 479 | > `arrT` 480 | > pt (nd `appP` rm (not `app` rm a))) $ \noti -> 481 | > letConstant "note" (piT "a" (pt o) $ \a -> piT "c" (pt o) $ \c -> 482 | > pt (nd `appP` rm (not `app` rm a)) 483 | > `arrT` 484 | > pt (nd `appP` rm a) 485 | > `arrT` 486 | > pt (nd `appP` rm c)) $ \note -> 487 | > letConstant "andi" (piT "a" (pt o) $ \a -> piT "b" (pt o) $ \b -> 488 | > pt (nd `appP` rm a) 489 | > `arrT` 490 | > pt (nd `appP` rm b) 491 | > `arrT` 492 | > pt (nd `appP` rm (and `app` rm a `app` rm b))) $ \andi -> 493 | > letConstant "ande1" (piT "a" (pt o) $ \a -> piT "b" (pt o) $ \b -> 494 | > pt (nd `appP` rm (and `app` rm a `app` rm b)) 495 | > `arrT` 496 | > pt (nd `appP` rm a)) $ \ande1 -> 497 | > letConstant "ande2" (piT "a" (pt o) $ \a -> piT "b" (pt o) $ \b -> 498 | > pt (nd `appP` rm (and `app` rm a `app` rm b)) 499 | > `arrT` 500 | > pt (nd `appP` rm b)) $ \ande2 -> 501 | > endSig 502 | 503 | > checkSynSig :: (Fresh m, MonadReader Env m, MonadError String m) => Syn m (Signature -> Signature) -> m () 504 | > checkSynSig sig = do 505 | > sigf <- unSyn sig 506 | > withSigOk (sigf NilS) $ return () 507 | 508 | Example: 509 | ```haskell 510 | >>> runExceptT $ runFreshMT $ runReaderT (checkSynSig example1) emptyEnv 511 | Right () 512 | ``` 513 | 514 | Appendix: Lens utilities 515 | ============== 516 | 517 | Some machinery to work with records. 518 | 519 | > type Lens s t a b = forall f . Functor f => (a -> f b) -> s -> f t 520 | > type Lens' s a = Lens s s a a 521 | 522 | > type Setting s t a b = (a -> Identity b) -> s -> Identity t 523 | > type Setting' s a = Setting s s a a 524 | 525 | > over :: Setting s t a b -> (a -> b) -> s -> t 526 | > over l f = runIdentity . l (Identity . f) 527 | 528 | > set :: Setting s t a b -> b -> s -> t 529 | > set l = over l . const 530 | 531 | > type Getting r s a = (a -> Const r a) -> s -> Const r s 532 | 533 | > views :: MonadReader s m => Getting a s a -> (a -> r) -> m r 534 | > views l f = asks (\s -> f (getConst (l Const s))) 535 | 536 | -------------------------------------------------------------------------------- /examples/F.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, 2 | DeriveDataTypeable, 3 | FlexibleInstances, 4 | FlexibleContexts, 5 | MultiParamTypeClasses, 6 | ScopedTypeVariables 7 | #-} 8 | 9 | module F where 10 | 11 | import Unbound.Generics.LocallyNameless 12 | 13 | import GHC.Generics 14 | import Data.Typeable (Typeable) 15 | 16 | import Control.Monad.Identity 17 | import Control.Monad.Writer hiding (All) 18 | import Control.Monad.Trans.Error 19 | import Data.List as List 20 | 21 | 22 | -- System F with type and term variables 23 | 24 | type TyName = Name Ty 25 | type TmName = Name Tm 26 | 27 | data Ty = TyVar TyName 28 | | Arr Ty Ty 29 | | All (Bind [TyName] Ty) 30 | deriving (Show, Generic, Typeable) 31 | 32 | data Tm = TmVar TmName 33 | | Lam (Bind (TmName, Embed Ty) Tm) 34 | | TLam (Bind [TyName] Tm) 35 | | App Tm Tm 36 | | TApp Tm [Ty] 37 | deriving (Show, Generic, Typeable) 38 | 39 | ------------------------------------------------------ 40 | instance Alpha Ty 41 | instance Alpha Tm 42 | 43 | instance Subst Tm Ty 44 | instance Subst Tm Tm where 45 | isvar (TmVar v) = Just (SubstName v) 46 | isvar _ = Nothing 47 | 48 | instance Subst Ty Ty where 49 | isvar (TyVar v) = Just (SubstName v) 50 | isvar _ = Nothing 51 | 52 | ------------------------------------------------------ 53 | -- Example terms 54 | ------------------------------------------------------ 55 | 56 | x :: Name Tm 57 | y :: Name Tm 58 | z :: Name Tm 59 | (x,y,z) = (string2Name "x", string2Name "y", string2Name "z") 60 | 61 | a :: Name Ty 62 | b :: Name Ty 63 | c :: Name Ty 64 | (a,b,c) = (string2Name "a", string2Name "b", string2Name "c") 65 | 66 | -- /\a. \x:a. x 67 | polyid :: Tm 68 | polyid = TLam (bind [a] (Lam (bind (x, Embed (TyVar a)) (TmVar x)))) 69 | 70 | -- All a. a -> a 71 | polyidty :: Ty 72 | polyidty = All (bind [a] (Arr (TyVar a) (TyVar a))) 73 | 74 | -- /\b. \y:b. y 75 | polyid2 :: Tm 76 | polyid2 = TLam (bind [b] (Lam (bind (y, Embed (TyVar b)) (TmVar y)))) 77 | 78 | -- /\c. \y:b. y 79 | bad_polyid2 :: Tm 80 | bad_polyid2 = TLam (bind [c] (Lam (bind (y, Embed (TyVar b)) (TmVar y)))) 81 | 82 | -- /\a b. a -> b -> a 83 | const_ty :: Ty 84 | const_ty = All (bind [a,b] (Arr (TyVar a) (Arr (TyVar b) (TyVar a)))) 85 | 86 | -- /\a b. a -> b -> a 87 | const_tm :: Tm 88 | const_tm = TLam (bind [a,b] (Lam (bind (x, Embed (TyVar a)) (Lam (bind (y, Embed (TyVar b)) (TmVar x)))))) 89 | 90 | test :: Ty 91 | test = fst (runM (ti emptyCtx (TApp const_tm [polyidty, All (bind [c] (TyVar c))]))) 92 | 93 | ----------------------------------------------------------------- 94 | -- Typechecker 95 | ----------------------------------------------------------------- 96 | type Delta = [ TyName ] 97 | type Gamma = [ (TmName, Ty) ] 98 | 99 | data Ctx = Ctx { getDelta :: Delta , getGamma :: Gamma } 100 | deriving (Show) 101 | 102 | emptyCtx :: Ctx 103 | emptyCtx = Ctx { getDelta = [], getGamma = [] } 104 | 105 | type M = ErrorT String (WriterT [String] (FreshMT Identity)) 106 | 107 | runM :: M a -> (a, [String]) 108 | runM m = case (runIdentity $ runFreshMT $ runWriterT (runErrorT m)) of 109 | (Left s, msgs) -> error $ s ++ "\nLog: " ++ show msgs 110 | (Right ans, msgs) -> (ans, msgs) 111 | 112 | checkTyVar :: Ctx -> TyName -> M () 113 | checkTyVar g v = do 114 | if List.elem v (getDelta g) then 115 | return () 116 | else 117 | throwError $ "NotFound: " ++ show v ++ " in " ++ show g 118 | 119 | lookupTmVar :: Ctx -> TmName -> M Ty 120 | lookupTmVar g v = do 121 | case lookup v (getGamma g) of 122 | Just s -> return s 123 | Nothing -> throwError "NotFound" 124 | 125 | extendTy :: [TyName] -> Ctx -> Ctx 126 | extendTy ns ctx = ctx { getDelta = ns <> (getDelta ctx) } 127 | 128 | extendTm :: TmName -> Ty -> Ctx -> Ctx 129 | extendTm n ty ctx = ctx { getGamma = (n, ty) : (getGamma ctx) } 130 | 131 | tcty :: Ctx -> Ty -> M () 132 | tcty g (TyVar alpha) = do 133 | trace $ "looking up tyvar " ++ show alpha 134 | checkTyVar g alpha 135 | tcty g (All bnder) = do 136 | trace $ "checking " ++ show (All bnder) 137 | (alpha, ty') <- unbind bnder 138 | trace $ "unbinding All gave " ++ show alpha ++ " in " ++ show ty' 139 | tcty (extendTy alpha g) ty' 140 | tcty g (Arr t1 t2) = do 141 | trace $ "checking " ++ show (Arr t1 t2) 142 | tcty g t1 143 | tcty g t2 144 | 145 | trace :: String -> M () 146 | trace s = lift (tell [s]) 147 | 148 | ti :: Ctx -> Tm -> M Ty 149 | ti g (TmVar v) = trace ("looking up " ++ show v) >> lookupTmVar g v 150 | ti g (Lam bnd) = do 151 | trace $ "checking " ++ show (Lam bnd) 152 | ((v, Embed ty1), t) <- unbind bnd 153 | tcty g ty1 154 | ty2 <- ti (extendTm v ty1 g) t 155 | return (Arr ty1 ty2) 156 | ti g (App t1 t2) = do 157 | trace $ "checking " ++ show (App t1 t2) 158 | ty1 <- ti g t1 159 | ty2 <- ti g t2 160 | case ty1 of 161 | Arr ty11 ty21 | ty2 `aeq` ty11 -> 162 | return ty21 163 | _ -> throwError "TypeError" 164 | ti g (TLam bnd) = do 165 | trace $ "checking " ++ show (TLam bnd) 166 | (v, t) <- unbind bnd 167 | trace $ "unbinding TLam gave " ++ show v ++ " in " ++ show t 168 | ty <- ti (extendTy v g) t 169 | return (All (bind v ty)) 170 | ti g (TApp t ty) = do 171 | trace $ "checking " ++ show (TApp t ty) 172 | tyt <- ti g t 173 | case tyt of 174 | (All bnder) -> do 175 | mapM_ (tcty g) ty 176 | return $ instantiate bnder ty 177 | _ -> throwError $ "Expected a ForAll in a type application, got " ++ show tyt 178 | 179 | 180 | -------------------------------------------------------------------------------- /examples/LC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, 2 | DeriveDataTypeable, 3 | FlexibleInstances, 4 | FlexibleContexts, 5 | MultiParamTypeClasses, 6 | ScopedTypeVariables 7 | #-} 8 | 9 | module LC where 10 | 11 | import Unbound.Generics.LocallyNameless 12 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf) 13 | 14 | import GHC.Generics 15 | import Data.Typeable (Typeable) 16 | 17 | import Control.Monad.Reader (Reader, runReader) 18 | import Data.Set as S 19 | 20 | data Exp = Var (Name Exp) 21 | | Lam (Bind (Name Exp) Exp) 22 | | App Exp Exp 23 | deriving (Show, Generic, Typeable) 24 | 25 | instance Alpha Exp 26 | 27 | instance Subst Exp Exp where 28 | isvar (Var x) = Just (SubstName x) 29 | isvar _ = Nothing 30 | 31 | fvSet :: (Alpha a, Typeable b) => a -> S.Set (Name b) 32 | fvSet = S.fromList . toListOf fv 33 | 34 | type M a = FreshM a 35 | 36 | (=~) :: Exp -> Exp -> M Bool 37 | e1 =~ e2 | e1 `aeq` e2 = return True 38 | e1 =~ e2 = do 39 | e1' <- red e1 40 | e2' <- red e2 41 | if e1' `aeq` e1 && e2' `aeq` e2 42 | then return False 43 | else e1' =~ e2' 44 | 45 | red :: Exp -> M Exp 46 | red (App e1 e2) = do 47 | e1' <- red e1 48 | e2' <- red e2 49 | case e1' of 50 | Lam bnd -> do 51 | return $ substBind bnd e2' 52 | otherwise -> return $ App e1' e2' 53 | red (Lam bnd) = do 54 | (x, e) <- unbind bnd 55 | e' <- red e 56 | case e of 57 | App e1 (Var y) | y == x && x `S.notMember` fvSet e1 -> return e1 58 | otherwise -> return (Lam (bind x e')) 59 | red (Var x) = return $ (Var x) 60 | 61 | 62 | x :: Name Exp 63 | x = string2Name "x" 64 | 65 | y :: Name Exp 66 | y = string2Name "y" 67 | 68 | z :: Name Exp 69 | z = string2Name "z" 70 | 71 | s :: Name Exp 72 | s = string2Name "s" 73 | 74 | lam :: Name Exp -> Exp -> Exp 75 | lam x y = Lam (bind x y) 76 | 77 | zero = lam s (lam z (Var z)) 78 | one = lam s (lam z (App (Var s) (Var z))) 79 | two = lam s (lam z (App (Var s) (App (Var s) (Var z)))) 80 | three = lam s (lam z (App (Var s) (App (Var s) (App (Var s) (Var z))))) 81 | 82 | plus = lam x (lam y (lam s (lam z (App (App (Var x) (Var s)) (App (App (Var y) (Var s)) (Var z)))))) 83 | 84 | true = lam x (lam y (Var x)) 85 | false = lam x (lam y (Var y)) 86 | if_ x y z = (App (App x y) z) 87 | 88 | 89 | assert :: String -> Bool -> IO () 90 | assert s True = return () 91 | assert s False = print ("Assertion " ++ s ++ " failed") 92 | 93 | assertM :: String -> M Bool -> IO () 94 | assertM s c = 95 | if (runFreshM c) then return () 96 | else print ("Assertion " ++ s ++ " failed") 97 | 98 | main :: IO () 99 | main = do 100 | assert "a1" $ lam x (Var x) `aeq` lam y (Var y) 101 | assert "a2" $ not (lam x (Var y) `aeq` lam x (Var x)) 102 | assertM "be1" $ lam x (App (lam y (Var x)) (lam y (Var y))) =~ (lam y (Var y)) 103 | assertM "be2" $ lam x (App (Var y) (Var x)) =~ Var y 104 | assertM "be3" $ if_ true (Var x) (Var y) =~ Var x 105 | assertM "be4" $ if_ false (Var x) (Var y) =~ Var y 106 | assertM "be5" $ App (App plus one) two =~ three 107 | print "Done" 108 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Unbound.Generics.LocallyNameless 3 | -- Copyright : (c) 2014, Aleksey Kliger 4 | -- License : BSD3 (See LICENSE) 5 | -- Maintainer : Aleksey Kliger 6 | -- Stability : experimental 7 | -- 8 | -- 9 | -- The purpose of @unbound-genrics@ is to simplify the construction of 10 | -- data structures with rich variable binding structure by providing 11 | -- generic implementations of alpha-equivalence ('aeq'), free variable 12 | -- permutation ('swaps'), local and global variable freshness 13 | -- ('lfresh', 'fresh'), 14 | -- 15 | -- 16 | -- 17 | -- See 'Alpha', 'Bind', "Unbound.Generics.LocallyNameless.Operations" for more information. 18 | module Unbound.Generics.LocallyNameless ( 19 | module Unbound.Generics.LocallyNameless.Alpha, 20 | module Unbound.Generics.LocallyNameless.Name, 21 | module Unbound.Generics.LocallyNameless.Operations, 22 | module Unbound.Generics.LocallyNameless.Bind, 23 | module Unbound.Generics.LocallyNameless.Ignore, 24 | module Unbound.Generics.LocallyNameless.Embed, 25 | module Unbound.Generics.LocallyNameless.Shift, 26 | module Unbound.Generics.LocallyNameless.Rebind, 27 | module Unbound.Generics.LocallyNameless.Rec, 28 | module Unbound.Generics.LocallyNameless.Fresh, 29 | module Unbound.Generics.LocallyNameless.LFresh, 30 | module Unbound.Generics.LocallyNameless.Subst 31 | ) where 32 | 33 | import Unbound.Generics.LocallyNameless.Alpha 34 | import Unbound.Generics.LocallyNameless.Name hiding (Bn, Fn) 35 | import Unbound.Generics.LocallyNameless.Bind hiding (B) 36 | import Unbound.Generics.LocallyNameless.Ignore hiding (I) 37 | import Unbound.Generics.LocallyNameless.Embed 38 | import Unbound.Generics.LocallyNameless.Shift 39 | import Unbound.Generics.LocallyNameless.Rebind hiding (Rebnd) 40 | import Unbound.Generics.LocallyNameless.Rec 41 | import Unbound.Generics.LocallyNameless.Fresh 42 | import Unbound.Generics.LocallyNameless.LFresh 43 | import Unbound.Generics.LocallyNameless.Operations 44 | import Unbound.Generics.LocallyNameless.Subst 45 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Alpha.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | -- | 3 | -- Module : Unbound.Generics.LocallyNameless.Alpha 4 | -- Copyright : (c) 2014, Aleksey Kliger 5 | -- License : BSD3 (See LICENSE) 6 | -- Maintainer : Aleksey Kliger 7 | -- Stability : experimental 8 | -- 9 | -- Use the 'Alpha' typeclass to mark types that may contain 'Name's. 10 | {-# LANGUAGE DefaultSignatures 11 | , FlexibleContexts 12 | , TypeOperators 13 | , RankNTypes 14 | #-} 15 | module Unbound.Generics.LocallyNameless.Alpha ( 16 | -- * Name-aware opertions 17 | Alpha(..) 18 | -- * Binder variables 19 | , DisjointSet(..) 20 | , inconsistentDisjointSet 21 | , singletonDisjointSet 22 | , isConsistentDisjointSet 23 | , isNullDisjointSet 24 | -- * Implementation details 25 | , NthPatFind(..) 26 | , NamePatFind(..) 27 | , AlphaCtx 28 | , ctxLevel 29 | , initialCtx 30 | , patternCtx 31 | , termCtx 32 | , isTermCtx 33 | , incrLevelCtx 34 | , decrLevelCtx 35 | , isZeroLevelCtx 36 | , ctxLevel 37 | -- * Internal 38 | , gaeq 39 | , gfvAny 40 | , gclose 41 | , gopen 42 | , gisPat 43 | , gisTerm 44 | , gnthPatFind 45 | , gnamePatFind 46 | , gswaps 47 | , gfreshen 48 | , glfreshen 49 | , gacompare 50 | -- ** Interal helpers for gfreshen 51 | , FFM 52 | , liftFFM 53 | , retractFFM 54 | ) where 55 | 56 | import Control.Applicative (Applicative(..), (<$>)) 57 | import Control.Arrow (first) 58 | import Control.Monad (liftM) 59 | import Data.Function (on) 60 | import Data.Functor.Contravariant (Contravariant(..)) 61 | import Data.Foldable (Foldable(..)) 62 | import Data.List (intersect) 63 | import Data.List.NonEmpty (NonEmpty) 64 | import Data.Monoid (Monoid(..), All(..)) 65 | import Data.Ratio (Ratio) 66 | import Data.Semigroup as Sem 67 | import Data.Typeable (Typeable, gcast, typeOf) 68 | import GHC.Generics 69 | 70 | import Unbound.Generics.LocallyNameless.Name 71 | import Unbound.Generics.LocallyNameless.Fresh 72 | import Unbound.Generics.LocallyNameless.LFresh 73 | import Unbound.Generics.PermM 74 | 75 | -- | Some 'Alpha' operations need to record information about their 76 | -- progress. Instances should just pass it through unchanged. 77 | -- 78 | -- The context records whether we are currently operating on terms or patterns, 79 | -- and how many binding levels we've descended. 80 | data AlphaCtx = AlphaCtx { ctxMode :: !Mode, ctxLevel :: !Integer } 81 | 82 | data Mode = Term | Pat 83 | deriving Eq 84 | 85 | -- | The starting context for alpha operations: we are expecting to 86 | -- work on terms and we are under no binders. 87 | initialCtx :: AlphaCtx 88 | initialCtx = AlphaCtx { ctxMode = Term, ctxLevel = 0 } 89 | 90 | -- | Switches to a context where we expect to operate on patterns. 91 | patternCtx :: AlphaCtx -> AlphaCtx 92 | patternCtx ctx = ctx { ctxMode = Pat } 93 | 94 | -- | Switches to a context where we expect to operate on terms. 95 | termCtx :: AlphaCtx -> AlphaCtx 96 | termCtx ctx = ctx { ctxMode = Term } 97 | 98 | -- | Returns 'True' iff we are in a context where we expect to see terms. 99 | isTermCtx :: AlphaCtx -> Bool 100 | isTermCtx (AlphaCtx {ctxMode = Term}) = True 101 | isTermCtx _ = False 102 | 103 | -- | Increment the number of binders that we are operating under. 104 | incrLevelCtx :: AlphaCtx -> AlphaCtx 105 | incrLevelCtx ctx = ctx { ctxLevel = 1 + ctxLevel ctx } 106 | 107 | -- | Decrement the number of binders that we are operating under. 108 | decrLevelCtx :: AlphaCtx -> AlphaCtx 109 | decrLevelCtx ctx = ctx { ctxLevel = ctxLevel ctx - 1 } 110 | 111 | -- | Are we operating under no binders? 112 | isZeroLevelCtx :: AlphaCtx -> Bool 113 | isZeroLevelCtx ctx = ctxLevel ctx == 0 114 | 115 | -- | A @DisjointSet a@ is a 'Just' a list of distinct @a@s. In addition to a monoidal 116 | -- structure, a disjoint set also has an annihilator 'inconsistentDisjointSet'. 117 | -- 118 | -- @ 119 | -- inconsistentDisjointSet \<> s == inconsistentDisjointSet 120 | -- s \<> inconsistentDisjoinSet == inconsistentDisjointSet 121 | -- @ 122 | newtype DisjointSet a = DisjointSet (Maybe [a]) 123 | 124 | -- | @since 0.3.2 125 | instance Eq a => Sem.Semigroup (DisjointSet a) where 126 | (<>) = \s1 s2 -> 127 | case (s1, s2) of 128 | (DisjointSet (Just xs), DisjointSet (Just ys)) | disjointLists xs ys -> DisjointSet (Just (xs <> ys)) 129 | _ -> inconsistentDisjointSet 130 | 131 | instance Eq a => Monoid (DisjointSet a) where 132 | mempty = DisjointSet (Just []) 133 | mappend = (<>) 134 | 135 | instance Foldable DisjointSet where 136 | foldMap summarize (DisjointSet ms) = foldMap (foldMap summarize) ms 137 | 138 | -- | Returns a @DisjointSet a@ that is the annihilator element for the 'Monoid' instance of 'DisjointSet'. 139 | inconsistentDisjointSet :: DisjointSet a 140 | inconsistentDisjointSet = DisjointSet Nothing 141 | 142 | -- | @singletonDisjointSet x@ a @DisjointSet a@ that contains the single element @x@ 143 | singletonDisjointSet :: a -> DisjointSet a 144 | singletonDisjointSet x = DisjointSet (Just [x]) 145 | 146 | disjointLists :: Eq a => [a] -> [a] -> Bool 147 | disjointLists xs ys = null (intersect xs ys) 148 | 149 | -- | @isConsistentDisjointSet@ returns @True@ iff the given disjoint set is not inconsistent. 150 | isConsistentDisjointSet :: DisjointSet a -> Bool 151 | isConsistentDisjointSet (DisjointSet Nothing) = False 152 | isConsistentDisjointSet _ = True 153 | 154 | -- | @isNullDisjointSet@ return @True@ iff the given disjoint set is 'mempty'. 155 | isNullDisjointSet :: DisjointSet a -> Bool 156 | isNullDisjointSet (DisjointSet (Just [])) = True 157 | isNullDisjointSet _ = False 158 | 159 | -- | Types that are instances of @Alpha@ may participate in name representation. 160 | -- 161 | -- Minimal instance is entirely empty, provided that your type is an instance of 162 | -- 'Generic'. 163 | class (Show a) => Alpha a where 164 | -- | See 'Unbound.Generics.LocallyNameless.Operations.aeq'. 165 | aeq' :: AlphaCtx -> a -> a -> Bool 166 | default aeq' :: (Generic a, GAlpha (Rep a)) => AlphaCtx -> a -> a -> Bool 167 | aeq' c = (gaeq c) `on` from 168 | {-# INLINE aeq' #-} 169 | 170 | -- | See 'Unbound.Generics.LocallyNameless.Operations.fvAny'. 171 | -- 172 | -- @ 173 | -- fvAny' :: Fold a AnyName 174 | -- @ 175 | fvAny' :: (Contravariant f, Applicative f) => AlphaCtx -> (AnyName -> f AnyName) -> a -> f a 176 | default fvAny' :: (Generic a, GAlpha (Rep a), Contravariant f, Applicative f) => AlphaCtx -> (AnyName -> f AnyName) -> a -> f a 177 | fvAny' c nfn = fmap to . gfvAny c nfn . from 178 | {-# INLINE fvAny' #-} 179 | 180 | -- | Replace free names by bound names. 181 | close :: AlphaCtx -> NamePatFind -> a -> a 182 | default close :: (Generic a, GAlpha (Rep a)) => AlphaCtx -> NamePatFind -> a -> a 183 | close c b = to . gclose c b . from 184 | {-# INLINE close #-} 185 | 186 | -- | Replace bound names by free names. 187 | open :: AlphaCtx -> NthPatFind -> a -> a 188 | default open :: (Generic a, GAlpha (Rep a)) => AlphaCtx -> NthPatFind -> a -> a 189 | open c b = to . gopen c b . from 190 | {-# INLINE open #-} 191 | 192 | -- | @isPat x@ dynamically checks whether @x@ can be used as a valid pattern. 193 | isPat :: a -> DisjointSet AnyName 194 | default isPat :: (Generic a, GAlpha (Rep a)) => a -> DisjointSet AnyName 195 | isPat = gisPat . from 196 | {-# INLINE isPat #-} 197 | 198 | -- | @isPat x@ dynamically checks whether @x@ can be used as a valid term. 199 | isTerm :: a -> All 200 | default isTerm :: (Generic a, GAlpha (Rep a)) => a -> All 201 | isTerm = gisTerm . from 202 | {-# INLINE isTerm #-} 203 | 204 | -- | @isEmbed@ is needed internally for the implementation of 205 | -- 'isPat'. @isEmbed@ is true for terms wrapped in 'Embed' and zero 206 | -- or more occurrences of 'Shift'. The default implementation 207 | -- simply returns @False@. 208 | isEmbed :: a -> Bool 209 | isEmbed _ = False 210 | {-# INLINE isEmbed #-} 211 | 212 | -- | If @a@ is a pattern, finds the @n@th name in the pattern 213 | -- (starting from zero), returning the number of names encountered 214 | -- if not found. 215 | nthPatFind :: a -> NthPatFind 216 | default nthPatFind :: (Generic a, GAlpha (Rep a)) => a -> NthPatFind 217 | nthPatFind = gnthPatFind . from 218 | {-# INLINE nthPatFind #-} 219 | 220 | -- | If @a@ is a pattern, find the index of the given name in the pattern. 221 | namePatFind :: a -> NamePatFind 222 | default namePatFind :: (Generic a, GAlpha (Rep a)) => a -> NamePatFind 223 | namePatFind = gnamePatFind . from 224 | {-# INLINE namePatFind #-} 225 | 226 | -- | See 'Unbound.Generics.LocallyNameless.Operations.swaps'. Apply 227 | -- the given permutation of variable names to the given pattern. 228 | swaps' :: AlphaCtx -> Perm AnyName -> a -> a 229 | default swaps' :: (Generic a, GAlpha (Rep a)) => AlphaCtx -> Perm AnyName -> a -> a 230 | swaps' ctx perm = to . gswaps ctx perm . from 231 | {-# INLINE swaps' #-} 232 | 233 | -- | See 'Unbound.Generics.LocallyNameless.Operations.freshen'. 234 | lfreshen' :: LFresh m => AlphaCtx -> a -> (a -> Perm AnyName -> m b) -> m b 235 | default lfreshen' :: (LFresh m, Generic a, GAlpha (Rep a)) 236 | => AlphaCtx -> a -> (a -> Perm AnyName -> m b) -> m b 237 | lfreshen' ctx m cont = glfreshen ctx (from m) (cont . to) 238 | {-# INLINE lfreshen' #-} 239 | 240 | -- | See 'Unbound.Generics.LocallyNameless.Operations.freshen'. Rename the free variables 241 | -- in the given term to be distinct from all other names seen in the monad @m@. 242 | freshen' :: Fresh m => AlphaCtx -> a -> m (a, Perm AnyName) 243 | default freshen' :: (Generic a, GAlpha (Rep a), Fresh m) => AlphaCtx -> a -> m (a, Perm AnyName) 244 | freshen' ctx = retractFFM . liftM (first to) . gfreshen ctx . from 245 | 246 | -- | See 'Unbound.Generics.LocallyNameless.Operations.acompare'. An alpha-respecting total order on terms involving binders. 247 | acompare' :: AlphaCtx -> a -> a -> Ordering 248 | default acompare' :: (Generic a, GAlpha (Rep a)) => AlphaCtx -> a -> a -> Ordering 249 | acompare' c = (gacompare c) `on` from 250 | 251 | -- Internal: the free monad over the Functor f. Note that 'freshen'' 252 | -- has a monadic return type and moreover we have to thread the 253 | -- permutation through the 'gfreshen' calls to crawl over the value 254 | -- constructors. Since we don't know anything about the monad @m@, 255 | -- GHC can't help us. But note that none of the code in the generic 256 | -- 'gfreshen' instances actually makes use of the 'Fresh.fresh' 257 | -- function; they just plumb the dictionary through to any 'K' nodes 258 | -- that happen to contain a value of a type like 'Name' that does 259 | -- actually freshen something. So what we do is we actually make 260 | -- gfreshen work not in the monad @m@, but in the monad @FFM m@ and 261 | -- then use 'retractFFM' in the default 'Alpha' method to return back 262 | -- down to @m@. We don't really make use of the fact that 'FFM' 263 | -- reassociates the binds of the underlying monad, but it doesn't hurt 264 | -- anything. Mostly what we care about is giving the inliner a chance 265 | -- to eliminate most of the monadic plumbing. 266 | newtype FFM f a = FFM { runFFM :: forall r . (a -> r) -> (f r -> r) -> r } 267 | 268 | instance Functor (FFM f) where 269 | fmap f (FFM h) = FFM (\r j -> h (r . f) j) 270 | {-# INLINE fmap #-} 271 | 272 | instance Applicative (FFM f) where 273 | pure x = FFM (\r _j -> r x) 274 | {-# INLINE pure #-} 275 | (FFM h) <*> (FFM k) = FFM (\r j -> h (\f -> k (r . f) j) j) 276 | {-# INLINE (<*>) #-} 277 | 278 | instance Monad (FFM f) where 279 | return = pure 280 | {-# INLINE return #-} 281 | (FFM h) >>= f = FFM (\r j -> h (\x -> runFFM (f x) r j) j) 282 | {-# INLINE (>>=) #-} 283 | 284 | instance Fresh m => Fresh (FFM m) where 285 | fresh = liftFFM . fresh 286 | {-# INLINE fresh #-} 287 | 288 | liftFFM :: Monad m => m a -> FFM m a 289 | liftFFM m = FFM (\r j -> j (liftM r m)) 290 | {-# INLINE liftFFM #-} 291 | 292 | retractFFM :: Monad m => FFM m a -> m a 293 | retractFFM (FFM h) = h return j 294 | where 295 | j mmf = mmf >>= \mf -> mf 296 | {-# INLINE retractFFM #-} 297 | 298 | -- | The result of @'nthPatFind' a i@ is @Left k@ where @i-k@ is the 299 | -- number of names in pattern @a@ (with @k < i@) or @Right x@ where @x@ 300 | -- is the @i@th name in @a@ 301 | newtype NthPatFind = NthPatFind { runNthPatFind :: Integer -> Either Integer AnyName } 302 | 303 | -- | @since 0.3.2 304 | instance Sem.Semigroup NthPatFind where 305 | (<>) = \(NthPatFind f) (NthPatFind g) -> 306 | NthPatFind $ \i -> case f i of 307 | Left i' -> g i' 308 | found@Right {} -> found 309 | 310 | instance Monoid NthPatFind where 311 | mempty = NthPatFind Left 312 | mappend = (<>) 313 | 314 | -- | The result of @'namePatFind' a x@ is either @Left i@ if @a@ is a pattern that 315 | -- contains @i@ free names none of which are @x@, or @Right j@ if @x@ is the @j@th name 316 | -- in @a@ 317 | newtype NamePatFind = NamePatFind { runNamePatFind :: AnyName 318 | -- Left - names skipped over 319 | -- Right - index of the name we found 320 | -> Either Integer Integer } 321 | 322 | -- | @since 0.3.2 323 | instance Sem.Semigroup NamePatFind where 324 | (<>) = \(NamePatFind f) (NamePatFind g) -> 325 | NamePatFind $ \nm -> case f nm of 326 | ans@Right {} -> ans 327 | Left n -> case g nm of 328 | Left m -> Left $! n + m 329 | Right i -> Right $! n + i 330 | 331 | instance Monoid NamePatFind where 332 | mempty = NamePatFind (\_ -> Left 0) 333 | mappend = (<>) 334 | 335 | -- | The "Generic" representation version of 'Alpha' 336 | class GAlpha f where 337 | gaeq :: AlphaCtx -> f a -> f a -> Bool 338 | 339 | gfvAny :: (Contravariant g, Applicative g) => AlphaCtx -> (AnyName -> g AnyName) -> f a -> g (f a) 340 | 341 | gclose :: AlphaCtx -> NamePatFind -> f a -> f a 342 | gopen :: AlphaCtx -> NthPatFind -> f a -> f a 343 | 344 | gisPat :: f a -> DisjointSet AnyName 345 | gisTerm :: f a -> All 346 | 347 | gnthPatFind :: f a -> NthPatFind 348 | gnamePatFind :: f a -> NamePatFind 349 | 350 | gswaps :: AlphaCtx -> Perm AnyName -> f a -> f a 351 | gfreshen :: Fresh m => AlphaCtx -> f a -> FFM m (f a, Perm AnyName) 352 | 353 | glfreshen :: LFresh m => AlphaCtx -> f a -> (f a -> Perm AnyName -> m b) -> m b 354 | 355 | gacompare :: AlphaCtx -> f a -> f a -> Ordering 356 | 357 | instance (Alpha c) => GAlpha (K1 i c) where 358 | gaeq ctx (K1 c1) (K1 c2) = aeq' ctx c1 c2 359 | {-# INLINE gaeq #-} 360 | 361 | gfvAny ctx nfn = fmap K1 . fvAny' ctx nfn . unK1 362 | {-# INLINE gfvAny #-} 363 | 364 | gclose ctx b = K1 . close ctx b . unK1 365 | {-# INLINE gclose #-} 366 | gopen ctx b = K1 . open ctx b . unK1 367 | {-# INLINE gopen #-} 368 | 369 | gisPat = isPat . unK1 370 | {-# INLINE gisPat #-} 371 | gisTerm = isTerm . unK1 372 | {-# INLINE gisTerm #-} 373 | 374 | gnthPatFind = nthPatFind . unK1 375 | {-# INLINE gnthPatFind #-} 376 | gnamePatFind = namePatFind . unK1 377 | {-# INLINE gnamePatFind #-} 378 | 379 | gswaps ctx perm = K1 . swaps' ctx perm . unK1 380 | {-# INLINE gswaps #-} 381 | gfreshen ctx = liftM (first K1) . liftFFM . freshen' ctx . unK1 382 | {-# INLINE gfreshen #-} 383 | 384 | glfreshen ctx (K1 c) cont = lfreshen' ctx c (cont . K1) 385 | {-# INLINE glfreshen #-} 386 | 387 | gacompare ctx (K1 c1) (K1 c2) = acompare' ctx c1 c2 388 | 389 | instance GAlpha f => GAlpha (M1 i c f) where 390 | gaeq ctx (M1 f1) (M1 f2) = gaeq ctx f1 f2 391 | {-# INLINE gaeq #-} 392 | 393 | gfvAny ctx nfn = fmap M1 . gfvAny ctx nfn . unM1 394 | {-# INLINE gfvAny #-} 395 | 396 | gclose ctx b = M1 . gclose ctx b . unM1 397 | {-# INLINE gclose #-} 398 | gopen ctx b = M1 . gopen ctx b . unM1 399 | {-# INLINE gopen #-} 400 | 401 | gisPat = gisPat . unM1 402 | {-# INLINE gisPat #-} 403 | gisTerm = gisTerm . unM1 404 | {-# INLINE gisTerm #-} 405 | 406 | gnthPatFind = gnthPatFind . unM1 407 | {-# INLINE gnthPatFind #-} 408 | gnamePatFind = gnamePatFind . unM1 409 | {-# INLINE gnamePatFind #-} 410 | 411 | gswaps ctx perm = M1 . gswaps ctx perm . unM1 412 | {-# INLINE gswaps #-} 413 | gfreshen ctx = liftM (first M1) . gfreshen ctx . unM1 414 | {-# INLINE gfreshen #-} 415 | 416 | glfreshen ctx (M1 f) cont = 417 | glfreshen ctx f (cont . M1) 418 | {-# INLINE glfreshen #-} 419 | 420 | gacompare ctx (M1 f1) (M1 f2) = gacompare ctx f1 f2 421 | 422 | instance GAlpha U1 where 423 | gaeq _ctx _ _ = True 424 | {-# INLINE gaeq #-} 425 | 426 | gfvAny _ctx _nfn _ = pure U1 427 | 428 | gclose _ctx _b _ = U1 429 | gopen _ctx _b _ = U1 430 | 431 | gisPat _ = mempty 432 | gisTerm _ = mempty 433 | 434 | gnthPatFind _ = mempty 435 | gnamePatFind _ = mempty 436 | 437 | gswaps _ctx _perm _ = U1 438 | gfreshen _ctx _ = return (U1, mempty) 439 | {-# INLINE gfreshen #-} 440 | 441 | glfreshen _ctx _ cont = cont U1 mempty 442 | 443 | gacompare _ctx _ _ = EQ 444 | 445 | instance GAlpha V1 where 446 | gaeq _ctx _ _ = False 447 | {-# INLINE gaeq #-} 448 | 449 | gfvAny _ctx _nfn = pure 450 | 451 | gclose _ctx _b _ = undefined 452 | gopen _ctx _b _ = undefined 453 | 454 | gisPat _ = mempty 455 | gisTerm _ = mempty 456 | 457 | gnthPatFind _ = mempty 458 | gnamePatFind _ = mempty 459 | 460 | gswaps _ctx _perm _ = undefined 461 | gfreshen _ctx _ = return (undefined, mempty) 462 | {-# INLINE gfreshen #-} 463 | 464 | glfreshen _ctx _ cont = cont undefined mempty 465 | 466 | gacompare _ctx _ _ = error "LocallyNameless.gacompare: undefined for empty data types" 467 | 468 | instance (GAlpha f, GAlpha g) => GAlpha (f :*: g) where 469 | gaeq ctx (f1 :*: g1) (f2 :*: g2) = 470 | gaeq ctx f1 f2 && gaeq ctx g1 g2 471 | {-# INLINE gaeq #-} 472 | 473 | gfvAny ctx nfn (f :*: g) = (:*:) <$> gfvAny ctx nfn f 474 | <*> gfvAny ctx nfn g 475 | {-# INLINE gfvAny #-} 476 | 477 | gclose ctx b (f :*: g) = gclose ctx b f :*: gclose ctx b g 478 | {-# INLINE gclose #-} 479 | gopen ctx b (f :*: g) = gopen ctx b f :*: gopen ctx b g 480 | {-# INLINE gopen #-} 481 | 482 | gisPat (f :*: g) = gisPat f <> gisPat g 483 | {-# INLINE gisPat #-} 484 | gisTerm (f :*: g) = gisTerm f <> gisTerm g 485 | {-# INLINE gisTerm #-} 486 | 487 | gnthPatFind (f :*: g) = gnthPatFind f <> gnthPatFind g 488 | {-# INLINE gnthPatFind #-} 489 | gnamePatFind (f :*: g) = gnamePatFind f <> gnamePatFind g 490 | {-# INLINE gnamePatFind #-} 491 | 492 | gswaps ctx perm (f :*: g) = 493 | gswaps ctx perm f :*: gswaps ctx perm g 494 | {-# INLINE gswaps #-} 495 | 496 | gfreshen ctx (f :*: g) = do 497 | ~(g', perm2) <- gfreshen ctx g 498 | ~(f', perm1) <- gfreshen ctx (gswaps ctx perm2 f) 499 | return (f' :*: g', perm1 <> perm2) 500 | {-# INLINE gfreshen #-} 501 | 502 | glfreshen ctx (f :*: g) cont = 503 | glfreshen ctx g $ \g' perm2 -> 504 | glfreshen ctx (gswaps ctx perm2 f) $ \f' perm1 -> 505 | cont (f' :*: g') (perm1 <> perm2) 506 | {-# INLINE glfreshen #-} 507 | 508 | gacompare ctx (f1 :*: g1) (f2 :*: g2) = 509 | (gacompare ctx f1 f2) <> (gacompare ctx g1 g2) 510 | 511 | instance (GAlpha f, GAlpha g) => GAlpha (f :+: g) where 512 | gaeq ctx (L1 f1) (L1 f2) = gaeq ctx f1 f2 513 | gaeq ctx (R1 g1) (R1 g2) = gaeq ctx g1 g2 514 | gaeq _ctx _ _ = False 515 | {-# INLINE gaeq #-} 516 | 517 | gfvAny ctx nfn (L1 f) = fmap L1 (gfvAny ctx nfn f) 518 | gfvAny ctx nfn (R1 g) = fmap R1 (gfvAny ctx nfn g) 519 | {-# INLINE gfvAny #-} 520 | 521 | gclose ctx b (L1 f) = L1 (gclose ctx b f) 522 | gclose ctx b (R1 g) = R1 (gclose ctx b g) 523 | {-# INLINE gclose #-} 524 | gopen ctx b (L1 f) = L1 (gopen ctx b f) 525 | gopen ctx b (R1 g) = R1 (gopen ctx b g) 526 | {-# INLINE gopen #-} 527 | 528 | gisPat (L1 f) = gisPat f 529 | gisPat (R1 g) = gisPat g 530 | {-# INLINE gisPat #-} 531 | 532 | gisTerm (L1 f) = gisTerm f 533 | gisTerm (R1 g) = gisTerm g 534 | {-# INLINE gisTerm #-} 535 | 536 | gnthPatFind (L1 f) = gnthPatFind f 537 | gnthPatFind (R1 g) = gnthPatFind g 538 | {-# INLINE gnthPatFind #-} 539 | 540 | gnamePatFind (L1 f) = gnamePatFind f 541 | gnamePatFind (R1 g) = gnamePatFind g 542 | {-# INLINE gnamePatFind #-} 543 | 544 | gswaps ctx perm (L1 f) = L1 (gswaps ctx perm f) 545 | gswaps ctx perm (R1 f) = R1 (gswaps ctx perm f) 546 | {-# INLINE gswaps #-} 547 | 548 | gfreshen ctx (L1 f) = liftM (first L1) (gfreshen ctx f) 549 | gfreshen ctx (R1 f) = liftM (first R1) (gfreshen ctx f) 550 | {-# INLINE gfreshen #-} 551 | 552 | glfreshen ctx (L1 f) cont = 553 | glfreshen ctx f (cont . L1) 554 | glfreshen ctx (R1 g) cont = 555 | glfreshen ctx g (cont . R1) 556 | {-# INLINE glfreshen #-} 557 | 558 | gacompare _ctx (L1 _) (R1 _) = LT 559 | gacompare _ctx (R1 _) (L1 _) = GT 560 | gacompare ctx (L1 f1) (L1 f2) = gacompare ctx f1 f2 561 | gacompare ctx (R1 g1) (R1 g2) = gacompare ctx g1 g2 562 | {-# INLINE gacompare #-} 563 | 564 | -- ============================================================ 565 | -- Alpha instances for the usual types 566 | 567 | instance Alpha Int where 568 | aeq' _ctx i j = i == j 569 | 570 | fvAny' _ctx _nfn i = pure i 571 | 572 | close _ctx _b i = i 573 | open _ctx _b i = i 574 | 575 | isPat _ = mempty 576 | isTerm _ = mempty 577 | 578 | nthPatFind _ = mempty 579 | namePatFind _ = mempty 580 | 581 | swaps' _ctx _p i = i 582 | freshen' _ctx i = return (i, mempty) 583 | lfreshen' _ctx i cont = cont i mempty 584 | 585 | acompare' _ctx i j = compare i j 586 | 587 | instance Alpha Char where 588 | aeq' _ctx i j = i == j 589 | 590 | fvAny' _ctx _nfn i = pure i 591 | 592 | close _ctx _b i = i 593 | open _ctx _b i = i 594 | 595 | isPat _ = mempty 596 | isTerm _ = mempty 597 | 598 | nthPatFind _ = mempty 599 | namePatFind _ = mempty 600 | 601 | swaps' _ctx _p i = i 602 | freshen' _ctx i = return (i, mempty) 603 | lfreshen' _ctx i cont = cont i mempty 604 | 605 | acompare' _ctx i j = compare i j 606 | 607 | instance Alpha Integer where 608 | aeq' _ctx i j = i == j 609 | 610 | fvAny' _ctx _nfn i = pure i 611 | 612 | close _ctx _b i = i 613 | open _ctx _b i = i 614 | 615 | isPat _ = mempty 616 | isTerm _ = mempty 617 | 618 | nthPatFind _ = mempty 619 | namePatFind _ = mempty 620 | 621 | swaps' _ctx _p i = i 622 | freshen' _ctx i = return (i, mempty) 623 | lfreshen' _ctx i cont = cont i mempty 624 | 625 | acompare' _ctx i j = compare i j 626 | 627 | instance Alpha Float where 628 | aeq' _ctx i j = i == j 629 | 630 | fvAny' _ctx _nfn i = pure i 631 | 632 | close _ctx _b i = i 633 | open _ctx _b i = i 634 | 635 | isPat _ = mempty 636 | isTerm _ = mempty 637 | 638 | nthPatFind _ = mempty 639 | namePatFind _ = mempty 640 | 641 | swaps' _ctx _p i = i 642 | freshen' _ctx i = return (i, mempty) 643 | lfreshen' _ctx i cont = cont i mempty 644 | 645 | acompare' _ctx i j = compare i j 646 | 647 | instance Alpha Double where 648 | aeq' _ctx i j = i == j 649 | 650 | fvAny' _ctx _nfn i = pure i 651 | 652 | close _ctx _b i = i 653 | open _ctx _b i = i 654 | 655 | isPat _ = mempty 656 | isTerm _ = mempty 657 | 658 | nthPatFind _ = mempty 659 | namePatFind _ = mempty 660 | 661 | swaps' _ctx _p i = i 662 | freshen' _ctx i = return (i, mempty) 663 | lfreshen' _ctx i cont = cont i mempty 664 | 665 | acompare' _ctx i j = compare i j 666 | 667 | instance (Integral n, Alpha n) => Alpha (Ratio n) where 668 | aeq' _ctx i j = i == j 669 | 670 | fvAny' _ctx _nfn i = pure i 671 | 672 | close _ctx _b i = i 673 | open _ctx _b i = i 674 | 675 | isPat _ = mempty 676 | isTerm _ = mempty 677 | 678 | nthPatFind _ = mempty 679 | namePatFind _ = mempty 680 | 681 | swaps' _ctx _p i = i 682 | freshen' _ctx i = return (i, mempty) 683 | lfreshen' _ctx i cont = cont i mempty 684 | 685 | acompare' _ctx i j = compare i j 686 | 687 | instance Alpha Bool 688 | 689 | instance Alpha a => Alpha (Maybe a) 690 | instance Alpha a => Alpha [a] 691 | instance Alpha a => Alpha (NonEmpty a) 692 | instance Alpha () 693 | instance (Alpha a,Alpha b) => Alpha (Either a b) 694 | instance (Alpha a,Alpha b) => Alpha (a,b) 695 | instance (Alpha a,Alpha b,Alpha c) => Alpha (a,b,c) 696 | instance (Alpha a, Alpha b,Alpha c, Alpha d) => Alpha (a,b,c,d) 697 | instance (Alpha a, Alpha b,Alpha c, Alpha d, Alpha e) => 698 | Alpha (a,b,c,d,e) 699 | 700 | -- ============================================================ 701 | -- Alpha instances for interesting types 702 | 703 | instance Typeable a => Alpha (Name a) where 704 | aeq' ctx n1 n2 = 705 | if isTermCtx ctx 706 | then n1 == n2 -- in terms, better be the same name 707 | else True -- in a pattern, names are always equivlent (since 708 | -- they're both bound, so they can vary). 709 | 710 | fvAny' ctx nfn nm = if isTermCtx ctx && isFreeName nm 711 | then contramap AnyName (nfn (AnyName nm)) 712 | else pure nm 713 | 714 | open ctx b a@(Bn l k) = 715 | if ctxMode ctx == Term && ctxLevel ctx == l 716 | then case runNthPatFind b k of 717 | Right (AnyName nm) -> case gcast nm of 718 | Just nm' -> nm' 719 | Nothing -> error "LocallyNameless.open: inconsistent sorts" 720 | Left _ -> error "LocallyNameless.open : inconsistency - pattern had too few variables" 721 | else 722 | a 723 | open _ctx _ a = a 724 | 725 | close ctx b a@(Fn _ _) = 726 | if isTermCtx ctx 727 | then case runNamePatFind b (AnyName a) of 728 | Right k -> Bn (ctxLevel ctx) k 729 | Left _ -> a 730 | else a 731 | close _ctx _ a = a 732 | 733 | 734 | isPat n = if isFreeName n 735 | then singletonDisjointSet (AnyName n) 736 | else inconsistentDisjointSet 737 | 738 | isTerm _ = mempty 739 | 740 | nthPatFind nm = NthPatFind $ \i -> 741 | if i == 0 then Right (AnyName nm) else Left $! i-1 742 | 743 | namePatFind nm1 = NamePatFind $ \(AnyName nm2) -> 744 | case gcast nm1 of 745 | Just nm1' -> if nm1' == nm2 then Right 0 else Left 1 746 | Nothing -> Left 1 747 | 748 | swaps' ctx perm nm = 749 | if isTermCtx ctx 750 | then case apply perm (AnyName nm) of 751 | AnyName nm' -> 752 | case gcast nm' of 753 | Just nm'' -> nm'' 754 | Nothing -> error "Internal error swaps' on a Name returned permuted name of wrong sort" 755 | else nm 756 | 757 | freshen' ctx nm = 758 | if not (isTermCtx ctx) 759 | then do 760 | nm' <- fresh nm 761 | return (nm', single (AnyName nm) (AnyName nm')) 762 | else error "freshen' on a Name in term position" 763 | 764 | lfreshen' ctx nm cont = 765 | if not (isTermCtx ctx) 766 | then do 767 | nm' <- lfresh nm 768 | avoid [AnyName nm'] $ cont nm' $ single (AnyName nm) (AnyName nm') 769 | else error "lfreshen' on a Name in term position" 770 | 771 | acompare' ctx (Fn s1 i1) (Fn s2 i2) 772 | | isTermCtx ctx = (compare s1 s2) <> (compare i1 i2) 773 | 774 | acompare' ctx n1@(Bn i1 j1) n2@(Bn i2 j2) 775 | | isTermCtx ctx = mconcat [ compare (typeOf n1) (typeOf n2) 776 | , compare i1 i2 777 | , compare j1 j2 778 | ] 779 | 780 | acompare' ctx (Fn _ _) (Bn _ _) | isTermCtx ctx = LT 781 | acompare' ctx (Bn _ _) (Fn _ _) | isTermCtx ctx = GT 782 | 783 | acompare' _ _ _ = EQ 784 | 785 | instance Alpha AnyName where 786 | aeq' ctx x y = 787 | if x == y 788 | then True 789 | else 790 | -- in a term unequal variables are unequal, in a pattern it's 791 | -- ok. 792 | not (isTermCtx ctx) 793 | 794 | fvAny' ctx nfn n@(AnyName nm) = if isTermCtx ctx && isFreeName nm 795 | then nfn n 796 | else pure n 797 | 798 | isTerm _ = mempty 799 | 800 | isPat n@(AnyName nm) = if isFreeName nm 801 | then singletonDisjointSet n 802 | else inconsistentDisjointSet 803 | 804 | swaps' ctx perm n = 805 | if isTermCtx ctx 806 | then apply perm n 807 | else n 808 | 809 | freshen' ctx (AnyName nm) = 810 | if isTermCtx ctx 811 | then error "LocallyNameless.freshen' on AnyName in Term mode" 812 | else do 813 | nm' <- fresh nm 814 | return (AnyName nm', single (AnyName nm) (AnyName nm')) 815 | 816 | lfreshen' ctx (AnyName nm) cont = 817 | if isTermCtx ctx 818 | then error "LocallyNameless.lfreshen' on AnyName in Term mode" 819 | else do 820 | nm' <- lfresh nm 821 | avoid [AnyName nm'] $ cont (AnyName nm') $ single (AnyName nm) (AnyName nm') 822 | 823 | open ctx b (AnyName nm) = AnyName (open ctx b nm) 824 | 825 | close ctx b (AnyName nm) = AnyName (close ctx b nm) 826 | 827 | nthPatFind nm = NthPatFind $ \i -> 828 | if i == 0 then Right nm else Left $! i - 1 829 | 830 | namePatFind nmHave = NamePatFind $ \nmWant -> 831 | if nmHave == nmWant then Right 0 else Left 1 832 | 833 | acompare' _ x y | x == y = EQ 834 | 835 | acompare' ctx (AnyName n1) (AnyName n2) 836 | | isTermCtx ctx = 837 | case compare (typeOf n1) (typeOf n2) of 838 | EQ -> case gcast n2 of 839 | Just n2' -> acompare' ctx n1 n2' 840 | Nothing -> error "LocallyNameless.acompare': Equal type representations, but gcast failed in comparing two AnyName values" 841 | ord -> ord 842 | 843 | acompare' _ _ _ = EQ 844 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Bind.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | -- | 3 | -- Module : Unbound.Generics.LocallyNameless.Bind 4 | -- Copyright : (c) 2014, Aleksey Kliger 5 | -- License : BSD3 (See LICENSE) 6 | -- Maintainer : Aleksey Kliger 7 | -- Stability : experimental 8 | -- 9 | -- The fundamental binding form. The type @'Bind' p t@ allows you to 10 | -- place a pattern @p@ in a term @t@ such that the names in the 11 | -- pattern scope over the term. Use 'Unbound.Generics.LocallyNameless.Operations.bind' 12 | -- and 'Unbound.Generics.LocallyNameless.Operations.unbind' and 'Unbound.Generics.LocallyNameless.Operations.lunbind' 13 | -- to work with @'Bind' p t@ 14 | {-# LANGUAGE DeriveGeneric #-} 15 | module Unbound.Generics.LocallyNameless.Bind ( 16 | -- * Name binding 17 | Bind(..) 18 | ) where 19 | 20 | import Control.Applicative (Applicative(..), (<$>)) 21 | import Control.DeepSeq (NFData(..)) 22 | import Data.Monoid ((<>), All(..)) 23 | 24 | import GHC.Generics (Generic) 25 | 26 | import Unbound.Generics.LocallyNameless.Alpha 27 | 28 | -- | A term of type @'Bind' p t@ is a term that binds the free 29 | -- variable occurrences of the variables in pattern @p@ in the term 30 | -- @t@. In the overall term, those variables are now bound. See also 31 | -- 'Unbound.Generics.LocallyNameless.Operations.bind' and 32 | -- 'Unbound.Generics.LocallyNameless.Operations.unbind' and 33 | -- 'Unbound.Generics.LocallyNameless.Operations.lunbind' 34 | data Bind p t = B p t 35 | deriving (Generic) 36 | 37 | instance (NFData p, NFData t) => NFData (Bind p t) where 38 | rnf (B p t) = rnf p `seq` rnf t `seq` () 39 | 40 | instance (Show p, Show t) => Show (Bind p t) where 41 | showsPrec prec (B p t) = 42 | showParen (prec > 0) (showString "<" 43 | . showsPrec prec p 44 | . showString "> " 45 | . showsPrec 0 t) 46 | 47 | instance (Alpha p, Alpha t) => Alpha (Bind p t) where 48 | 49 | aeq' ctx (B p1 t1) (B p2 t2) = 50 | aeq' (patternCtx ctx) p1 p2 51 | && aeq' (incrLevelCtx ctx) t1 t2 52 | 53 | fvAny' ctx nfn (B p t) = B <$> fvAny' (patternCtx ctx) nfn p 54 | <*> fvAny' (incrLevelCtx ctx) nfn t 55 | 56 | isPat _ = inconsistentDisjointSet 57 | 58 | isTerm (B p t) = (All $ isConsistentDisjointSet $ isPat p) <> isTerm t 59 | 60 | close ctx b (B p t) = 61 | B (close (patternCtx ctx) b p) (close (incrLevelCtx ctx) b t) 62 | 63 | open ctx b (B p t) = 64 | B (open (patternCtx ctx) b p) (open (incrLevelCtx ctx) b t) 65 | 66 | nthPatFind b = error $ "Binding " ++ show b ++ " used as a pattern" 67 | namePatFind b = error $ "Binding " ++ show b ++ " used as a pattern" 68 | 69 | swaps' ctx perm (B p t) = 70 | B (swaps' (patternCtx ctx) perm p) 71 | (swaps' (incrLevelCtx ctx) perm t) 72 | 73 | freshen' ctx (B p t) = do 74 | (p', perm1) <- freshen' (patternCtx ctx) p 75 | (t', perm2) <- freshen' (incrLevelCtx ctx) (swaps' (incrLevelCtx ctx) perm1 t) 76 | return (B p' t', perm1 <> perm2) 77 | {-# INLINE freshen' #-} 78 | 79 | lfreshen' ctx (B p t) cont = 80 | lfreshen' (patternCtx ctx) p $ \p' pm1 -> 81 | lfreshen' (incrLevelCtx ctx) (swaps' (incrLevelCtx ctx) pm1 t) $ \t' pm2 -> 82 | cont (B p' t') (pm1 <> pm2) 83 | 84 | acompare' ctx (B p1 t1) (B p2 t2) = 85 | acompare' (patternCtx ctx) p1 p2 <> acompare' (incrLevelCtx ctx) t1 t2 86 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Embed.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | -- | 3 | -- Module : Unbound.Generics.LocallyNameless.Embed 4 | -- Copyright : (c) 2014, Aleksey Kliger 5 | -- License : BSD3 (See LICENSE) 6 | -- Maintainer : Aleksey Kliger 7 | -- Stability : experimental 8 | -- 9 | -- The pattern @'Embed' t@ contains a term @t@. 10 | {-# LANGUAGE DeriveGeneric, TypeFamilies #-} 11 | module Unbound.Generics.LocallyNameless.Embed where 12 | 13 | import Control.Applicative (pure, (<$>)) 14 | import Control.DeepSeq (NFData(..)) 15 | import Data.Monoid (mempty, All(..)) 16 | import Data.Profunctor (Profunctor(..)) 17 | 18 | import GHC.Generics (Generic) 19 | 20 | import Unbound.Generics.LocallyNameless.Alpha 21 | import Unbound.Generics.LocallyNameless.Internal.Iso (iso) 22 | 23 | -- | @Embed@ allows for terms to be /embedded/ within patterns. Such 24 | -- embedded terms do not bind names along with the rest of the 25 | -- pattern. For examples, see the tutorial or examples directories. 26 | -- 27 | -- If @t@ is a /term type/, then @Embed t@ is a /pattern type/. 28 | -- 29 | -- @Embed@ is not abstract since it involves no binding, and hence 30 | -- it is safe to manipulate directly. To create and destruct 31 | -- @Embed@ terms, you may use the @Embed@ constructor directly. 32 | -- (You may also use the functions 'embed' and 'unembed', which 33 | -- additionally can construct or destruct any number of enclosing 34 | -- 'Shift's at the same time.) 35 | newtype Embed t = Embed t deriving (Eq, Ord, Generic) 36 | 37 | class IsEmbed e where 38 | -- | The term type embedded in the embedding 'e' 39 | type Embedded e :: * 40 | -- | Insert or extract the embedded term. 41 | -- If you're not using the lens library, see 'Unbound.Generics.LocallyNameless.Operations.embed' 42 | -- and 'Unbound.Generics.LocallyNameless.Operations.unembed' 43 | -- otherwise 'embedded' is an isomorphism that you can use with lens. 44 | -- @ 45 | -- embedded :: Iso' (Embedded e) e 46 | -- @ 47 | embedded :: (Profunctor p, Functor f) => p (Embedded e) (f (Embedded e)) -> p e (f e) 48 | 49 | instance IsEmbed (Embed t) where 50 | type Embedded (Embed t) = t 51 | embedded = iso (\(Embed t) -> t) Embed 52 | 53 | instance NFData t => NFData (Embed t) where 54 | rnf (Embed t) = rnf t `seq` () 55 | 56 | instance Show a => Show (Embed a) where 57 | showsPrec _ (Embed a) = showString "{" . showsPrec 0 a . showString "}" 58 | 59 | instance Alpha t => Alpha (Embed t) where 60 | isPat (Embed t) = if getAll (isTerm t) then mempty else inconsistentDisjointSet 61 | 62 | isTerm _ = All False 63 | 64 | isEmbed (Embed t) = getAll (isTerm t) 65 | 66 | swaps' ctx perm (Embed t) = 67 | if isTermCtx ctx 68 | then Embed t 69 | else Embed (swaps' (termCtx ctx) perm t) 70 | 71 | freshen' ctx p = 72 | if isTermCtx ctx 73 | then error "LocallyNameless.freshen' called on a term" 74 | else return (p, mempty) 75 | 76 | lfreshen' ctx p cont = 77 | if isTermCtx ctx 78 | then error "LocallyNameless.lfreshen' called on a term" 79 | else cont p mempty 80 | 81 | 82 | aeq' ctx (Embed x) (Embed y) = aeq' (termCtx ctx) x y 83 | 84 | fvAny' ctx afa ex@(Embed x) = 85 | if isTermCtx ctx 86 | then pure ex 87 | else Embed <$> fvAny' (termCtx ctx) afa x 88 | 89 | close ctx b (Embed x) = 90 | if isTermCtx ctx 91 | then error "LocallyNameless.close on Embed" 92 | else Embed (close (termCtx ctx) b x) 93 | 94 | open ctx b (Embed x) = 95 | if isTermCtx ctx 96 | then error "LocallyNameless.open on Embed" 97 | else Embed (open (termCtx ctx) b x) 98 | 99 | nthPatFind _ = mempty 100 | namePatFind _ = mempty 101 | 102 | acompare' ctx (Embed x) (Embed y) = acompare' (termCtx ctx) x y 103 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Fresh.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Unbound.Generics.LocallyNameless.Fresh 3 | -- Copyright : (c) 2014, Aleksey Kliger 4 | -- License : BSD3 (See LICENSE) 5 | -- Maintainer : Aleksey Kliger 6 | -- Stability : experimental 7 | -- 8 | -- Global freshness monad. 9 | {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, 10 | FlexibleInstances, MultiParamTypeClasses, 11 | StandaloneDeriving, 12 | UndecidableInstances 13 | #-} 14 | -- (we expect deprecation warnings about Control.Monad.Trans.Error) 15 | {-# OPTIONS_GHC -Wwarn #-} 16 | module Unbound.Generics.LocallyNameless.Fresh where 17 | 18 | import Control.Applicative (Applicative, Alternative) 19 | import Control.Monad () 20 | 21 | import Control.Monad.Identity 22 | 23 | import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) 24 | #if MIN_VERSION_base(4,9,0) 25 | import qualified Control.Monad.Fail as Fail 26 | #endif 27 | #if MIN_VERSION_mtl(2,3,0) 28 | import Control.Monad (MonadPlus) 29 | import Control.Monad.Fix (MonadFix) 30 | #endif 31 | import Control.Monad.Trans 32 | import Control.Monad.Trans.Except 33 | #if !MIN_VERSION_transformers(0,6,0) 34 | import Control.Monad.Trans.Error 35 | #endif 36 | import Control.Monad.Trans.Maybe 37 | import Control.Monad.Trans.Reader 38 | import Control.Monad.Trans.State.Lazy as Lazy 39 | import Control.Monad.Trans.State.Strict as Strict 40 | import Control.Monad.Trans.Writer.Lazy as Lazy 41 | import Control.Monad.Trans.Writer.Strict as Strict 42 | 43 | import qualified Control.Monad.Cont.Class as CC 44 | import qualified Control.Monad.Error.Class as EC 45 | import qualified Control.Monad.State.Class as StC 46 | import qualified Control.Monad.Reader.Class as RC 47 | import qualified Control.Monad.Writer.Class as WC 48 | 49 | import Data.Monoid (Monoid) 50 | 51 | import qualified Control.Monad.State as St 52 | 53 | import Unbound.Generics.LocallyNameless.Name 54 | 55 | -- | The @Fresh@ type class governs monads which can generate new 56 | -- globally unique 'Name's based on a given 'Name'. 57 | class Monad m => Fresh m where 58 | 59 | -- | Generate a new globally unique name based on the given one. 60 | fresh :: Name a -> m (Name a) 61 | 62 | 63 | -- | The @FreshM@ monad transformer. Keeps track of the lowest index 64 | -- still globally unused, and increments the index every time it is 65 | -- asked for a fresh name. 66 | newtype FreshMT m a = FreshMT { unFreshMT :: St.StateT Integer m a } 67 | deriving 68 | ( Functor 69 | , Applicative 70 | , Alternative 71 | , Monad 72 | , MonadIO 73 | , MonadPlus 74 | , MonadFix 75 | , MonadThrow 76 | , MonadCatch 77 | , MonadMask 78 | ) 79 | 80 | #if MIN_VERSION_base(4,9,0) 81 | deriving instance Fail.MonadFail m => Fail.MonadFail (FreshMT m) 82 | #endif 83 | 84 | -- | Run a 'FreshMT' computation (with the global index starting at zero). 85 | runFreshMT :: Monad m => FreshMT m a -> m a 86 | runFreshMT m = contFreshMT m 0 87 | 88 | -- | Run a 'FreshMT' computation given a starting index for fresh name 89 | -- generation. 90 | contFreshMT :: Monad m => FreshMT m a -> Integer -> m a 91 | contFreshMT (FreshMT m) = St.evalStateT m 92 | 93 | instance MonadTrans FreshMT where 94 | lift = FreshMT . lift 95 | 96 | instance CC.MonadCont m => CC.MonadCont (FreshMT m) where 97 | callCC c = FreshMT $ CC.callCC (unFreshMT . (\k -> c (FreshMT . k))) 98 | 99 | instance EC.MonadError e m => EC.MonadError e (FreshMT m) where 100 | throwError = lift . EC.throwError 101 | catchError m h = FreshMT $ EC.catchError (unFreshMT m) (unFreshMT . h) 102 | 103 | instance StC.MonadState s m => StC.MonadState s (FreshMT m) where 104 | get = lift StC.get 105 | put = lift . StC.put 106 | 107 | instance RC.MonadReader r m => RC.MonadReader r (FreshMT m) where 108 | ask = lift RC.ask 109 | local f = FreshMT . RC.local f . unFreshMT 110 | 111 | instance WC.MonadWriter w m => WC.MonadWriter w (FreshMT m) where 112 | tell = lift . WC.tell 113 | listen = FreshMT . WC.listen . unFreshMT 114 | pass = FreshMT . WC.pass . unFreshMT 115 | 116 | 117 | instance Monad m => Fresh (FreshMT m) where 118 | fresh (Fn s _) = FreshMT $ do 119 | n <- St.get 120 | St.put $! n + 1 121 | return $ (Fn s n) 122 | fresh nm@(Bn {}) = return nm 123 | 124 | #if !MIN_VERSION_transformers(0,6,0) 125 | instance (Error e, Fresh m) => Fresh (ErrorT e m) where 126 | fresh = lift . fresh 127 | #endif 128 | 129 | instance Fresh m => Fresh (ExceptT e m) where 130 | fresh = lift . fresh 131 | 132 | instance Fresh m => Fresh (MaybeT m) where 133 | fresh = lift . fresh 134 | 135 | instance Fresh m => Fresh (ReaderT r m) where 136 | fresh = lift . fresh 137 | 138 | instance Fresh m => Fresh (Lazy.StateT s m) where 139 | fresh = lift . fresh 140 | 141 | instance Fresh m => Fresh (Strict.StateT s m) where 142 | fresh = lift . fresh 143 | 144 | instance (Monoid w, Fresh m) => Fresh (Lazy.WriterT w m) where 145 | fresh = lift . fresh 146 | 147 | instance (Monoid w, Fresh m) => Fresh (Strict.WriterT w m) where 148 | fresh = lift . fresh 149 | 150 | ------------------------------------------------------------ 151 | -- FreshM monad 152 | 153 | -- | A convenient monad which is an instance of 'Fresh'. It keeps 154 | -- track of a global index used for generating fresh names, which is 155 | -- incremented every time 'fresh' is called. 156 | type FreshM = FreshMT Identity 157 | 158 | -- | Run a FreshM computation (with the global index starting at zero). 159 | runFreshM :: FreshM a -> a 160 | runFreshM = runIdentity . runFreshMT 161 | 162 | -- | Run a FreshM computation given a starting index. 163 | contFreshM :: FreshM a -> Integer -> a 164 | contFreshM m = runIdentity . contFreshMT m 165 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Ignore.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Unbound.Generics.LocallyNameless.Ignore 3 | -- Copyright : (c) 2018, Reed Mullanix 4 | -- License : BSD3 (See LICENSE) 5 | -- Maintainer : Reed Mullanix 6 | -- Stability : experimental 7 | -- 8 | -- Ignores a term for the purposes of alpha-equality and substitution 9 | {-# LANGUAGE DeriveGeneric #-} 10 | module Unbound.Generics.LocallyNameless.Ignore ( 11 | Ignore(..) 12 | ) where 13 | 14 | import Control.DeepSeq (NFData(..)) 15 | import Control.Applicative 16 | import Data.Monoid 17 | 18 | import GHC.Generics (Generic) 19 | 20 | import Unbound.Generics.LocallyNameless.Alpha 21 | 22 | -- | Ignores a term 't' for the purpose of alpha-equality and substitution 23 | data Ignore t = I !t 24 | deriving (Generic) 25 | 26 | instance (NFData t) => NFData (Ignore t) where 27 | rnf (I t) = rnf t `seq` () 28 | 29 | instance (Show t) => Show (Ignore t) where 30 | showsPrec prec (I t) = 31 | showParen (prec > 0) (showString "<-" 32 | . showsPrec prec t 33 | . showString "->") 34 | 35 | instance (Show t) => Alpha (Ignore t) where 36 | aeq' _ _ _ = True 37 | fvAny' _ _ = pure 38 | isPat _ = inconsistentDisjointSet 39 | isTerm _ = mempty 40 | close _ _ = id 41 | open _ _ = id 42 | namePatFind _ = NamePatFind $ const $ Left 0 43 | nthPatFind _ = NthPatFind Left 44 | swaps' _ _ = id 45 | lfreshen' _ i cont = cont i mempty 46 | freshen' _ i = return (i, mempty) 47 | acompare' _ _ _ = EQ -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Internal/Fold.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Unbound.Generics.LocallyNameless.Internal.Fold 3 | -- Copyright : (c) 2014, Aleksey Kliger 4 | -- License : BSD3 (See LICENSE) 5 | -- Maintainer : Aleksey Kliger 6 | -- Stability : experimental 7 | -- 8 | -- Some utilities for working with Folds. 9 | -- 10 | -- If you are using , you don't need this module. 11 | {-# LANGUAGE RankNTypes #-} 12 | module Unbound.Generics.LocallyNameless.Internal.Fold (Fold, Traversal', toListOf, filtered, justFiltered, foldMapOf) where 13 | 14 | import Control.Applicative 15 | import Data.Maybe (fromJust) 16 | import Data.Functor.Contravariant 17 | import Data.Monoid 18 | 19 | type Getting r s a = (a -> Const r a) -> s -> Const r s 20 | 21 | type Fold s a = forall f . (Contravariant f, Applicative f) => (a -> f a) -> s -> f s 22 | 23 | type Traversal' s a = forall f . Applicative f => (a -> f a) -> s -> f s 24 | 25 | toListOf :: Fold s a -> s -> [a] 26 | -- toListOf :: Getting (Endo [a]) s a -> s -> [a] 27 | toListOf l = foldrOf l (:) [] 28 | {-# INLINE toListOf #-} 29 | 30 | foldMapOf :: Getting r s a -> (a -> r) -> s -> r 31 | foldMapOf l f = getConst . l (Const . f) 32 | {-# INLINE foldMapOf #-} 33 | 34 | foldrOf :: Getting (Endo r) s a -> (a -> r -> r) -> r -> s -> r 35 | foldrOf l f z = fmap (flip appEndo z) (foldMapOf l (Endo .f)) 36 | {-# INLINE foldrOf #-} 37 | 38 | filtered :: (a -> Bool) -> Traversal' a a 39 | filtered p afa x = if p x then afa x else pure x 40 | {-# INLINE filtered #-} 41 | 42 | justFiltered :: (a -> Maybe b) -> Fold a b 43 | justFiltered p bfb x = case p x of 44 | Just b -> contramap (fromJust . p) (bfb b) 45 | Nothing -> pure x 46 | {-# INLINE justFiltered #-} 47 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Internal/GSubst.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Unbound.Generics.LocallyNameless.Subst 3 | -- Copyright : (c) 2014, Aleksey Kliger 4 | -- License : BSD3 (See LICENSE) 5 | -- Maintainer : Aleksey Kliger 6 | -- Stability : experimental 7 | -- 8 | -- A typeclass for generic structural substitution. 9 | 10 | {-# LANGUAGE 11 | FlexibleInstances 12 | , MultiParamTypeClasses 13 | , TypeOperators 14 | #-} 15 | 16 | module Unbound.Generics.LocallyNameless.Internal.GSubst ( 17 | GSubst(..) 18 | ) where 19 | 20 | import GHC.Generics 21 | 22 | import Unbound.Generics.LocallyNameless.Name 23 | import Unbound.Generics.LocallyNameless.Alpha 24 | 25 | ---- generic structural substitution. 26 | 27 | class GSubst b f where 28 | gsubst :: Name b -> b -> f c -> f c 29 | gsubsts :: [(Name b, b)] -> f c -> f c 30 | gsubstBvs :: AlphaCtx -> [b] -> f c -> f c 31 | 32 | instance GSubst b f => GSubst b (M1 i c f) where 33 | gsubst nm val = M1 . gsubst nm val . unM1 34 | gsubsts ss = M1 . gsubsts ss . unM1 35 | gsubstBvs c b = M1 . gsubstBvs c b . unM1 36 | 37 | instance GSubst b U1 where 38 | gsubst _nm _val _ = U1 39 | gsubsts _ss _ = U1 40 | gsubstBvs _c _b _ = U1 41 | 42 | instance GSubst b V1 where 43 | gsubst _nm _val = id 44 | gsubsts _ss = id 45 | gsubstBvs _c _b = id 46 | 47 | instance (GSubst b f, GSubst b g) => GSubst b (f :*: g) where 48 | gsubst nm val (f :*: g) = gsubst nm val f :*: gsubst nm val g 49 | gsubsts ss (f :*: g) = gsubsts ss f :*: gsubsts ss g 50 | gsubstBvs c b (f :*: g) = gsubstBvs c b f :*: gsubstBvs c b g 51 | 52 | instance (GSubst b f, GSubst b g) => GSubst b (f :+: g) where 53 | gsubst nm val (L1 f) = L1 $ gsubst nm val f 54 | gsubst nm val (R1 g) = R1 $ gsubst nm val g 55 | 56 | gsubsts ss (L1 f) = L1 $ gsubsts ss f 57 | gsubsts ss (R1 g) = R1 $ gsubsts ss g 58 | 59 | gsubstBvs c b (L1 f) = L1 $ gsubstBvs c b f 60 | gsubstBvs c b (R1 g) = R1 $ gsubstBvs c b g 61 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Internal/Iso.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Unbound.Generics.LocallyNameless.Internal.Iso where 3 | 4 | import Data.Profunctor (Profunctor(..)) 5 | import Data.Functor.Identity (Identity(..)) 6 | 7 | data Exchange a b s t = Exchange (s -> a) (b -> t) 8 | 9 | instance Functor (Exchange a b s) where 10 | fmap f (Exchange p q) = Exchange p (f . q) 11 | 12 | instance Profunctor (Exchange a b) where 13 | dimap f g (Exchange h k) = Exchange (h . f ) (g . k) 14 | 15 | type Iso s t a b = forall p f . (Profunctor p, Functor f) => p a (f b) -> p s (f t) 16 | 17 | type AnIso s t a b = Exchange a b a (Identity b) -> Exchange a b s (Identity t) 18 | 19 | iso :: (s -> a) -> (b -> t) -> Iso s t a b 20 | iso sa bt = dimap sa (fmap bt) 21 | {-# INLINE iso #-} 22 | 23 | from :: AnIso s t a b -> Iso b a t s 24 | from l = withIso l $ \ sa bt -> iso bt sa 25 | {-# INLINE from #-} 26 | 27 | withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r 28 | withIso ai k = 29 | case ai (Exchange id Identity) of 30 | Exchange sa bt -> k sa (runIdentity . bt) 31 | {-# INLINE withIso #-} 32 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Internal/Lens.hs: -------------------------------------------------------------------------------- 1 | module Unbound.Generics.LocallyNameless.Internal.Lens where 2 | 3 | import Control.Monad.Reader (MonadReader(..)) 4 | import qualified Control.Monad.Reader as Reader 5 | import Control.Applicative (Const(..)) 6 | 7 | type Getting r s a = (a -> Const r a) -> s -> Const r s 8 | 9 | view :: MonadReader s m => Getting a s a -> m a 10 | view l = Reader.asks (getConst . l Const) 11 | {-# INLINE view #-} 12 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/LFresh.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | -- | 3 | -- Module : Unbound.Generics.LocallyNameless.LFresh 4 | -- Copyright : (c) 2011, Stephanie Weirich 5 | -- License : BSD3 (See LFresh.hs) 6 | -- Maintainer : Aleksey Kliger 7 | -- Stability : experimental 8 | -- 9 | -- Local freshness monad. 10 | {- 11 | Copyright (c)2011, Stephanie Weirich 12 | 13 | All rights reserved. 14 | 15 | Redistribution and use in source and binary forms, with or without 16 | modification, are permitted provided that the following conditions are met: 17 | 18 | * Redistributions of source code must retain the above copyright 19 | notice, this list of conditions and the following disclaimer. 20 | 21 | * Redistributions in binary form must reproduce the above 22 | copyright notice, this list of conditions and the following 23 | disclaimer in the documentation and/or other materials provided 24 | with the distribution. 25 | 26 | * Neither the name of Stephanie Weirich nor the names of other 27 | contributors may be used to endorse or promote products derived 28 | from this software without specific prior written permission. 29 | 30 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 31 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 32 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 33 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 34 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 35 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 36 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 37 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 38 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 39 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 40 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 41 | -} 42 | -- we expect deprecation warnings about Control.Monad.Trans.Error 43 | {-# OPTIONS_GHC -Wwarn #-} 44 | {-# LANGUAGE CPP 45 | , GeneralizedNewtypeDeriving 46 | , FlexibleInstances 47 | , MultiParamTypeClasses 48 | , StandaloneDeriving 49 | , UndecidableInstances #-} 50 | module Unbound.Generics.LocallyNameless.LFresh 51 | ( 52 | -- * The 'LFresh' class 53 | 54 | LFresh(..), 55 | 56 | LFreshM, runLFreshM, contLFreshM, 57 | LFreshMT(..), runLFreshMT, contLFreshMT 58 | 59 | ) where 60 | 61 | import Data.Set (Set) 62 | import qualified Data.Set as S 63 | 64 | import Data.Monoid 65 | import Data.Typeable (Typeable) 66 | 67 | import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) 68 | #if MIN_VERSION_base(4,9,0) 69 | import qualified Control.Monad.Fail as Fail 70 | #endif 71 | #if MIN_VERSION_mtl(2,3,0) 72 | import Control.Monad (MonadPlus) 73 | import Control.Monad.Fix (MonadFix) 74 | #endif 75 | import Control.Monad.Reader 76 | import Control.Monad.Identity 77 | import Control.Applicative (Applicative, Alternative) 78 | 79 | import Control.Monad.Trans.Cont 80 | #if !MIN_VERSION_transformers(0,6,0) 81 | import Control.Monad.Trans.Error 82 | #endif 83 | import Control.Monad.Trans.Except 84 | import Control.Monad.Trans.Identity 85 | #if !MIN_VERSION_transformers(0,6,0) 86 | import Control.Monad.Trans.List 87 | #endif 88 | import Control.Monad.Trans.Maybe 89 | import Control.Monad.Trans.State.Lazy as Lazy 90 | import Control.Monad.Trans.State.Strict as Strict 91 | import Control.Monad.Trans.Writer.Lazy as Lazy 92 | import Control.Monad.Trans.Writer.Strict as Strict 93 | 94 | import qualified Control.Monad.Cont.Class as CC 95 | import qualified Control.Monad.Error.Class as EC 96 | import qualified Control.Monad.State.Class as StC 97 | import qualified Control.Monad.Reader.Class as RC 98 | import qualified Control.Monad.Writer.Class as WC 99 | 100 | import Unbound.Generics.LocallyNameless.Name 101 | 102 | -- | This is the class of monads that support freshness in an 103 | -- (implicit) local scope. Generated names are fresh for the current 104 | -- local scope, not necessarily globally fresh. 105 | class Monad m => LFresh m where 106 | -- | Pick a new name that is fresh for the current (implicit) scope. 107 | lfresh :: Typeable a => Name a -> m (Name a) 108 | -- | Avoid the given names when freshening in the subcomputation, 109 | -- that is, add the given names to the in-scope set. 110 | avoid :: [AnyName] -> m a -> m a 111 | -- | Get the set of names currently being avoided. 112 | getAvoids :: m (Set AnyName) 113 | 114 | -- | The LFresh monad transformer. Keeps track of a set of names to 115 | -- avoid, and when asked for a fresh one will choose the first numeric 116 | -- prefix of the given name which is currently unused. 117 | newtype LFreshMT m a = LFreshMT { unLFreshMT :: ReaderT (Set AnyName) m a } 118 | deriving 119 | ( Functor 120 | , Applicative 121 | , Alternative 122 | , Monad 123 | , MonadIO 124 | , MonadPlus 125 | , MonadFix 126 | , MonadThrow 127 | , MonadCatch 128 | , MonadMask 129 | ) 130 | 131 | #if MIN_VERSION_base(4,9,0) 132 | deriving instance Fail.MonadFail m => Fail.MonadFail (LFreshMT m) 133 | #endif 134 | 135 | -- | Run an 'LFreshMT' computation in an empty context. 136 | runLFreshMT :: LFreshMT m a -> m a 137 | runLFreshMT m = contLFreshMT m S.empty 138 | 139 | -- | Run an 'LFreshMT' computation given a set of names to avoid. 140 | contLFreshMT :: LFreshMT m a -> Set AnyName -> m a 141 | contLFreshMT (LFreshMT m) = runReaderT m 142 | 143 | instance Monad m => LFresh (LFreshMT m) where 144 | lfresh nm = LFreshMT $ do 145 | let s = name2String nm 146 | used <- ask 147 | return $ head (filter (\x -> not (S.member (AnyName x) used)) 148 | (map (makeName s) [0..])) 149 | avoid names = LFreshMT . local (S.union (S.fromList names)) . unLFreshMT 150 | 151 | getAvoids = LFreshMT ask 152 | 153 | -- | A convenient monad which is an instance of 'LFresh'. It keeps 154 | -- track of a set of names to avoid, and when asked for a fresh one 155 | -- will choose the first unused numerical name. 156 | type LFreshM = LFreshMT Identity 157 | 158 | -- | Run a LFreshM computation in an empty context. 159 | runLFreshM :: LFreshM a -> a 160 | runLFreshM = runIdentity . runLFreshMT 161 | 162 | -- | Run a LFreshM computation given a set of names to avoid. 163 | contLFreshM :: LFreshM a -> Set AnyName -> a 164 | contLFreshM m = runIdentity . contLFreshMT m 165 | 166 | instance LFresh m => LFresh (ContT r m) where 167 | lfresh = lift . lfresh 168 | avoid = mapContT . avoid 169 | getAvoids = lift getAvoids 170 | 171 | #if !MIN_VERSION_transformers(0,6,0) 172 | instance (Error e, LFresh m) => LFresh (ErrorT e m) where 173 | lfresh = lift . lfresh 174 | avoid = mapErrorT . avoid 175 | getAvoids = lift getAvoids 176 | #endif 177 | 178 | instance LFresh m => LFresh (ExceptT e m) where 179 | lfresh = lift . lfresh 180 | avoid = mapExceptT . avoid 181 | getAvoids = lift getAvoids 182 | 183 | instance LFresh m => LFresh (IdentityT m) where 184 | lfresh = lift . lfresh 185 | avoid = mapIdentityT . avoid 186 | getAvoids = lift getAvoids 187 | 188 | #if !MIN_VERSION_transformers(0,6,0) 189 | instance LFresh m => LFresh (ListT m) where 190 | lfresh = lift . lfresh 191 | avoid = mapListT . avoid 192 | getAvoids = lift getAvoids 193 | #endif 194 | 195 | instance LFresh m => LFresh (MaybeT m) where 196 | lfresh = lift . lfresh 197 | avoid = mapMaybeT . avoid 198 | getAvoids = lift getAvoids 199 | 200 | instance LFresh m => LFresh (ReaderT r m) where 201 | lfresh = lift . lfresh 202 | avoid = mapReaderT . avoid 203 | getAvoids = lift getAvoids 204 | 205 | instance LFresh m => LFresh (Lazy.StateT s m) where 206 | lfresh = lift . lfresh 207 | avoid = Lazy.mapStateT . avoid 208 | getAvoids = lift getAvoids 209 | 210 | instance LFresh m => LFresh (Strict.StateT s m) where 211 | lfresh = lift . lfresh 212 | avoid = Strict.mapStateT . avoid 213 | getAvoids = lift getAvoids 214 | 215 | instance (Monoid w, LFresh m) => LFresh (Lazy.WriterT w m) where 216 | lfresh = lift . lfresh 217 | avoid = Lazy.mapWriterT . avoid 218 | getAvoids = lift getAvoids 219 | 220 | instance (Monoid w, LFresh m) => LFresh (Strict.WriterT w m) where 221 | lfresh = lift . lfresh 222 | avoid = Strict.mapWriterT . avoid 223 | getAvoids = lift getAvoids 224 | 225 | -- Instances for applying LFreshMT to other monads 226 | 227 | instance MonadTrans LFreshMT where 228 | lift = LFreshMT . lift 229 | 230 | instance CC.MonadCont m => CC.MonadCont (LFreshMT m) where 231 | callCC c = LFreshMT $ CC.callCC (unLFreshMT . (\k -> c (LFreshMT . k))) 232 | 233 | instance EC.MonadError e m => EC.MonadError e (LFreshMT m) where 234 | throwError = lift . EC.throwError 235 | catchError m h = LFreshMT $ EC.catchError (unLFreshMT m) (unLFreshMT . h) 236 | 237 | instance StC.MonadState s m => StC.MonadState s (LFreshMT m) where 238 | get = lift StC.get 239 | put = lift . StC.put 240 | 241 | instance RC.MonadReader r m => RC.MonadReader r (LFreshMT m) where 242 | ask = lift RC.ask 243 | local f = LFreshMT . mapReaderT (RC.local f) . unLFreshMT 244 | 245 | instance WC.MonadWriter w m => WC.MonadWriter w (LFreshMT m) where 246 | tell = lift . WC.tell 247 | listen = LFreshMT . WC.listen . unLFreshMT 248 | pass = LFreshMT . WC.pass . unLFreshMT 249 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Name.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Unbound.Generics.LocallyNameless.Name 3 | -- Copyright : (c) 2014, Aleksey Kliger 4 | -- License : BSD3 (See LICENSE) 5 | -- Maintainer : Aleksey Kliger 6 | -- Stability : experimental 7 | -- 8 | -- Names stand for values. They may be bound or free. 9 | {-# LANGUAGE DeriveDataTypeable 10 | , DeriveGeneric 11 | , ExistentialQuantification 12 | , FlexibleContexts 13 | , GADTs #-} 14 | module Unbound.Generics.LocallyNameless.Name 15 | ( 16 | -- * Names over terms 17 | Name(..) 18 | , isFreeName 19 | -- * Name construction 20 | , string2Name 21 | , s2n 22 | , makeName 23 | -- * Name inspection 24 | , name2String 25 | , name2Integer 26 | -- * Heterogeneous names 27 | , AnyName(..) 28 | ) where 29 | 30 | import Control.DeepSeq (NFData(..)) 31 | import Data.Typeable (Typeable, gcast, typeOf) 32 | import GHC.Generics (Generic) 33 | 34 | -- | An abstract datatype of names @Name a@ that stand for terms of 35 | -- type @a@. The type @a@ is used as a tag to distinguish these names 36 | -- from names that may stand for other sorts of terms. 37 | -- 38 | -- Two names in a term are considered 39 | -- 'Unbound.Generics.LocallyNameless.Operations.aeq' equal when they 40 | -- are the same name (in the sense of '(==)'). In patterns, however, 41 | -- any two names are equal if they occur in the same place within the 42 | -- pattern. This induces alpha equivalence on terms in general. 43 | -- 44 | -- Names may either be free or bound (see 'isFreeName'). Free names 45 | -- may be extracted from patterns using 46 | -- 'Unbound.Generics.LocallyNameless.Alpha.isPat'. Bound names 47 | -- cannot be. 48 | -- 49 | data Name a = Fn String !Integer -- free names 50 | | Bn !Integer !Integer -- bound names / binding level + pattern index 51 | deriving (Eq, Ord, Typeable, Generic) 52 | 53 | instance NFData (Name a) where 54 | rnf (Fn s n) = rnf s `seq` rnf n `seq` () 55 | rnf (Bn i j) = rnf i `seq` rnf j `seq` () 56 | 57 | -- | Returns 'True' iff the given @Name a@ is free. 58 | isFreeName :: Name a -> Bool 59 | isFreeName (Fn _ _) = True 60 | isFreeName _ = False 61 | 62 | -- | Make a free 'Name a' from a 'String' 63 | string2Name :: String -> Name a 64 | string2Name s = makeName s 0 65 | 66 | -- | Synonym for 'string2Name'. 67 | s2n :: String -> Name a 68 | s2n = string2Name 69 | 70 | -- | Make a name from a 'String' and an 'Integer' index 71 | makeName :: String -> Integer -> Name a 72 | makeName = Fn 73 | 74 | -- | Get the integer part of a 'Name'. 75 | name2Integer :: Name a -> Integer 76 | name2Integer (Fn _ i) = i 77 | name2Integer (Bn _ _) = error "Internal Error: cannot call name2Integer for bound names" 78 | 79 | -- | Get the string part of a 'Name'. 80 | name2String :: Name a -> String 81 | name2String (Fn s _) = s 82 | name2String (Bn _ _) = error "Internal Error: cannot call name2String for bound names" 83 | 84 | instance Show (Name a) where 85 | show (Fn "" n) = "_" ++ (show n) 86 | show (Fn x 0) = x 87 | show (Fn x n) = x ++ (show n) 88 | show (Bn x y) = show x ++ "@" ++ show y 89 | 90 | -- | An @AnyName@ is a name that stands for a term of some (existentially hidden) type. 91 | data AnyName where 92 | AnyName :: Typeable a => Name a -> AnyName 93 | 94 | instance Show AnyName where 95 | show (AnyName nm) = show nm 96 | 97 | instance Eq AnyName where 98 | (AnyName n1) == (AnyName n2) = case gcast n2 of 99 | Just n2' -> n1 == n2' 100 | Nothing -> False 101 | 102 | instance Ord AnyName where 103 | compare (AnyName n1) (AnyName n2) = case compare (typeOf n1) (typeOf n2) of 104 | EQ -> case gcast n2 of 105 | Just n2' -> compare n1 n2' 106 | Nothing -> error "Equal type representations, but gcast failed in comparing two AnyName values" 107 | ord -> ord 108 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Operations.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Unbound.Generics.LocallyNameless.Operations 3 | -- Copyright : (c) 2014, Aleksey Kliger 4 | -- License : BSD3 (See LICENSE) 5 | -- Maintainer : Aleksey Kliger 6 | -- Stability : experimental 7 | -- 8 | -- Operations on terms and patterns that contain names. 9 | {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} 10 | module Unbound.Generics.LocallyNameless.Operations 11 | (-- * Equivalence, free variables, freshness 12 | aeq 13 | , acompare 14 | , fvAny 15 | , fv 16 | , freshen 17 | , lfreshen 18 | , swaps 19 | -- * Binding, unbinding 20 | , Bind 21 | , bind 22 | , unbind 23 | , lunbind 24 | , unbind2 25 | , lunbind2 26 | , unbind2Plus 27 | -- * Rebinding, embedding 28 | , Rebind 29 | , rebind 30 | , unrebind 31 | , Embed(..) 32 | , IsEmbed(..) 33 | , embed 34 | , unembed 35 | -- * Recursive bindings 36 | , Rec 37 | , Unbound.Generics.LocallyNameless.Rec.rec 38 | , Unbound.Generics.LocallyNameless.Rec.unrec 39 | , TRec(..) 40 | , trec 41 | , untrec 42 | , luntrec 43 | -- * Opaque terms 44 | , Ignore 45 | , ignore 46 | , unignore 47 | ) where 48 | 49 | import Control.Applicative (Applicative) 50 | import Control.Monad (MonadPlus(mzero)) 51 | import Data.Functor.Contravariant (Contravariant) 52 | import Data.Monoid ((<>)) 53 | import Data.Typeable (Typeable, cast) 54 | import Unbound.Generics.LocallyNameless.Alpha 55 | import Unbound.Generics.LocallyNameless.Fresh 56 | import Unbound.Generics.LocallyNameless.LFresh 57 | import Unbound.Generics.LocallyNameless.Name 58 | import Unbound.Generics.LocallyNameless.Bind 59 | import Unbound.Generics.LocallyNameless.Embed (Embed(..), IsEmbed(..)) 60 | import Unbound.Generics.LocallyNameless.Rebind 61 | import Unbound.Generics.LocallyNameless.Rec 62 | import Unbound.Generics.LocallyNameless.Ignore 63 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf, justFiltered) 64 | import Unbound.Generics.LocallyNameless.Internal.Lens (view) 65 | import Unbound.Generics.LocallyNameless.Internal.Iso (from) 66 | import Unbound.Generics.PermM 67 | 68 | -- | @'aeq' t1 t2@ returns @True@ iff @t1@ and @t2@ are alpha-equivalent terms. 69 | aeq :: Alpha a => a -> a -> Bool 70 | aeq = aeq' initialCtx 71 | 72 | -- | An alpha-respecting total order on terms involving binders. 73 | acompare :: Alpha a => a -> a -> Ordering 74 | acompare = acompare' initialCtx 75 | 76 | -- | @'fvAny'@ returns a fold over any names in a term @a@. 77 | -- 78 | -- @ 79 | -- fvAny :: Alpha a => Fold a AnyName 80 | -- @ 81 | fvAny :: (Alpha a, Contravariant f, Applicative f) => (AnyName -> f AnyName) -> a -> f a 82 | fvAny = fvAny' initialCtx 83 | 84 | -- | @'fv'@ returns the free @b@ variables of term @a@. 85 | -- 86 | -- @ 87 | -- fv :: (Alpha a, Typeable b) => Fold a (Name b) 88 | -- @ 89 | fv :: forall a f b . (Alpha a, Typeable b, Contravariant f, Applicative f) 90 | => (Name b -> f (Name b)) -> a -> f a 91 | fv = fvAny . justFiltered f 92 | where f :: AnyName -> Maybe (Name b) 93 | f (AnyName n) = cast n 94 | 95 | -- | Freshen a pattern by replacing all old binding 'Name's with new 96 | -- fresh 'Name's, returning a new pattern and a @'Perm' 'Name'@ 97 | -- specifying how 'Name's were replaced. 98 | freshen :: (Alpha p, Fresh m) => p -> m (p, Perm AnyName) 99 | freshen = freshen' (patternCtx initialCtx) 100 | 101 | -- | \"Locally\" freshen a pattern, replacing all binding names with 102 | -- new names that are not already \"in scope\". The second argument 103 | -- is a continuation, which takes the renamed term and a permutation 104 | -- that specifies how the pattern has been renamed. The resulting 105 | -- computation will be run with the in-scope set extended by the 106 | -- names just generated. 107 | lfreshen :: (Alpha p, LFresh m) => p -> (p -> Perm AnyName -> m b) -> m b 108 | lfreshen = lfreshen' (patternCtx initialCtx) 109 | 110 | -- | Apply the given permutation of variable names to the given term. 111 | swaps :: Alpha t => Perm AnyName -> t -> t 112 | swaps = swaps' initialCtx 113 | 114 | 115 | -- | @'bind' p t@ closes over the variables of pattern @p@ in the term @t@ 116 | bind :: (Alpha p, Alpha t) => p -> t -> Bind p t 117 | bind p t = B p (close initialCtx (namePatFind p) t) 118 | 119 | -- | @'unbind' b@ lets you descend beneath a binder @b :: 'Bind' p t@ 120 | -- by returning the pair of the pattern @p@ and the term @t@ where the 121 | -- variables in the pattern have been made globally fresh with respect 122 | -- to the freshness monad @m@. 123 | unbind :: (Alpha p, Alpha t, Fresh m) => Bind p t -> m (p, t) 124 | unbind (B p t) = do 125 | (p', _) <- freshen p 126 | return (p', open initialCtx (nthPatFind p') t) 127 | 128 | -- | @lunbind@ opens a binding in an 'LFresh' monad, ensuring that the 129 | -- names chosen for the binders are /locally/ fresh. The components 130 | -- of the binding are passed to a /continuation/, and the resulting 131 | -- monadic action is run in a context extended to avoid choosing new 132 | -- names which are the same as the ones chosen for this binding. 133 | -- 134 | -- For more information, see the documentation for the 'LFresh' type 135 | -- class. 136 | lunbind :: (LFresh m, Alpha p, Alpha t) => Bind p t -> ((p, t) -> m c) -> m c 137 | lunbind (B p t) cont = 138 | lfreshen p (\x _ -> cont (x, open initialCtx (nthPatFind x) t)) 139 | 140 | 141 | -- | Simultaneously unbind two patterns in two terms, returning 'Nothing' if 142 | -- the two patterns don't bind the same number of variables. 143 | unbind2 :: (Fresh m, Alpha p1, Alpha p2, Alpha t1, Alpha t2) 144 | => Bind p1 t1 145 | -> Bind p2 t2 146 | -> m (Maybe (p1, t1, p2, t2)) 147 | unbind2 (B p1 t1) (B p2 t2) = do 148 | case mkPerm (toListOf fvAny p2) (toListOf fvAny p1) of 149 | Just pm -> do 150 | (p1', pm') <- freshen p1 151 | let npf = nthPatFind p1' 152 | return $ Just (p1', open initialCtx npf t1, 153 | swaps (pm' <> pm) p2, open initialCtx npf t2) 154 | Nothing -> return Nothing 155 | 156 | -- | Simultaneously 'lunbind' two patterns in two terms in the 'LFresh' monad, 157 | -- passing @Just (p1, t1, p2, t2)@ to the continuation such that the patterns 158 | -- are permuted such that they introduce the same free names, or 'Nothing' if 159 | -- the number of variables differs. 160 | lunbind2 :: (LFresh m, Alpha p1, Alpha p2, Alpha t1, Alpha t2) 161 | => Bind p1 t1 162 | -> Bind p2 t2 163 | -> (Maybe (p1, t1, p2, t2) -> m c) 164 | -> m c 165 | lunbind2 (B p1 t1) (B p2 t2) cont = 166 | case mkPerm (toListOf fvAny p2) (toListOf fvAny p1) of 167 | Just pm -> 168 | lfreshen p1 $ \p1' pm' -> 169 | cont $ let npf = nthPatFind p1' 170 | in Just (p1', open initialCtx npf t1, 171 | swaps (pm' <> pm) p2, open initialCtx npf t2) 172 | Nothing -> cont Nothing 173 | 174 | -- | Simultaneously unbind two patterns in two terms, returning 'mzero' if 175 | -- the patterns don't bind the same number of variables. 176 | unbind2Plus :: (MonadPlus m, Fresh m, Alpha p1, Alpha p2, Alpha t1, Alpha t2) 177 | => Bind p1 t1 178 | -> Bind p2 t2 179 | -> m (p1, t1, p2, t2) 180 | unbind2Plus bnd bnd' = maybe mzero return =<< unbind2 bnd bnd' 181 | 182 | 183 | -- | @'rebind' p1 p2@ is a smart constructor for 'Rebind'. It 184 | -- captures the variables of pattern @p1@ that occur within @p2@ in 185 | -- addition to providing binding occurrences for all the variables of @p1@ and @p2@ 186 | rebind :: (Alpha p1, Alpha p2) => p1 -> p2 -> Rebind p1 p2 187 | rebind p1 p2 = Rebnd p1 (close (patternCtx initialCtx) (namePatFind p1) p2) 188 | 189 | -- | @'unrebind' p@ is the elimination form for 'Rebind'. It is not 190 | -- monadic (unlike 'unbind') because a @Rebind@ pattern can only occur 191 | -- somewhere in a pattern position of a 'Bind', and therefore 'unbind' 192 | -- must have already been called and all names apropriately 193 | -- 'freshen'ed. 194 | unrebind :: (Alpha p1, Alpha p2) => Rebind p1 p2 -> (p1, p2) 195 | unrebind (Rebnd p1 p2) = (p1, open (patternCtx initialCtx) (nthPatFind p1) p2) 196 | 197 | -- | Embeds a term in an 'Embed', or an 'Embed' under some number of 'Unbound.Generics.LocallyNameless.Shift.Shift' constructors. 198 | embed :: IsEmbed e => Embedded e -> e 199 | embed e = view (from embedded) e 200 | 201 | -- | @'unembed' p@ extracts the term embedded in the pattern @p@. 202 | unembed :: IsEmbed e => e -> Embedded e 203 | unembed e = view embedded e 204 | 205 | -- | Constructor for recursive abstractions. 206 | trec :: Alpha p => p -> TRec p 207 | trec p = TRec (bind (rec p) ()) 208 | 209 | -- | Destructor for recursive abstractions which picks globally fresh 210 | -- names for the binders. 211 | untrec :: (Alpha p, Fresh m) => TRec p -> m p 212 | untrec (TRec b) = do 213 | (p, ()) <- unbind b 214 | return (unrec p) 215 | 216 | -- | Destructor for recursive abstractions which picks /locally/ fresh 217 | -- names for binders (see 'LFresh'). 218 | luntrec :: (Alpha p, LFresh m) => TRec p -> m p 219 | luntrec (TRec b) = 220 | lunbind b $ \(p, ()) -> return (unrec p) 221 | 222 | -- | Constructor for ignoring a term for the purposes of alpha-equality and substs 223 | ignore :: t -> Ignore t 224 | ignore t = I t 225 | 226 | -- | Destructor for ignored terms 227 | unignore :: Ignore t -> t 228 | unignore (I t) = t 229 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Rebind.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | -- | 3 | -- Module : Unbound.Generics.LocallyNameless.Rebind 4 | -- Copyright : (c) 2014, Aleksey Kliger 5 | -- License : BSD3 (See LICENSE) 6 | -- Maintainer : Aleksey Kliger 7 | -- Stability : experimental 8 | -- 9 | -- The pattern @'Rebind' p1 p2@ binds the names in @p1@ and @p2@ just as @(p1, p2)@ would, 10 | -- however it additionally also brings the names of @p1@ into scope in @p2@. 11 | -- 12 | {-# LANGUAGE DeriveGeneric #-} 13 | module Unbound.Generics.LocallyNameless.Rebind where 14 | 15 | import Control.Applicative ((<*>), (<$>)) 16 | import Control.DeepSeq (NFData(..)) 17 | import Data.Monoid ((<>), All(..)) 18 | import GHC.Generics 19 | 20 | import Unbound.Generics.LocallyNameless.Alpha 21 | 22 | 23 | -- | @'Rebind' p1 p2@ is a pattern that binds the names of @p1@ and @p2@, and additionally 24 | -- brings the names of @p1@ into scope over @p2@. 25 | -- 26 | -- This may be used, for example, to faithfully represent Scheme's @let*@ binding form, defined by: 27 | -- 28 | -- > (let* () body) ≙ body 29 | -- > (let* ([v1, e1] binds ...) body) ≙ (let ([v1, e1]) (let* (binds ...) body)) 30 | -- 31 | -- using the following AST: 32 | -- 33 | -- @ 34 | -- type Var = Name Expr 35 | -- data Lets = EmptyLs 36 | -- | ConsLs (Rebind (Var, Embed Expr) Lets) 37 | -- data Expr = ... 38 | -- | LetStar (Bind Lets Expr) 39 | -- | ... 40 | -- @ 41 | data Rebind p1 p2 = Rebnd p1 p2 42 | deriving (Generic, Eq) 43 | 44 | instance (NFData p1, NFData p2) => NFData (Rebind p1 p2) where 45 | rnf (Rebnd p1 p2) = rnf p1 `seq` rnf p2 `seq` () 46 | 47 | instance (Show p1, Show p2) => Show (Rebind p1 p2) where 48 | showsPrec paren (Rebnd p1 p2) = 49 | showParen (paren > 0) (showString "<<" 50 | . showsPrec paren p1 51 | . showString ">> " 52 | . showsPrec 0 p2) 53 | 54 | instance (Alpha p1, Alpha p2) => Alpha (Rebind p1 p2) where 55 | isTerm _ = All False 56 | 57 | isPat (Rebnd p1 p2) = isPat p1 <> isPat p2 58 | 59 | swaps' ctx perm (Rebnd p1 p2) = 60 | Rebnd (swaps' ctx perm p1) (swaps' (incrLevelCtx ctx) perm p2) 61 | 62 | freshen' ctx (Rebnd p1 p2) = 63 | if isTermCtx ctx 64 | then error "freshen' on Rebind in Term mode" 65 | else do 66 | (p1', perm1) <- freshen' ctx p1 67 | (p2', perm2) <- freshen' (incrLevelCtx ctx) (swaps' (incrLevelCtx ctx) perm1 p2) 68 | return (Rebnd p1' p2', perm1 <> perm2) 69 | 70 | lfreshen' ctx (Rebnd p q) cont = 71 | if isTermCtx ctx 72 | then error "lfreshen' on Rebind in Term mode" 73 | else 74 | lfreshen' ctx p $ \ p' pm1 -> 75 | lfreshen' (incrLevelCtx ctx) (swaps' (incrLevelCtx ctx) pm1 q) $ \ q' pm2 -> 76 | cont (Rebnd p' q') (pm1 <> pm2) 77 | 78 | 79 | aeq' ctx (Rebnd p1 p2) (Rebnd q1 q2) = 80 | -- XXX TODO: Unbound had (aeq' ctx p2 q2) here. But that doesn't seem right. 81 | aeq' ctx p1 q1 && aeq' (incrLevelCtx ctx) p2 q2 82 | 83 | fvAny' ctx afa (Rebnd p1 p2) = Rebnd <$> fvAny' ctx afa p1 84 | <*> fvAny' (incrLevelCtx ctx) afa p2 85 | 86 | open ctx b (Rebnd p1 p2) = Rebnd (open ctx b p1) (open (incrLevelCtx ctx) b p2) 87 | close ctx b (Rebnd p1 p2) = Rebnd (close ctx b p1) (close (incrLevelCtx ctx) b p2) 88 | 89 | acompare' ctx (Rebnd p1 p2) (Rebnd q1 q2) = 90 | acompare' ctx p1 q1 <> acompare' (incrLevelCtx ctx) p2 q2 91 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Rec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | -- | 3 | -- Module : Unbound.Generics.LocallyNameless.Rec 4 | -- Copyright : (c) 2014, Aleksey Kliger 5 | -- License : BSD3 (See LICENSE) 6 | -- Maintainer : Aleksey Kliger 7 | -- Stability : experimental 8 | -- 9 | -- The pattern @'Rec' p@ binds the names in @p@ like @p@ itself would, 10 | -- but additionally, the names in @p@ are scope over @p@. 11 | -- 12 | -- The term @'TRec' p@ is shorthand for @'Bind' (Rec p) ()@ 13 | {-# LANGUAGE DeriveGeneric #-} 14 | module Unbound.Generics.LocallyNameless.Rec 15 | ( 16 | Rec (Rec) 17 | , rec 18 | , unrec 19 | , TRec (..) 20 | ) where 21 | 22 | import Control.DeepSeq (NFData(..)) 23 | import GHC.Generics (Generic) 24 | 25 | import Data.Monoid(All(..)) 26 | 27 | import Unbound.Generics.LocallyNameless.Alpha 28 | import Unbound.Generics.LocallyNameless.Bind 29 | 30 | -- | If @p@ is a pattern type, then @Rec p@ is also a pattern type, 31 | -- which is /recursive/ in the sense that @p@ may bind names in terms 32 | -- embedded within itself. Useful for encoding e.g. lectrec and 33 | -- Agda's dot notation. 34 | newtype Rec p = Rec p 35 | deriving (Generic, Eq) 36 | 37 | instance NFData p => NFData (Rec p) where 38 | rnf (Rec p) = rnf p `seq` () 39 | 40 | instance Show a => Show (Rec a) where 41 | showsPrec _ (Rec a) = showString "[" . showsPrec 0 a . showString "]" 42 | 43 | -- | @TRec@ is a standalone variant of 'Rec': the only difference is 44 | -- that whereas @'Rec' p@ is a pattern type, @TRec p@ 45 | -- is a /term type/. It is isomorphic to @'Bind' ('Rec' p) ()@. 46 | -- 47 | -- Note that @TRec@ corresponds to Pottier's /abstraction/ construct 48 | -- from alpha-Caml. In this context, @'Embed' t@ corresponds to 49 | -- alpha-Caml's @inner t@, and @'Shift' ('Embed' t)@ corresponds to 50 | -- alpha-Caml's @outer t@. 51 | newtype TRec p = TRec (Bind (Rec p) ()) 52 | deriving (Generic) 53 | 54 | instance Show a => Show (TRec a) where 55 | showsPrec _ (TRec (B (Rec p) ())) = showString "[" . showsPrec 0 p . showString "]" 56 | 57 | 58 | instance Alpha p => Alpha (Rec p) where 59 | isTerm _ = All False 60 | isPat (Rec p) = isPat p 61 | 62 | nthPatFind (Rec p) = nthPatFind p 63 | namePatFind (Rec p) = namePatFind p 64 | 65 | open ctx b (Rec p) = Rec (open (incrLevelCtx ctx) b p) 66 | close ctx b (Rec p) = Rec (close (incrLevelCtx ctx) b p) 67 | 68 | instance Alpha p => Alpha (TRec p) 69 | 70 | -- | Constructor for recursive patterns. 71 | rec :: Alpha p => p -> Rec p 72 | rec p = Rec (close (patternCtx initialCtx) (namePatFind p) p) 73 | 74 | -- | Destructor for recursive patterns. 75 | unrec :: Alpha p => Rec p -> p 76 | unrec r@(Rec p) = open (patternCtx initialCtx) (nthPatFind r) p 77 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Shift.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | -- | 3 | -- Module : Unbound.Generics.LocallyNameless.Shift 4 | -- Copyright : (c) 2015, Aleksey Kliger 5 | -- License : BSD3 (See LICENSE) 6 | -- Maintainer : Aleksey Kliger 7 | -- Stability : experimental 8 | -- 9 | -- The pattern @'Shift' e@ shifts the scope of the embedded term in @e@ one level outwards. 10 | -- 11 | {-# LANGUAGE TypeFamilies #-} 12 | module Unbound.Generics.LocallyNameless.Shift where 13 | 14 | import Control.Applicative 15 | import Control.DeepSeq (NFData(..)) 16 | import Data.Monoid (Monoid(..), All(..)) 17 | 18 | import Unbound.Generics.LocallyNameless.Alpha (Alpha(..), 19 | decrLevelCtx, isTermCtx, 20 | isZeroLevelCtx, 21 | inconsistentDisjointSet) 22 | import Unbound.Generics.LocallyNameless.Embed (IsEmbed(..)) 23 | 24 | import Unbound.Generics.LocallyNameless.Internal.Iso (iso) 25 | 26 | -- | The type @Shift e@ is an embedding pattern that shifts the scope of the 27 | -- free variables of the embedded term @'Embedded' e@ up by one level. 28 | newtype Shift e = Shift e 29 | 30 | instance Functor Shift where 31 | fmap f (Shift e) = Shift (f e) 32 | 33 | instance IsEmbed e => IsEmbed (Shift e) where 34 | type Embedded (Shift e) = Embedded e 35 | embedded = iso (\(Shift e) -> e) Shift . embedded 36 | 37 | instance NFData e => NFData (Shift e) where 38 | rnf (Shift e) = rnf e `seq` () 39 | 40 | instance Show e => Show (Shift e) where 41 | showsPrec _ (Shift e) = showString "{" . showsPrec 0 e . showString "}" 42 | 43 | instance Alpha e => Alpha (Shift e) where 44 | isPat (Shift e) = if (isEmbed e) then mempty else inconsistentDisjointSet 45 | 46 | isTerm _ = All False 47 | 48 | isEmbed (Shift e) = isEmbed e 49 | 50 | swaps' ctx perm (Shift e) = Shift (swaps' (decrLevelCtx ctx) perm e) 51 | 52 | freshen' ctx p = 53 | if isTermCtx ctx 54 | then error "LocallyNameless.freshen' called on a term" 55 | else return (p, mempty) 56 | 57 | lfreshen' ctx p kont = 58 | if isTermCtx ctx 59 | then error "LocallyNameless.lfreshen' called on a term" 60 | else kont p mempty 61 | 62 | aeq' ctx (Shift e1) (Shift e2) = aeq' ctx e1 e2 63 | 64 | fvAny' ctx afa (Shift e) = Shift <$> fvAny' ctx afa e 65 | 66 | close ctx b se@(Shift e) = 67 | if isTermCtx ctx 68 | then error "LocallyNameless.close on Shift" 69 | else if isZeroLevelCtx ctx 70 | then 71 | -- consider type A = Rec (Name t, Shift (Embed e), (Embed e)) 72 | -- (ie the 2nd element of the tuple is not allowed to refer to itself, 73 | -- but the third is) 74 | -- if we have (x, e1, e2) and we apply 'rec' to it, 75 | -- we must close the tuple with respect to itself. 76 | -- in that case, the ctxLevel is 0 and so none of the names in 77 | -- e1 need be bound. 78 | -- on the other hand once we go to 79 | -- Bind P (Bind A B) for some P and B, 80 | -- the free vars of e1 in A are bound by P. 81 | se 82 | else Shift (close (decrLevelCtx ctx) b e) 83 | 84 | open ctx b se@(Shift e) = 85 | if isTermCtx ctx 86 | then error "LocallyNameless.open on Shift" 87 | else if isZeroLevelCtx ctx 88 | then se 89 | else Shift (open (decrLevelCtx ctx) b e) 90 | 91 | nthPatFind (Shift e) = nthPatFind e 92 | namePatFind (Shift e) = namePatFind e 93 | 94 | 95 | acompare' ctx (Shift x) (Shift y) = acompare' ctx x y 96 | 97 | 98 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Subst.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Unbound.Generics.LocallyNameless.Subst 3 | -- Copyright : (c) 2014, Aleksey Kliger 4 | -- License : BSD3 (See LICENSE) 5 | -- Maintainer : Aleksey Kliger 6 | -- Stability : experimental 7 | -- 8 | -- A typeclass for types that may participate in capture-avoiding substitution 9 | -- 10 | -- The minimal definition is empty, provided your type is an instance of 'GHC.Generics.Generic' 11 | -- 12 | -- @ 13 | -- type Var = Name Factor 14 | -- data Expr = SumOf [Summand] 15 | -- deriving (Show, Generic) 16 | -- data Summand = ProductOf [Factor] 17 | -- deriving (Show, Generic) 18 | -- instance Subst Var Expr 19 | -- instance Subst Var Summand 20 | -- @ 21 | -- 22 | -- The default instance just propagates the substitution into the constituent factors. 23 | -- 24 | -- If you identify the variable occurrences by implementing the 'isvar' function, the derived 'subst' function 25 | -- will be able to substitute a factor for a variable. 26 | -- 27 | -- @ 28 | -- data Factor = V Var 29 | -- | C Int 30 | -- | Subexpr Expr 31 | -- deriving (Show, Generic) 32 | -- instance Subst Var Factor where 33 | -- isvar (V v) = Just (SubstName v) 34 | -- isvar _ = Nothing 35 | -- @ 36 | -- 37 | {-# LANGUAGE DefaultSignatures 38 | , FlexibleContexts 39 | , FlexibleInstances 40 | , GADTs 41 | , MultiParamTypeClasses 42 | , ScopedTypeVariables 43 | , TypeOperators 44 | #-} 45 | module Unbound.Generics.LocallyNameless.Subst ( 46 | SubstName(..) 47 | , SubstCoerce(..) 48 | , Subst(..) 49 | , substBind 50 | , instantiate 51 | ) where 52 | 53 | import GHC.Generics 54 | 55 | import Data.List (find) 56 | import Data.List.NonEmpty (NonEmpty) 57 | 58 | import Unbound.Generics.LocallyNameless.Name 59 | import Unbound.Generics.LocallyNameless.Alpha 60 | import Unbound.Generics.LocallyNameless.Embed 61 | import Unbound.Generics.LocallyNameless.Shift 62 | import Unbound.Generics.LocallyNameless.Ignore 63 | import Unbound.Generics.LocallyNameless.Bind 64 | import Unbound.Generics.LocallyNameless.Rebind 65 | import Unbound.Generics.LocallyNameless.Rec 66 | import Unbound.Generics.LocallyNameless.Internal.GSubst 67 | 68 | -- | See 'isVar' 69 | data SubstName a b where 70 | SubstName :: (a ~ b) => Name a -> SubstName a b 71 | 72 | -- | See 'isCoerceVar' 73 | data SubstCoerce a b where 74 | SubstCoerce :: Name b -> (b -> Maybe a) -> SubstCoerce a b 75 | 76 | -- | Immediately substitute for the bound variables of a pattern 77 | -- in a binder, without first naming the variables. 78 | -- NOTE: this operation does not check that the number of terms passed in 79 | -- match the number of variables in the pattern. (Or that they are of appropriate type.) 80 | instantiate :: (Alpha a, Alpha b, Alpha p , Subst a b) => Bind p b -> [a] -> b 81 | instantiate bnd u = instantiate_ bnd u 82 | 83 | -- | A version of 'instantiate' with a more general type 84 | instantiate_ :: Subst a b => Bind p b -> [a] -> b 85 | instantiate_ (B _p t) u = substBvs initialCtx u t 86 | 87 | 88 | -- | Instances of @'Subst' b a@ are terms of type @a@ that may contain 89 | -- variables of type @b@ that may participate in capture-avoiding 90 | -- substitution. 91 | class Subst b a where 92 | -- | This is the only method that must be implemented 93 | isvar :: a -> Maybe (SubstName a b) 94 | isvar _ = Nothing 95 | 96 | -- | This is an alternative version to 'isvar', useable in the case 97 | -- that the substituted argument doesn't have *exactly* the same type 98 | -- as the term it should be substituted into. 99 | -- The default implementation always returns 'Nothing'. 100 | isCoerceVar :: a -> Maybe (SubstCoerce a b) 101 | isCoerceVar _ = Nothing 102 | 103 | -- | @'subst' nm e tm@ substitutes @e@ for @nm@ in @tm@. It has 104 | -- a default generic implementation in terms of @isvar@ 105 | subst :: Name b -> b -> a -> a 106 | default subst :: (Generic a, GSubst b (Rep a)) => Name b -> b -> a -> a 107 | subst n u x = 108 | if (isFreeName n) 109 | then case (isvar x :: Maybe (SubstName a b)) of 110 | Just (SubstName m) | m == n -> u 111 | _ -> case (isCoerceVar x :: Maybe (SubstCoerce a b)) of 112 | Just (SubstCoerce m f) | m == n -> maybe x id (f u) 113 | _ -> to $ gsubst n u (from x) 114 | else error $ "Cannot substitute for bound variable " ++ show n 115 | 116 | substs :: [(Name b, b)] -> a -> a 117 | default substs :: (Generic a, GSubst b (Rep a)) => [(Name b, b)] -> a -> a 118 | substs ss x 119 | | all (isFreeName . fst) ss = 120 | case (isvar x :: Maybe (SubstName a b)) of 121 | Just (SubstName m) | Just (_, u) <- find ((==m) . fst) ss -> u 122 | _ -> case isCoerceVar x :: Maybe (SubstCoerce a b) of 123 | Just (SubstCoerce m f) | Just (_, u) <- find ((==m) . fst) ss -> maybe x id (f u) 124 | _ -> to $ gsubsts ss (from x) 125 | | otherwise = 126 | error $ "Cannot substitute for bound variable in: " ++ show (map fst ss) 127 | 128 | -- Bound variable substitution (replace a single pattern variable with a list of terms) 129 | -- Similar to open, but replaces with b's instead of with names 130 | -- Does not check whether enough b's are provided: will ignore extra if there are too many 131 | -- and skip the substitution if there are too few. 132 | substBvs :: AlphaCtx -> [b] -> a -> a 133 | default substBvs :: (Generic a, GSubst b (Rep a)) => AlphaCtx -> [b] -> a -> a 134 | substBvs ctx bs x = 135 | case (isvar x :: Maybe (SubstName a b)) of 136 | Just (SubstName (Bn j k)) | ctxLevel ctx == j, fromInteger k < length bs -> bs !! fromInteger k 137 | _ -> to $ gsubstBvs ctx bs (from x) 138 | 139 | instance Subst b c => GSubst b (K1 i c) where 140 | gsubst nm val = K1 . subst nm val . unK1 141 | gsubsts ss = K1 . substs ss . unK1 142 | gsubstBvs ctx b = K1 . substBvs ctx b . unK1 143 | 144 | -- these have a Generic instance, but 145 | -- it's self-refential (ie: Rep Int = D1 (C1 (S1 (Rec0 Int)))) 146 | -- so our structural GSubst instances get stuck in an infinite loop. 147 | instance Subst b Int where subst _ _ = id ; substs _ = id ; substBvs _ _ = id 148 | instance Subst b Bool where subst _ _ = id ; substs _ = id ; substBvs _ _ = id 149 | instance Subst b () where subst _ _ = id ; substs _ = id ; substBvs _ _ = id 150 | instance Subst b Char where subst _ _ = id ; substs _ = id ; substBvs _ _ = id 151 | instance Subst b Float where subst _ _ = id ; substs _ = id ; substBvs _ _ = id 152 | instance Subst b Double where subst _ _ = id ; substs _ = id ; substBvs _ _ = id 153 | 154 | -- huh, apparently there's no instance Generic Integer. 155 | instance Subst b Integer where subst _ _ = id ; substs _ = id ; substBvs _ _ = id 156 | 157 | instance (Subst c a, Subst c b) => Subst c (a,b) 158 | instance (Subst c a, Subst c b, Subst c d) => Subst c (a,b,d) 159 | instance (Subst c a, Subst c b, Subst c d, Subst c e) => Subst c (a,b,d,e) 160 | instance (Subst c a, Subst c b, Subst c d, Subst c e, Subst c f) => 161 | Subst c (a,b,d,e,f) 162 | instance (Subst c a) => Subst c [a] 163 | instance (Subst c a) => Subst c (NonEmpty a) 164 | instance (Subst c a) => Subst c (Maybe a) 165 | instance (Subst c a, Subst c b) => Subst c (Either a b) 166 | 167 | instance Subst b (Name a) where subst _ _ = id ; substs _ = id ; substBvs _ _ = id 168 | instance Subst b AnyName where subst _ _ = id ; substs _ = id ; substBvs _ _ = id 169 | 170 | instance (Subst c a) => Subst c (Embed a) where 171 | substBvs c us (Embed x) 172 | | isTermCtx c = Embed (substBvs (termCtx c) us x) 173 | | otherwise = error "Internal error: substBvs on Embed" 174 | 175 | instance (Subst c e) => Subst c (Shift e) where 176 | subst x b (Shift e) = Shift (subst x b e) 177 | substs ss (Shift e) = Shift (substs ss e) 178 | substBvs c b (Shift e) = Shift (substBvs (decrLevelCtx c) b e) 179 | 180 | instance (Subst c b, Subst c a, Alpha a, Alpha b) => Subst c (Bind a b) where 181 | substBvs c b (B p t) = B (substBvs (patternCtx c) b p) (substBvs (incrLevelCtx c) b t) 182 | 183 | instance (Subst c p1, Subst c p2) => Subst c (Rebind p1 p2) where 184 | substBvs c us (Rebnd p q) = Rebnd (substBvs c us p) (substBvs (incrLevelCtx c) us q) 185 | 186 | instance (Subst c p) => Subst c (Rec p) where 187 | substBvs c us (Rec p) = Rec (substBvs (incrLevelCtx c) us p) 188 | 189 | instance (Alpha p, Subst c p) => Subst c (TRec p) where 190 | substBvs c us (TRec p) = TRec (substBvs (patternCtx (incrLevelCtx c)) us p) 191 | 192 | instance Subst a (Ignore b) where 193 | subst _ _ = id 194 | substs _ = id 195 | substBvs _ _ = id 196 | 197 | -- | Specialized version of capture-avoiding substitution for that operates on a @'Bind' ('Name' a) t@ term to @'unbind'@ 198 | -- the bound name @Name a@ and immediately subsitute a new term for its occurrences. 199 | -- 200 | -- This is a specialization of @'instantiate' :: Bind pat term -> [a] -> term@ where the @'Bind' pat term@ has a pattern that is just 201 | -- a single @'Name' a@ and there is a single substitution term of type @a@. Unlike 'instantiate', this function cannot fail at runtime. 202 | substBind :: Subst a t => Bind (Name a) t -> a -> t 203 | substBind b u = instantiate_ b [u] 204 | 205 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/TH.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | -- | 3 | -- Module : Unbound.Generics.LocallyNameless.TH 4 | -- Copyright : (c) 2015, Aleksey Kliger 5 | -- License : BSD3 (See LICENSE) 6 | -- Maintainer : Aleksey Kliger 7 | -- Stability : experimental 8 | -- 9 | -- Template Haskell methods to construct instances of 'Alpha' for 10 | -- datatypes that don't contain any names and don't participate in 11 | -- 'Alpha' operations in any non-trivial way. 12 | {-# LANGUAGE TemplateHaskell #-} 13 | module Unbound.Generics.LocallyNameless.TH (makeClosedAlpha) where 14 | import Language.Haskell.TH 15 | 16 | import Control.Applicative (Applicative(..)) 17 | import Data.Monoid (Monoid(..)) 18 | import Unbound.Generics.LocallyNameless.Alpha (Alpha(..)) 19 | 20 | -- | Make a trivial @instance 'Alpha' T@ for a type @T@ that does not 21 | -- contain any bound or free variable names 22 | -- (or any in general any values that are themselves non-trivial 23 | -- instances of 'Alpha'). Use this to write 'Alpha' instances for 24 | -- types that you don't want to traverse via their @GHC.Generics.Rep@ 25 | -- representation just to find out that there aren't any names. 26 | -- 27 | -- 28 | -- @ 29 | -- newtype T = T Int deriving (Eq, Ord, Show) 30 | -- $(makeClosedAlpha T) 31 | -- -- constructs 32 | -- -- instance Alpha T where 33 | -- -- aeq' _ = (==) 34 | -- -- acompare' _ = compare 35 | -- -- fvAny' _ _ = pure 36 | -- -- close _ _ = id 37 | -- -- open _ _ = id 38 | -- -- isPat _ = mempty 39 | -- -- isTerm _ = mempty 40 | -- -- nthPatFind _ = mempty 41 | -- -- namePatFind _ _ = mempty 42 | -- -- swaps' _ _ = id 43 | -- -- freshen' _ i = return (i, mempty) 44 | -- -- lfreshen' _ i cont = cont i mempty 45 | -- @ 46 | -- 47 | makeClosedAlpha :: Name -> DecsQ 48 | makeClosedAlpha tyName = do 49 | 50 | let valueD vName e = valD (varP vName) (normalB e) [] 51 | -- methods :: [Q Dec] 52 | methods = 53 | [ 54 | valueD (mkName "aeq'") [e| \_ctx -> (==) |] 55 | , valueD (mkName "fvAny'") [e| \_ctx _nfn -> pure |] 56 | , valueD 'close [e| \_ctx _b -> id |] 57 | , valueD 'open [e| \_ctx _b -> id |] 58 | , valueD 'isPat [e| \_ -> mempty |] 59 | , valueD 'isTerm [e| \_ -> mempty |] 60 | , valueD 'nthPatFind [e| \_ -> mempty |] 61 | , valueD 'namePatFind [e| \_ -> mempty |] 62 | , valueD (mkName "swaps'") [e| \_ctx _p -> id |] 63 | , valueD (mkName "freshen'") [e| \_ctx i -> return (i, mempty) |] 64 | , valueD (mkName "lfreshen'") [e| \_ctx i cont -> cont i mempty |] 65 | , valueD (mkName "acompare'") [e| \_ctx -> compare |] 66 | ] 67 | d <- instanceD (cxt []) (appT [t|Alpha|] (conT tyName)) methods 68 | return [d] 69 | 70 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Unbound.Generics.LocallyNameless.Types 3 | -- Copyright: (c) 2014, Aleksey Kliger 4 | -- License: BSD3 (See LICENSE) 5 | -- 6 | 7 | -------------------------------------------------------------------------------- /src/Unbound/Generics/LocallyNameless/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | -- | 3 | -- Module : Unbound.Generics.LocallyNameless.Unsafe 4 | -- Copyright : (c) 2014, Aleksey Kliger 5 | -- License : BSD3 (See LICENSE) 6 | -- Maintainer : Aleksey Kliger 7 | -- Stability : experimental 8 | -- 9 | -- Dangerous operations that may disturb the invariants of 10 | -- "Unbind.Generics.LocallyNameless" or of your AST. 11 | {-# LANGUAGE DeriveGeneric #-} 12 | module Unbound.Generics.LocallyNameless.Unsafe 13 | ( 14 | unsafeUnbind 15 | ) where 16 | 17 | import Unbound.Generics.LocallyNameless.Alpha 18 | import Unbound.Generics.LocallyNameless.Bind 19 | 20 | -- | A destructor for binders that does /not/ guarantee fresh 21 | -- names for the binders. 22 | unsafeUnbind :: (Alpha p, Alpha t) => Bind p t -> (p, t) 23 | unsafeUnbind (B p t) = (p, open initialCtx (nthPatFind p) t) 24 | 25 | -------------------------------------------------------------------------------- /src/Unbound/Generics/PermM.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------- 2 | -- | 3 | -- Module : Unbound.Generics.PermM 4 | -- Copyright : (c) 2011, Stephanie Weirich 5 | -- License : BSD-like (see PermM.hs) 6 | -- Maintainer : Aleksey Kliger 7 | -- Portability : portable 8 | -- 9 | -- A slow, but hopefully correct implementation of permutations. 10 | -- 11 | ---------------------------------------------------------------------- 12 | {- 13 | Copyright (c)2011, Stephanie Weirich 14 | 15 | All rights reserved. 16 | 17 | Redistribution and use in source and binary forms, with or without 18 | modification, are permitted provided that the following conditions are met: 19 | 20 | * Redistributions of source code must retain the above copyright 21 | notice, this list of conditions and the following disclaimer. 22 | 23 | * Redistributions in binary form must reproduce the above 24 | copyright notice, this list of conditions and the following 25 | disclaimer in the documentation and/or other materials provided 26 | with the distribution. 27 | 28 | * Neither the name of Stephanie Weirich nor the names of other 29 | contributors may be used to endorse or promote products derived 30 | from this software without specific prior written permission. 31 | 32 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 33 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 34 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 35 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 36 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 37 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 38 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 39 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 40 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 41 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 42 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 43 | -} 44 | {-# LANGUAGE PatternGuards #-} 45 | module Unbound.Generics.PermM ( 46 | Perm(..), permValid, single, compose, apply, support, isid, join, empty, restrict, mkPerm 47 | ) where 48 | 49 | import Prelude (Eq(..), Show(..), (.), ($), Monad(return), Ord(..), Maybe(..), otherwise, (&&), Bool(..), id, uncurry, Functor(..)) 50 | import Data.Monoid hiding ((<>)) 51 | import Data.List 52 | import Data.Map (Map) 53 | import Data.Semigroup as Sem 54 | import qualified Data.Map as M 55 | import qualified Data.Set as S 56 | import Control.Arrow ((&&&)) 57 | import Control.Monad ((>=>)) 58 | 59 | -- | A /permutation/ is a bijective function from names to names 60 | -- which is the identity on all but a finite set of names. They 61 | -- form the basis for nominal approaches to binding, but can 62 | -- also be useful in general. 63 | newtype Perm a = Perm (Map a a) 64 | 65 | -- | @'permValid' p@ returns @True@ iff the perumation is /valid/: if 66 | -- each value in the range of the permutation is also a key. 67 | permValid :: Ord a => Perm a -> Bool 68 | permValid (Perm p) = all (\(_,v) -> M.member v p) (M.assocs p) 69 | -- a Map sends every key uniquely to a value by construction. So if 70 | -- every value is also a key, the sizes of the domain and range must 71 | -- be equal and hence the mapping is a bijection. 72 | 73 | instance Ord a => Eq (Perm a) where 74 | (Perm p1) == (Perm p2) = 75 | all (\x -> M.findWithDefault x x p1 == M.findWithDefault x x p2) (M.keys p1) && 76 | all (\x -> M.findWithDefault x x p1 == M.findWithDefault x x p2) (M.keys p2) 77 | 78 | instance Show a => Show (Perm a) where 79 | show (Perm p) = show p 80 | 81 | -- | Apply a permutation to an element of the domain. 82 | apply :: Ord a => Perm a -> a -> a 83 | apply (Perm p) x = M.findWithDefault x x p 84 | 85 | -- | Create a permutation which swaps two elements. 86 | single :: Ord a => a -> a -> Perm a 87 | single x y = if x == y then Perm M.empty else 88 | Perm (M.insert x y (M.insert y x M.empty)) 89 | 90 | -- | The empty (identity) permutation. 91 | empty :: Perm a 92 | empty = Perm M.empty 93 | 94 | -- | Compose two permutations. The right-hand permutation will be 95 | -- applied first. 96 | compose :: Ord a => Perm a -> Perm a -> Perm a 97 | compose (Perm b) (Perm a) = 98 | Perm (M.fromList ([ (x,M.findWithDefault y y b) | (x,y) <- M.toList a] 99 | ++ [ (x, M.findWithDefault x x b) | x <- M.keys b, M.notMember x a])) 100 | 101 | -- | Permutations form a semigroup under 'compose'. 102 | -- @since 0.3.2 103 | instance Ord a => Sem.Semigroup (Perm a) where 104 | (<>) = compose 105 | 106 | -- | Permutations form a monoid with identity 'empty'. 107 | instance Ord a => Monoid (Perm a) where 108 | mempty = empty 109 | mappend = (<>) 110 | 111 | -- | Is this the identity permutation? 112 | isid :: Ord a => Perm a -> Bool 113 | isid (Perm p) = 114 | M.foldrWithKey (\ a b r -> r && a == b) True p 115 | 116 | -- | /Join/ two permutations by taking the union of their relation 117 | -- graphs. Fail if they are inconsistent, i.e. map the same element 118 | -- to two different elements. 119 | join :: Ord a => Perm a -> Perm a -> Maybe (Perm a) 120 | join (Perm p1) (Perm p2) = 121 | let overlap = M.intersectionWith (==) p1 p2 in 122 | if M.foldr (&&) True overlap then 123 | Just (Perm (M.union p1 p2)) 124 | else Nothing 125 | 126 | -- | The /support/ of a permutation is the set of elements which are 127 | -- not fixed. 128 | support :: Ord a => Perm a -> [a] 129 | support (Perm p) = [ x | x <- M.keys p, M.findWithDefault x x p /= x] 130 | 131 | -- | Restrict a permutation to a certain domain. 132 | restrict :: Ord a => Perm a -> [a] -> Perm a 133 | restrict (Perm p) l = Perm (foldl' (\p' k -> M.delete k p') p l) 134 | 135 | -- | A partial permutation consists of two maps, one in each direction 136 | -- (inputs -> outputs and outputs -> inputs). 137 | data PartialPerm a = PP (M.Map a a) (M.Map a a) 138 | deriving Show 139 | 140 | emptyPP :: PartialPerm a 141 | emptyPP = PP M.empty M.empty 142 | 143 | extendPP :: Ord a => a -> a -> PartialPerm a -> Maybe (PartialPerm a) 144 | extendPP x y pp@(PP mfwd mrev) 145 | | Just y' <- M.lookup x mfwd = if y == y' then Just pp 146 | else Nothing 147 | | Just x' <- M.lookup y mrev = if x == x' then Just pp 148 | else Nothing 149 | | otherwise = Just $ PP (M.insert x y mfwd) (M.insert y x mrev) 150 | 151 | -- | Convert a partial permutation into a full permutation by closing 152 | -- off any remaining open chains into a cycles. 153 | ppToPerm :: Ord a => PartialPerm a -> Perm a 154 | ppToPerm (PP mfwd mrev) = Perm $ foldr (uncurry M.insert) mfwd 155 | (map (findEnd &&& id) chainStarts) 156 | -- beginnings of open chains are elements which map to 157 | -- something in the forward direction but have no ancestor. 158 | where chainStarts = S.toList (M.keysSet mfwd `S.difference` M.keysSet mrev) 159 | findEnd x = case M.lookup x mfwd of 160 | Nothing -> x 161 | Just x' -> findEnd x' 162 | 163 | -- | @mkPerm l1 l2@ creates a permutation that sends @l1@ to @l2@. 164 | -- Fail if there is no such permutation, either because the lists 165 | -- have different lengths or because they are inconsistent (which 166 | -- can only happen if @l1@ or @l2@ have repeated elements). 167 | mkPerm :: Ord a => [a] -> [a] -> Maybe (Perm a) 168 | mkPerm xs ys 169 | | length xs /= length ys = Nothing 170 | | otherwise = 171 | fmap ppToPerm . ($emptyPP) . foldr (>=>) return $ zipWith extendPP xs ys 172 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-18.28 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/AlphaAssertions.hs: -------------------------------------------------------------------------------- 1 | module AlphaAssertions where 2 | 3 | import Test.Tasty.HUnit 4 | 5 | import Unbound.Generics.LocallyNameless 6 | 7 | assertAeq :: (Alpha t, Show t) => t -> t -> Assertion 8 | assertAeq x y = assertBool (show x ++ " not alpha equivalent to " ++ show y) (x `aeq` y) 9 | 10 | assertAcompare :: (Alpha t, Show t) => t -> t -> Ordering -> Assertion 11 | assertAcompare x y o = 12 | let o' = acompare x y 13 | in assertBool (show x ++ " not alpha-" ++ show o' ++ " to " ++ show y ++ ", but alpha-" ++ show o) (o' == o) 14 | -------------------------------------------------------------------------------- /test/AlphaProperties.hs: -------------------------------------------------------------------------------- 1 | module AlphaProperties where 2 | 3 | import Unbound.Generics.LocallyNameless (fv, aeq, Name, Alpha) 4 | 5 | import Test.Tasty.QuickCheck (counterexample, Property, testProperty) 6 | 7 | import Data.Typeable (Typeable) 8 | 9 | import Data.Monoid (Any(..)) 10 | import Unbound.Generics.LocallyNameless.Internal.Fold (foldMapOf, toListOf) 11 | 12 | 13 | 14 | isFreeIn :: (Typeable a, Alpha b) => Name a -> b -> Bool 15 | isFreeIn = elementOf fv 16 | where 17 | elementOf l = anyOf l . (==) 18 | anyOf l f = getAny . foldMapOf l (Any . f) 19 | 20 | notFreeIn :: (Typeable a, Alpha b) => Name a -> b -> Bool 21 | notFreeIn v = not . isFreeIn v 22 | 23 | (=~=) :: (Alpha a, Show a) => a -> a -> Property 24 | x =~= y = counterexample (show x ++ " not alpha equivalent to " ++ show y) (x `aeq` y) 25 | 26 | (/~@) :: (Typeable a, Alpha b, Show b) => Name a -> b -> Property 27 | v /~@ t = counterexample (show v ++ " is free in " ++ show t) (v `notFreeIn` t) -------------------------------------------------------------------------------- /test/Calc.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Calc 3 | -- Copyright : (c) 2014, Aleksey Kliger 4 | -- License : BSD3 (See LICENSE) 5 | -- Maintainer : Aleksey Kliger 6 | -- Stability : experimental 7 | -- 8 | {-# LANGUAGE CPP, DeriveGeneric, DeriveDataTypeable #-} 9 | module Calc where 10 | 11 | #if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,13,0) 12 | import Control.Monad.Fail (MonadFail) 13 | #endif 14 | import Control.Arrow (second) 15 | import Data.Typeable (Typeable) 16 | import GHC.Generics (Generic) 17 | 18 | import Unbound.Generics.LocallyNameless 19 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf) 20 | 21 | -- variables will range over expressions 22 | type Var = Name Expr 23 | 24 | -- expression is either a variable, a constant int, a summation of two 25 | -- expressions, a list of variables bound to expressions that may 26 | -- occur in the body of an expression (where the expressions in the 27 | -- list of bindings refer to an outer scope), or a sequence of nested bindings 28 | -- where each binding expression can refer to previously bound variables. 29 | data Expr = V Var 30 | | C Int 31 | | Add Expr Expr 32 | | Let (Bind [(Var, Embed Expr)] Expr) 33 | | LetStar (Bind LetStarBinds Expr) 34 | deriving (Generic, Typeable, Show) 35 | 36 | data LetStarBinds = EmptyLSB 37 | | ConsLSB (Rebind (Var, Embed Expr) LetStarBinds) 38 | deriving (Generic, Typeable, Show) 39 | 40 | instance Alpha Expr 41 | instance Alpha LetStarBinds 42 | 43 | mkVar :: String -> Var 44 | mkVar = s2n 45 | 46 | anyFreeVarList :: Alpha a => a -> [AnyName] 47 | anyFreeVarList = toListOf fvAny 48 | 49 | freeVarList :: (Alpha a, Typeable b) => a -> [Name b] 50 | freeVarList = toListOf fv 51 | 52 | -- smart constructor for Let 53 | mkLet :: [(Var, Expr)] -> Expr -> Expr 54 | mkLet binds body = Let (bind (map (second Embed) binds) body) 55 | 56 | -- smart constructor for Let* 57 | mkLetStar :: [(Var, Expr)] -> Expr -> Expr 58 | mkLetStar binds body = LetStar (bind (mkLsb binds) body) 59 | where 60 | mkLsb [] = EmptyLSB 61 | mkLsb ((v,e):rest) = ConsLSB (rebind (v, Embed e) (mkLsb rest)) 62 | 63 | -- environments are partial maps from (free) variables to expressions. 64 | type Env = Var -> Maybe Expr 65 | 66 | emptyEnv :: Env 67 | emptyEnv = const Nothing 68 | 69 | extendEnv :: Var -> Expr -> Env -> Env 70 | extendEnv v e rho w = 71 | if v == w then Just e else rho w 72 | 73 | whnf :: ( 74 | #if MIN_VERSION_base(4,9,0) 75 | MonadFail m, 76 | #endif 77 | Fresh m) => Env -> Expr -> m Expr 78 | whnf rho (V v) = case rho v of 79 | Just e -> return e 80 | Nothing -> fail $ "unbound variable " ++ show v 81 | whnf _rho (C i) = return (C i) 82 | whnf rho (Add e1 e2) = do 83 | v1 <- whnf rho e1 84 | v2 <- whnf rho e2 85 | add v1 v2 86 | where add :: ( 87 | #if MIN_VERSION_base(4,9,0) 88 | MonadFail m, 89 | #endif 90 | Monad m) => Expr -> Expr -> m Expr 91 | add (C i1) (C i2) = return (C $ i1 + i2) 92 | add _ _ = fail "add of two non-integers" 93 | whnf rho0 (Let b) = do 94 | (binds, body) <- unbind b 95 | binds' <- mapM (\(v, Embed e) -> do 96 | e' <- whnf rho0 e 97 | return (v, e')) binds 98 | let rho' = foldl (\rho (v,e) -> extendEnv v e rho) rho0 binds' 99 | whnf rho' body 100 | whnf rho0 (LetStar b) = do 101 | (lsb, body) <- unbind b 102 | rho' <- whnfLsb lsb rho0 103 | whnf rho' body 104 | 105 | whnfLsb :: ( 106 | #if MIN_VERSION_base(4,9,0) 107 | MonadFail m, 108 | #endif 109 | Fresh m) => LetStarBinds -> Env -> m Env 110 | whnfLsb EmptyLSB = return 111 | whnfLsb (ConsLSB rbnd) = \rho -> do 112 | let ((v, Embed e), lsb) = unrebind rbnd 113 | e' <- whnf rho e 114 | whnfLsb lsb (extendEnv v e' rho) 115 | 116 | runWhnf :: Env -> Expr -> Maybe Expr 117 | runWhnf rho e = runFreshMT (whnf rho e) 118 | 119 | ex1 :: Expr 120 | ex1 = Add (C 1) (C 2) 121 | 122 | ex2x :: Expr 123 | ex2x = V (mkVar "x") 124 | 125 | ex2y :: Expr 126 | ex2y = V (mkVar "y") 127 | 128 | ex2xc :: Expr 129 | ex2xc = close initialCtx (namePatFind (mkVar "x")) ex2x 130 | 131 | ex2yc :: Expr 132 | ex2yc = close initialCtx (namePatFind (mkVar "y")) ex2y 133 | 134 | ex3x :: Expr 135 | ex3x = let x = mkVar "x" 136 | in mkLet [(x, (C 1))] $ Add (V x) (C 2) 137 | 138 | ex3y :: Expr 139 | ex3y = let y = mkVar "y" 140 | in mkLet [(y, (C 1))] $ Add (V y) (C 2) 141 | 142 | ex4 :: Expr 143 | ex4 = let 144 | x = mkVar "x" 145 | y = mkVar "y" 146 | in 147 | mkLet [(y, (C 5))] 148 | $ mkLet [(y, (C 200)) 149 | , (x, (Add (V y) -- refers to the outer y 150 | (C 6)))] 151 | $ Add (V x) (V x) -- expect (C 22), not (C 412) 152 | 153 | ex4_ans :: Expr 154 | ex4_ans = C 22 155 | 156 | ex5 :: Expr 157 | ex5 = let 158 | x = mkVar "x" 159 | y = mkVar "y" 160 | in 161 | mkLet [(y, (C 5))] 162 | $ mkLetStar [(y, (C 200)) 163 | , (x, (Add (V y) -- refers to the inner y 164 | (C 6)))] 165 | $ Add (V x) (V x) -- expect (C 412), not (C 22) 166 | 167 | ex5_ans :: Expr 168 | ex5_ans = C 412 169 | 170 | ex6 :: [Expr] 171 | ex6 = [V (mkVar "x"), V (mkVar "z"), mkLet [(mkVar "y", C 1)] (V (mkVar "y"))] 172 | 173 | ex6_ans :: [AnyName] 174 | ex6_ans = [AnyName (mkVar "x"), AnyName (mkVar "z")] 175 | 176 | ex7 :: [Expr] 177 | ex7 = [V (mkVar "x"), V (mkVar "z"), mkLet [(mkVar "y", C 1)] (V (mkVar "y"))] 178 | 179 | ex7_ans :: [Var] 180 | ex7_ans = [mkVar "x", mkVar "z"] 181 | -------------------------------------------------------------------------------- /test/ParallelReduction.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- We implement the parallel reduction relation e ⇛ e' 3 | -- that is a key to some kinds of confluence proofs for lambda calculi. 4 | {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, MultiParamTypeClasses #-} 5 | module ParallelReduction where 6 | 7 | import Control.Applicative 8 | import Control.Monad.Identity 9 | import GHC.Generics (Generic) 10 | import Data.Typeable (Typeable) 11 | 12 | import Unbound.Generics.LocallyNameless 13 | 14 | type Var = Name Expr 15 | 16 | -- in this case we just have an untyped lambda calculus 17 | data Expr = V Var 18 | | Lam (Bind Var Expr) 19 | | App Expr Expr 20 | deriving (Show, Generic, Typeable) 21 | 22 | instance Alpha Expr 23 | 24 | instance Subst Expr Expr where 25 | isvar (V n) = Just (SubstName n) 26 | isvar _ = Nothing 27 | 28 | run :: FreshMT Identity Expr -> Expr 29 | run = runIdentity . runFreshMT 30 | 31 | -- parallel reduction is the compatible closure of cbn beta : (λx.e)f ⇛ {f'/x}e' where e⇛e' and f⇛f' 32 | -- we choose to allow reduction under a lambda. 33 | parStep :: (Applicative m, Fresh m) => Expr -> m Expr 34 | parStep v@(V _) = return v 35 | parStep (App e1 e2) = 36 | case e1 of 37 | Lam b -> betaStep e2 b 38 | _ -> App <$> parStep e1 <*> parStep e2 39 | parStep (Lam b) = do 40 | (v, e) <- unbind b 41 | (Lam . (bind v)) <$> parStep e 42 | 43 | betaStep :: (Applicative m, Fresh m) => Expr -> Bind Var Expr -> m Expr 44 | betaStep f b = do 45 | f' <- parStep f 46 | (v, e) <- unbind b 47 | e' <- parStep e 48 | return (subst v f' e') 49 | 50 | -- repeatedly take parStep steps until the term doesn't change anymore. 51 | parSteps :: (Applicative m, Fresh m) => Expr -> m Expr 52 | parSteps e = do 53 | e' <- parStep e 54 | if (e `aeq` e') 55 | then return e 56 | else parSteps e' 57 | 58 | ex1 :: Bind Var Expr 59 | ex1 = let 60 | x = s2n "x" 61 | in bind x (V x) 62 | ex1' :: (Var, Expr) 63 | ex1' = let 64 | y = s2n "y" 65 | in 66 | (y, V y) 67 | 68 | ex2 :: Expr 69 | ex2 = App (Lam ex2_1) ex2_2 70 | 71 | ex2_1 :: Bind Var Expr 72 | ex2_1 = let 73 | x = s2n "x" 74 | y = s2n "y" 75 | in 76 | bind x $ Lam $ bind y $ App (V x) (V y) 77 | 78 | ex2_2 :: Expr 79 | ex2_2 = let 80 | z = s2n "z" 81 | in 82 | (Lam $ bind z $ V z) 83 | 84 | ident :: Expr 85 | ident = let 86 | u = s2n "u" 87 | in Lam $ bind u $ V u 88 | 89 | -- same as ex2 but with some extra beta redices in both halves of the application 90 | ex2_alt :: Expr 91 | ex2_alt = App (App ident (Lam ex2_1)) (App (App ident ident) ex2_2) 92 | 93 | -------------------------------------------------------------------------------- /test/PropOpenClose.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} 2 | module PropOpenClose (test_openClose) where 3 | 4 | import Control.Applicative (Applicative(..), (<$>)) 5 | import Data.Monoid (Any(..)) 6 | import Data.Typeable (Typeable) 7 | import GHC.Generics (Generic) 8 | 9 | import Test.QuickCheck 10 | import Test.Tasty (testGroup, TestTree) 11 | import Test.Tasty.QuickCheck (testProperty) 12 | 13 | import Unbound.Generics.LocallyNameless 14 | import Unbound.Generics.LocallyNameless.Internal.Fold (foldMapOf, toListOf) 15 | 16 | import AlphaProperties 17 | 18 | 19 | -- Wrapper around 'Name a' that has an Arbitrary instance that generates free names. 20 | -- Note that this doesn't guarantee /freshness/. The name may clash with some other one. 21 | -- But it will never be a bound name. 22 | newtype FreeName a = FreeName {getFreeName :: Name a} 23 | deriving (Show) 24 | 25 | instance Arbitrary (FreeName a) where 26 | arbitrary = do 27 | s <- listOf1 (elements ['a'..'z']) 28 | n <- arbitrary 29 | return $ FreeName $ makeName s n 30 | shrink = const [] 31 | 32 | ---------------------------------------- 33 | -- example data structure, with no bound names. 34 | 35 | data T a = Leaf !a 36 | | V !(Name (T a)) 37 | | B !(T a) !(T a) 38 | deriving (Show, Typeable, Generic) 39 | 40 | instance (Typeable a, Alpha a) => Alpha (T a) 41 | 42 | instance Arbitrary a => Arbitrary (T a) where 43 | arbitrary = 44 | oneof 45 | [ 46 | Leaf <$> arbitrary 47 | ,(V . getFreeName) <$> arbitrary 48 | , B <$> arbitrary <*> arbitrary 49 | ] 50 | 51 | -- generator that picks out one of the free variables of a tree 52 | arbVarsOf :: (Alpha a, Typeable a) => T a -> Gen (Name (T a)) 53 | arbVarsOf t = 54 | let vs = toListOf fv t 55 | in elements vs 56 | 57 | -- spec for free variables of a tree. 58 | -- fvSpec :: Traversal' (T a) (Name (T a)) 59 | fvSpec :: Applicative f => (Name (T a) -> f (Name (T a))) -> T a -> f (T a) 60 | fvSpec f t = 61 | case t of 62 | Leaf {} -> pure t 63 | V v -> V <$> f v 64 | B t1 t2 -> B <$> fvSpec f t1 <*> fvSpec f t2 65 | 66 | ---------------------------------------- 67 | -- Properties 68 | 69 | -- every tree is alpha-equivalent to itself 70 | prop_refl :: T Int -> Property 71 | prop_refl x = x =~= x 72 | 73 | -- generic fv gives the same answer as fvSpec 74 | prop_fv_spec :: T Int -> Property 75 | prop_fv_spec t = toListOf fv t === toListOf fvSpec t 76 | 77 | -- if a name is already free opening it has no effect 78 | prop_open_idempotent :: T Int -> Property 79 | prop_open_idempotent t = 80 | forAll (arbVarsOf t) $ \v -> open initialCtx (nthPatFind v) t =~= t 81 | 82 | -- if you close over a variable, then it is no longer free. 83 | prop_close_binds :: T Int -> Property 84 | prop_close_binds t = 85 | (not $ null $ toListOf fvAny t) ==> 86 | forAll (arbVarsOf t) $ \v -> v /~@ close initialCtx (namePatFind v) t 87 | 88 | ---------------------------------------- 89 | -- Test group 90 | 91 | test_openClose :: TestTree 92 | test_openClose = 93 | testGroup "QuickCheck properties" 94 | [ 95 | testProperty "reflexivity" prop_refl 96 | , testProperty "fv specification" prop_fv_spec 97 | , testProperty "open idempotency" prop_open_idempotent 98 | , testProperty "closing binds variables" prop_close_binds 99 | ] 100 | -------------------------------------------------------------------------------- /test/TestACompare.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} 2 | module TestACompare where 3 | 4 | import Data.Typeable 5 | import GHC.Generics 6 | import Unbound.Generics.LocallyNameless 7 | 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | 11 | import AlphaAssertions 12 | 13 | data Expr 14 | = V (Name Expr) 15 | | Add Expr Expr 16 | | L (Bind (Name Expr) Expr) 17 | deriving (Show,Generic,Typeable) 18 | 19 | instance Alpha Expr 20 | 21 | nameA, nameB, nameC :: Name Expr 22 | nameA = s2n "a" 23 | nameB = s2n "b" 24 | nameC = s2n "c" 25 | 26 | test_acompare :: TestTree 27 | test_acompare = testGroup "acompare" 28 | -- Names compare in the obvious way. 29 | [ testGroup "obvious" 30 | [testCase "ac1 (a < b)" $ assertAcompare nameA nameB LT 31 | ,testCase "ac2 (b = b)" $ assertAcompare nameB nameB EQ 32 | ,testCase "ac3 (b > a)" $ assertAcompare nameB nameA GT 33 | ] 34 | -- structured date compares lexicographically 35 | , testGroup "lexicographically" 36 | [testCase "ac4 (a + a = a + a)" $ 37 | assertAcompare (Add (V nameA) (V nameA)) (Add (V nameA) (V nameA)) EQ 38 | ,testCase "ac5 (a + a < a + b)" $ 39 | assertAcompare (Add (V nameA) (V nameA)) (Add (V nameA) (V nameB)) LT 40 | ,testCase "ac6 (a + b > a + a)" $ 41 | assertAcompare (Add (V nameA) (V nameB)) (Add (V nameA) (V nameA)) GT 42 | ,testCase "ac7 (a + a < b + a)" $ 43 | assertAcompare (Add (V nameA) (V nameA)) (Add (V nameB) (V nameA)) LT 44 | ,testCase "ac8 (b + a > a + a)" $ 45 | assertAcompare (Add (V nameB) (V nameA)) (Add (V nameA) (V nameA)) GT 46 | ,testCase "ac9 (b + a > a + b)" $ 47 | assertAcompare (Add (V nameB) (V nameA)) (Add (V nameA) (V nameB)) GT 48 | ] 49 | -- comparison goes under binders, alpha-respectingly. 50 | , testGroup "binders" 51 | [testCase "ac10 (\\a.a+a = \\b.b+b)" $ 52 | assertAcompare (bind nameA (Add (V nameA) (V nameA))) 53 | (bind nameB (Add (V nameB) (V nameB))) 54 | EQ 55 | ,testCase "ac11 (\\a.a+a > \\a.a+b)" $ 56 | assertAcompare (bind nameA (Add (V nameA) (V nameA))) 57 | (bind nameA (Add (V nameA) (V nameB))) 58 | GT 59 | ,testCase "ac12 (\\c.c+a < \\a.a+b)" $ 60 | assertAcompare (bind nameC (Add (V nameC) (V nameA))) 61 | (bind nameA (Add (V nameA) (V nameB))) 62 | LT 63 | ] 64 | -- non-matching binders handled alpha-respectingly. 65 | , testGroup "non-matching binders" 66 | [testCase "ac13 ((\\a.a `ac` \\a b.a) = (\\c.c `ac` \\a b.a))" $ 67 | assertAcompare (bind [nameA] nameA) 68 | (bind [nameA,nameB] nameA) 69 | (acompare (bind [nameC] nameC) (bind [nameA,nameB] nameA)) 70 | ,testCase "ac14 ((\\a b.a `ac` \\a.a) = (\\c b.c `ac` \\a.a))" $ 71 | assertAcompare (bind [nameA,nameB] nameA) 72 | (bind [nameA] nameA) 73 | (acompare (bind [nameC,nameB] nameC) (bind [nameA] nameA)) 74 | ] 75 | -- non-binding stuff in patterns gets compared 76 | , testGroup "non-binding stuff" 77 | [testCase "ac15 ( < )" $ 78 | assertAcompare (Embed nameA) (Embed nameB) LT 79 | ,testCase "ac16 (\\c.c+c < \\c.c+c)" $ 80 | assertAcompare 81 | (bind (nameC, Embed nameA) (Add (V nameC) (V nameC))) 82 | (bind (nameC, Embed nameB) (Add (V nameC) (V nameC))) 83 | LT 84 | ,testCase "ac17 (\\c.b+b < \\c.a+a)" $ 85 | assertAcompare 86 | (bind (nameC, Embed nameA) (Add (V nameB) (V nameB))) 87 | (bind (nameC, Embed nameB) (Add (V nameA) (V nameA))) 88 | LT 89 | ] 90 | ] 91 | -------------------------------------------------------------------------------- /test/TestCalc.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : test-stlc 3 | -- Copyright : (c) 2014, Aleksey Kliger 4 | -- License : BSD3 (See LICENSE) 5 | -- Maintainer : Aleksey Kliger 6 | -- Stability : experimental 7 | -- 8 | {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} 9 | module TestCalc (test_calc) where 10 | 11 | import Unbound.Generics.LocallyNameless 12 | 13 | import Calc 14 | 15 | import Test.Tasty 16 | import Test.Tasty.HUnit 17 | 18 | import AlphaAssertions 19 | 20 | test_ex1 :: TestTree 21 | test_ex1 = testCase "example 1" $ assertAeq (runWhnf emptyEnv ex1) (Just $ C 3) 22 | 23 | test_ex2_open :: TestTree 24 | test_ex2_open = testCase "example 2 (open)" $ assertBool "alpha equivalent" (not $ aeq ex2x ex2y) 25 | 26 | test_ex2_closed :: TestTree 27 | test_ex2_closed = testCase "example 2 (closed)" $ assertAeq ex2xc ex2yc 28 | 29 | test_ex3 :: TestTree 30 | test_ex3 = testCase "example 3" $ assertAeq ex3x ex3y 31 | 32 | test_ex4 :: TestTree 33 | test_ex4 = testCase "example 4 (let scoping)" $ assertAeq (runWhnf emptyEnv ex4) (Just ex4_ans) 34 | 35 | test_ex5 :: TestTree 36 | test_ex5 = testCase "example 5 (let* scoping)" $ assertAeq (runWhnf emptyEnv ex5) (Just ex5_ans) 37 | 38 | test_ex6 :: TestTree 39 | test_ex6 = testCase "example 6 (free variables)" $ assertAeq (anyFreeVarList ex6) ex6_ans 40 | 41 | test_ex7 :: TestTree 42 | test_ex7 = testCase "example 7 (sorted free variables)" $ assertAeq (freeVarList ex7) ex7_ans 43 | 44 | 45 | test_calc :: TestTree 46 | test_calc = 47 | testGroup "calc" 48 | [test_ex1 49 | , test_ex2_open 50 | , test_ex2_closed 51 | , test_ex3 52 | , test_ex4 53 | , test_ex5 54 | , test_ex6 55 | , test_ex7 56 | ] 57 | 58 | -------------------------------------------------------------------------------- /test/TestIgnore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, MultiParamTypeClasses #-} 2 | module TestIgnore (test_ignore) where 3 | 4 | import Data.Typeable(Typeable) 5 | import GHC.Generics (Generic) 6 | import Unbound.Generics.LocallyNameless 7 | 8 | import AlphaAssertions 9 | 10 | import Test.Tasty 11 | import Test.Tasty.HUnit 12 | 13 | type Var = Name Term 14 | 15 | type SourcePos = (Int, Int) 16 | data SourceSpan = SourceSpan 17 | { start :: SourcePos 18 | , end :: SourcePos 19 | } 20 | deriving (Show) 21 | 22 | data Term 23 | = Var Var 24 | | Lam (Bind Var Term) 25 | | App Term Term 26 | | Ann (Ignore SourceSpan) Term 27 | | NoSubst (Ignore Term) 28 | deriving (Show, Typeable, Generic) 29 | 30 | instance Alpha Term 31 | instance Subst Term Term where 32 | isvar (Var x) = Just $ SubstName x 33 | isvar _ = Nothing 34 | 35 | lam :: Var -> Term -> Term 36 | lam x t = Lam (bind x t) 37 | 38 | x :: Var 39 | x = s2n "x" 40 | 41 | y :: Var 42 | y = s2n "y" 43 | 44 | t1 :: Term 45 | t1 = Ann (ignore (SourceSpan (0,0) (0,1))) (Var x) 46 | 47 | t2 :: Term 48 | t2 = Ann (ignore (SourceSpan (1,0) (1,10))) (Var x) 49 | 50 | test_ignore :: TestTree 51 | test_ignore = 52 | testCase "<-(0,0) (0,1)-> x = <-(1,0) (1,10)-> x" $ assertAeq t1 t2 -------------------------------------------------------------------------------- /test/TestParallelReduction.hs: -------------------------------------------------------------------------------- 1 | module TestParallelReduction (test_parallelReduction) where 2 | 3 | import Test.Tasty 4 | import Test.Tasty.HUnit 5 | 6 | import Unbound.Generics.LocallyNameless (Alpha, subst, aeq) 7 | 8 | import ParallelReduction 9 | 10 | 11 | assertAeq :: (Alpha t, Show t) => t -> t -> Assertion 12 | assertAeq x y = assertBool (show x ++ " not alpha equivalent to " ++ show y) (x `aeq` y) 13 | 14 | test_ex1 :: TestTree 15 | test_ex1 = testCase "simple substitution" $ assertAeq (subst (fst ex1') (Lam ex1) (snd ex1')) (Lam ex1) 16 | 17 | test_ex2 :: TestTree 18 | test_ex2 = testCase "parallel reduction" $ assertAeq (run (parSteps ex2)) (run (parSteps ex2_alt)) 19 | 20 | test_parallelReduction :: TestTree 21 | test_parallelReduction = 22 | testGroup "parallel reduction" 23 | [test_ex1 24 | , test_ex2 25 | ] 26 | 27 | -------------------------------------------------------------------------------- /test/TestRefine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, MultiParamTypeClasses #-} 2 | module TestRefine (test_refine) where 3 | 4 | import Data.Typeable (Typeable) 5 | import GHC.Generics (Generic) 6 | import Unbound.Generics.LocallyNameless 7 | 8 | import AlphaAssertions 9 | 10 | import Test.Tasty 11 | import Test.Tasty.HUnit 12 | 13 | -- Regular variables range over terms 14 | type Var = Name Term 15 | 16 | -- Metavariables range over extracts 17 | type MetaVar = Name Extract 18 | 19 | data Term 20 | = Var Var 21 | | Hole MetaSubst MetaVar -- Every occurance of a metavariable must subst away fvs of extract 22 | | Lam (Bind Var Term) 23 | | App Term Term 24 | deriving (Generic, Typeable, Show) 25 | 26 | -- Extracts represent code extracted via refinement 27 | newtype Extract = Extract { extractTerm :: Term } 28 | deriving (Generic, Typeable, Show) 29 | 30 | newtype MetaSubst = MetaSubst { unMetaSubst :: [(Var, Term)] } 31 | deriving (Generic, Typeable, Show) 32 | 33 | instance Alpha Term 34 | instance Alpha Extract 35 | instance Alpha MetaSubst 36 | 37 | instance Subst Term Term where 38 | isvar (Var x) = Just $ SubstName x 39 | isvar _ = Nothing 40 | 41 | instance Subst Extract Term where 42 | isCoerceVar (Hole ms x) = Just $ SubstCoerce x (Just . applyMetaSubst ms) 43 | isCoerceVar _ = Nothing 44 | 45 | applyMetaSubst :: MetaSubst -> Extract -> Term 46 | applyMetaSubst (MetaSubst ms) e = substs ms $ extractTerm e 47 | 48 | instance Subst Term MetaSubst 49 | instance Subst Extract MetaSubst 50 | 51 | test_refine :: TestTree 52 | test_refine = 53 | testCase "subst ?1 x ?0 = ?0" 54 | $ let h0 = s2n "0" :: MetaVar 55 | h1 = s2n "1" :: MetaVar 56 | a = s2n "a" :: Var 57 | x = s2n "x" :: Var 58 | e1 = Hole (MetaSubst [(a, Hole (MetaSubst []) h1)]) h0 59 | e2 = Hole (MetaSubst [(a, Var x)]) h0 60 | in assertAeq (subst h1 (Extract $ Var x) e1) e2 -------------------------------------------------------------------------------- /test/TestShiftEmbed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} 2 | module TestShiftEmbed (test_shiftEmbed) where 3 | 4 | import Prelude hiding (pi) 5 | 6 | import Data.Typeable (Typeable) 7 | import GHC.Generics (Generic) 8 | import Unbound.Generics.LocallyNameless 9 | import qualified Unbound.Generics.PermM as PermM 10 | 11 | import AlphaAssertions 12 | 13 | import Test.Tasty 14 | import Test.Tasty.HUnit 15 | 16 | type Var = Name Term 17 | 18 | data Term 19 | = V Var 20 | | Pi (Bind (Var, Embed Term) Term) 21 | | LetRec (Bind (Rec Decl) Term) 22 | deriving (Show, Generic, Typeable) 23 | 24 | data Decl = 25 | -- a recursive declaration x : A = m 26 | -- where x may occur in m but not in A 27 | Decl { 28 | declVar :: Var 29 | , declClass :: Shift (Embed Term) 30 | , declVal :: Embed Term 31 | } 32 | deriving (Show, Generic, Typeable) 33 | 34 | instance Alpha Term 35 | instance Alpha Decl 36 | 37 | x, y, z :: Var 38 | x = s2n "x" 39 | y = s2n "y" 40 | z = s2n "z" 41 | 42 | pi :: Var -> Term -> Term -> Term 43 | pi v a b = Pi $ bind (v, embed a) b 44 | 45 | letrec :: Decl -> Term -> Term 46 | letrec d e = LetRec $ bind (rec d) e 47 | 48 | decl :: Var -> Term -> Term -> Decl 49 | decl v klass e = Decl v (embed klass) (embed e) 50 | 51 | 52 | test_shiftEmbed = 53 | testGroup "Embedded and Shifted terms" 54 | [ 55 | testGroup "Embed" 56 | [ 57 | testCase "(pi x:x . x) = (pi y:x . y)" $ let m1 = pi x (V x) (V x) 58 | m2 = pi y (V x) (V y) 59 | in assertAeq m1 m2 60 | , testCase "(letrec x : x = x in x) = (letrec y : x = y in y)" 61 | $ let m1 = letrec (decl x (V x) (V x)) (V x) 62 | m2 = letrec (decl y (V x) (V y)) (V y) 63 | in assertAeq m1 m2 64 | , testCase "pi x : z . (letrec x : x = x in x) = pi y : z . (letrec x : y = x in x)" 65 | $ let m1 = pi x (V z) $ letrec (decl x (V x) (V x)) (V x) 66 | m2 = pi y (V z) $ letrec (decl x (V y) (V x)) (V x) 67 | in assertAeq m1 m2 68 | ] 69 | ] 70 | -------------------------------------------------------------------------------- /test/TestSubstBind.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, DeriveGeneric, DeriveDataTypeable #-} 2 | 3 | module TestSubstBind where 4 | 5 | import Test.Tasty 6 | import Unbound.Generics.LocallyNameless 7 | import Data.Typeable (Typeable) 8 | import GHC.Generics (Generic) 9 | 10 | 11 | import Test.QuickCheck 12 | import Test.Tasty.QuickCheck (testProperty) 13 | import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) 14 | 15 | import AlphaProperties 16 | 17 | type Var = Name Expr 18 | 19 | data Expr = V Var | Lam (Bind Var Expr) | I Int | App Expr Expr 20 | deriving (Generic, Typeable, Show) 21 | 22 | instance Alpha Expr 23 | 24 | instance Subst Expr Expr where 25 | isvar (V x) = Just (SubstName x) 26 | isvar _ = Nothing 27 | 28 | 29 | instance Arbitrary Expr where 30 | arbitrary = sized arbitrarySizedExpr 31 | 32 | shrink (I i) = I <$> shrink i 33 | shrink (Lam bndExp) = 34 | (substBind bndExp <$> [I 0, V x, V y, V z]) -- does the problem persist with the binder removed? 35 | ++ (Lam <$> underBinder shrink bndExp) -- shrink under the binder 36 | shrink (f `App` a) = [f, a] ++ (App <$> shrink f <*> shrink a) 37 | shrink _ = [] 38 | 39 | underBinder :: (Monad m) => (Expr -> m Expr) -> Bind Var Expr -> m (Bind Var Expr) 40 | underBinder op bndExp = let 41 | (name, bod) = unsafeUnbind bndExp -- Should be safe since no freshnames are invoked 42 | in do 43 | bod' <- op bod 44 | pure $ bind name bod' 45 | 46 | arbitrarySizedExpr :: Int -> Gen Expr 47 | arbitrarySizedExpr i | i < 1 = do 48 | n <- arbitrary 49 | var <- elements [x,y,z] 50 | elements [I n, V $ var] 51 | arbitrarySizedExpr i = do 52 | rest <- arbitrarySizedExpr (i - 1) 53 | var <- elements [x,y,z] 54 | n <- arbitrary 55 | f <- arbitrarySizedExpr (i `div` 2) -- TODO: reorganize better 56 | a <- arbitrarySizedExpr (i `div` 2) 57 | elements [Lam $ bind var rest, f `App` a, I n, V $ var] 58 | 59 | 60 | x,y,z :: Var 61 | x = s2n "x" 62 | y = s2n "y" 63 | z = s2n "z" 64 | 65 | 66 | smallStep :: Expr -> Maybe Expr 67 | smallStep ((Lam bndBod) `App` a) = Just $ substBind bndBod a 68 | smallStep (f `App` a) = 69 | case (smallStep f, smallStep a) of 70 | (Nothing, Nothing) -> Nothing 71 | (Just f', _) -> Just $ f' `App` a 72 | (Nothing, Just a') -> Just $ f `App` a' 73 | smallStep (Lam bndBod) = Lam <$> underBinder smallStep bndBod 74 | smallStep _ = Nothing -- no step 75 | 76 | 77 | smallStep' :: (Fresh m) => Expr -> m (Maybe Expr) 78 | smallStep' ((Lam bndBod) `App` a) = do 79 | (name, bod) <- unbind bndBod 80 | pure $ Just $ subst name a bod 81 | smallStep' (f `App` a) = do 82 | mf' <- smallStep' f 83 | ma' <- smallStep' a 84 | case (mf', ma') of 85 | (Nothing, Nothing) -> pure $ Nothing 86 | (Just f', _) -> pure $ Just $ f' `App` a 87 | (Nothing, Just a') -> pure $ Just $ f `App` a' 88 | smallStep' (Lam bndBod) = do 89 | (name, bod) <- unbind bndBod 90 | mbod' <- smallStep' bod 91 | case mbod' of 92 | Nothing -> pure $ Nothing 93 | Just bod' -> pure $ Just $ Lam $ bind name bod' 94 | smallStep' _ = pure $ Nothing -- no step 95 | 96 | 97 | expbindProp :: Expr -> Property 98 | expbindProp e = smallStep e =~= runFreshM (smallStep' e) 99 | 100 | test_substBind :: TestTree 101 | test_substBind = testGroup "substBind" 102 | [testProperty "substBind matches unbind subst" $ expbindProp] 103 | -------------------------------------------------------------------------------- /test/TestTH.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK show-extensions #-} 2 | -- | 3 | -- Module : TestTH 4 | -- Copyright : (c) 2015, Aleksey Kliger 5 | -- License : BSD3 (See LICENSE) 6 | -- Maintainer : Aleksey Kliger 7 | -- Stability : experimental 8 | -- 9 | -- Test of 'makeClosedAlpha' splice. 10 | {-# LANGUAGE TemplateHaskell #-} 11 | module TestTH (test_TH) where 12 | 13 | import Data.Monoid(Monoid(..)) 14 | 15 | import Test.Tasty 16 | import Test.Tasty.HUnit 17 | import AlphaAssertions 18 | 19 | import Unbound.Generics.LocallyNameless 20 | import Unbound.Generics.LocallyNameless.Internal.Fold (toListOf) 21 | import Unbound.Generics.LocallyNameless.TH 22 | 23 | 24 | 25 | data K = 26 | KT 27 | | KArr K K 28 | deriving (Eq, Ord, Show) 29 | 30 | $(makeClosedAlpha ''K) 31 | 32 | kt, kF, kG :: K 33 | kt = KT 34 | kF = KT `KArr` KT 35 | kG = kF `KArr` KT 36 | 37 | emptyPat :: [Name ()] 38 | emptyPat = [] 39 | 40 | test_TH :: TestTree 41 | test_TH = testGroup "TH makeClosedAlpha splice" 42 | [ testCase "TH aeq" $ assertAeq kt kt 43 | , testCase "TH acompare" $ assertAcompare kt kF (compare kt kF) 44 | , testCase "TH fvAny kG" $ assertEqual "" (toListOf fvAny kG) [] 45 | , testCase "TH close" $ assertEqual "" (close initialCtx (namePatFind emptyPat) kt) kt 46 | , testCase "TH open" $ assertEqual "" (open initialCtx (nthPatFind emptyPat) kG) kG 47 | , testCase "TH isTerm" $ assertEqual "" (isTerm kF) mempty 48 | , testCase "TH isPat" 49 | $ assertBool "isNullDisjointSEt (isPat kF)" (isNullDisjointSet $ isPat kF) 50 | ] 51 | -------------------------------------------------------------------------------- /test/TinyLam.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleContexts #-} 2 | module TinyLam where 3 | 4 | import GHC.Generics (Generic) 5 | import Data.Typeable (Typeable) 6 | 7 | import Control.Applicative (Applicative(..)) 8 | import Control.Monad.Reader 9 | import Data.Monoid (Monoid(..)) 10 | import qualified Data.List 11 | 12 | import Test.Tasty 13 | import Test.Tasty.HUnit 14 | 15 | import Unbound.Generics.LocallyNameless 16 | 17 | 18 | type Var = Name Expr 19 | 20 | data ArithOp = ArithOp String (Int -> Int -> Int) 21 | deriving (Typeable, Generic) 22 | 23 | instance Show ArithOp where 24 | show (ArithOp f _) = f 25 | 26 | data Expr = V Var 27 | | I Int 28 | | Arith ArithOp Expr Expr 29 | | Lam Fun 30 | | App Expr Expr 31 | | If0 Expr Expr Expr 32 | | Letrec (Bind (Rec (Var, Embed Fun)) Expr) 33 | deriving (Typeable, Generic, Show) 34 | 35 | newtype Fun = Fun (Bind Var Expr) 36 | deriving (Typeable, Generic, Show) 37 | 38 | instance Eq Expr where 39 | (==) = aeq 40 | 41 | instance Eq Fun where 42 | (==) = aeq 43 | 44 | -- leaf instance for ArithOp 45 | instance Alpha ArithOp where 46 | aeq' _ctx (ArithOp s1 _) (ArithOp s2 _) = s1 == s2 47 | fvAny' _ctx _nfn x = pure x 48 | close _ctx _b x = x 49 | open _ctx _b x = x 50 | isPat _ = mempty 51 | isTerm _ = mempty 52 | nthPatFind _ = mempty 53 | namePatFind _ = mempty 54 | 55 | swaps' _ctx _p x = x 56 | freshen' _ctx x = return (x, mempty) 57 | lfreshen' _ctx x cont = cont x mempty 58 | acompare' _ctx (ArithOp s1 _) (ArithOp s2 _) = compare s1 s2 59 | 60 | instance Alpha Expr 61 | instance Alpha Fun 62 | 63 | type Env = [(Var, Value)] 64 | 65 | data Value = VI !Int 66 | | VClo !Env !Fun 67 | deriving (Eq, Show) 68 | 69 | 70 | emptyEnv :: Env 71 | emptyEnv = [] 72 | 73 | extendEnv :: Var -> Value -> Env -> Env 74 | extendEnv x v rho = (x,v) : rho 75 | 76 | env :: MonadReader Env m => m Env 77 | env = ask 78 | 79 | lookupV :: MonadReader Env m => Var -> m Value 80 | lookupV x = env >>= \rho -> 81 | case Data.List.lookup x rho of 82 | Just v -> return v 83 | Nothing -> error $ "unbound variable " ++ show x 84 | 85 | eval :: (Fresh m, MonadReader Env m) => Expr -> m Value 86 | eval (V x) = lookupV x 87 | eval (I i) = return $ VI i 88 | eval (Lam f) = env >>= \rho -> return (VClo rho f) 89 | eval (App e1 e2) = do 90 | v1 <- eval e1 91 | case v1 of 92 | (VClo rho (Fun bnd)) -> do 93 | v2 <- eval e2 94 | (x, e3) <- unbind bnd 95 | local (const $ extendEnv x v2 rho) $ eval e3 96 | _ -> error ("expected a function, but got " ++ show v1) 97 | eval (Arith (ArithOp _ op) e1 e2) = do 98 | v1 <- eval e1 99 | v2 <- eval e2 100 | case (v1, v2) of 101 | (VI n1, VI n2) -> return $ VI (op n1 n2) 102 | _ -> error ("expected pair of ints, but got " ++ show v1 103 | ++ " and " ++ show v2) 104 | eval (If0 e1 e2 e3) = do 105 | v1 <- eval e1 106 | case v1 of 107 | VI 0 -> eval e2 108 | VI _ -> eval e3 109 | _ -> error ("expected int, but got " ++ show v1) 110 | eval (Letrec bnd) = do 111 | (r, ebody) <- unbind bnd 112 | rho0 <- ask 113 | let (f, Embed fun) = unrec r 114 | -- N.B. knot tying 115 | rho = extendEnv f vclo rho0 116 | vclo = VClo rho fun 117 | local (extendEnv f vclo) $ eval ebody 118 | 119 | runEval :: Expr -> Value 120 | runEval e = runReader (runFreshMT (eval e)) emptyEnv 121 | 122 | ex_f :: Int -> Expr 123 | ex_f n = let 124 | (/*/) = Arith (ArithOp "*" (*)) 125 | (/-/) = Arith (ArithOp "-" (-)) 126 | fact = s2n "fact" 127 | x = s2n "x" 128 | body = If0 (V x) 129 | {-then-} (I 1) 130 | {-else-} (V x 131 | /*/ 132 | App (V fact) (V x /-/ I 1)) 133 | factfun = Fun (bind x body) 134 | in Letrec $ bind (rec (fact, Embed factfun)) 135 | (App (V fact) (I n)) 136 | 137 | test_ex_f0 :: TestTree 138 | test_ex_f0 = 139 | testCase "eval (fact 0) = 1" 140 | $ assertEqual "" (runEval (ex_f 0)) (VI 1) 141 | 142 | test_ex_f5 :: TestTree 143 | test_ex_f5 = 144 | testCase "eval (fact 5) = 120" 145 | $ assertEqual "" (runEval (ex_f 5)) (VI 120) 146 | 147 | test_tinyLam :: TestTree 148 | test_tinyLam = 149 | testGroup "tinyLam" 150 | [ test_ex_f0 151 | , test_ex_f5 152 | ] 153 | -------------------------------------------------------------------------------- /test/test-main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Tasty 4 | 5 | import TestCalc 6 | import TestParallelReduction 7 | import PropOpenClose 8 | import TinyLam 9 | import TestACompare 10 | import TestRefine 11 | import TestIgnore 12 | import TestShiftEmbed 13 | import TestTH 14 | import TestSubstBind 15 | 16 | main :: IO () 17 | main = defaultMain $ testGroup "unboundGenerics" 18 | [ 19 | test_calc 20 | , test_parallelReduction 21 | , test_openClose 22 | , test_refine 23 | , test_ignore 24 | , test_tinyLam 25 | , test_acompare 26 | , test_shiftEmbed 27 | , test_TH 28 | , test_substBind 29 | ] 30 | -------------------------------------------------------------------------------- /unbound-generics.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: unbound-generics 3 | version: 0.4.4 4 | synopsis: Support for programming with names and binders using GHC Generics 5 | description: Specify the binding structure of your data type with an 6 | expressive set of type combinators, and unbound-generics 7 | handles the rest! Automatically derives 8 | alpha-equivalence, free variable calculation, 9 | capture-avoiding substitution, and more. See 10 | @Unbound.Generics.LocallyNameless@ to get started. 11 | . 12 | This is an independent re-implementation of 13 | but using 14 | instead of . 15 | See the accompanying README for some porting notes. 16 | 17 | homepage: http://github.com/lambdageek/unbound-generics 18 | bug-reports: http://github.com/lambdageek/unbound-generics/issues 19 | license: BSD3 20 | license-file: LICENSE 21 | author: Aleksey Kliger, Austin Erlandson 22 | maintainer: aleksey@lambdageek.org 23 | copyright: (c) 2014-2022, Aleksey Kliger 24 | category: Language 25 | build-type: Simple 26 | 27 | extra-source-files: examples/*.hs, examples/*.lhs, 28 | README.md, 29 | Changelog.md 30 | 31 | tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.*, GHC == 9.4.*, GHC == 9.8.* 32 | 33 | library 34 | exposed-modules: Unbound.Generics.LocallyNameless 35 | Unbound.Generics.LocallyNameless.Name 36 | Unbound.Generics.LocallyNameless.Fresh 37 | Unbound.Generics.LocallyNameless.LFresh 38 | Unbound.Generics.LocallyNameless.Alpha 39 | Unbound.Generics.LocallyNameless.Bind 40 | Unbound.Generics.LocallyNameless.Ignore 41 | Unbound.Generics.LocallyNameless.Rebind 42 | Unbound.Generics.LocallyNameless.Embed 43 | Unbound.Generics.LocallyNameless.Shift 44 | Unbound.Generics.LocallyNameless.Operations 45 | Unbound.Generics.LocallyNameless.Unsafe 46 | Unbound.Generics.LocallyNameless.Internal.Fold 47 | Unbound.Generics.LocallyNameless.Internal.GSubst 48 | Unbound.Generics.LocallyNameless.Internal.Iso 49 | Unbound.Generics.LocallyNameless.Internal.Lens 50 | Unbound.Generics.LocallyNameless.Rec 51 | Unbound.Generics.LocallyNameless.TH 52 | Unbound.Generics.PermM 53 | Unbound.Generics.LocallyNameless.Subst 54 | -- other-modules: 55 | -- other-extensions: 56 | build-depends: base >=4.9 && <5, 57 | template-haskell >= 2.8.0.0, 58 | deepseq >= 1.3.0.0, 59 | mtl >= 2.1, 60 | transformers >= 0.3 && < 0.7, 61 | transformers-compat >= 0.3, 62 | containers >= 0.5 && < 0.8, 63 | contravariant >= 0.5, 64 | profunctors >= 4.0, 65 | ansi-wl-pprint >= 0.6.7.2 && < 1.1, 66 | exceptions >= 0.8 && < 0.11 67 | hs-source-dirs: src 68 | default-language: Haskell2010 69 | ghc-options: -Wall 70 | if impl (ghc >= 8.0.0) 71 | ghc-options: -Wcompat 72 | if !impl(ghc >= 8.0) 73 | build-depends: semigroups == 0.18.* 74 | 75 | Test-Suite test-unbound-generics 76 | type: exitcode-stdio-1.0 77 | main-is: test-main.hs 78 | other-modules: AlphaAssertions 79 | Calc 80 | TestCalc 81 | ParallelReduction 82 | TestParallelReduction 83 | PropOpenClose 84 | TinyLam 85 | TestRefine 86 | TestIgnore 87 | TestACompare 88 | TestShiftEmbed 89 | TestTH 90 | TestSubstBind 91 | AlphaProperties 92 | build-depends: base, 93 | mtl, 94 | tasty, 95 | tasty-hunit, 96 | tasty-quickcheck, 97 | QuickCheck >= 2.7 && < 3, 98 | unbound-generics 99 | hs-source-dirs: test 100 | default-language: Haskell2010 101 | ghc-options: -Wall 102 | if impl (ghc >= 8.0.0) 103 | ghc-options: -Wcompat 104 | 105 | Benchmark benchmark-unbound-generics 106 | type: exitcode-stdio-1.0 107 | default-language: Haskell2010 108 | hs-source-dirs: benchmarks 109 | main-is: benchmark-main.hs 110 | build-depends: base 111 | , criterion >= 1.0.0.1 112 | , deepseq >= 1.3.0.0 113 | , unbound-generics 114 | if impl (ghc == 7.6.*) 115 | build-depends: unix <= 2.6.0.1 116 | if impl (ghc == 7.6.*) || impl (ghc == 7.8.*) 117 | build-depends: deepseq-generics 118 | else 119 | build-depends: deepseq >= 1.4.0.0 120 | other-modules: BenchLam 121 | ghc-options: -Wall 122 | if impl (ghc >= 8.0.0) 123 | ghc-options: -Wcompat 124 | 125 | source-repository head 126 | type: git 127 | location: git://github.com/lambdageek/unbound-generics.git 128 | 129 | --------------------------------------------------------------------------------