├── .gitattributes ├── .github ├── dependabot.yml └── workflows │ └── ci.yml ├── .gitignore ├── AUTHORS ├── CHANGELOG ├── LICENSE ├── README.md ├── Setup.hs ├── TODO ├── cabal.project ├── latex ├── Makefile ├── unification-intro-mcmaster.tex └── unification-opt-mcmaster.lhs ├── src ├── Control │ ├── Monad │ │ ├── EitherK.hs │ │ ├── MaybeK.hs │ │ └── State │ │ │ └── UnificationExtras.hs │ ├── Unification.hs │ └── Unification │ │ ├── IntVar.hs │ │ ├── Ranked.hs │ │ ├── Ranked │ │ ├── IntVar.hs │ │ └── STVar.hs │ │ ├── STVar.hs │ │ └── Types.hs └── Data │ └── Functor │ └── Fixedpoint.hs ├── test ├── bench │ └── Control │ │ ├── Unification.hs │ │ └── Unification │ │ ├── Classes.hs │ │ ├── IntVar.hs │ │ └── STVar.hs ├── bench2 │ ├── Codensity-Lib=K.html │ ├── Codensity-Lib=Mb.html │ ├── Codensity.hs │ └── Codensity.html ├── correctness │ └── TestInteractive.hs ├── experiments │ ├── feature-structures │ │ └── FeatureStructure.hs │ ├── putting │ │ ├── PuttingDM.hs │ │ ├── PuttingHR.hs │ │ └── PuttingHRPlus.hs │ └── st-trail │ │ └── Control │ │ └── Monad │ │ └── BacktrackST.hs └── tutorial │ ├── tutorial1.hs │ └── tutorial1.html └── unification-fd.cabal /.gitattributes: -------------------------------------------------------------------------------- 1 | # Ignore all the Criterion-generated html 2 | test/bench2/* linguist-vendored=true 3 | test/tutorial/* linguist-vendored=false -------------------------------------------------------------------------------- /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | # Use Dependabot to automatically generate PRs if the dependencies 2 | # of our GitHub Actions scripts get out of date. For more info, see: 3 | # 4 | # 5 | version: 2 6 | updates: 7 | - package-ecosystem: "github-actions" 8 | directory: "/" 9 | schedule: 10 | interval: "monthly" 11 | commit-message: 12 | prefix: "[CI] " 13 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub Actions script was modified from from: 2 | # 3 | # (commit/bd3c32c784bde80c9a46b22ef0029e668c954e70) 2021-10-09 4 | # with particular changes taken from 5 | # (which has still more stuff we may want to incorporate later). 6 | # 7 | # Once Haskell-CI fully supports generating GitHub Actions scripts, 8 | # we should switch over to using that rather than maintaining this 9 | # file manually. 10 | name: ci 11 | on: 12 | push: 13 | branches: 14 | - master 15 | pull_request: {} 16 | 17 | defaults: 18 | run: 19 | shell: bash 20 | 21 | jobs: 22 | build: 23 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 24 | runs-on: ${{ matrix.os }} 25 | strategy: 26 | fail-fast: true 27 | matrix: 28 | # Note(2021-10-23): All these versions resolve to using the 29 | # latest Cabal (3.4.0.0); they do *not* use the version of 30 | # Cabal that originally shipped with the version of GHC. 31 | os: [ubuntu-latest] 32 | ghc: ['8.6.5', '8.8.4', '8.10.3', '9.0.1', '9.2.4', '9.4.8', '9.6.5', '9.8.2', '9.10.1', '9.12.1'] 33 | include: 34 | # This package has no build details specific to Win/Mac, 35 | # so building for the latest GHC should be sufficient 36 | # (in conjunction with the full list above for Ubuntu). 37 | - os: windows-latest 38 | ghc: 'latest' 39 | - os: macOS-latest 40 | ghc: 'latest' 41 | steps: 42 | - uses: actions/checkout@v4 43 | - uses: haskell-actions/setup@v2.7.9 44 | id: setup-haskell-cabal 45 | with: 46 | ghc-version: ${{ matrix.ghc }} 47 | - name: Update cabal package database 48 | run: cabal update 49 | - name: Configure 50 | # Generates the `cabal.project.local` file. 51 | # We make sure to enable tests & benchmarks here so that when 52 | # we run the tests/benchmarks they don't reconfigure things 53 | # and thus cause rebuilding. 54 | run: cabal configure --minimize-conflict-set --enable-tests --enable-benchmarks --test-show-details=direct 55 | - name: Freeze 56 | # Generates the `cabal.project.freeze` file. 57 | run: cabal freeze 58 | - uses: actions/cache@v4.2.0 59 | name: Cache ~/.cabal/store and ./dist-newstyle 60 | # TODO(2021-10-23): Do we really want the hash in the key? 61 | # With nix-style builds it shouldn't be necessary (afaict), 62 | # and so it reduces the likelihood of cache hits (albeit 63 | # also reducing the footprint of the cache). 64 | with: 65 | path: | 66 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 67 | dist-newstyle 68 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 69 | - name: Install dependencies 70 | run: cabal build all --only-dependencies 71 | - name: Build 72 | run: cabal build all 73 | ## TODO: Add a test suite! 74 | #- name: Test 75 | # run: cabal test all -j1 76 | ## TODO: Add benchmarks! 77 | #- name: Bench 78 | # run: cabal bench --benchmark-option=-l all 79 | - name: Haddock 80 | run: cabal haddock 81 | 82 | # TODO(2021-10-23): Should probably move to using Cirrus instead, 83 | # since that's what bytestring does since: 84 | # (commit/06cbef10f4869c6afdac210a22d9813b4f7f2fe6) 2021-06-10 85 | #build-freebsd: 86 | # # This job intentionally is using macOS because at the time of 87 | # # the writing Linux and Windows environments don't have the 88 | # # necessary virtualization features. 89 | # # See 90 | # runs-on: macos-latest 91 | # steps: 92 | # - uses: actions/checkout@v4 93 | # - name: Test 94 | # id: build-freebsd 95 | # uses: vmactions/freebsd-vm@v0.1.5 96 | # with: 97 | # usesh: true 98 | # mem: 4096 99 | # prepare: pkg install -y ghc hs-cabal-install git 100 | # # Virtual machine does not allow to leverage cache 101 | # # and is quite slow, so only tests are run. 102 | # run: | 103 | # cabal update 104 | # cabal test --test-show-details=direct 105 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore OSX-specific cruft 2 | .DS_Store 3 | 4 | # Ignore Haskell building stuff 5 | .cabal-sandbox/ 6 | cabal.sandbox.config 7 | cabal-dev/ 8 | .hpc/ 9 | *.hi 10 | *.o 11 | *.p_hi 12 | *.prof 13 | *.tix 14 | cabal.config 15 | cabal.project.freeze 16 | cabal.project.local 17 | dist-sandbox 18 | dist/ 19 | dist-newstyle/ 20 | .hsenv/ 21 | 22 | # Ignore editor cruft 23 | .*.swp 24 | .*.swo 25 | *~ 26 | *# 27 | .#* 28 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | === Haskell unification-fd package AUTHORS/THANKS file === 2 | 3 | The unification-fd package was written by wren gayle romano and is 4 | released under the terms in the LICENSE file. 5 | 6 | 7 | === Thanks === 8 | 9 | Christopher Anand --- for partially funding this work at McMaster 10 | University during the summer of 2011. 11 | 12 | Nathaniel W. Filardo --- for helping to figure out the intricacies 13 | of unification in Dyna2 (though this code is at best loosely 14 | based on that work). 15 | 16 | Edward Kmett --- for pointing out the weighted extension to path 17 | compression (popular in the union--find literature), and for 18 | suggsting the switch to having variables be of kind * rather 19 | than *->* 20 | 21 | Roman Cheplyaka --- for suggesting the switching of type parameter 22 | order on UTerm so that it actually is the free monad. And 23 | for providing the freshenAll implementation. 24 | 25 | Graham Rogers --- for suggesting the addition of Functor, Foldable, 26 | and Traversable instances for UnificationFailure. 27 | 28 | === Related Work === 29 | 30 | The two-level types approach was adapted from Tim Sheard[1]. The 31 | initial (simple yet naive) implementation of unification was based 32 | on Sheard's presentation of Cardelli's[2] algorithm in Modula-2. 33 | Efficient backtracking search via the logict library is described 34 | by Kiselyov et al.[3] The idea of functional pointers were independently 35 | discovered by Dijkstra et al.[4] after their apperance in Dyna2. 36 | 37 | 38 | [1] Tim Sheard (2001) /Generic Unification via Two-Level Types and/ 39 | /Parameterized Modules/, Functional Pearl, ICFP. 40 | 41 | [2] Luca Cardelli (1987) /Basic polymorphic typechecking/. Science 42 | of Computer Programming, 8(2):147--172. 43 | 44 | [3] Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, and Amr 45 | Sabry (2005) /Backtracking, Interleaving, and Terminating/ 46 | /Monad Transformers/, ICFP. 47 | 48 | [4] Atze Dijkstra, Arie Middelkoop, S. Doaitse Swierstra (2008) 49 | /Efficient Functional Unification and Substitution/, Technical 50 | Report UU-CS-2008-027, Utrecht University. 51 | -------------------------------------------------------------------------------- /CHANGELOG: -------------------------------------------------------------------------------- 1 | 0.12.0.2 (2025-02-11): 2 | - Updated version upper-bounds for GHC 9.12 3 | 0.12.0.1 (2024-11-26): 4 | - Nudged the version upper bound for logict 5 | 0.12.0 (2024-08-30): 6 | - Switched to using data-fix, which causes several breaking changes. 7 | * The oldest supported GHC is now 8.6.1 (September 2018). 8 | * Several functions exported from "Data.Functor.Fixedpoint" are now deprecated, with error messages indicating the data-fix function to use instead. 9 | * The "Data.Functor.Fixedpoint" module used to have several rewrite rules for fusing various functions (to avoid redundant traversal of data structures); but all of these are no longer active. If this introduces any performance regressions for you, please let the maintainer know. 10 | 11 | 0.11.2.3 (2024-08-29): 12 | - Updated version lower-bounds, to fix https://github.com/wrengr/unification-fd/issues/71 13 | 0.11.2.2 (2024-08-28): 14 | - Updated version upper-bounds for GHC 9.10, and logict-0.8.1 15 | 0.11.2.1 (2022-08-28): 16 | - Updated verion bounds for GHC 9.4 17 | 0.11.2 (2022-05-25): 18 | - Adjusted Applicative/Monad instances to avoid warnings on GHC 9.2 19 | due to 20 | - Adjusted Alternative/MonadPlus similarly, though not strictly required. 21 | - Adjusted the CPP version guard for importing Data.Monoid.(<>) 22 | in Control.Unification.Types, to remove an unused-imports warning 23 | on GHC 8.8 24 | - Relaxed upper bound on logict 25 | 26 | 0.11.1.1 (2021-11-02): 27 | - Added `Tested-With: GHC == 9.2.1` (didn't actually need to 28 | nudge the upper bound on 'base', because it's already lenient) 29 | 0.11.1 (2021-02-24): 30 | - Migrating from TravisCI to GithubActions 31 | - Properly fixed the logict-0.7.1 issue. 32 | 0.11.0 (2021-02-23): 33 | - Made Unifiable derivable whenever we have a Generic1 instance. 34 | (h/t/ Roman Cheplyaka) 35 | - Removed the Alternative/MonadPlus instances for UTerm, because 36 | they're unlawful. 37 | - Added NOINLINE for Fix's Eq and Ord instances, to avoid an 38 | inliner bug affecting GHC 8.0.1 and 8.0.2 (fixed in 8.0.3) 39 | 40 | - HOTFIX: added logict < 0.7.1 upper bound to avoid breakage. 41 | Will add a proper fix in the future. For more details see, 42 | 43 | 0.10.0.1 (2015-05-30): 44 | - Moved VERSION to CHANGELOG 45 | 0.10.0 (2015-03-29): 46 | - Cleaned up things to compile cleanly for GHC 7.10 47 | - Cleaned up deprecation warnings re Control.Monad.Error 48 | - Control.Monad.EitherK: liberalized Monad restriction to 49 | Applicative where possible. 50 | - Control.Monad.MaybeK: liberalized Monad restriction to 51 | Applicative where possible. 52 | - Control.Unification.Types: Completely revamped the old 53 | UnificationFailure data type as the new UFailure data type 54 | and Fallible type class. 55 | 0.9.0 (2014-06-03): 56 | - Control.Unification.Types: changed the fundeps on BindingMonad 57 | and RankedBindingMonad so that things compile under GHC 7.8.2 58 | - Data.Functor.Fixedpoint: eta-expanded RULES to avoid GHC >= 59 | 7.8 warnings about them potentially not firing due to (.) 60 | being inlined first. 61 | 0.8.1 (2014-05-27): 62 | - Control.Unification.Types: added Functor, Foldable, and 63 | Traversable instances for UnificationFailure. (h/t Graham Rogers) 64 | 0.8.0 (2012-07-11): 65 | - Control.Unification.Types: Changed the type of Unifiable.zipMatch 66 | 0.7.0 (2012-03-19): 67 | - Renamed MutTerm to UTerm (and MutVar to UVar) 68 | - Replaced the Variable.eqVar method by plain old Eq.(==) 69 | - Control.Unification: added getFreeVarsAll, applyBindingsAll, 70 | freshenAll 71 | - Swapped type argument order for MutTerm, so that it can be a 72 | functor etc. Also changed BindingMonad, UnificationFailure, 73 | Rank, and RankedBindingMonad for consistency. 74 | 0.6.0 (2012-02-17): 75 | - Removed the phantom type argument for Variables. 76 | 0.5.0 (2011-07-12): 77 | - Moved UnificationFailure to Control.Unification.Types 78 | - Renamed NonUnifiable to TermMismatch 79 | - Control.Unification: exposed fullprune, semiprune, occursIn 80 | - Control.Unification: added unifyOccurs, subsumes 81 | - Control.Unification: (re)added symbolic names for binary operators 82 | 0.4.0 (2011-07-07): 83 | - Removed heterogeneous unification, and rewrote practically everything. 84 | - Added semipruning instead of full pruning. 85 | - Added visited-sets instead of occurs-checks. 86 | - Added weightedness to path compression (a la union--find). 87 | - This is the version emailed for the 2011-07-07 talk at McMaster. 88 | 0.3.6 (2011-06-18): 89 | - Forked from the Dyna2 project. 90 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | === Notes === 2 | 3 | The following license applies to all code in this package. The 4 | module Control.Monad.MaybeK is derived from code on the Haskell 5 | Wiki[1] which was released under a simple permissive license[2]. 6 | 7 | [1] 8 | [2] 9 | 10 | 11 | === unification-fd license === 12 | 13 | Copyright (c) 2007, 2008, 2011, 2012, 2013, 2014, 2017, 2021, wren gayle romano. 14 | ALL RIGHTS RESERVED. 15 | 16 | Redistribution and use in source and binary forms, with or without 17 | modification, are permitted provided that the following conditions 18 | 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 the copyright holders nor the names of 29 | other contributors may be used to endorse or promote products 30 | derived from this software without specific prior written 31 | permission. 32 | 33 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 34 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 35 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 36 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 37 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 38 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 39 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 40 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 41 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 42 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 43 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 44 | POSSIBILITY OF SUCH DAMAGE. 45 | 46 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | unification-fd 2 | ============== 3 | [![CI Status](https://github.com/wrengr/unification-fd/actions/workflows/ci.yml/badge.svg)](https://github.com/wrengr/unification-fd/actions?query=workflow%3Aci+-event%3Apull_request) 4 | [![Hackage version](https://img.shields.io/hackage/v/unification-fd.svg)](https://hackage.haskell.org/package/unification-fd) 5 | [![Stackage LTS version](https://stackage.org/package/unification-fd/badge/lts)](https://stackage.org/lts/package/unification-fd) 6 | [![Stackage Nightly version](https://stackage.org/package/unification-fd/badge/nightly)](https://stackage.org/nightly/package/unification-fd) 7 | 8 | The unification-fd package offers generic functions for single-sorted 9 | first-order structural unification (think of programming in Prolog, 10 | or of the metavariables in type inference)[^1][^2]. The library 11 | *is* sufficient for implementing higher-rank type systems à la 12 | _Peyton Jones, Vytiniotis, Weirich, Shields_, but bear in mind that 13 | unification variables are the metavariables of type inference— not 14 | the type-variables. 15 | 16 | 17 | ## Build Warnings/Errors 18 | 19 | This is a simple package and should be easy to install; however, 20 | on older setups you may encounter some of the following warnings/errors. 21 | If during building you see some stray lines that look like this: 22 | 23 | mkUsageInfo: internal name? t{tv a7XM} 24 | 25 | Feel free to ignore them. They shouldn't cause any problems, even 26 | though they're unsightly. This should be fixed in newer versions 27 | of GHC. For more details, see: 28 | 29 | http://hackage.haskell.org/trac/ghc/ticket/3955 30 | 31 | If you get a bunch of type errors about there being no `MonadLogic` 32 | instance for `StateT`, this means that your copy of the logict 33 | library is not compiled against the same mtl that we're using. To 34 | fix this, update logict to use the same mtl. 35 | 36 | 37 | ## Portability 38 | 39 | An effort has been made to make the package as portable as possible. 40 | However, because it uses the `ST` monad and the mtl-2 package it 41 | can't be H98 nor H2010. However, it only uses the following common 42 | extensions which should be well supported[^3]: 43 | 44 | * Rank2Types 45 | * MultiParamTypeClasses 46 | * FunctionalDependencies - Alas, necessary for type inference. 47 | * FlexibleContexts - Necessary for practical use of MPTCs. 48 | * FlexibleInstances - Necessary for practical use of MPTCs. 49 | * UndecidableInstances - Needed for `Show` instances due to two-level types. 50 | 51 | 52 | ## Description 53 | 54 | The unification API is generic in the type of the structures being 55 | unified and in the implementation of unification variables, following 56 | the two-level types pearl of Sheard (2001). This style mixes well 57 | with Swierstra (2008), though an implementation of the latter is 58 | not included in this package. 59 | 60 | That is, all you have to do is define the functor whose fixed-point 61 | is the recursive type you're interested in: 62 | 63 | -- The non-recursive structure of terms 64 | data S a = ... 65 | 66 | -- The recursive term type 67 | type PureTerm = Fix S 68 | 69 | And then provide an instance for `Unifiable`, where `zipMatch` 70 | performs one level of equality testing for terms and returns the 71 | one-level spine filled with pairs of subterms to be recursively 72 | checked (or `Nothing` if this level doesn't match). 73 | 74 | class (Traversable t) => Unifiable t where 75 | zipMatch :: t a -> t b -> Maybe (t (a,b)) 76 | 77 | The choice of which variable implementation to use is defined by 78 | similarly simple classes `Variable` and `BindingMonad`. We store 79 | the variable bindings in a monad, for obvious reasons. In case it's 80 | not obvious, see Dijkstra et al. (2008) for benchmarks demonstrating 81 | the cost of naively applying bindings eagerly. 82 | 83 | There are currently two implementations of variables provided: one 84 | based on `STRef`s, and another based on a state monad carrying an 85 | `IntMap`. The former has the benefit of O(1) access time, but the 86 | latter is plenty fast and has the benefit of supporting backtracking. 87 | Backtracking itself is provided by the logict package and is described 88 | in Kiselyov et al. (2005). 89 | 90 | In addition to this modularity, unification-fd implements a number 91 | of optimizations over the algorithm presented in Sheard (2001)— 92 | which is also the algorithm presented in Cardelli (1987). 93 | 94 | * Their implementation uses path compression, which we retain. 95 | Though we modify the compression algorithm in order to make 96 | sharing observable. 97 | * In addition, we perform aggressive opportunistic observable 98 | sharing, a potentially novel method of introducing even more 99 | sharing than is provided by the monadic bindings. Basically, 100 | we make it so that we can use the observable sharing provided 101 | by the modified path compression as much as possible (without 102 | introducing any new variables). 103 | * And we remove the notoriously expensive occurs-check, replacing 104 | it with visited-sets (which detect cyclic terms more lazily and 105 | without the asymptotic overhead of the occurs-check). A variant 106 | of unification which retains the occurs-check is also provided, 107 | in case you really need to fail fast. 108 | * Finally, a highly experimental branch of the API performs *weighted* 109 | path compression, which is asymptotically optimal. Unfortunately, 110 | the current implementation is quite a bit uglier than the 111 | unweighted version, and I haven't had a chance to perform 112 | benchmarks to see how the constant factors compare. Hence moving 113 | it to an experimental branch. 114 | 115 | These optimizations pass a test suite for detecting obvious errors. 116 | If you find any bugs, do be sure to let me know. Also, if you happen 117 | to have a test suite or benchmark suite for unification on hand, 118 | I'd love to get a copy. 119 | 120 | 121 | ## Notes and limitations 122 | 123 | [^1]: At present the library does not appear amenable for implementing 124 | higher-rank unification itself; i.e., for higher-ranked metavariables, 125 | or higher-ranked logic programming. To be fully general we'd have 126 | to abstract over which structural positions are co/contravariant, 127 | whether the unification variables should be predicative or 128 | impredicative, as well as the isomorphisms of moving quantifiers 129 | around. It's on my todo list, but it's certainly non-trivial. If 130 | you have any suggestions, feel free to contact me. 131 | 132 | [^2]: At present it is only suitable for single-sorted (aka untyped) 133 | unification, à la Prolog. In the future I aim to support multi-sorted 134 | (aka typed) unification, however doing so is complicated by the 135 | fact that it can lead to the loss of MGUs; so it will likely be 136 | offered as an alternative to the single-sorted variant, similar to 137 | how the weighted path-compression is currently offered as an 138 | alternative. 139 | 140 | [^3]: With the exception of fundeps which are notoriously difficult 141 | to implement. However, they are supported by Hugs and GHC 6.6, so 142 | I don't feel bad about requiring them. Once the API stabilizes a 143 | bit more I plan to release a unification-tf package which uses type 144 | families instead, for those who feel type families are easier to 145 | implement or use. There have been a couple requests for unification-tf, 146 | so I've bumped it up on my todo list. 147 | 148 | 149 | ## References 150 | 151 |
152 |
Luca Cardelli (1987)
154 |
Basic polymorphic typechecking. 155 | Science of Computer Programming, 8(2): 147–172.
156 |
Atze Dijkstra, Arie Middelkoop, S. Doaitse Swierstra (2008)
159 |
Efficient Functional Unification and Substitution. 160 | Technical Report UU-CS-2008-027, Utrecht University.
161 |
Simon Peyton Jones, Dimitrios Vytiniotis, Stephanie Weirich, Mark 164 | Shields (2007)
165 |
Practical type inference for arbitrary-rank types. 166 | JFP 17(1). The online version has some minor corrections/clarifications.
167 |
Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, and Amr Sabry (2005)
170 |
Backtracking, Interleaving, and Terminating Monad Transformers. 171 | ICFP.
172 |
Tim Sheard (2001)
175 |
Generic Unification via Two-Level Types and Parameterized Modules, 176 | Functional Pearl. ICFP.
177 |
Tim Sheard and Emir Pasalic (2004)
180 |
Two-Level Types and Parameterized Modules. 181 | JFP 14(5): 547–587. 182 | This is an expanded version of Sheard (2001) with new examples.
183 |
Wouter Swierstra (2008)
186 |
Data types à la carte, 187 | Functional Pearl. JFP 18: 423–436.
188 |
189 | 190 | 191 | ## Links 192 | 193 | * [Website](https://wrengr.org/) 194 | * [Blog](http://winterkoninkje.dreamwidth.org/) 195 | * [Twitter](https://twitter.com/wrengr) 196 | * [Hackage](http://hackage.haskell.org/package/unification-fd) 197 | * [GitHub](https://github.com/wrengr/unification-fd) 198 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | module Main (main) where 4 | import Distribution.Simple 5 | 6 | main :: IO () 7 | main = defaultMain 8 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Bugs: 2 | * fix the situation re UnificationFailure, monoids, and ErrorT vs ExceptT. 3 | 4 | Debugging: 5 | * Create a test suite to be sure of correctness & usability. 6 | * Combine the test suite into a single executable and then do: 7 | $> darcs setpref test "runhaskell Tests.hs" 8 | * Also, tell Setup.hs so that `cabal test` and `runhaskell 9 | Setup.hs test` call the test suite. 10 | 11 | Enhancements: 12 | * Add a fast occurs check for looking at the whole binding state (outside of unifications) 13 | 14 | Sooner than later: 15 | * Proper benchmarking. Especially for the union--find enhancement 16 | 17 | Eventually: 18 | * Antiunification? 19 | * Disunification? 20 | * Higher-rank unification (in a way that generalizes over contravariance and im/predicativity issues)? 21 | * Typed unification? (is there a clean way to do it without HList-style hackery?) 22 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | tests: True 3 | -------------------------------------------------------------------------------- /latex/Makefile: -------------------------------------------------------------------------------- 1 | FILES=\ 2 | unification-intro-mcmaster \ 3 | unification-opt-mcmaster 4 | 5 | EXTRA_FILES={dvi,ps,ptb} 6 | 7 | .SUFFIXES: 8 | .PHONY: all clean realclean 9 | 10 | all: 11 | @# TODO: update latexmk to call lhs2TeX? 12 | for f in ${FILES} ; do \ 13 | if [ -e "$$f.lhs" ] ; then \ 14 | lhs2TeX "$$f".lhs -o "$$f".tex || break ;\ 15 | fi ;\ 16 | latexmk -pdfps "$$f".tex || break ;\ 17 | done 18 | 19 | clean: 20 | for f in ${FILES} ; do \ 21 | latexmk -c "$$f".tex || break ;\ 22 | done 23 | 24 | realclean: 25 | @# TODO: also remove BibTeX logs, makeindex logs,... 26 | @# TODO: update latexmk to remove all these... 27 | for f in ${FILES} ; do \ 28 | if [ -e "$$f".tex ] ; then \ 29 | latexmk -C "$$f".tex || break ;\ 30 | fi ;\ 31 | rm -f "$$f".${EXTRA_FILES} || break ;\ 32 | if [ -e "$$f".lhs ] ; then \ 33 | rm -f "$$f".tex || break ;\ 34 | fi ;\ 35 | done 36 | -------------------------------------------------------------------------------- /src/Control/Monad/EitherK.hs: -------------------------------------------------------------------------------- 1 | -- The MPTCs and FlexibleInstances are only for 2 | -- mtl:Control.Monad.{Error,Except}.MonadError 3 | {-# LANGUAGE CPP, Rank2Types, MultiParamTypeClasses, FlexibleInstances #-} 4 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 5 | ---------------------------------------------------------------- 6 | -- ~ 2021.11.07 7 | -- | 8 | -- Module : Control.Monad.EitherK 9 | -- License : BSD 10 | -- Maintainer : wren@cpan.org 11 | -- Stability : provisional 12 | -- Portability : semi-portable (CPP, Rank2Types, MPTCs, FlexibleInstances) 13 | -- 14 | -- A continuation-passing variant of 'Either' for short-circuiting 15 | -- at failure. This code is based on "Control.Monad.MaybeK". 16 | ---------------------------------------------------------------- 17 | module Control.Monad.EitherK 18 | ( 19 | -- * The short-circuiting monad 20 | EitherK() 21 | , runEitherK 22 | , toEitherK 23 | , eitherK 24 | , throwEitherK 25 | , catchEitherK 26 | -- * The short-circuiting monad transformer 27 | , EitherKT() 28 | , runEitherKT 29 | , toEitherKT 30 | , liftEitherK 31 | , lowerEitherK 32 | , throwEitherKT 33 | , catchEitherKT 34 | ) where 35 | 36 | #if __GLASGOW_HASKELL__ < 710 37 | import Data.Monoid (Monoid(..)) 38 | import Control.Applicative (Applicative(..)) 39 | #endif 40 | import Control.Applicative (Alternative(..)) 41 | import Control.Monad (MonadPlus(..)) 42 | import Control.Monad.Trans (MonadTrans(..)) 43 | #if (MIN_VERSION_mtl(2,2,1)) 44 | -- aka: transformers(0,4,1) 45 | import Control.Monad.Except (MonadError(..)) 46 | #else 47 | import Control.Monad.Error (MonadError(..)) 48 | #endif 49 | ---------------------------------------------------------------- 50 | ---------------------------------------------------------------- 51 | 52 | -- | A continuation-passing encoding of 'Either' as an error monad; 53 | -- also known as @Codensity (Either e)@, if you're familiar with 54 | -- that terminology. N.B., this is not the 2-continuation implementation 55 | -- based on the Church encoding of @Either@. The latter tends to 56 | -- have worse performance than non-continuation based implementations. 57 | -- 58 | -- This is generally more efficient than using @Either@ (or the 59 | -- MTL's @Error@) for two reasons. First is that it right associates 60 | -- all binds, ensuring that bad associativity doesn't artificially 61 | -- introduce midpoints in short-circuiting to the nearest handler. 62 | -- Second is that it removes the need for intermediate case 63 | -- expressions. 64 | -- 65 | -- Another benefit over MTL's @Error@ is that it doesn't artificially 66 | -- restrict the error type. In fact, there's no reason why @e@ must 67 | -- denote \"errors\" per se. This could also denote computations 68 | -- which short-circuit with the final answer, or similar methods 69 | -- of non-local control flow. 70 | -- 71 | -- N.B., the 'Alternative' and 'MonadPlus' instances are left-biased 72 | -- in @a@ and monoidal in @e@. Thus, they are not commutative. 73 | newtype EitherK e a = EK (forall r. (a -> Either e r) -> Either e r) 74 | 75 | 76 | -- | Execute an @EitherK@ and return the concrete @Either@ encoding. 77 | runEitherK :: EitherK e a -> Either e a 78 | {-# INLINE runEitherK #-} 79 | runEitherK (EK m) = m Right 80 | 81 | 82 | -- | Lift an @Either@ into an @EitherK@. 83 | toEitherK :: Either e a -> EitherK e a 84 | {-# INLINE toEitherK #-} 85 | toEitherK (Left e) = throwEitherK e 86 | toEitherK (Right a) = return a 87 | 88 | 89 | -- | Throw an error in the @EitherK@ monad. This is identical to 90 | -- 'throwError'. 91 | throwEitherK :: e -> EitherK e a 92 | {-# INLINE throwEitherK #-} 93 | throwEitherK e = EK (\_ -> Left e) 94 | 95 | 96 | -- | Handle errors in the @EitherK@ monad. N.B., this type is more 97 | -- general than that of 'catchError', allowing the type of the 98 | -- errors to change. 99 | catchEitherK :: EitherK e a -> (e -> EitherK f a) -> EitherK f a 100 | {-# INLINE catchEitherK #-} 101 | catchEitherK m handler = eitherK handler return m 102 | 103 | 104 | -- | A version of 'either' on @EitherK@, for convenience. N.B., 105 | -- using this function inserts a case match, reducing the range of 106 | -- short-circuiting. 107 | eitherK :: (e -> b) -> (a -> b) -> EitherK e a -> b 108 | {-# INLINE eitherK #-} 109 | eitherK left right m = 110 | case runEitherK m of 111 | Left e -> left e 112 | Right a -> right a 113 | 114 | 115 | instance Functor (EitherK e) where 116 | fmap f (EK m) = EK (\k -> m (k . f)) 117 | x <$ EK m = EK (\k -> m (\_ -> k x)) 118 | 119 | instance Applicative (EitherK e) where 120 | pure x = EK (\k -> k x) 121 | EK m <*> EK n = EK (\k -> m (\f -> n (k . f))) 122 | EK m *> EK n = EK (\k -> m (\_ -> n k)) 123 | EK m <* EK n = EK (\k -> m (\x -> n (\_ -> k x))) 124 | 125 | -- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. 126 | -- Since ghc-9.2.1 we get a warning about providing any other 127 | -- definition, and should instead define both 'pure' and @(*>)@ 128 | -- directly, leaving 'return' and @(>>)@ as their defaults so they 129 | -- can eventually be removed from the class. 130 | -- 131 | -- 132 | -- However, base-4.16 (ghc-9.2.1) still uses the @m >> n = m >>= \_ -> n@ 133 | -- default. In principle, that ought to compile down to the same 134 | -- thing as our @(*>)@; however, there's a decent chance the case 135 | -- analysis on @n@ won't get lifted out from under the lambdas, and 136 | -- thus the default definition would loose the strictness of the 137 | -- second argument. Therefore, we're going to keep defining @(>>)@ 138 | -- until whatever future version of GHC actually removes it from 139 | -- the class to make it a proper alias of @(*>)@. 140 | instance Monad (EitherK e) where 141 | #if (!(MIN_VERSION_base(4,8,0))) 142 | return = pure 143 | #endif 144 | (>>) = (*>) 145 | EK m >>= f = EK (\k -> m (\a -> case f a of EK n -> n k)) 146 | -- Using case instead of let seems to improve performance 147 | -- considerably by removing excessive laziness. 148 | 149 | -- TODO: is there anything to optimize over the default definitions 150 | -- of 'some' and 'many'? 151 | instance (Monoid e) => Alternative (EitherK e) where 152 | empty = throwEitherK mempty 153 | m <|> n = catchEitherK m $ \me -> 154 | catchEitherK n $ \ne -> 155 | throwEitherK $ me `mappend` ne 156 | 157 | instance (Monoid e) => MonadPlus (EitherK e) 158 | #if (!(MIN_VERSION_base(4,8,0))) 159 | where 160 | mzero = empty 161 | mplus = (<|>) 162 | #endif 163 | 164 | instance MonadError e (EitherK e) where 165 | throwError = throwEitherK 166 | catchError = catchEitherK 167 | 168 | ---------------------------------------------------------------- 169 | ---------------------------------------------------------------- 170 | 171 | -- | A monad transformer version of 'EitherK'. 172 | newtype EitherKT e m a = 173 | EKT (forall r. (a -> m (Either e r)) -> m (Either e r)) 174 | 175 | 176 | -- | Execute an @EitherKT@ and return the concrete @Either@ encoding. 177 | runEitherKT :: (Applicative m) => EitherKT e m a -> m (Either e a) 178 | {-# INLINE runEitherKT #-} 179 | runEitherKT (EKT m) = m (pure . Right) 180 | 181 | 182 | -- | Lift an @Either@ into an @EitherKT@. 183 | toEitherKT :: (Applicative m) => Either e a -> EitherKT e m a 184 | {-# INLINE toEitherKT #-} 185 | toEitherKT (Left e) = throwEitherKT e 186 | toEitherKT (Right a) = pure a 187 | 188 | 189 | -- | Lift an @EitherK@ into an @EitherKT@. 190 | liftEitherK :: (Applicative m) => EitherK e a -> EitherKT e m a 191 | {-# INLINE liftEitherK #-} 192 | liftEitherK = toEitherKT . runEitherK 193 | -- 194 | -- With the above implementation, when @liftEitherK x@ is forced 195 | -- it will force not only @x = EK m@, but will also force @m@. If 196 | -- we want to force only @x@ and to defer @m@, then we should use 197 | -- the following implementation instead: 198 | -- 199 | -- > liftEitherK (EK m) = EKT (\k -> either (return . Left) k (m Right)) 200 | -- 201 | -- Or if we want to defer both @m@ and @x@, then we could use: 202 | -- 203 | -- > liftEitherK x = EKT (\k -> either (return . Left) k (runEitherK x)) 204 | -- 205 | -- However, all versions need to reify @m@ at some point, and 206 | -- therefore will lose short-circuiting. This is necessary since 207 | -- given some @k :: a -> m (Either e r)@ we have no way of constructing 208 | -- the needed @k' :: a -> Either e r@ from it without prematurely 209 | -- executing the side-effects. 210 | 211 | 212 | -- | Lower an @EitherKT@ into an @EitherK@. 213 | lowerEitherK :: (Applicative m) => EitherKT e m a -> m (EitherK e a) 214 | {-# INLINE lowerEitherK #-} 215 | lowerEitherK = fmap toEitherK . runEitherKT 216 | 217 | 218 | -- | Throw an error in the @EitherKT@ monad. This is identical to 219 | -- 'throwError'. 220 | throwEitherKT :: (Applicative m) => e -> EitherKT e m a 221 | {-# INLINE throwEitherKT #-} 222 | throwEitherKT e = EKT (\_ -> pure (Left e)) 223 | 224 | 225 | -- | Handle errors in the @EitherKT@ monad. N.B., this type is more 226 | -- general than that of 'catchError', allowing the type of the 227 | -- errors to change. 228 | catchEitherKT 229 | :: (Applicative m, Monad m) 230 | => EitherKT e m a -> (e -> EitherKT f m a) -> EitherKT f m a 231 | {-# INLINE catchEitherKT #-} 232 | catchEitherKT m handler = EKT $ \k -> 233 | runEitherKT m >>= \ea -> 234 | case ea of 235 | Left e -> case handler e of EKT n -> n k 236 | Right a -> k a 237 | 238 | 239 | instance Functor (EitherKT e m) where 240 | fmap f (EKT m) = EKT (\k -> m (k . f)) 241 | x <$ EKT m = EKT (\k -> m (\_ -> k x)) 242 | 243 | instance Applicative (EitherKT e m) where 244 | pure x = EKT (\k -> k x) 245 | EKT m <*> EKT n = EKT (\k -> m (\f -> n (k . f))) 246 | EKT m *> EKT n = EKT (\k -> m (\_ -> n k)) 247 | EKT m <* EKT n = EKT (\k -> m (\x -> n (\_ -> k x))) 248 | 249 | instance Monad (EitherKT e m) where 250 | #if (!(MIN_VERSION_base(4,8,0))) 251 | return = pure 252 | #endif 253 | (>>) = (*>) 254 | EKT m >>= f = EKT (\k -> m (\a -> case f a of EKT n -> n k)) 255 | 256 | -- In order to define a @(<|>)@ which only requires @Applicative m@ 257 | -- we'd need a law @m (Either e a) -> Either (m e) (m a)@; or 258 | -- equivalently, we'd need to use a 2-CPS style. 259 | instance (Applicative m, Monad m, Monoid e) => Alternative (EitherKT e m) where 260 | empty = throwEitherKT mempty 261 | m <|> n = catchEitherKT m (catchEitherKT n . (throwEitherKT .) . mappend) 262 | 263 | instance (Applicative m, Monad m, Monoid e) => MonadPlus (EitherKT e m) 264 | #if (!(MIN_VERSION_base(4,8,0))) 265 | where 266 | mzero = empty 267 | mplus = (<|>) 268 | #endif 269 | 270 | instance (Applicative m, Monad m) => MonadError e (EitherKT e m) where 271 | throwError = throwEitherKT 272 | catchError = catchEitherKT 273 | 274 | instance MonadTrans (EitherKT e) where 275 | lift m = EKT (\k -> m >>= k) 276 | 277 | ---------------------------------------------------------------- 278 | ----------------------------------------------------------- fin. 279 | -------------------------------------------------------------------------------- /src/Control/Monad/MaybeK.hs: -------------------------------------------------------------------------------- 1 | -- The MPTCs is only for mtl:Control.Monad.Error.MonadError 2 | {-# LANGUAGE CPP, Rank2Types, MultiParamTypeClasses #-} 3 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 4 | ---------------------------------------------------------------- 5 | -- ~ 2021.11.07 6 | -- | 7 | -- Module : Control.Monad.MaybeK 8 | -- License : BSD 9 | -- Maintainer : wren@cpan.org 10 | -- Stability : provisional 11 | -- Portability : semi-portable (CPP, Rank2Types, MPTCs) 12 | -- 13 | -- A continuation-passing variant of 'Maybe' for short-circuiting 14 | -- at failure. This is based largely on code from the Haskell Wiki 15 | -- () which 16 | -- was released under a simple permissive license 17 | -- (). 18 | -- However, various changes and extensions have been made, which 19 | -- are subject to the BSD license of this package. 20 | ---------------------------------------------------------------- 21 | module Control.Monad.MaybeK 22 | ( 23 | -- * The partiality monad 24 | MaybeK 25 | , runMaybeK 26 | , toMaybeK 27 | , maybeK 28 | -- * The partiality monad transformer 29 | , MaybeKT 30 | , runMaybeKT 31 | , toMaybeKT 32 | , liftMaybeK 33 | , lowerMaybeK 34 | ) where 35 | 36 | #if __GLASGOW_HASKELL__ < 710 37 | import Control.Applicative (Applicative(..)) 38 | #endif 39 | import Control.Applicative (Alternative(..)) 40 | import Control.Monad (MonadPlus(..)) 41 | import Control.Monad.Trans (MonadTrans(..)) 42 | #if (MIN_VERSION_mtl(2,2,1)) 43 | -- aka: transformers(0,4,1) 44 | import Control.Monad.Except (MonadError(..)) 45 | #else 46 | import Control.Monad.Error (MonadError(..)) 47 | #endif 48 | ---------------------------------------------------------------- 49 | ---------------------------------------------------------------- 50 | 51 | -- | A continuation-passing encoding of 'Maybe'; also known as 52 | -- @Codensity Maybe@, if you're familiar with that terminology. 53 | -- N.B., this is not the 2-continuation implementation based on the 54 | -- Church encoding of @Maybe@. The latter tends to have worse 55 | -- performance than non-continuation based implementations. 56 | -- 57 | -- This is generally more efficient than using @Maybe@ for two 58 | -- reasons. First is that it right associates all binds, ensuring 59 | -- that bad associativity doesn't artificially introduce midpoints 60 | -- in short-circuiting to the nearest handler. Second is that it 61 | -- removes the need for intermediate case expressions. 62 | -- 63 | -- N.B., the 'Alternative' and 'MonadPlus' instances are left-biased 64 | -- in @a@. Thus, they are not commutative. 65 | newtype MaybeK a = MK (forall r. (a -> Maybe r) -> Maybe r) 66 | 67 | 68 | -- | Execute the @MaybeK@ and return the concrete @Maybe@ encoding. 69 | runMaybeK :: MaybeK a -> Maybe a 70 | {-# INLINE runMaybeK #-} 71 | runMaybeK (MK m) = m return 72 | 73 | 74 | -- | Lift a @Maybe@ into @MaybeK@. 75 | toMaybeK :: Maybe a -> MaybeK a 76 | {-# INLINE toMaybeK #-} 77 | toMaybeK Nothing = mzero 78 | toMaybeK (Just a) = return a 79 | 80 | 81 | -- | A version of 'maybe' for convenience. This is almost identical 82 | -- to 'mplus' but allows applying a continuation to @Just@ values 83 | -- as well as handling @Nothing@ errors. If you only want to handle 84 | -- the errors, use 'mplus' instead. 85 | maybeK :: b -> (a -> b) -> MaybeK a -> b 86 | {-# INLINE maybeK #-} 87 | maybeK nothing just m = 88 | case runMaybeK m of 89 | Nothing -> nothing 90 | Just a -> just a 91 | 92 | 93 | instance Functor MaybeK where 94 | fmap f (MK m) = MK (\k -> m (k . f)) 95 | x <$ MK m = MK (\k -> m (\_ -> k x)) 96 | 97 | instance Applicative MaybeK where 98 | pure x = MK (\k -> k x) 99 | MK m <*> MK n = MK (\k -> m (\f -> n (k . f))) 100 | MK m *> MK n = MK (\k -> m (\_ -> n k)) 101 | MK m <* MK n = MK (\k -> m (\x -> n (\_ -> k x))) 102 | 103 | -- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. 104 | -- Since ghc-9.2.1 we get a warning about providing any other 105 | -- definition, and should instead define both 'pure' and @(*>)@ 106 | -- directly, leaving 'return' and @(>>)@ as their defaults so they 107 | -- can eventually be removed from the class. 108 | -- 109 | -- 110 | -- However, base-4.16 (ghc-9.2.1) still uses the @m >> n = m >>= \_ -> n@ 111 | -- default. In principle, that ought to compile down to the same 112 | -- thing as our @(*>)@; however, there's a decent chance the case 113 | -- analysis on @n@ won't get lifted out from under the lambdas, and 114 | -- thus the default definition would loose the strictness of the 115 | -- second argument. Therefore, we're going to keep defining @(>>)@ 116 | -- until whatever future version of GHC actually removes it from 117 | -- the class to make it a proper alias of @(*>)@. 118 | instance Monad MaybeK where 119 | #if (!(MIN_VERSION_base(4,8,0))) 120 | return = pure 121 | #endif 122 | (>>) = (*>) 123 | MK m >>= f = MK (\k -> m (\a -> case f a of MK n -> n k)) 124 | -- Using case instead of let seems to improve performance 125 | -- considerably by removing excessive laziness. 126 | 127 | -- This is non-commutative, but it's the same as Alternative Maybe. 128 | instance Alternative MaybeK where 129 | empty = MK (\_ -> Nothing) 130 | m <|> n = maybeK n pure m 131 | 132 | instance MonadPlus MaybeK 133 | #if (!(MIN_VERSION_base(4,8,0))) 134 | where 135 | mzero = empty 136 | mplus = (<|>) 137 | #endif 138 | 139 | instance MonadError () MaybeK where 140 | throwError _ = mzero 141 | catchError m f = maybeK (f ()) return m 142 | 143 | ---------------------------------------------------------------- 144 | 145 | -- | A monad transformer version of 'MaybeK'. 146 | newtype MaybeKT m a = MKT (forall r . (a -> m (Maybe r)) -> m (Maybe r)) 147 | 148 | 149 | -- | Execute a @MaybeKT@ and return the concrete @Maybe@ encoding. 150 | runMaybeKT :: (Applicative m) => MaybeKT m a -> m (Maybe a) 151 | {-# INLINE runMaybeKT #-} 152 | runMaybeKT (MKT m) = m (pure . Just) 153 | 154 | 155 | -- | Lift a @Maybe@ into an @MaybeKT@. 156 | toMaybeKT :: (Applicative m) => Maybe a -> MaybeKT m a 157 | {-# INLINE toMaybeKT #-} 158 | toMaybeKT Nothing = MKT (\_ -> pure Nothing) 159 | toMaybeKT (Just a) = pure a 160 | 161 | 162 | -- | Lift an @MaybeK@ into an @MaybeKT@. 163 | liftMaybeK :: (Applicative m) => MaybeK a -> MaybeKT m a 164 | {-# INLINE liftMaybeK #-} 165 | liftMaybeK = toMaybeKT . runMaybeK 166 | -- 167 | -- With the above implementation, when @liftMaybeK x@ is forced it 168 | -- will force not only @x = MK m@, but will also force @m@. If we 169 | -- want to force only @x@ and to defer @m@, then we should use the 170 | -- following implementation instead: 171 | -- 172 | -- > liftMaybeK (MK m) = MKT (\k -> maybe (return Nothing) k (m Just)) 173 | -- 174 | -- Or if we want to defer both @m@ and @x@, then we could use: 175 | -- 176 | -- > liftMaybeK x = MKT (\k -> maybe (return Nothing) k (runMaybeK x)) 177 | -- 178 | -- However, all versions need to reify @m@ at some point, and 179 | -- therefore will lose short-circuiting. This is necessary since 180 | -- given some @k :: a -> m (Maybe r)@ we have no way of constructing 181 | -- the needed @k' :: a -> Maybe r@ from it without prematurely 182 | -- executing the side-effects. 183 | 184 | 185 | -- | Lower an @MaybeKT@ into an @MaybeK@. 186 | lowerMaybeK :: (Applicative m) => MaybeKT m a -> m (MaybeK a) 187 | {-# INLINE lowerMaybeK #-} 188 | lowerMaybeK = fmap toMaybeK . runMaybeKT 189 | 190 | 191 | instance Functor (MaybeKT m) where 192 | fmap f (MKT m) = MKT (\k -> m (k . f)) 193 | x <$ MKT m = MKT (\k -> m (\_ -> k x)) 194 | 195 | instance Applicative (MaybeKT m) where 196 | pure x = MKT (\k -> k x) 197 | MKT m <*> MKT n = MKT (\k -> m (\f -> n (k . f))) 198 | MKT m *> MKT n = MKT (\k -> m (\_ -> n k)) 199 | MKT m <* MKT n = MKT (\k -> m (\x -> n (\_ -> k x))) 200 | 201 | instance Monad (MaybeKT m) where 202 | #if (!(MIN_VERSION_base(4,8,0))) 203 | return = pure 204 | #endif 205 | (>>) = (*>) 206 | MKT m >>= f = MKT (\k -> m (\a -> case f a of MKT n -> n k)) 207 | 208 | -- In order to define a @(<|>)@ which only requires @Applicative m@ 209 | -- we'd need a law @m (Either e a) -> Either (m e) (m a)@; or 210 | -- equivalently, we'd need to use a 2-CPS style. 211 | instance (Applicative m, Monad m) => Alternative (MaybeKT m) where 212 | empty = MKT (\_ -> pure Nothing) 213 | m <|> n = MKT $ \k -> 214 | runMaybeKT m >>= \mb -> 215 | case mb of 216 | Nothing -> case n of MKT n' -> n' k 217 | Just a -> k a 218 | 219 | instance (Applicative m, Monad m) => MonadPlus (MaybeKT m) 220 | #if (!(MIN_VERSION_base(4,8,0))) 221 | where 222 | mzero = empty 223 | mplus = (<|>) 224 | #endif 225 | 226 | instance (Applicative m, Monad m) => MonadError () (MaybeKT m) where 227 | throwError _ = mzero 228 | catchError m f = MKT $ \k -> 229 | runMaybeKT m >>= \mb -> 230 | case mb of 231 | Nothing -> case f () of MKT n -> n k 232 | Just a -> k a 233 | 234 | instance MonadTrans MaybeKT where 235 | lift m = MKT (\k -> m >>= k) 236 | 237 | ---------------------------------------------------------------- 238 | ----------------------------------------------------------- fin. 239 | -------------------------------------------------------------------------------- /src/Control/Monad/State/UnificationExtras.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 3 | ---------------------------------------------------------------- 4 | -- ~ 2021.10.17 5 | -- | 6 | -- Module : Control.Monad.State.UnificationExtras 7 | -- Copyright : Copyright (c) 2008--2021 wren gayle romano 8 | -- License : BSD 9 | -- Maintainer : wren@cpan.org 10 | -- Stability : perpetually unstable 11 | -- Portability : semi-portable (MPTCs) 12 | -- 13 | -- This module defines some extra functions for "Control.Monad.State.Lazy". 14 | -- This package really isn't the proper place for these, but we 15 | -- need them to be somewhere. 16 | -- 17 | -- TODO: patch transformers\/mtl-2 with these functions. 18 | ---------------------------------------------------------------- 19 | module Control.Monad.State.UnificationExtras 20 | ( 21 | -- * Additional functions for MTL 22 | liftReader 23 | , liftReaderT 24 | , modify' 25 | , localState 26 | ) where 27 | 28 | import Control.Monad (liftM) 29 | import Control.Monad.Reader (Reader(), ReaderT(..)) 30 | import Control.Monad.State.Lazy (MonadState(..), State(), StateT(..)) 31 | 32 | ---------------------------------------------------------------- 33 | ---------------------------------------------------------------- 34 | 35 | -- | Lift a reader into a state monad. More particularly, this 36 | -- allows disabling mutability in a local context within @StateT@. 37 | liftReaderT :: (Monad m) => ReaderT e m a -> StateT e m a 38 | {-# INLINE liftReaderT #-} 39 | liftReaderT r = StateT $ \e -> liftM (\a -> (a,e)) (runReaderT r e) 40 | 41 | 42 | -- | Lift a reader into a state monad. More particularly, this 43 | -- allows disabling mutability in a local context within @State@. 44 | liftReader :: Reader e a -> State e a 45 | {-# INLINE liftReader #-} 46 | liftReader = liftReaderT 47 | 48 | 49 | -- | A strict version of 'Control.Monad.State.modify'. 50 | modify' :: (MonadState s m) => (s -> s) -> m () 51 | {-# INLINE modify' #-} 52 | modify' f = do 53 | s <- get 54 | put $! f s 55 | 56 | 57 | -- | Run a state action and undo the state changes at the end. 58 | localState :: (MonadState s m) => m a -> m a 59 | {-# INLINE localState #-} 60 | localState m = do 61 | s <- get 62 | x <- m 63 | put s 64 | return x 65 | 66 | ---------------------------------------------------------------- 67 | ----------------------------------------------------------- fin. 68 | -------------------------------------------------------------------------------- /src/Control/Unification/IntVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP 2 | , MultiParamTypeClasses 3 | , FlexibleInstances 4 | , UndecidableInstances 5 | #-} 6 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 7 | ---------------------------------------------------------------- 8 | -- ~ 2024-11-20 9 | -- | 10 | -- Module : Control.Unification.IntVar 11 | -- Copyright : Copyright (c) 2007--2024 wren gayle romano 12 | -- License : BSD 13 | -- Maintainer : wren@cpan.org 14 | -- Stability : experimental 15 | -- Portability : semi-portable (MPTCs,...) 16 | -- 17 | -- This module defines a state monad for functional pointers 18 | -- represented by integers as keys into an @IntMap@. This technique 19 | -- was independently discovered by Dijkstra et al. This module 20 | -- extends the approach by using a state monad transformer, which 21 | -- can be made into a backtracking state monad by setting the 22 | -- underlying monad to some 'MonadLogic' (part of the @logict@ 23 | -- library, described by Kiselyov et al.). 24 | -- 25 | -- * Atze Dijkstra, Arie Middelkoop, S. Doaitse Swierstra (2008) 26 | -- /Efficient Functional Unification and Substitution/, 27 | -- Technical Report UU-CS-2008-027, Utrecht University. 28 | -- 29 | -- * Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, and 30 | -- Amr Sabry (2005) /Backtracking, Interleaving, and/ 31 | -- /Terminating Monad Transformers/, ICFP. 32 | ---------------------------------------------------------------- 33 | module Control.Unification.IntVar 34 | ( IntVar(..) 35 | , IntBindingState() 36 | , IntBindingT() 37 | , runIntBindingT 38 | , evalIntBindingT 39 | , execIntBindingT 40 | ) where 41 | 42 | import Prelude hiding (mapM, sequence, foldr, foldr1, foldl, foldl1) 43 | 44 | import qualified Data.IntMap as IM 45 | import Control.Applicative 46 | import Control.Monad (MonadPlus(..), liftM) 47 | import Control.Monad.Trans (MonadTrans(..)) 48 | import Control.Monad.State (MonadState(..), StateT, runStateT, evalStateT, execStateT, gets) 49 | import Control.Monad.Logic (MonadLogic(..)) 50 | import Control.Unification.Types 51 | ---------------------------------------------------------------- 52 | ---------------------------------------------------------------- 53 | 54 | -- | A \"mutable\" unification variable implemented by an integer. 55 | -- This provides an entirely pure alternative to truly mutable 56 | -- alternatives (like @STVar@), which can make backtracking easier. 57 | -- 58 | -- N.B., because this implementation is pure, we can use it for 59 | -- both ranked and unranked monads. 60 | newtype IntVar = IntVar Int 61 | deriving (Show, Eq) 62 | 63 | {- 64 | -- BUG: This part works, but we'd want to change Show IntBindingState too. 65 | 66 | instance Show IntVar where 67 | show (IntVar i) = "IntVar " ++ show (boundedInt2Word i) 68 | 69 | -- | Convert an integer to a word, via the continuous mapping that 70 | -- preserves @minBound@ and @maxBound@. 71 | boundedInt2Word :: Int -> Word 72 | boundedInt2Word i 73 | | i < 0 = fromIntegral (i + maxBound + 1) 74 | | otherwise = fromIntegral i + fromIntegral (maxBound :: Int) + 1 75 | -} 76 | 77 | instance Variable IntVar where 78 | getVarID (IntVar v) = v 79 | 80 | 81 | ---------------------------------------------------------------- 82 | -- | Binding state for 'IntVar'. 83 | data IntBindingState t = IntBindingState 84 | { nextFreeVar :: {-# UNPACK #-} !Int 85 | , varBindings :: IM.IntMap (UTerm t IntVar) 86 | } 87 | 88 | -- Can't derive this because it's an UndecidableInstance 89 | instance (Show (t (UTerm t IntVar))) => 90 | Show (IntBindingState t) 91 | where 92 | show (IntBindingState nr bs) = 93 | "IntBindingState { nextFreeVar = "++show nr++ 94 | ", varBindings = "++show bs++"}" 95 | 96 | -- | The initial @IntBindingState@. 97 | emptyIntBindingState :: IntBindingState t 98 | emptyIntBindingState = IntBindingState minBound IM.empty 99 | 100 | 101 | ---------------------------------------------------------------- 102 | -- | A monad for storing 'IntVar' bindings, implemented as a 'StateT'. 103 | -- For a plain state monad, set @m = Identity@; for a backtracking 104 | -- state monad, set @m = Logic@. 105 | newtype IntBindingT t m a = IBT { unIBT :: StateT (IntBindingState t) m a } 106 | 107 | -- For portability reasons, we're intentionally avoiding 108 | -- -XDeriveFunctor, -XGeneralizedNewtypeDeriving, and the like. 109 | 110 | instance (Functor m) => Functor (IntBindingT t m) where 111 | fmap f = IBT . fmap f . unIBT 112 | 113 | -- BUG: can't reduce dependency to Applicative because of StateT's instance. 114 | instance (Functor m, Monad m) => Applicative (IntBindingT t m) where 115 | pure = IBT . pure 116 | IBT m <*> IBT n = IBT (m <*> n) 117 | IBT m *> IBT n = IBT (m *> n) 118 | IBT m <* IBT n = IBT (m <* n) 119 | 120 | -- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. 121 | -- Since ghc-9.2.1 we get a warning about providing any other 122 | -- definition, and should instead define both 'pure' and @(*>)@ 123 | -- directly, leaving 'return' and @(>>)@ as their defaults so they 124 | -- can eventually be removed from the class. 125 | -- 126 | instance (Monad m) => Monad (IntBindingT t m) where 127 | #if (!(MIN_VERSION_base(4,8,0))) 128 | return = pure 129 | #endif 130 | IBT m >>= f = IBT (m >>= unIBT . f) 131 | 132 | instance MonadTrans (IntBindingT t) where 133 | lift = IBT . lift 134 | 135 | -- BUG: can't reduce dependency to Alternative because of StateT's instance. 136 | instance (Functor m, MonadPlus m) => Alternative (IntBindingT t m) where 137 | empty = IBT empty 138 | IBT x <|> IBT y = IBT (x <|> y) 139 | 140 | instance (MonadPlus m) => MonadPlus (IntBindingT t m) 141 | #if (!(MIN_VERSION_base(4,8,0))) 142 | where 143 | mzero = empty 144 | mplus = (<|>) 145 | #endif 146 | 147 | instance (Monad m) => MonadState (IntBindingState t) (IntBindingT t m) where 148 | get = IBT get 149 | put = IBT . put 150 | 151 | -- N.B., we already have (MonadLogic m) => MonadLogic (StateT s m), 152 | -- provided that logict is compiled against the same mtl/monads-fd 153 | -- we're getting StateT from. Otherwise we'll get a bunch of warnings 154 | -- here. 155 | instance (MonadLogic m, MonadPlus m) => MonadLogic (IntBindingT t m) where 156 | msplit (IBT m) = IBT (coerce `liftM` msplit m) 157 | where 158 | coerce Nothing = Nothing 159 | coerce (Just (a, m')) = Just (a, IBT m') 160 | 161 | interleave (IBT l) (IBT r) = IBT (interleave l r) 162 | 163 | IBT m >>- f = IBT (m >>- (unIBT . f)) 164 | 165 | ifte (IBT b) t (IBT f) = IBT (ifte b (unIBT . t) f) 166 | 167 | once (IBT m) = IBT (once m) 168 | 169 | ---------------------------------------------------------------- 170 | 171 | -- | Run the binding computation with the empty initial binding 172 | -- state, and return both the final value and the final state. 173 | runIntBindingT :: IntBindingT t m a -> m (a, IntBindingState t) 174 | runIntBindingT (IBT m) = runStateT m emptyIntBindingState 175 | 176 | -- | Run the binding computation with the empty initial binding 177 | -- state, and return both the final value but discard the final state. 178 | -- 179 | -- NOTE: you should explicitly apply bindings before calling this 180 | -- function, or else the bindings will be lost 181 | evalIntBindingT :: (Monad m) => IntBindingT t m a -> m a 182 | evalIntBindingT (IBT m) = evalStateT m emptyIntBindingState 183 | 184 | -- | Run the binding computation with the empty initial binding 185 | -- state, and return both the final state but discard the final value. 186 | execIntBindingT :: (Monad m) => IntBindingT t m a -> m (IntBindingState t) 187 | execIntBindingT (IBT m) = execStateT m emptyIntBindingState 188 | 189 | ---------------------------------------------------------------- 190 | 191 | instance (Unifiable t, Applicative m, Monad m) => 192 | BindingMonad t IntVar (IntBindingT t m) 193 | where 194 | 195 | lookupVar (IntVar v) = IBT $ gets (IM.lookup v . varBindings) 196 | 197 | freeVar = IBT $ do 198 | ibs <- get 199 | let v = nextFreeVar ibs 200 | if v == maxBound 201 | then error "freeVar: no more variables!" 202 | else do 203 | put $ ibs { nextFreeVar = v+1 } 204 | return $ IntVar v 205 | 206 | newVar t = IBT $ do 207 | ibs <- get 208 | let v = nextFreeVar ibs 209 | if v == maxBound 210 | then error "newVar: no more variables!" 211 | else do 212 | let bs' = IM.insert v t (varBindings ibs) 213 | put $ ibs { nextFreeVar = v+1, varBindings = bs' } 214 | return $ IntVar v 215 | 216 | bindVar (IntVar v) t = IBT $ do 217 | ibs <- get 218 | let bs' = IM.insert v t (varBindings ibs) 219 | put $ ibs { varBindings = bs' } 220 | 221 | ---------------------------------------------------------------- 222 | ----------------------------------------------------------- fin. 223 | -------------------------------------------------------------------------------- /src/Control/Unification/Ranked.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts #-} 2 | {-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-name-shadowing #-} 3 | ---------------------------------------------------------------- 4 | -- ~ 2021.10.17 5 | -- | 6 | -- Module : Control.Unification.Ranked 7 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 8 | -- License : BSD 9 | -- Maintainer : wren@cpan.org 10 | -- Stability : highly experimental 11 | -- Portability : semi-portable (CPP, MPTCs, FlexibleContexts) 12 | -- 13 | -- This module provides the API of "Control.Unification" except 14 | -- using 'RankedBindingMonad' where appropriate. This module (and 15 | -- the binding implementations for it) are highly experimental and 16 | -- subject to change in future versions. 17 | ---------------------------------------------------------------- 18 | module Control.Unification.Ranked 19 | ( 20 | -- * Data types, classes, etc 21 | module Control.Unification.Types 22 | 23 | -- * Operations on one term 24 | , getFreeVars 25 | , applyBindings 26 | , freshen 27 | -- freezeM -- apply bindings and freeze in one traversal 28 | -- unskolemize -- convert Skolemized variables to free variables 29 | -- skolemize -- convert free variables to Skolemized variables 30 | -- getSkolems -- compute the skolem variables in a term; helpful? 31 | 32 | -- * Operations on two terms 33 | -- ** Symbolic names 34 | , (===) 35 | , (=~=) 36 | , (=:=) 37 | -- (<:=) 38 | -- ** Textual names 39 | , equals 40 | , equiv 41 | , unify 42 | -- unifyOccurs 43 | -- subsumes 44 | 45 | -- * Operations on many terms 46 | , getFreeVarsAll 47 | , applyBindingsAll 48 | , freshenAll 49 | -- subsumesAll 50 | ) where 51 | 52 | import Prelude 53 | hiding (mapM, mapM_, sequence, foldr, foldr1, foldl, foldl1, all, or) 54 | 55 | import qualified Data.IntMap as IM 56 | import Data.Traversable 57 | #if __GLASGOW_HASKELL__ < 710 58 | import Control.Applicative 59 | #endif 60 | import Control.Monad.Trans (MonadTrans(..)) 61 | #if (MIN_VERSION_mtl(2,2,1)) 62 | -- aka: transformers(0,4,1) 63 | import Control.Monad.Except (MonadError(..)) 64 | #else 65 | import Control.Monad.Error (MonadError(..)) 66 | #endif 67 | import Control.Monad.State (MonadState(..), StateT, evalStateT) 68 | import Control.Monad.State.UnificationExtras 69 | import Control.Unification.Types 70 | import Control.Unification hiding (unify, (=:=)) 71 | ---------------------------------------------------------------- 72 | ---------------------------------------------------------------- 73 | 74 | -- | 'unify' 75 | (=:=) 76 | :: ( RankedBindingMonad t v m 77 | , Fallible t v e 78 | , MonadTrans em 79 | , Functor (em m) -- Grr, Monad(em m) should imply Functor(em m) 80 | , MonadError e (em m) 81 | ) 82 | => UTerm t v -- ^ 83 | -> UTerm t v -- ^ 84 | -> em m (UTerm t v) -- ^ 85 | (=:=) = unify 86 | {-# INLINE (=:=) #-} 87 | infix 4 =:=, `unify` 88 | 89 | 90 | -- HACK: apparently this wasn't exported from Control.Unification; so c&p 91 | -- TODO: use IM.insertWith or the like to do this in one pass 92 | -- 93 | -- | Update the visited-set with a seclaration that a variable has 94 | -- been seen with a given binding, or throw 'occursFailure' if the 95 | -- variable has already been seen. 96 | seenAs 97 | :: ( BindingMonad t v m 98 | , Fallible t v e 99 | , MonadTrans em 100 | , MonadError e (em m) 101 | ) 102 | => v -- ^ 103 | -> t (UTerm t v) -- ^ 104 | -> StateT (IM.IntMap (t (UTerm t v))) (em m) () -- ^ 105 | {-# INLINE seenAs #-} 106 | seenAs v0 t0 = do 107 | seenVars <- get 108 | case IM.lookup (getVarID v0) seenVars of 109 | Just t -> lift . throwError $ occursFailure v0 (UTerm t) 110 | Nothing -> put $! IM.insert (getVarID v0) t0 seenVars 111 | 112 | 113 | -- TODO: keep in sync as we verify correctness. 114 | -- 115 | -- | Unify two terms, or throw an error with an explanation of why 116 | -- unification failed. Since bindings are stored in the monad, the 117 | -- two input terms and the output term are all equivalent if 118 | -- unification succeeds. However, the returned value makes use of 119 | -- aggressive opportunistic observable sharing, so it will be more 120 | -- efficient to use it in future calculations than either argument. 121 | unify 122 | :: ( RankedBindingMonad t v m 123 | , Fallible t v e 124 | , MonadTrans em 125 | , Functor (em m) -- Grr, Monad(em m) should imply Functor(em m) 126 | , MonadError e (em m) 127 | ) 128 | => UTerm t v -- ^ 129 | -> UTerm t v -- ^ 130 | -> em m (UTerm t v) -- ^ 131 | unify tl0 tr0 = evalStateT (loop tl0 tr0) IM.empty 132 | where 133 | {-# INLINE (=:) #-} 134 | v =: t = bindVar v t >> return t 135 | 136 | loop tl0 tr0 = do 137 | tl0 <- lift . lift $ semiprune tl0 138 | tr0 <- lift . lift $ semiprune tr0 139 | case (tl0, tr0) of 140 | (UVar vl, UVar vr) 141 | | vl == vr -> return tr0 142 | | otherwise -> do 143 | Rank rl mtl <- lift . lift $ lookupRankVar vl 144 | Rank rr mtr <- lift . lift $ lookupRankVar vr 145 | let cmp = compare rl rr 146 | case (mtl, mtr) of 147 | (Nothing, Nothing) -> lift . lift $ 148 | case cmp of 149 | LT -> do { vl =: tr0 } 150 | EQ -> do { incrementRank vr ; vl =: tr0 } 151 | GT -> do { vr =: tl0 } 152 | 153 | (Nothing, Just tr) -> lift . lift $ 154 | case cmp of 155 | LT -> do { vl =: tr0 } 156 | EQ -> do { incrementRank vr ; vl =: tr0 } 157 | GT -> do { vl `bindVar` tr ; vr =: tl0 } 158 | 159 | (Just tl, Nothing) -> lift . lift $ 160 | case cmp of 161 | LT -> do { vr `bindVar` tl ; vl =: tr0 } 162 | EQ -> do { incrementRank vl ; vr =: tl0 } 163 | GT -> do { vr =: tl0 } 164 | 165 | (Just (UTerm tl), Just (UTerm tr)) -> do 166 | t <- localState $ do 167 | vl `seenAs` tl 168 | vr `seenAs` tr 169 | match tl tr 170 | lift . lift $ 171 | case cmp of 172 | LT -> do { vr `bindVar` t ; vl =: tr0 } 173 | EQ -> do { incrementBindVar vl t ; vr =: tl0 } 174 | GT -> do { vl `bindVar` t ; vr =: tl0 } 175 | _ -> error _impossible_unify 176 | 177 | (UVar vl, UTerm tr) -> do 178 | t <- do 179 | mtl <- lift . lift $ lookupVar vl 180 | case mtl of 181 | Nothing -> return tr0 182 | Just (UTerm tl) -> localState $ do 183 | vl `seenAs` tl 184 | match tl tr 185 | _ -> error _impossible_unify 186 | lift . lift $ do 187 | vl `bindVar` t 188 | return tl0 189 | 190 | (UTerm tl, UVar vr) -> do 191 | t <- do 192 | mtr <- lift . lift $ lookupVar vr 193 | case mtr of 194 | Nothing -> return tl0 195 | Just (UTerm tr) -> localState $ do 196 | vr `seenAs` tr 197 | match tl tr 198 | _ -> error _impossible_unify 199 | lift . lift $ do 200 | vr `bindVar` t 201 | return tr0 202 | 203 | (UTerm tl, UTerm tr) -> match tl tr 204 | 205 | match tl tr = 206 | case zipMatch tl tr of 207 | Nothing -> lift . throwError $ mismatchFailure tl tr 208 | Just tlr -> UTerm <$> mapM loop_ tlr 209 | 210 | loop_ (Left t) = return t 211 | loop_ (Right (tl,tr)) = loop tl tr 212 | 213 | _impossible_unify :: String 214 | {-# NOINLINE _impossible_unify #-} 215 | _impossible_unify = "unify: the impossible happened" 216 | 217 | ---------------------------------------------------------------- 218 | ----------------------------------------------------------- fin. 219 | -------------------------------------------------------------------------------- /src/Control/Unification/Ranked/IntVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP 2 | , MultiParamTypeClasses 3 | , FlexibleInstances 4 | , UndecidableInstances 5 | #-} 6 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 7 | ---------------------------------------------------------------- 8 | -- ~ 2024-11-20 9 | -- | 10 | -- Module : Control.Unification.Ranked.IntVar 11 | -- Copyright : Copyright (c) 2007--2024 wren gayle romano 12 | -- License : BSD 13 | -- Maintainer : wren@cpan.org 14 | -- Stability : highly experimental 15 | -- Portability : semi-portable (MPTCs,...) 16 | -- 17 | -- A ranked variant of "Control.Unification.IntVar". 18 | ---------------------------------------------------------------- 19 | module Control.Unification.Ranked.IntVar 20 | ( IntVar(..) 21 | , IntRBindingState() 22 | , IntRBindingT() 23 | , runIntRBindingT 24 | , evalIntRBindingT 25 | , execIntRBindingT 26 | ) where 27 | 28 | import Prelude hiding (mapM, sequence, foldr, foldr1, foldl, foldl1) 29 | 30 | import qualified Data.IntMap as IM 31 | import Control.Applicative 32 | import Control.Monad (MonadPlus(..), liftM) 33 | import Control.Monad.Trans (MonadTrans(..)) 34 | import Control.Monad.State (MonadState(..), StateT, runStateT, evalStateT, execStateT, gets) 35 | import Control.Monad.Logic (MonadLogic(..)) 36 | import Control.Unification.Types 37 | import Control.Unification.IntVar (IntVar(..)) 38 | ---------------------------------------------------------------- 39 | ---------------------------------------------------------------- 40 | 41 | -- | Ranked binding state for 'IntVar'. 42 | data IntRBindingState t = IntRBindingState 43 | { nextFreeVar :: {-# UNPACK #-} !Int 44 | , varBindings :: IM.IntMap (Rank t IntVar) 45 | } 46 | 47 | -- Can't derive this because it's an UndecidableInstance 48 | instance (Show (t (UTerm t IntVar))) => 49 | Show (IntRBindingState t) 50 | where 51 | show (IntRBindingState nr bs) = 52 | "IntRBindingState { nextFreeVar = "++show nr++ 53 | ", varBindings = "++show bs++"}" 54 | 55 | -- | The initial @IntRBindingState@. 56 | emptyIntRBindingState :: IntRBindingState t 57 | emptyIntRBindingState = IntRBindingState minBound IM.empty 58 | 59 | 60 | ---------------------------------------------------------------- 61 | -- | A monad for storing 'IntVar' bindings, implemented as a 'StateT'. 62 | -- For a plain state monad, set @m = Identity@; for a backtracking 63 | -- state monad, set @m = Logic@. 64 | newtype IntRBindingT t m a = IRBT { unIRBT :: StateT (IntRBindingState t) m a } 65 | 66 | -- For portability reasons, we're intentionally avoiding 67 | -- -XDeriveFunctor, -XGeneralizedNewtypeDeriving, and the like. 68 | 69 | instance (Functor m) => Functor (IntRBindingT t m) where 70 | fmap f = IRBT . fmap f . unIRBT 71 | 72 | -- N.B., it's not possible to reduce the dependency to Applicative. 73 | instance (Functor m, Monad m) => Applicative (IntRBindingT t m) where 74 | pure = IRBT . pure 75 | IRBT m <*> IRBT n = IRBT (m <*> n) 76 | IRBT m *> IRBT n = IRBT (m *> n) 77 | IRBT m <* IRBT n = IRBT (m <* n) 78 | 79 | -- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. 80 | -- Since ghc-9.2.1 we get a warning about providing any other 81 | -- definition, and should instead define both 'pure' and @(*>)@ 82 | -- directly, leaving 'return' and @(>>)@ as their defaults so they 83 | -- can eventually be removed from the class. 84 | -- 85 | instance (Monad m) => Monad (IntRBindingT t m) where 86 | #if (!(MIN_VERSION_base(4,8,0))) 87 | return = pure 88 | #endif 89 | IRBT m >>= f = IRBT (m >>= unIRBT . f) 90 | 91 | instance MonadTrans (IntRBindingT t) where 92 | lift = IRBT . lift 93 | 94 | -- BUG: can't reduce dependency to Alternative because of StateT's instance. 95 | instance (Functor m, MonadPlus m) => Alternative (IntRBindingT t m) where 96 | empty = IRBT empty 97 | x <|> y = IRBT (unIRBT x <|> unIRBT y) 98 | 99 | instance (MonadPlus m) => MonadPlus (IntRBindingT t m) 100 | #if (!(MIN_VERSION_base(4,8,0))) 101 | where 102 | mzero = empty 103 | mplus = (<|>) 104 | #endif 105 | 106 | instance (Monad m) => MonadState (IntRBindingState t) (IntRBindingT t m) where 107 | get = IRBT get 108 | put = IRBT . put 109 | 110 | -- N.B., we already have (MonadLogic m) => MonadLogic (StateT s m), 111 | -- provided that logict is compiled against the same mtl/monads-fd 112 | -- we're getting StateT from. Otherwise we'll get a bunch of warnings 113 | -- here. 114 | instance (MonadLogic m, MonadPlus m) => MonadLogic (IntRBindingT t m) where 115 | msplit (IRBT m) = IRBT (coerce `liftM` msplit m) 116 | where 117 | coerce Nothing = Nothing 118 | coerce (Just (a, m')) = Just (a, IRBT m') 119 | 120 | interleave (IRBT l) (IRBT r) = IRBT (interleave l r) 121 | 122 | IRBT m >>- f = IRBT (m >>- (unIRBT . f)) 123 | 124 | ifte (IRBT b) t (IRBT f) = IRBT (ifte b (unIRBT . t) f) 125 | 126 | once (IRBT m) = IRBT (once m) 127 | 128 | ---------------------------------------------------------------- 129 | 130 | -- | Run the binding computation with the empty initial binding 131 | -- state, and return both the final value and the final state. 132 | runIntRBindingT :: IntRBindingT t m a -> m (a, IntRBindingState t) 133 | runIntRBindingT (IRBT m) = runStateT m emptyIntRBindingState 134 | 135 | -- | Run the binding computation with the empty initial binding 136 | -- state, and return both the final value but discard the final state. 137 | -- 138 | -- NOTE: you should explicitly apply bindings before calling this 139 | -- function, or else the bindings will be lost 140 | evalIntRBindingT :: (Monad m) => IntRBindingT t m a -> m a 141 | evalIntRBindingT (IRBT m) = evalStateT m emptyIntRBindingState 142 | 143 | 144 | -- | Run the binding computation with the empty initial binding 145 | -- state, and return both the final state but discard the final value. 146 | execIntRBindingT :: (Monad m) => IntRBindingT t m a -> m (IntRBindingState t) 147 | execIntRBindingT (IRBT m) = execStateT m emptyIntRBindingState 148 | 149 | ---------------------------------------------------------------- 150 | 151 | instance (Unifiable t, Applicative m, Monad m) => 152 | BindingMonad t IntVar (IntRBindingT t m) 153 | where 154 | 155 | lookupVar (IntVar v) = IRBT $ do 156 | mb <- gets (IM.lookup v . varBindings) 157 | case mb of 158 | Nothing -> return Nothing 159 | Just (Rank _ mb') -> return mb' 160 | 161 | freeVar = IRBT $ do 162 | ibs <- get 163 | let v = nextFreeVar ibs 164 | if v == maxBound 165 | then error "freeVar: no more variables!" 166 | else do 167 | put $ ibs { nextFreeVar = v+1 } 168 | return $ IntVar v 169 | 170 | newVar t = IRBT $ do 171 | ibs <- get 172 | let v = nextFreeVar ibs 173 | if v == maxBound 174 | then error "newVar: no more variables!" 175 | else do 176 | let bs' = IM.insert v (Rank 0 (Just t)) (varBindings ibs) 177 | put $ ibs { nextFreeVar = v+1, varBindings = bs' } 178 | return $ IntVar v 179 | 180 | bindVar (IntVar v) t = IRBT $ do 181 | ibs <- get 182 | let bs' = IM.insertWith f v (Rank 0 (Just t)) (varBindings ibs) 183 | f (Rank _0 jt) (Rank r _) = Rank r jt 184 | put $ ibs { varBindings = bs' } 185 | 186 | 187 | instance (Unifiable t, Applicative m, Monad m) => 188 | RankedBindingMonad t IntVar (IntRBindingT t m) 189 | where 190 | lookupRankVar (IntVar v) = IRBT $ do 191 | mb <- gets (IM.lookup v . varBindings) 192 | case mb of 193 | Nothing -> return (Rank 0 Nothing) 194 | Just rk -> return rk 195 | 196 | incrementRank (IntVar v) = IRBT $ do 197 | ibs <- get 198 | let bs' = IM.insertWith f v (Rank 1 Nothing) (varBindings ibs) 199 | f (Rank _1 _n) (Rank r mb) = Rank (r+1) mb 200 | put $ ibs { varBindings = bs' } 201 | 202 | incrementBindVar (IntVar v) t = IRBT $ do 203 | ibs <- get 204 | let bs' = IM.insertWith f v (Rank 1 (Just t)) (varBindings ibs) 205 | f (Rank _1 jt) (Rank r _) = Rank (r+1) jt 206 | put $ ibs { varBindings = bs' } 207 | 208 | ---------------------------------------------------------------- 209 | ----------------------------------------------------------- fin. 210 | -------------------------------------------------------------------------------- /src/Control/Unification/Ranked/STVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP 2 | , Rank2Types 3 | , MultiParamTypeClasses 4 | , UndecidableInstances 5 | , FlexibleInstances 6 | #-} 7 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 8 | ---------------------------------------------------------------- 9 | -- ~ 2021.11.07 10 | -- | 11 | -- Module : Control.Unification.Ranked.STVar 12 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 13 | -- License : BSD 14 | -- Maintainer : wren@cpan.org 15 | -- Stability : highly experimental 16 | -- Portability : semi-portable (Rank2Types, MPTCs,...) 17 | -- 18 | -- A ranked variant of "Control.Unification.STVar". 19 | ---------------------------------------------------------------- 20 | module Control.Unification.Ranked.STVar 21 | ( STRVar() 22 | , STRBinding() 23 | , runSTRBinding 24 | ) where 25 | 26 | import Prelude hiding (mapM, sequence, foldr, foldr1, foldl, foldl1) 27 | 28 | import Data.STRef 29 | import Data.Word (Word8) 30 | #if __GLASGOW_HASKELL__ < 710 31 | import Control.Applicative (Applicative(..)) 32 | #endif 33 | import Control.Monad.Trans (lift) 34 | import Control.Monad.ST 35 | import Control.Monad.Reader (ReaderT, runReaderT, ask) 36 | import Control.Unification.Types 37 | ---------------------------------------------------------------- 38 | ---------------------------------------------------------------- 39 | 40 | -- | A ranked unification variable implemented by 'STRef's. In 41 | -- addition to the @STRef@ for the term itself, we also track the 42 | -- variable's ID (to support visited-sets) and rank (to support 43 | -- weighted path compression). 44 | data STRVar s t = 45 | STRVar 46 | {-# UNPACK #-} !Int 47 | {-# UNPACK #-} !(STRef s Word8) 48 | {-# UNPACK #-} !(STRef s (Maybe (UTerm t (STRVar s t)))) 49 | 50 | instance Show (STRVar s t) where 51 | show (STRVar i _ _) = "STRVar " ++ show i 52 | 53 | instance Eq (STRVar s t) where 54 | (STRVar i _ _) == (STRVar j _ _) = (i == j) 55 | 56 | instance Variable (STRVar s t) where 57 | getVarID (STRVar i _ _) = i 58 | 59 | 60 | ---------------------------------------------------------------- 61 | -- TODO: parameterize this so we can use BacktrackST too. Of course, 62 | -- that means defining another class for STRef-like variables 63 | -- 64 | -- TODO: parameterize this so we can share the implementation for STVar and STRVar 65 | -- 66 | -- TODO: does MTL still have the overhead that'd make it worthwhile 67 | -- to do this manually instead of using ReaderT? 68 | -- 69 | -- | A monad for handling 'STRVar' bindings. 70 | newtype STRBinding s a = STRB { unSTRB :: ReaderT (STRef s Int) (ST s) a } 71 | 72 | 73 | -- | Run the 'ST' ranked binding monad. N.B., because 'STRVar' are 74 | -- rank-2 quantified, this guarantees that the return value has no 75 | -- such references. However, in order to remove the references from 76 | -- terms, you'll need to explicitly apply the bindings. 77 | runSTRBinding :: (forall s. STRBinding s a) -> a 78 | runSTRBinding m = 79 | runST (newSTRef minBound >>= runReaderT (unSTRB m)) 80 | -- N.B., because of the rank-2 quantification, cannot use the 81 | -- 'STRB' pattern in lieu of 'unSTRB' here. 82 | 83 | 84 | -- For portability reasons, we're intentionally avoiding 85 | -- -XDeriveFunctor, -XGeneralizedNewtypeDeriving, and the like. 86 | 87 | instance Functor (STRBinding s) where 88 | fmap f = STRB . fmap f . unSTRB 89 | 90 | instance Applicative (STRBinding s) where 91 | pure = STRB . pure 92 | STRB m <*> STRB n = STRB (m <*> n) 93 | STRB m *> STRB n = STRB (m *> n) 94 | STRB m <* STRB n = STRB (m <* n) 95 | 96 | -- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. 97 | -- Since ghc-9.2.1 we get a warning about providing any other 98 | -- definition, and should instead define both 'pure' and @(*>)@ 99 | -- directly, leaving 'return' and @(>>)@ as their defaults so they 100 | -- can eventually be removed from the class. 101 | -- 102 | instance Monad (STRBinding s) where 103 | #if (!(MIN_VERSION_base(4,8,0))) 104 | return = pure 105 | #endif 106 | STRB m >>= f = STRB (m >>= unSTRB . f) 107 | 108 | 109 | ---------------------------------------------------------------- 110 | 111 | _newSTRVar 112 | :: String 113 | -> Maybe (UTerm t (STRVar s t)) 114 | -> STRBinding s (STRVar s t) 115 | _newSTRVar fun mb = STRB $ do 116 | nr <- ask 117 | lift $ do 118 | n <- readSTRef nr 119 | if n == maxBound 120 | then error $ fun ++ ": no more variables!" 121 | else do 122 | writeSTRef nr $! n+1 123 | -- BUG: no applicative ST 124 | rk <- newSTRef 0 125 | ptr <- newSTRef mb 126 | return (STRVar n rk ptr) 127 | 128 | 129 | instance (Unifiable t) => BindingMonad t (STRVar s t) (STRBinding s) where 130 | lookupVar (STRVar _ _ p) = STRB . lift $ readSTRef p 131 | 132 | freeVar = _newSTRVar "freeVar" Nothing 133 | 134 | newVar t = _newSTRVar "newVar" (Just t) 135 | 136 | bindVar (STRVar _ _ p) t = STRB . lift $ writeSTRef p (Just t) 137 | 138 | 139 | instance (Unifiable t) => 140 | RankedBindingMonad t (STRVar s t) (STRBinding s) 141 | where 142 | 143 | lookupRankVar (STRVar _ r p) = STRB . lift $ do 144 | n <- readSTRef r 145 | mb <- readSTRef p 146 | return (Rank n mb) 147 | 148 | incrementRank (STRVar _ r _) = STRB . lift $ do 149 | n <- readSTRef r 150 | writeSTRef r $! n+1 151 | 152 | -- incrementBindVar = default 153 | 154 | ---------------------------------------------------------------- 155 | ----------------------------------------------------------- fin. 156 | -------------------------------------------------------------------------------- /src/Control/Unification/STVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP 2 | , Rank2Types 3 | , MultiParamTypeClasses 4 | , UndecidableInstances 5 | , FlexibleInstances 6 | #-} 7 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 8 | ---------------------------------------------------------------- 9 | -- ~ 2021.11.07 10 | -- | 11 | -- Module : Control.Unification.STVar 12 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 13 | -- License : BSD 14 | -- Maintainer : wren@cpan.org 15 | -- Stability : experimental 16 | -- Portability : semi-portable (Rank2Types, MPTCs,...) 17 | -- 18 | -- This module defines an implementation of unification variables 19 | -- using the 'ST' monad. 20 | ---------------------------------------------------------------- 21 | module Control.Unification.STVar 22 | ( STVar() 23 | , STBinding() 24 | , runSTBinding 25 | ) where 26 | 27 | import Prelude hiding (mapM, sequence, foldr, foldr1, foldl, foldl1) 28 | 29 | import Data.STRef 30 | #if __GLASGOW_HASKELL__ < 710 31 | import Control.Applicative (Applicative(..), (<$>)) 32 | #endif 33 | import Control.Monad.Trans (lift) 34 | import Control.Monad.ST 35 | import Control.Monad.Reader (ReaderT, runReaderT, ask) 36 | import Control.Unification.Types 37 | ---------------------------------------------------------------- 38 | ---------------------------------------------------------------- 39 | 40 | -- | Unification variables implemented by 'STRef's. In addition to 41 | -- the @STRef@ for the term itself, we also track the variable's 42 | -- ID (to support visited-sets). 43 | data STVar s t = 44 | STVar 45 | {-# UNPACK #-} !Int 46 | {-# UNPACK #-} !(STRef s (Maybe (UTerm t (STVar s t)))) 47 | 48 | instance Show (STVar s t) where 49 | show (STVar i _) = "STVar " ++ show i 50 | 51 | instance Eq (STVar s t) where 52 | (STVar i _) == (STVar j _) = (i == j) 53 | 54 | instance Variable (STVar s t) where 55 | getVarID (STVar i _) = i 56 | 57 | 58 | ---------------------------------------------------------------- 59 | -- TODO: parameterize this so we can use BacktrackST too. Or course, 60 | -- that means defining another class for STRef-like variables 61 | -- 62 | -- TODO: parameterize this so we can share the implementation for STVar and STRVar 63 | -- 64 | -- TODO: does MTL still have the overhead that'd make it worthwhile 65 | -- to do this manually instead of using ReaderT? 66 | -- 67 | -- | A monad for handling 'STVar' bindings. 68 | newtype STBinding s a = STB { unSTB :: ReaderT (STRef s Int) (ST s) a } 69 | 70 | 71 | -- | Run the 'ST' ranked binding monad. N.B., because 'STVar' are 72 | -- rank-2 quantified, this guarantees that the return value has no 73 | -- such references. However, in order to remove the references from 74 | -- terms, you'll need to explicitly apply the bindings and ground 75 | -- the term. 76 | runSTBinding :: (forall s. STBinding s a) -> a 77 | runSTBinding stb = 78 | runST (newSTRef minBound >>= runReaderT (unSTB stb)) 79 | -- N.B., because of the rank-2 quantification, cannot use the 80 | -- 'STB' pattern in lieu of 'unSTB' here. 81 | 82 | 83 | -- For portability reasons, we're intentionally avoiding 84 | -- -XDeriveFunctor, -XGeneralizedNewtypeDeriving, and the like. 85 | 86 | instance Functor (STBinding s) where 87 | fmap f = STB . fmap f . unSTB 88 | 89 | instance Applicative (STBinding s) where 90 | pure = STB . pure 91 | STB m <*> STB n = STB (m <*> n) 92 | STB m *> STB n = STB (m *> n) 93 | STB m <* STB n = STB (m <* n) 94 | 95 | -- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. 96 | -- Since ghc-9.2.1 we get a warning about providing any other 97 | -- definition, and should instead define both 'pure' and @(*>)@ 98 | -- directly, leaving 'return' and @(>>)@ as their defaults so they 99 | -- can eventually be removed from the class. 100 | -- 101 | instance Monad (STBinding s) where 102 | #if (!(MIN_VERSION_base(4,8,0))) 103 | return = pure 104 | (>>) = (*>) 105 | #endif 106 | STB m >>= f = STB (m >>= unSTB . f) 107 | 108 | 109 | ---------------------------------------------------------------- 110 | 111 | _newSTVar 112 | :: String 113 | -> Maybe (UTerm t (STVar s t)) 114 | -> STBinding s (STVar s t) 115 | _newSTVar fun mb = STB $ do 116 | nr <- ask 117 | lift $ do 118 | n <- readSTRef nr 119 | if n == maxBound 120 | then error $ fun ++ ": no more variables!" 121 | else do 122 | writeSTRef nr $! n+1 123 | STVar n <$> newSTRef mb 124 | 125 | instance (Unifiable t) => 126 | BindingMonad t (STVar s t) (STBinding s) 127 | where 128 | 129 | lookupVar (STVar _ p) = STB . lift $ readSTRef p 130 | 131 | freeVar = _newSTVar "freeVar" Nothing 132 | 133 | newVar t = _newSTVar "newVar" (Just t) 134 | 135 | bindVar (STVar _ p) t = STB . lift $ writeSTRef p (Just t) 136 | 137 | ---------------------------------------------------------------- 138 | ----------------------------------------------------------- fin. 139 | -------------------------------------------------------------------------------- /src/Control/Unification/Types.hs: -------------------------------------------------------------------------------- 1 | -- Required for Show instances 2 | {-# LANGUAGE FlexibleContexts, UndecidableInstances #-} 3 | -- Required for cleaning up Haddock messages for GHC 7.10 4 | {-# LANGUAGE CPP #-} 5 | -- For the generic Unifiable instances. N.B., while the lower bound 6 | -- for 'Generic1' stuff is nominally base-4.6.0, those early versions 7 | -- lack a 'Traversable' instance, making them useless for us. Thus, 8 | -- the actual lower bound is GHC-8.0.2 aka base-4.9.1.0. 9 | #if MIN_VERSION_base(4,9,1) 10 | {-# LANGUAGE TypeOperators 11 | , ScopedTypeVariables 12 | , DefaultSignatures 13 | #-} 14 | #endif 15 | -- Required more generally 16 | {-# LANGUAGE MultiParamTypeClasses 17 | , FunctionalDependencies 18 | , FlexibleInstances 19 | #-} 20 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 21 | 22 | ---------------------------------------------------------------- 23 | -- ~ 2021.11.07 24 | -- | 25 | -- Module : Control.Unification.Types 26 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 27 | -- License : BSD 28 | -- Maintainer : wren@cpan.org 29 | -- Stability : experimental 30 | -- Portability : semi-portable (MPTCs, fundeps,...) 31 | -- 32 | -- This module defines the classes and primitive types used by 33 | -- unification and related functions. 34 | ---------------------------------------------------------------- 35 | module Control.Unification.Types 36 | ( 37 | -- * Unification terms 38 | UTerm(..) 39 | , freeze 40 | , unfreeze 41 | -- * Errors 42 | , Fallible(..) 43 | , UFailure(..) 44 | -- * Basic type classes 45 | , Unifiable(..) 46 | , Variable(..) 47 | , BindingMonad(..) 48 | -- * Weighted path compression 49 | , Rank(..) 50 | , RankedBindingMonad(..) 51 | ) where 52 | 53 | import Prelude hiding (mapM, sequence, foldr, foldr1, foldl, foldl1) 54 | 55 | import Data.Word (Word8) 56 | import Data.Fix (Fix(..)) 57 | #if __GLASGOW_HASKELL__ < 804 58 | import Data.Monoid ((<>)) 59 | #endif 60 | import Data.Traversable (Traversable(..)) 61 | #if __GLASGOW_HASKELL__ < 710 62 | import Data.Foldable (Foldable(..)) 63 | import Control.Applicative (Applicative(..), (<$>)) 64 | #endif 65 | #if MIN_VERSION_base(4,9,1) 66 | -- for the generic Unifiable instances 67 | import GHC.Generics 68 | #endif 69 | 70 | ---------------------------------------------------------------- 71 | ---------------------------------------------------------------- 72 | 73 | -- TODO: incorporate Ed's cheaper free monads, at least as a view. 74 | 75 | -- | The type of terms generated by structures @t@ over variables 76 | -- @v@. The structure type should implement 'Unifiable' and the 77 | -- variable type should implement 'Variable'. 78 | -- 79 | -- The 'Show' instance doesn't show the constructors, in order to 80 | -- improve legibility for large terms. 81 | -- 82 | -- All the category theoretic instances ('Functor', 'Foldable', 83 | -- 'Traversable',...) are provided because they are often useful; 84 | -- however, beware that since the implementations must be pure, 85 | -- they cannot read variables bound in the current context and 86 | -- therefore can create incoherent results. Therefore, you should 87 | -- apply the current bindings before using any of the functions 88 | -- provided by those classes. 89 | 90 | data UTerm t v 91 | = UVar !v -- ^ A unification variable. 92 | | UTerm !(t (UTerm t v)) -- ^ Some structure containing subterms. 93 | 94 | instance (Show v, Show (t (UTerm t v))) => Show (UTerm t v) where 95 | showsPrec p (UVar v) = showsPrec p v 96 | showsPrec p (UTerm t) = showsPrec p t 97 | 98 | instance (Functor t) => Functor (UTerm t) where 99 | fmap f (UVar v) = UVar (f v) 100 | fmap f (UTerm t) = UTerm (fmap (fmap f) t) 101 | 102 | instance (Foldable t) => Foldable (UTerm t) where 103 | foldMap f (UVar v) = f v 104 | foldMap f (UTerm t) = foldMap (foldMap f) t 105 | 106 | instance (Traversable t) => Traversable (UTerm t) where 107 | traverse f (UVar v) = UVar <$> f v 108 | traverse f (UTerm t) = UTerm <$> traverse (traverse f) t 109 | 110 | -- Does this even make sense for UTerm? Having variables of function 111 | -- type for @(<*>)@ is very strange; but even if we rephrase things 112 | -- with 'liftA2', we'd still be forming new variables as a function 113 | -- of two old variables, which is still odd... 114 | instance (Functor t) => Applicative (UTerm t) where 115 | pure = UVar 116 | UVar a <*> UVar b = UVar (a b) 117 | UVar a <*> UTerm mb = UTerm (fmap a <$> mb) 118 | UTerm ma <*> b = UTerm ((<*> b) <$> ma) 119 | 120 | -- Does this even make sense for UTerm? It may be helpful for 121 | -- building terms at least; though bind is inefficient for that. 122 | -- Should use the cheaper free... 123 | instance (Functor t) => Monad (UTerm t) where 124 | #if (!(MIN_VERSION_base(4,8,0))) 125 | return = pure 126 | #endif 127 | UVar v >>= f = f v 128 | UTerm t >>= f = UTerm ((>>= f) <$> t) 129 | 130 | {- 131 | -- TODO: how to fill in the missing cases to make these work? In 132 | -- full generality we'd need @Monoid v@ and for it to be a two-sided 133 | -- action over @Alternative t@. 134 | instance (Alternative t) => Alternative (UTerm t) where 135 | empty = UTerm empty 136 | UVar x <|> UVar y = 137 | UVar x <|> UTerm b = 138 | UTerm a <|> UVar y = 139 | UTerm a <|> UTerm b = UTerm (a <|> b) 140 | 141 | instance (Functor t, MonadPlus t) => MonadPlus (UTerm t) where 142 | mzero = UTerm mzero 143 | UVar x `mplus` UVar y = 144 | UVar x `mplus` UTerm b = 145 | UTerm a `mplus` UVar y = 146 | UTerm a `mplus` UTerm b = UTerm (a `mplus` b) 147 | -} 148 | 149 | -- There's also MonadTrans, MonadWriter, MonadReader, MonadState, 150 | -- MonadError, MonadCont; which make even less sense for us. See 151 | -- Ed Kmett's free package for the implementations. 152 | 153 | 154 | -- | /O(n)/. Embed a pure term as a mutable term. 155 | unfreeze :: (Functor t) => Fix t -> UTerm t v 156 | unfreeze = UTerm . fmap unfreeze . unFix 157 | 158 | 159 | -- | /O(n)/. Extract a pure term from a mutable term, or return 160 | -- @Nothing@ if the mutable term actually contains variables. N.B., 161 | -- this function is pure, so you should manually apply bindings 162 | -- before calling it. 163 | freeze :: (Traversable t) => UTerm t v -> Maybe (Fix t) 164 | freeze (UVar _) = Nothing 165 | freeze (UTerm t) = Fix <$> mapM freeze t 166 | 167 | 168 | ---------------------------------------------------------------- 169 | -- TODO: provide zipper context so better error messages can be generated. 170 | -- 171 | -- | The possible failure modes that could be encountered in 172 | -- unification and related functions. While many of the functions 173 | -- could be given more accurate types if we used ad-hoc combinations 174 | -- of these constructors (i.e., because they can only throw one of 175 | -- the errors), the extra complexity is not considered worth it. 176 | -- 177 | -- This is a finally-tagless encoding of the 'UFailure' data type 178 | -- so that we can abstract over clients adding additional domain-specific 179 | -- failure modes, introducing monoid instances, etc. 180 | -- 181 | -- /Since: 0.10.0/ 182 | class Fallible t v a where 183 | -- | A cyclic term was encountered (i.e., the variable occurs 184 | -- free in a term it would have to be bound to in order to 185 | -- succeed). Infinite terms like this are not generally acceptable, 186 | -- so we do not support them. In logic programming this should 187 | -- simply be treated as unification failure; in type checking 188 | -- this should result in a \"could not construct infinite type 189 | -- @a = Foo a@\" error. 190 | -- 191 | -- Note that since, by default, the library uses visited-sets 192 | -- instead of the occurs-check these errors will be thrown at 193 | -- the point where the cycle is dereferenced\/unrolled (e.g., 194 | -- when applying bindings), instead of at the time when the 195 | -- cycle is created. However, the arguments to this constructor 196 | -- should express the same context as if we had performed the 197 | -- occurs-check, in order for error messages to be intelligable. 198 | occursFailure :: v -> UTerm t v -> a 199 | 200 | -- | The top-most level of the terms do not match (according 201 | -- to 'zipMatch'). In logic programming this should simply be 202 | -- treated as unification failure; in type checking this should 203 | -- result in a \"could not match expected type @Foo@ with 204 | -- inferred type @Bar@\" error. 205 | mismatchFailure :: t (UTerm t v) -> t (UTerm t v) -> a 206 | 207 | 208 | -- | A concrete representation for the 'Fallible' type class. 209 | -- Whenever possible, you should prefer to keep the concrete 210 | -- representation abstract by using the 'Fallible' class instead. 211 | -- 212 | -- /Updated: 0.10.0/ Used to be called @UnificationFailure@. Removed 213 | -- the @UnknownError@ constructor, and the @Control.Monad.Error.Error@ 214 | -- instance associated with it. Renamed @OccursIn@ constructor to 215 | -- @OccursFailure@; and renamed @TermMismatch@ constructor to 216 | -- @MismatchFailure@. 217 | -- 218 | -- /Updated: 0.8.1/ added 'Functor', 'Foldable', and 'Traversable' instances. 219 | data UFailure t v 220 | = OccursFailure v (UTerm t v) 221 | | MismatchFailure (t (UTerm t v)) (t (UTerm t v)) 222 | 223 | 224 | instance Fallible t v (UFailure t v) where 225 | occursFailure = OccursFailure 226 | mismatchFailure = MismatchFailure 227 | 228 | 229 | -- Can't derive this because it's an UndecidableInstance 230 | instance (Show (t (UTerm t v)), Show v) => 231 | Show (UFailure t v) 232 | where 233 | showsPrec p (OccursFailure v t) = 234 | showParen (p > 9) 235 | ( showString "OccursFailure " 236 | . showsPrec 11 v 237 | . showString " " 238 | . showsPrec 11 t 239 | ) 240 | showsPrec p (MismatchFailure tl tr) = 241 | showParen (p > 9) 242 | ( showString "MismatchFailure " 243 | . showsPrec 11 tl 244 | . showString " " 245 | . showsPrec 11 tr 246 | ) 247 | 248 | 249 | instance (Functor t) => Functor (UFailure t) where 250 | fmap f (OccursFailure v t) = 251 | OccursFailure (f v) (fmap f t) 252 | 253 | fmap f (MismatchFailure tl tr) = 254 | MismatchFailure (fmap f <$> tl) (fmap f <$> tr) 255 | 256 | instance (Foldable t) => Foldable (UFailure t) where 257 | foldMap f (OccursFailure v t) = 258 | f v <> foldMap f t 259 | 260 | foldMap f (MismatchFailure tl tr) = 261 | foldMap (foldMap f) tl <> foldMap (foldMap f) tr 262 | 263 | instance (Traversable t) => Traversable (UFailure t) where 264 | traverse f (OccursFailure v t) = 265 | OccursFailure <$> f v <*> traverse f t 266 | 267 | traverse f (MismatchFailure tl tr) = 268 | MismatchFailure <$> traverse (traverse f) tl 269 | <*> traverse (traverse f) tr 270 | 271 | ---------------------------------------------------------------- 272 | 273 | -- | An implementation of syntactically unifiable structure. The 274 | -- @Traversable@ constraint is there because we also require terms 275 | -- to be functors and require the distributivity of 'sequence' or 276 | -- 'mapM'. 277 | -- 278 | -- /Updated: 0.11/ This class can now be derived so long as you 279 | -- have a 'Generic1' instance. 280 | class (Traversable t) => Unifiable t where 281 | 282 | -- | Perform one level of equality testing for terms. If the 283 | -- term constructors are unequal then return @Nothing@; if they 284 | -- are equal, then return the one-level spine filled with 285 | -- resolved subterms and\/or pairs of subterms to be recursively 286 | -- checked. 287 | zipMatch :: t a -> t a -> Maybe (t (Either a (a,a))) 288 | 289 | #if MIN_VERSION_base(4,9,1) 290 | default zipMatch 291 | :: (Generic1 t, Unifiable (Rep1 t)) 292 | => t a -> t a -> Maybe (t (Either a (a,a))) 293 | zipMatch a b = to1 <$> zipMatch (from1 a) (from1 b) 294 | #endif 295 | 296 | 297 | -- | An implementation of unification variables. The 'Eq' requirement 298 | -- is to determine whether two variables are equal /as variables/, 299 | -- without considering what they are bound to. We use 'Eq' rather 300 | -- than having our own @eqVar@ method so that clients can make use 301 | -- of library functions which commonly assume 'Eq'. 302 | class (Eq v) => Variable v where 303 | 304 | -- | Return a unique identifier for this variable, in order to 305 | -- support the use of visited-sets instead of occurs-checks. 306 | -- This function must satisfy the following coherence law with 307 | -- respect to the 'Eq' instance: 308 | -- 309 | -- @x == y@ if and only if @getVarID x == getVarID y@ 310 | getVarID :: v -> Int 311 | 312 | 313 | ---------------------------------------------------------------- 314 | 315 | -- | The basic class for generating, reading, and writing to bindings 316 | -- stored in a monad. These three functionalities could be split 317 | -- apart, but are combined in order to simplify contexts. Also, 318 | -- because most functions reading bindings will also perform path 319 | -- compression, there's no way to distinguish \"true\" mutation 320 | -- from mere path compression. 321 | -- 322 | -- The superclass constraints are there to simplify contexts, since 323 | -- we make the same assumptions everywhere we use @BindingMonad@. 324 | 325 | class (Unifiable t, Variable v, Applicative m, Monad m) => 326 | BindingMonad t v m | m t -> v, v m -> t 327 | where 328 | 329 | -- | Given a variable pointing to @UTerm t v@, return the 330 | -- term it's bound to, or @Nothing@ if the variable is unbound. 331 | lookupVar :: v -> m (Maybe (UTerm t v)) 332 | 333 | -- | Generate a new free variable guaranteed to be fresh in 334 | -- @m@. 335 | freeVar :: m v 336 | 337 | -- | Generate a new variable (fresh in @m@) bound to the given 338 | -- term. The default implementation is: 339 | -- 340 | -- > newVar t = do { v <- freeVar ; bindVar v t ; return v } 341 | newVar :: UTerm t v -> m v 342 | newVar t = do { v <- freeVar ; bindVar v t ; return v } 343 | 344 | -- | Bind a variable to a term, overriding any previous binding. 345 | bindVar :: v -> UTerm t v -> m () 346 | 347 | 348 | ---------------------------------------------------------------- 349 | -- | The target of variables for 'RankedBindingMonad's. In order 350 | -- to support weighted path compression, each variable is bound to 351 | -- both another term (possibly) and also a \"rank\" which is related 352 | -- to the length of the variable chain to the term it's ultimately 353 | -- bound to. 354 | -- 355 | -- The rank can be at most @log V@, where @V@ is the total number 356 | -- of variables in the unification problem. Thus, A @Word8@ is 357 | -- sufficient for @2^(2^8)@ variables, which is far more than can 358 | -- be indexed by 'getVarID' even on 64-bit architectures. 359 | data Rank t v = 360 | Rank {-# UNPACK #-} !Word8 !(Maybe (UTerm t v)) 361 | 362 | -- Can't derive this because it's an UndecidableInstance 363 | instance (Show v, Show (t (UTerm t v))) => Show (Rank t v) where 364 | show (Rank n mb) = "Rank "++show n++" "++show mb 365 | 366 | -- TODO: flatten the Rank.Maybe.UTerm so that we can tell that if 367 | -- semiprune returns a bound variable then it's bound to a term 368 | -- (not another var)? 369 | 370 | {- 371 | instance Monoid (Rank t v) where 372 | mempty = Rank 0 Nothing 373 | mappend (Rank l mb) (Rank r _) = Rank (max l r) mb 374 | -} 375 | 376 | 377 | -- | An advanced class for 'BindingMonad's which also support 378 | -- weighted path compression. The weightedness adds non-trivial 379 | -- implementation complications; so even though weighted path 380 | -- compression is asymptotically optimal, the constant factors may 381 | -- make it worthwhile to stick with the unweighted path compression 382 | -- supported by 'BindingMonad'. 383 | class (BindingMonad t v m) => 384 | RankedBindingMonad t v m | m t -> v, v m -> t 385 | where 386 | 387 | -- | Given a variable pointing to @UTerm t v@, return its 388 | -- rank and the term it's bound to. 389 | lookupRankVar :: v -> m (Rank t v) 390 | 391 | -- | Increase the rank of a variable by one. 392 | incrementRank :: v -> m () 393 | 394 | -- | Bind a variable to a term and increment the rank at the 395 | -- same time. The default implementation is: 396 | -- 397 | -- > incrementBindVar t v = do { incrementRank v ; bindVar v t } 398 | incrementBindVar :: v -> UTerm t v -> m () 399 | incrementBindVar v t = do { incrementRank v ; bindVar v t } 400 | 401 | ---------------------------------------------------------------- 402 | -- Generic 'Unifiable' instances. 403 | 404 | #if MIN_VERSION_base(4,9,1) 405 | instance Unifiable V1 where 406 | zipMatch a _ = Just $ Left <$> a 407 | 408 | instance Unifiable U1 where 409 | zipMatch a _ = Just $ Left <$> a 410 | 411 | instance Unifiable Par1 where 412 | zipMatch (Par1 a) (Par1 b) = Just . Par1 $ Right (a,b) 413 | 414 | instance Unifiable f => Unifiable (Rec1 f) where 415 | zipMatch (Rec1 a) (Rec1 b) = Rec1 <$> zipMatch a b 416 | 417 | instance Eq c => Unifiable (K1 i c) where 418 | zipMatch (K1 a) (K1 b) 419 | | a == b = Just (K1 a) 420 | | otherwise = Nothing 421 | 422 | instance Unifiable f => Unifiable (M1 i c f) where 423 | zipMatch (M1 a) (M1 b) = M1 <$> zipMatch a b 424 | 425 | instance (Unifiable f, Unifiable g) => Unifiable (f :+: g) where 426 | zipMatch (L1 a) (L1 b) = L1 <$> zipMatch a b 427 | zipMatch (R1 a) (R1 b) = R1 <$> zipMatch a b 428 | zipMatch _ _ = Nothing 429 | 430 | instance (Unifiable f, Unifiable g) => Unifiable (f :*: g) where 431 | zipMatch (a1 :*: a2) (b1 :*: b2) = 432 | (:*:) <$> zipMatch a1 b1 <*> zipMatch a2 b2 433 | 434 | instance (Unifiable f, Unifiable g) => Unifiable (f :.: g) where 435 | zipMatch (Comp1 fga) (Comp1 fgb) = 436 | Comp1 <$> (traverse step =<< zipMatch fga fgb) 437 | where 438 | -- TODO: can we avoid mapping 'Left' all the way down? 439 | step (Left gx) = Just (Left <$> gx) 440 | step (Right (ga, gb)) = zipMatch ga gb 441 | #endif 442 | 443 | ---------------------------------------------------------------- 444 | ----------------------------------------------------------- fin. 445 | -------------------------------------------------------------------------------- /src/Data/Functor/Fixedpoint.hs: -------------------------------------------------------------------------------- 1 | -- For 'build', 'hmap', and 'hmapM' 2 | {-# LANGUAGE Rank2Types #-} 3 | 4 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 5 | ---------------------------------------------------------------- 6 | -- 2024-11-20 7 | -- | 8 | -- Module : Data.Functor.Fixedpoint 9 | -- Copyright : Copyright (c) 2007--2024 wren gayle romano 10 | -- License : BSD 11 | -- Maintainer : wren@cpan.org 12 | -- Stability : deprecated since unification-fd-0.12.0 13 | -- Portability : semi-portable (Rank2Types) 14 | -- 15 | -- This module provides a backwards compatibility shim for users 16 | -- of older versions of @unification-fd@, before we switched over 17 | -- to using @data-fix@. New users should prefer calling @data-fix@ 18 | -- functions directly, whenever possible. If you use any of the 19 | -- functions that aren't deprecated ('hoistFixM'', 'ymap', 'ymapM', 20 | -- 'ycata', 'ycataM', 'build'), please let the maintainer know, 21 | -- so she can focus on getting those incorporated into @data-fix@. 22 | -- Returning users should beware that this module used to provide 23 | -- rewrite rules for fusing redundant traversals of data structures 24 | -- (which @data-fix@ does not). If you notice version >=0.12.0 25 | -- introducing any performance loss compared to earlier versions, 26 | -- please let the maintainer know, so she can focus on getting those 27 | -- incorporated into @data-fix@. 28 | -- 29 | -- This abstract nonsense is helpful in conjunction with other 30 | -- category theoretic tricks like Swierstra's functor coproducts 31 | -- (not provided by this package). For more on the utility of 32 | -- two-level recursive types, see: 33 | -- 34 | -- * Tim Sheard (2001) /Generic Unification via Two-Level Types/ 35 | -- /and Parameterized Modules/, Functional Pearl, ICFP. 36 | -- 37 | -- * Tim Sheard & Emir Pasalic (2004) /Two-Level Types and/ 38 | -- /Parameterized Modules/. JFP 14(5): 547--587. This is 39 | -- an expanded version of Sheard (2001) with new examples. 40 | -- 41 | -- * Wouter Swierstra (2008) /Data types a la carte/, Functional 42 | -- Pearl. JFP 18: 423--436. 43 | ---------------------------------------------------------------- 44 | 45 | module Data.Functor.Fixedpoint 46 | ( 47 | -- * Fixed point operator for functors 48 | Data.Fix.Fix(..) 49 | -- * Maps 50 | , hmap, hmapM, hoistFixM' 51 | , ymap, ymapM 52 | -- * Builders 53 | , build 54 | -- * Catamorphisms 55 | , cata, cataM 56 | , ycata, ycataM 57 | -- * Anamorphisms 58 | , ana, anaM 59 | -- * Hylomorphisms 60 | , hylo, hyloM 61 | ) where 62 | 63 | import Prelude hiding (mapM, sequence) 64 | import Control.Monad hiding (mapM, sequence) 65 | import Data.Traversable 66 | import Data.Fix (Fix()) 67 | import qualified Data.Fix 68 | 69 | ---------------------------------------------------------------- 70 | ---------------------------------------------------------------- 71 | 72 | -- | A higher-order map taking a natural transformation @(f -> g)@ 73 | -- and lifting it to operate on @Fix@. 74 | -- 75 | -- NOTE: The implementation of @hmap@ prior to version 0.12 was 76 | -- based on 'ana', and therefore most closely matches the behavior 77 | -- of 'Data.Fix.hoistFix''. However, this definition is extensionally 78 | -- equivalent to an implementation using 'cata' (and therefore most 79 | -- closely matches the behavior of 'Data.Fix.hoistFix') instead. 80 | hmap :: (Functor f, Functor g) => (forall a. f a -> g a) -> Fix f -> Fix g 81 | hmap = Data.Fix.hoistFix' 82 | {-# DEPRECATED hmap "Use Data.Fix.hoistFix'" #-} 83 | 84 | -- | A monadic variant of 'hmap'. 85 | hmapM 86 | :: (Functor f, Traversable g, Monad m) 87 | => (forall a. f a -> m (g a)) -> Fix f -> m (Fix g) 88 | hmapM = hoistFixM' 89 | {-# DEPRECATED hmapM "Use hoistFixM'" #-} 90 | 91 | -- | A monadic variant of 'Data.Fix.hoistFix''. 92 | -- 93 | -- NOTE: The implementation of @hmapM@ prior to version 0.12 was 94 | -- based on 'anaM', and therefore most closely matches the behavior 95 | -- of 'Data.Fix.unfoldFixM'. However, there is another function 96 | -- of the same type which is instead implemented via 'cataM', 97 | -- which has different semantics for many monads. 98 | hoistFixM' 99 | :: (Functor f, Traversable g, Monad m) 100 | => (forall a. f a -> m (g a)) -> Fix f -> m (Fix g) 101 | hoistFixM' eps = Data.Fix.unfoldFixM (eps . Data.Fix.unFix) 102 | 103 | -- | A version of 'fmap' for endomorphisms on the fixed point. That 104 | -- is, this maps the function over the first layer of recursive 105 | -- structure. 106 | ymap :: (Functor f) => (Fix f -> Fix f) -> Fix f -> Fix f 107 | ymap f = Data.Fix.Fix . fmap f . Data.Fix.unFix 108 | 109 | -- | A monadic variant of 'ymap'. 110 | ymapM :: (Traversable f, Monad m) 111 | => (Fix f -> m (Fix f)) -> Fix f -> m (Fix f) 112 | ymapM f = liftM Data.Fix.Fix . mapM f . Data.Fix.unFix 113 | 114 | 115 | ---------------------------------------------------------------- 116 | -- BUG: this isn't as helful as normal build\/fold fusion as in Data.Functor.Fusable 117 | -- 118 | -- | Take a Church encoding of a fixed point into the data 119 | -- representation of the fixed point. 120 | build :: (Functor f) => (forall r. (f r -> r) -> r) -> Fix f 121 | build g = g Data.Fix.Fix 122 | 123 | ---------------------------------------------------------------- 124 | -- | A pure catamorphism over the least fixed point of a functor. 125 | -- This function applies the @f@-algebra from the bottom up over 126 | -- @Fix f@ to create some residual value. 127 | cata :: (Functor f) => (f a -> a) -> (Fix f -> a) 128 | cata = Data.Fix.foldFix 129 | {-# DEPRECATED cata "Use Data.Fix.foldFix" #-} 130 | 131 | 132 | -- | A catamorphism for monadic @f@-algebras. Alas, this isn't wholly 133 | -- generic to @Functor@ since it requires distribution of @f@ over 134 | -- @m@ (provided by 'sequence' or 'mapM' in 'Traversable'). 135 | -- 136 | -- N.B., this orders the side effects from the bottom up. 137 | cataM :: (Traversable f, Monad m) => (f a -> m a) -> (Fix f -> m a) 138 | cataM = Data.Fix.foldFixM 139 | {-# DEPRECATED cataM "Use Data.Fix.foldFixM" #-} 140 | 141 | -- TODO: remove this, or add similar versions for ana* and hylo*? 142 | -- | A variant of 'cata' which restricts the return type to being 143 | -- a new fixpoint. Though more restrictive, it can be helpful when 144 | -- you already have an algebra which expects the outermost @Fix@. 145 | -- 146 | -- If you don't like either @fmap@ or @cata@, then maybe this is 147 | -- what you were thinking? 148 | ycata :: (Functor f) => (Fix f -> Fix f) -> Fix f -> Fix f 149 | ycata f = Data.Fix.foldFix (f . Data.Fix.Fix) 150 | 151 | 152 | -- TODO: remove this, or add similar versions for ana* and hylo*? 153 | -- | Monadic variant of 'ycata'. 154 | ycataM :: (Traversable f, Monad m) 155 | => (Fix f -> m (Fix f)) -> Fix f -> m (Fix f) 156 | ycataM f = Data.Fix.foldFixM (f . Data.Fix.Fix) 157 | 158 | 159 | ---------------------------------------------------------------- 160 | -- | A pure anamorphism generating the greatest fixed point of a 161 | -- functor. This function applies an @f@-coalgebra from the top 162 | -- down to expand a seed into a @Fix f@. 163 | ana :: (Functor f) => (a -> f a) -> (a -> Fix f) 164 | ana = Data.Fix.unfoldFix 165 | {-# DEPRECATED ana "Use Data.Fix.unfoldFix" #-} 166 | 167 | -- | An anamorphism for monadic @f@-coalgebras. Alas, this isn't 168 | -- wholly generic to @Functor@ since it requires distribution of 169 | -- @f@ over @m@ (provided by 'sequence' or 'mapM' in 'Traversable'). 170 | -- 171 | -- N.B., this orders the side effects from the top down. 172 | anaM :: (Traversable f, Monad m) => (a -> m (f a)) -> (a -> m (Fix f)) 173 | anaM = Data.Fix.unfoldFixM 174 | {-# DEPRECATED anaM "Use Data.Fix.unfoldFixM" #-} 175 | 176 | 177 | ---------------------------------------------------------------- 178 | -- | @hylo phi psi == cata phi . ana psi@ 179 | hylo :: (Functor f) => (f b -> b) -> (a -> f a) -> (a -> b) 180 | hylo = Data.Fix.refold 181 | {-# DEPRECATED hylo "Use Data.Fix.refold" #-} 182 | 183 | -- | @hyloM phiM psiM == cataM phiM <=< anaM psiM@ 184 | hyloM :: (Traversable f, Monad m) 185 | => (f b -> m b) -> (a -> m (f a)) -> (a -> m b) 186 | hyloM = Data.Fix.refoldM 187 | {-# DEPRECATED hyloM "Use Data.Fix.refoldM" #-} 188 | 189 | ---------------------------------------------------------------- 190 | ----------------------------------------------------------- fin. 191 | -------------------------------------------------------------------------------- /test/bench/Control/Unification/Classes.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE Rank2Types 3 | , MultiParamTypeClasses 4 | , FunctionalDependencies 5 | #-} 6 | 7 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 8 | 9 | ---------------------------------------------------------------- 10 | -- ~ 2021.10.17 11 | -- | 12 | -- Module : Control.Unification.Classes 13 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 14 | -- License : BSD 15 | -- Maintainer : wren@cpan.org 16 | -- Stability : experimental 17 | -- Portability : semi-portable (Rank2Types, MPTCs, fundeps) 18 | -- 19 | -- This module defines the classes used by unification and related 20 | -- functions. 21 | ---------------------------------------------------------------- 22 | module Control.Unification.Classes 23 | ( 24 | -- * Classes for unification variable bindings 25 | BindingReader(..) 26 | , BindingGenerator(..) 27 | , BindingWriter(..) 28 | -- * Classes for equality, subsumption, and unification 29 | , Unifiable(..) 30 | , Variable(..) 31 | -- ** Abstract type for continuations in equality, etc 32 | , More() 33 | , getMore 34 | , more 35 | , success 36 | , failure 37 | ) where 38 | 39 | import Prelude hiding (mapM, sequence, foldr, foldr1, foldl, foldl1) 40 | import qualified Prelude (foldr) 41 | 42 | import Data.Traversable (Traversable()) 43 | import Control.Applicative (Applicative()) 44 | import Control.Monad (MonadPlus(..)) 45 | import Control.Monad.Logic (Logic(..), LogicT(..)) 46 | ---------------------------------------------------------------- 47 | ---------------------------------------------------------------- 48 | 49 | -- TODO: since nearly all the readers will (semi)prune paths, should this just be combined with the BindingWriter class? Or maybe we should move semipruning into here? 50 | -- 51 | -- | A class for reading from bindings stored in a monad. 52 | class (Variable v, Applicative m, Monad m) => 53 | BindingReader v t m | m -> v t 54 | where 55 | -- | Given a variable pointing to @t@, return the @t@ it's bound 56 | -- to, or @Nothing@ if the variable is unbound. 57 | lookupVar :: v t -> m (Maybe t) 58 | 59 | -- TODO: for weighted path compression. Should probably be rolled into 'lookupVar' no doubt... 60 | -- lookupVarRank :: v t -> m Int 61 | 62 | {- 63 | class (Variable v, Functor m, Monad m) => BindingReifyer v t m where 64 | -- Return all the bindings as a mapping from variables to terms. But how? What type to use for (:->:) ? And this isn't even always possible (e.g., using STVars; we'd have to do extra work to keep track of the bindings). 65 | getBindings :: m (v t :->: t) 66 | -} 67 | 68 | 69 | -- | A class for non-destructive modification of the bindings stored 70 | -- in a monad, namely allocating new free and bound unification 71 | -- variables. 72 | class (Variable v, Applicative m, Monad m) => 73 | BindingGenerator v t m | m -> v t 74 | where 75 | -- | Generate a new free variable guaranteed to be fresh in 76 | -- @m@. 77 | freeVar :: m (v t) 78 | 79 | -- | Generate a new variable (fresh in @m@) bound to the given 80 | -- term. 81 | newVar :: t -> m (v t) 82 | 83 | 84 | -- | A class for potentially destructive modification of the bindings 85 | -- stored in a monad. 86 | class (Variable v, Applicative m, Monad m) => 87 | BindingWriter v t m | m -> v t 88 | where 89 | -- | Bind a variable to a term, returning the old binding if 90 | -- any. 91 | bindVar :: v t -> t -> m (Maybe t) 92 | 93 | -- | Bind a variable to a term. 94 | bindVar_ :: v t -> t -> m () 95 | bindVar_ v t = bindVar v t >> return () 96 | 97 | -- | Remove a variable binding, returning the old binding if 98 | -- any. 99 | unbindVar :: v t -> m (Maybe t) 100 | 101 | -- | Remove a variable binding. 102 | unbindVar_ :: v t -> m () 103 | unbindVar_ v = unbindVar v >> return () 104 | 105 | 106 | ---------------------------------------------------------------- 107 | 108 | -- TODO: use MaybeK 109 | -- | An abstract type representing a list of pairs of terms to 110 | -- continue unifying, testing for equality, etc. 111 | newtype More a b = More (Maybe (Logic (a,b))) 112 | 113 | -- | For internal use. 114 | getMore :: More a b -> Maybe (Logic (a,b)) 115 | getMore (More mb) = mb 116 | 117 | -- TODO: send a patch defining [a] -> Logic a to logict 118 | more :: [(a,b)] -> More a b 119 | more xs = More . Just . Logic . LogicT $ \ks kf -> Prelude.foldr ks kf xs 120 | 121 | success :: More a b 122 | success = More $ Just mzero 123 | 124 | failure :: More a b 125 | failure = More Nothing 126 | 127 | 128 | -- | An implementation of unifiable structure. 129 | class (Traversable t) => Unifiable t where 130 | -- | Perform one level of equality testing for terms. If the 131 | -- term constructors are unequal then return 'failure'; if they 132 | -- are equal, then return the subterms to be recursively checked 133 | -- (e.g., with 'more' to pair off the corresponding sub-terms, 134 | -- or 'success' if the constructors have no sub-terms). 135 | match :: t a -> t b -> More a b 136 | 137 | -- Perhaps this would be enough for the aggressive obs.sharing? (in conjunction with traverse/mapM) 138 | zipMatch :: t a -> t b -> Maybe (t (a,b)) 139 | 140 | 141 | -- | An implementation of unification variables. 142 | class Variable v where 143 | -- | Determine whether two variables are equal /as variables/, 144 | -- without considering what they are bound to. 145 | eqVar :: v a -> v a -> Bool 146 | 147 | -- | Return a unique identifier for this variable, in order to 148 | -- support the use of visited-sets instead of occurs checks. 149 | getVarID :: v a -> Int 150 | 151 | ---------------------------------------------------------------- 152 | ----------------------------------------------------------- fin. 153 | -------------------------------------------------------------------------------- /test/bench/Control/Unification/IntVar.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} 3 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 4 | ---------------------------------------------------------------- 5 | -- ~ 2021.10.17 6 | -- | 7 | -- Module : Control.Unification.IntVar 8 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 9 | -- License : BSD 10 | -- Maintainer : wren@cpan.org 11 | -- Stability : experimental 12 | -- Portability : semi-portable (MPTCs, FlexibleInstances) 13 | -- 14 | -- This module defines a state monad for functional pointers 15 | -- represented by integers as keys into an @IntMap@. This technique 16 | -- was independently discovered by Dijkstra et al. This module 17 | -- extends the approach by using a state monad transformer, which 18 | -- can be made into a backtracking state monad by setting the 19 | -- underlying monad to some 'MonadLogic' (part of the @logict@ 20 | -- library, described by Kiselyov et al.). 21 | -- 22 | -- * Atze Dijkstra, Arie Middelkoop, S. Doaitse Swierstra (2008) 23 | -- /Efficient Functional Unification and Substitution/, 24 | -- Technical Report UU-CS-2008-027, Utrecht University. 25 | -- 26 | -- * Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, and 27 | -- Amr Sabry (2005) /Backtracking, Interleaving, and/ 28 | -- /Terminating Monad Transformers/, ICFP. 29 | ---------------------------------------------------------------- 30 | module Control.Unification.IntVar 31 | ( IntVar() 32 | , IntBindingState() 33 | , IntBindingT() 34 | , runIntBindingT 35 | , evalIntBindingT 36 | , execIntBindingT 37 | ) where 38 | 39 | import Prelude hiding (mapM, sequence, foldr, foldr1, foldl, foldl1) 40 | 41 | --import Data.Word (Word) 42 | import qualified Data.IntMap as IM 43 | import Control.Applicative 44 | import Control.Monad (MonadPlus(..), liftM) 45 | import Control.Monad.Trans (MonadTrans(..)) 46 | import Control.Monad.State (MonadState(..), StateT, runStateT, evalStateT, execStateT, gets) 47 | import Control.Monad.Logic (MonadLogic(..)) 48 | import Control.Unification.Classes 49 | ---------------------------------------------------------------- 50 | ---------------------------------------------------------------- 51 | 52 | -- | A ``mutable'' unification variable implemented by an integer. 53 | -- This provides an entirely pure alternative to truly mutable 54 | -- alternatives like @STVar@, which can make backtracking easier. 55 | newtype IntVar t = IntVar Int 56 | deriving (Show) 57 | 58 | {- 59 | -- BUG: This part works, but we'd want to change Show IntBindingState too. 60 | 61 | instance Show (IntVar t) where 62 | show (IntVar i) = "IntVar " ++ show (boundedInt2Word i) 63 | 64 | -- | Convert an integer to a word, via the continuous mapping that 65 | -- preserves @minBound@ and @maxBound@. 66 | boundedInt2Word :: Int -> Word 67 | boundedInt2Word i 68 | | i < 0 = fromIntegral (i + maxBound + 1) 69 | | otherwise = fromIntegral i + fromIntegral (maxBound :: Int) + 1 70 | -} 71 | 72 | instance Variable IntVar where 73 | eqVar (IntVar i) (IntVar j) = i == j 74 | 75 | getVarID (IntVar v) = v 76 | 77 | 78 | ---------------------------------------------------------------- 79 | -- | Binding state for 'IntVar'. 80 | data IntBindingState t = IntBindingState 81 | { nextFreeVar :: {-# UNPACK #-} !Int 82 | , varBindings :: IM.IntMap t 83 | } 84 | deriving (Show) 85 | 86 | 87 | -- | The initial @IntBindingState@. 88 | emptyIntBindingState :: IntBindingState t 89 | emptyIntBindingState = IntBindingState minBound IM.empty 90 | 91 | 92 | ---------------------------------------------------------------- 93 | -- | A monad for storing 'IntVar' bindings, implemented as a 'StateT'. 94 | -- For a plain state monad, set @m = Identity@; for a backtracking 95 | -- state monad, set @m = Logic@. 96 | newtype IntBindingT t m a = IBT { unIBT :: StateT (IntBindingState t) m a } 97 | 98 | -- For portability reasons, we're intentionally avoiding 99 | -- -XDeriveFunctor, -XGeneralizedNewtypeDeriving, and the like. 100 | 101 | instance (Functor m) => Functor (IntBindingT t m) where 102 | fmap f = IBT . fmap f . unIBT 103 | 104 | -- BUG: can't reduce dependency to Applicative because of StateT's instance. 105 | instance (Functor m, Monad m) => Applicative (IntBindingT t m) where 106 | pure = IBT . pure 107 | x <*> y = IBT (unIBT x <*> unIBT y) 108 | x *> y = IBT (unIBT x *> unIBT y) 109 | x <* y = IBT (unIBT x <* unIBT y) 110 | 111 | instance (Monad m) => Monad (IntBindingT t m) where 112 | return = IBT . return 113 | m >>= f = IBT (unIBT m >>= unIBT . f) 114 | 115 | instance MonadTrans (IntBindingT t) where 116 | lift = IBT . lift 117 | 118 | -- BUG: can't reduce dependency to Alternative because of StateT's instance. 119 | instance (Functor m, MonadPlus m) => Alternative (IntBindingT t m) where 120 | empty = IBT empty 121 | x <|> y = IBT (unIBT x <|> unIBT y) 122 | 123 | instance (MonadPlus m) => MonadPlus (IntBindingT t m) where 124 | mzero = IBT mzero 125 | mplus ml mr = IBT (mplus (unIBT ml) (unIBT mr)) 126 | 127 | instance (Monad m) => MonadState (IntBindingState t) (IntBindingT t m) where 128 | get = IBT get 129 | put = IBT . put 130 | 131 | -- N.B., we already have (MonadLogic m) => MonadLogic (StateT s m), 132 | -- provided that logict is compiled against the same mtl/monads-fd 133 | -- we're getting StateT from. Otherwise we'll get a bunch of warnings 134 | -- here. 135 | instance (MonadLogic m) => MonadLogic (IntBindingT t m) where 136 | msplit (IBT m) = IBT (coerce `liftM` msplit m) 137 | where 138 | coerce Nothing = Nothing 139 | coerce (Just (a, m')) = Just (a, IBT m') 140 | 141 | interleave (IBT l) (IBT r) = IBT (interleave l r) 142 | 143 | IBT m >>- f = IBT (m >>- (unIBT . f)) 144 | 145 | ifte (IBT b) t (IBT f) = IBT (ifte b (unIBT . t) f) 146 | 147 | once (IBT m) = IBT (once m) 148 | 149 | ---------------------------------------------------------------- 150 | 151 | runIntBindingT :: IntBindingT t m a -> m (a, IntBindingState t) 152 | runIntBindingT (IBT m) = runStateT m emptyIntBindingState 153 | 154 | 155 | -- | N.B., you should explicitly apply bindings before calling this 156 | -- function, or else the bindings will be lost 157 | evalIntBindingT :: (Monad m) => IntBindingT t m a -> m a 158 | evalIntBindingT (IBT m) = evalStateT m emptyIntBindingState 159 | 160 | 161 | execIntBindingT :: (Monad m) => IntBindingT t m a -> m (IntBindingState t) 162 | execIntBindingT (IBT m) = execStateT m emptyIntBindingState 163 | 164 | ---------------------------------------------------------------- 165 | 166 | instance (Applicative m, Monad m) => 167 | BindingReader IntVar t (IntBindingT t m) 168 | where 169 | lookupVar (IntVar v) = IBT $ gets (IM.lookup v . varBindings) 170 | 171 | 172 | instance (Applicative m, Monad m) => 173 | BindingGenerator IntVar t (IntBindingT t m) 174 | where 175 | freeVar = IBT $ do 176 | ibs <- get 177 | let v = nextFreeVar ibs 178 | if v == maxBound 179 | then fail "freeVar: no more variables!" 180 | else do 181 | put $ ibs { nextFreeVar = v+1 } 182 | return $ IntVar v 183 | 184 | newVar t = IBT $ do 185 | ibs <- get 186 | let v = nextFreeVar ibs 187 | if v == maxBound 188 | then fail "newVar: no more variables!" 189 | else do 190 | let bs' = IM.insert v t (varBindings ibs) 191 | put $ ibs { nextFreeVar = v+1, varBindings = bs' } 192 | return $ IntVar v 193 | 194 | 195 | instance (Applicative m, Monad m) => 196 | BindingWriter IntVar t (IntBindingT t m) 197 | where 198 | bindVar (IntVar v) t = IBT $ do 199 | ibs <- get 200 | let bs = varBindings ibs 201 | let (mt, bs') = IM.insertLookupWithKey (\_ _ -> id) v t bs 202 | put $ ibs { varBindings = bs' } 203 | return mt 204 | 205 | bindVar_ (IntVar v) t = IBT $ do 206 | ibs <- get 207 | put $ ibs { varBindings = IM.insert v t (varBindings ibs) } 208 | 209 | unbindVar (IntVar v) = IBT $ do 210 | ibs <- get 211 | let bs = varBindings ibs 212 | let (mt,bs') = IM.updateLookupWithKey (\_ _ -> Nothing) v bs 213 | put $ ibs { varBindings = bs' } 214 | return mt 215 | 216 | unbindVar_ (IntVar v) = IBT $ do 217 | ibs <- get 218 | put $ ibs { varBindings = IM.delete v (varBindings ibs) } 219 | 220 | ---------------------------------------------------------------- 221 | ----------------------------------------------------------- fin. 222 | -------------------------------------------------------------------------------- /test/bench/Control/Unification/STVar.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE Rank2Types 3 | , MultiParamTypeClasses 4 | , UndecidableInstances 5 | , FlexibleInstances 6 | #-} 7 | 8 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 9 | ---------------------------------------------------------------- 10 | -- ~ 2021.10.17 11 | -- | 12 | -- Module : Control.Unification.STVar 13 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 14 | -- License : BSD 15 | -- Maintainer : wren@cpan.org 16 | -- Stability : experimental 17 | -- Portability : semi-portable (Rank2Types, MPTCs, Undecidable-, FlexibleInstances) 18 | -- 19 | -- This module defines an implementation of mutable unification 20 | -- variables using the 'ST' monad. 21 | ---------------------------------------------------------------- 22 | module Control.Unification.STVar 23 | ( STVar() 24 | , STBinding() 25 | , runSTBinding 26 | ) where 27 | 28 | import Prelude hiding (mapM, sequence, foldr, foldr1, foldl, foldl1) 29 | 30 | import Data.STRef 31 | import Control.Applicative (Applicative(..), (<$>)) 32 | import Control.Monad (ap) 33 | import Control.Monad.Trans (lift) 34 | import Control.Monad.ST 35 | import Control.Monad.Reader (ReaderT, runReaderT, ask) 36 | import Control.Unification.Classes 37 | ---------------------------------------------------------------- 38 | ---------------------------------------------------------------- 39 | 40 | -- | A mutable unification variable implemented by an 'STRef'. In 41 | -- addition to the @STRef@ itself, we also track an orderable ID 42 | -- in order to use visited sets instead of occurance checks. 43 | data STVar s a = STVar {-# UNPACK #-} !Int {-# UNPACK #-} !(STRef s (Maybe a)) 44 | -- BUG: can we actually unpack STRef? 45 | 46 | 47 | instance Show (STVar s a) where 48 | show (STVar i _) = "STVar " ++ show i 49 | 50 | 51 | instance Variable (STVar s) where 52 | eqVar (STVar i _) (STVar j _) = i == j 53 | 54 | getVarID (STVar i _) = i 55 | 56 | 57 | ---------------------------------------------------------------- 58 | -- TODO: parameterize this so we can use BacktrackST too. Or course, 59 | -- that means defining another class for STRef-like variables 60 | -- 61 | -- TODO: does MTL still have the overhead that'd make it worthwhile 62 | -- to do this manually instead of using ReaderT? 63 | -- 64 | -- | A monad for handling 'STVar' bindings. 65 | newtype STBinding s a = STB { unSTB :: ReaderT (STRef s Int) (ST s) a } 66 | 67 | 68 | -- | Run the 'ST' binding monad. N.B., because 'STVar' are rank-2 69 | -- quantified, this guarantees that the return value has no such 70 | -- references. However, in order to remove the references from 71 | -- terms, you'll need to explicitly apply the bindings. 72 | runSTBinding :: (forall s. STBinding s a) -> a 73 | runSTBinding stb = 74 | runST (newSTRef minBound >>= runReaderT (unSTB stb)) 75 | 76 | 77 | -- For portability reasons, we're intentionally avoiding 78 | -- -XDeriveFunctor, -XGeneralizedNewtypeDeriving, and the like. 79 | 80 | instance Functor (STBinding s) where 81 | fmap f = STB . fmap f . unSTB 82 | 83 | instance Applicative (STBinding s) where 84 | pure = return 85 | (<*>) = ap 86 | (*>) = (>>) 87 | x <* y = x >>= \a -> y >> return a 88 | 89 | instance Monad (STBinding s) where 90 | return = STB . return 91 | stb >>= f = STB (unSTB stb >>= unSTB . f) 92 | 93 | 94 | ---------------------------------------------------------------- 95 | 96 | instance BindingReader (STVar s) t (STBinding s) where 97 | lookupVar (STVar _ r) = STB . lift $ readSTRef r 98 | 99 | 100 | _newSTVar :: String -> Maybe a -> STBinding s (STVar s a) 101 | _newSTVar fun mb = STB $ do 102 | nr <- ask 103 | n <- lift $ readSTRef nr 104 | if n == maxBound 105 | then fail $ fun ++ ": no more variables!" 106 | else lift $ do 107 | writeSTRef nr $! n+1 108 | STVar n <$> newSTRef mb 109 | 110 | 111 | instance BindingGenerator (STVar s) t (STBinding s) where 112 | freeVar = _newSTVar "freeVar" Nothing 113 | newVar t = _newSTVar "newVar" (Just t) 114 | 115 | 116 | _writeSTVar :: STVar s a -> Maybe a -> STBinding s () 117 | _writeSTVar (STVar _ r) = STB . lift . writeSTRef r 118 | 119 | 120 | instance BindingWriter (STVar s) t (STBinding s) where 121 | bindVar v t = lookupVar v <* bindVar_ v t 122 | unbindVar v = lookupVar v <* unbindVar_ v 123 | 124 | bindVar_ v t = _writeSTVar v (Just t) 125 | unbindVar_ v = _writeSTVar v Nothing 126 | 127 | ---------------------------------------------------------------- 128 | ----------------------------------------------------------- fin. 129 | -------------------------------------------------------------------------------- /test/bench2/Codensity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} 2 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 3 | {-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-name-shadowing #-} 4 | ---------------------------------------------------------------- 5 | -- ~ 2021.10.17 6 | -- | 7 | -- Module : Codensity 8 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 9 | -- License : BSD 10 | -- Maintainer : wren@cpan.org 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | -- Test the efficiency of 'MaybeK' vs 'Maybe' 15 | ---------------------------------------------------------------- 16 | module Codensity (main) where 17 | 18 | import Prelude 19 | hiding (mapM, mapM_, sequence, foldr, foldr1, foldl, foldl1, all, and, or) 20 | 21 | import Criterion.Main 22 | import Data.Foldable 23 | import Data.Traversable 24 | import Data.List.Extras.Pair 25 | import Control.Applicative 26 | import Control.Monad (MonadPlus(..)) 27 | import Control.Monad.Trans (MonadTrans(..)) 28 | import Control.Monad.Identity (Identity(..)) 29 | import Control.Monad.MaybeK (MaybeKT, runMaybeKT) 30 | import Control.Monad.Trans.Maybe (MaybeT(..)) 31 | import Control.Unification 32 | import Control.Unification.IntVar 33 | ---------------------------------------------------------------- 34 | ---------------------------------------------------------------- 35 | 36 | equalsMaybeKT', equalsMaybeKT'_, equalsMaybeKT, equalsMaybeKT_, equalsMaybeT, equalsMaybeT_, equalsMaybe_, equalsBool_ 37 | :: (BindingMonad t v m) 38 | => UTerm t v -- ^ 39 | -> UTerm t v -- ^ 40 | -> m Bool -- ^ 41 | 42 | equalsMaybeKT'_ tl0 tr0 = do 43 | mb <- runMaybeKT (loop tl0 tr0) 44 | case mb of 45 | Nothing -> return False 46 | Just () -> return True 47 | where 48 | loop tl0 tr0 = do 49 | tl0 <- lift $ semiprune tl0 50 | tr0 <- lift $ semiprune tr0 51 | case (tl0, tr0) of 52 | (UVar vl, UVar vr) 53 | | vl == vr -> return () -- success 54 | | otherwise -> do 55 | mtl <- lift $ lookupVar vl 56 | mtr <- lift $ lookupVar vr 57 | case (mtl, mtr) of 58 | (Nothing, Nothing) -> mzero 59 | (Nothing, Just _ ) -> mzero 60 | (Just _, Nothing) -> mzero 61 | -- (Just tl, Just tr) -> loop tl tr 62 | (Just (UTerm tl), Just (UTerm tr)) -> match tl tr 63 | _ -> error "equals: the impossible happened" 64 | (UVar _, UTerm _ ) -> mzero 65 | (UTerm _, UVar _ ) -> mzero 66 | (UTerm tl, UTerm tr) -> match tl tr 67 | match tl tr = 68 | case zipMatch_ tl tr of 69 | Nothing -> mzero 70 | Just tlr -> mapM_ (uncurry loop) tlr 71 | ---------------------------------------------------------------- 72 | equalsMaybeKT' tl0 tr0 = do 73 | mb <- runMaybeKT (loop tl0 tr0) 74 | case mb of 75 | Nothing -> return False 76 | Just () -> return True 77 | where 78 | loop tl0 tr0 = do 79 | tl0 <- lift $ semiprune tl0 80 | tr0 <- lift $ semiprune tr0 81 | case (tl0, tr0) of 82 | (UVar vl, UVar vr) 83 | | vl == vr -> return () -- success 84 | | otherwise -> do 85 | mtl <- lift $ lookupVar vl 86 | mtr <- lift $ lookupVar vr 87 | case (mtl, mtr) of 88 | (Nothing, Nothing) -> mzero 89 | (Nothing, Just _ ) -> mzero 90 | (Just _, Nothing) -> mzero 91 | -- (Just tl, Just tr) -> loop tl tr 92 | (Just (UTerm tl), Just (UTerm tr)) -> match tl tr 93 | _ -> error "equals: the impossible happened" 94 | (UVar _, UTerm _ ) -> mzero 95 | (UTerm _, UVar _ ) -> mzero 96 | (UTerm tl, UTerm tr) -> match tl tr 97 | match tl tr = 98 | case zipMatch tl tr of 99 | Nothing -> mzero 100 | Just tlr -> mapM_ loop_ tlr 101 | loop_ (Left _) = return () -- success 102 | loop_ (Right (tl,tr)) = loop tl tr 103 | ---------------------------------------------------------------- 104 | equalsMaybeKT_ tl0 tr0 = do 105 | mb <- runMaybeKT (loop tl0 tr0) 106 | case mb of 107 | Nothing -> return False 108 | Just () -> return True 109 | where 110 | loop tl0 tr0 = do 111 | tl0 <- lift $ semiprune tl0 112 | tr0 <- lift $ semiprune tr0 113 | case (tl0, tr0) of 114 | (UVar vl, UVar vr) 115 | | vl == vr -> return () -- success 116 | | otherwise -> do 117 | mtl <- lift $ lookupVar vl 118 | mtr <- lift $ lookupVar vr 119 | case (mtl, mtr) of 120 | (Nothing, Nothing) -> mzero 121 | (Nothing, Just _ ) -> mzero 122 | (Just _, Nothing) -> mzero 123 | (Just tl, Just tr) -> loop tl tr -- TODO: should just jump to match 124 | (UVar _, UTerm _ ) -> mzero 125 | (UTerm _, UVar _ ) -> mzero 126 | (UTerm tl, UTerm tr) -> 127 | case zipMatch_ tl tr of 128 | Nothing -> mzero 129 | Just tlr -> mapM_ (uncurry loop) tlr 130 | ---------------------------------------------------------------- 131 | equalsMaybeKT tl0 tr0 = do 132 | mb <- runMaybeKT (loop tl0 tr0) 133 | case mb of 134 | Nothing -> return False 135 | Just () -> return True 136 | where 137 | loop tl0 tr0 = do 138 | tl0 <- lift $ semiprune tl0 139 | tr0 <- lift $ semiprune tr0 140 | case (tl0, tr0) of 141 | (UVar vl, UVar vr) 142 | | vl == vr -> return () -- success 143 | | otherwise -> do 144 | mtl <- lift $ lookupVar vl 145 | mtr <- lift $ lookupVar vr 146 | case (mtl, mtr) of 147 | (Nothing, Nothing) -> mzero 148 | (Nothing, Just _ ) -> mzero 149 | (Just _, Nothing) -> mzero 150 | (Just tl, Just tr) -> loop tl tr -- TODO: should just jump to match 151 | (UVar _, UTerm _ ) -> mzero 152 | (UTerm _, UVar _ ) -> mzero 153 | (UTerm tl, UTerm tr) -> 154 | case zipMatch tl tr of 155 | Nothing -> mzero 156 | Just tlr -> mapM_ loop_ tlr 157 | loop_ (Left _) = return () -- success 158 | loop_ (Right (tl,tr)) = loop tl tr 159 | ---------------------------------------------------------------- 160 | equalsMaybeT_ tl0 tr0 = do 161 | mb <- runMaybeT (loop tl0 tr0) 162 | case mb of 163 | Nothing -> return False 164 | Just () -> return True 165 | where 166 | loop tl0 tr0 = do 167 | tl0 <- lift $ semiprune tl0 168 | tr0 <- lift $ semiprune tr0 169 | case (tl0, tr0) of 170 | (UVar vl, UVar vr) 171 | | vl == vr -> return () -- success 172 | | otherwise -> do 173 | mtl <- lift $ lookupVar vl 174 | mtr <- lift $ lookupVar vr 175 | case (mtl, mtr) of 176 | (Nothing, Nothing) -> mzero 177 | (Nothing, Just _ ) -> mzero 178 | (Just _, Nothing) -> mzero 179 | (Just tl, Just tr) -> loop tl tr -- TODO: should just jump to match 180 | (UVar _, UTerm _ ) -> mzero 181 | (UTerm _, UVar _ ) -> mzero 182 | (UTerm tl, UTerm tr) -> 183 | case zipMatch_ tl tr of 184 | Nothing -> mzero 185 | Just tlr -> mapM_ (uncurry loop) tlr 186 | ---------------------------------------------------------------- 187 | equalsMaybeT tl0 tr0 = do 188 | mb <- runMaybeT (loop tl0 tr0) 189 | case mb of 190 | Nothing -> return False 191 | Just () -> return True 192 | where 193 | loop tl0 tr0 = do 194 | tl0 <- lift $ semiprune tl0 195 | tr0 <- lift $ semiprune tr0 196 | case (tl0, tr0) of 197 | (UVar vl, UVar vr) 198 | | vl == vr -> return () -- success 199 | | otherwise -> do 200 | mtl <- lift $ lookupVar vl 201 | mtr <- lift $ lookupVar vr 202 | case (mtl, mtr) of 203 | (Nothing, Nothing) -> mzero 204 | (Nothing, Just _ ) -> mzero 205 | (Just _, Nothing) -> mzero 206 | (Just tl, Just tr) -> loop tl tr -- TODO: should just jump to match 207 | (UVar _, UTerm _ ) -> mzero 208 | (UTerm _, UVar _ ) -> mzero 209 | (UTerm tl, UTerm tr) -> 210 | case zipMatch tl tr of 211 | Nothing -> mzero 212 | Just tlr -> mapM_ loop_ tlr 213 | loop_ (Left _) = return () -- success 214 | loop_ (Right (tl,tr)) = loop tl tr 215 | ---------------------------------------------------------------- 216 | equalsMaybe_ tl0 tr0 = do 217 | mb <- loop tl0 tr0 218 | case mb of 219 | Nothing -> return False 220 | Just () -> return True 221 | where 222 | loop tl0 tr0 = do 223 | tl0 <- semiprune tl0 224 | tr0 <- semiprune tr0 225 | case (tl0, tr0) of 226 | (UVar vl, UVar vr) 227 | | vl == vr -> return (Just ()) -- success 228 | | otherwise -> do 229 | mtl <- lookupVar vl 230 | mtr <- lookupVar vr 231 | case (mtl, mtr) of 232 | (Nothing, Nothing) -> return Nothing 233 | (Nothing, Just _ ) -> return Nothing 234 | (Just _, Nothing) -> return Nothing 235 | (Just tl, Just tr) -> loop tl tr -- TODO: should just jump to match 236 | (UVar _, UTerm _ ) -> return Nothing 237 | (UTerm _, UVar _ ) -> return Nothing 238 | (UTerm tl, UTerm tr) -> 239 | case zipMatch_ tl tr of 240 | Nothing -> return Nothing 241 | Just tlr -> 242 | foldr 243 | (\ (tl',tr') k mb -> 244 | case mb of 245 | Nothing -> return Nothing 246 | Just () -> loop tl' tr' >>= k) 247 | return 248 | tlr 249 | (Just ()) 250 | ---------------------------------------------------------------- 251 | {- 252 | foldlM :: (Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a 253 | foldlM f z0 xs = foldr f' return xs z0 where f' x k z = f z x >>= k 254 | 255 | mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () 256 | mapM_ f = foldr ((>>) . f) (return ()) 257 | -} 258 | 259 | equalsBool_ tl0 tr0 = do 260 | tl0 <- semiprune tl0 261 | tr0 <- semiprune tr0 262 | case (tl0, tr0) of 263 | (UVar vl, UVar vr) 264 | | vl == vr -> return True -- success 265 | | otherwise -> do 266 | mtl <- lookupVar vl 267 | mtr <- lookupVar vr 268 | case (mtl, mtr) of 269 | (Nothing, Nothing) -> return False 270 | (Nothing, Just _ ) -> return False 271 | (Just _, Nothing) -> return False 272 | (Just tl, Just tr) -> equalsBool_ tl tr -- TODO: should just jump to match 273 | (UVar _, UTerm _ ) -> return False 274 | (UTerm _, UVar _ ) -> return False 275 | (UTerm tl, UTerm tr) -> 276 | case zipMatch_ tl tr of 277 | Nothing -> return False 278 | Just tlr -> 279 | -- and <$> mapM (uncurry equalsBool_) tlr -- TODO: use foldlM 280 | -- {- 281 | foldlM 282 | (\b (tl',tr') -> 283 | if b 284 | then equalsBool_ tl' tr' 285 | else return False) 286 | True 287 | tlr 288 | {- 289 | -- WTF: if we use this implementation instead, then the MaybeT implementation suddenly becomes faster than the Maybe version! (And this function becomes slightly faster too). 290 | foldr 291 | (\ (tl',tr') k b -> 292 | if b 293 | then equalsBool_ tl' tr' >>= k 294 | else return False) 295 | return 296 | tlr 297 | True 298 | -- -} 299 | ---------------------------------------------------------------- 300 | 301 | 302 | data S a = S {-# UNPACK #-} !Int ![a] 303 | deriving (Read, Show, Eq, Ord, Functor, Foldable, Traversable) 304 | 305 | instance Unifiable S where 306 | -- The old type. In order to run these benchmarks, you'll need to add it back to the class and reinstall the library. 307 | zipMatch_ (S a xs) (S b ys) 308 | | a == b = fmap (S a) (pair xs ys) 309 | | otherwise = Nothing 310 | 311 | -- The new type 312 | zipMatch (S a xs) (S b ys) 313 | | a == b = fmap (S a) (pairWith (\x y -> Right(x,y)) xs ys) 314 | | otherwise = Nothing 315 | 316 | type STerm = UTerm S IntVar 317 | 318 | s :: Int -> [STerm] -> STerm 319 | s = (UTerm .) . S 320 | 321 | foo2 :: STerm -> STerm -> STerm 322 | foo2 x y = s 1 [x,y] 323 | 324 | bar0 = s 2 [] 325 | baz0 = s 3 [] 326 | 327 | foo4 :: STerm -> STerm -> STerm -> STerm -> STerm 328 | foo4 a b c d = foo2 (foo2 a b) (foo2 c d) 329 | 330 | foo16 a b c d = 331 | foo4 (foo4 a a a a) (foo4 a a a b) (foo4 a a a c) (foo4 a a a d) 332 | 333 | -- N.B., don't go deeper than about 15 if you're printing the term. 334 | fooN :: Int -> STerm 335 | fooN n 336 | | n <= 0 = baz0 337 | | otherwise = let t = fooN $! n-1 in foo2 t t 338 | 339 | evalIB = runIdentity . evalIntBindingT 340 | 341 | main :: IO () 342 | main = 343 | let f t = foo2 (foo2 (foo2 baz0 baz0) (foo2 baz0 baz0)) 344 | (foo2 (foo2 baz0 baz0) (foo2 baz0 t)) 345 | g t = foo2 (foo2 (foo2 baz0 baz0) (foo2 baz0 t)) 346 | (foo2 (foo2 baz0 baz0) (foo2 baz0 baz0)) 347 | f1z = f baz0; f1r = f bar0; g1z = g baz0; g1r = g bar0 348 | f2z = f f1z; f2r = f f1r; g2z = g g1z; g2r = g g1r 349 | f3z = f f2z; f3r = f f2r; g3z = g g2z; g3r = g g2r 350 | f4z = f f3z; f4r = f f3r; g4z = g g3z; g4r = g g3r 351 | 352 | mkBGroup tl tr = 353 | [ bench "equalsMaybeKT'_" $ nf (evalIB . equalsMaybeKT'_ tl) tr 354 | , bench "equalsMaybeKT'" $ nf (evalIB . equalsMaybeKT' tl) tr 355 | , bench "equalsMaybeKT_" $ nf (evalIB . equalsMaybeKT_ tl) tr 356 | , bench "equalsMaybeKT" $ nf (evalIB . equalsMaybeKT tl) tr 357 | , bench "equalsMaybeT_" $ nf (evalIB . equalsMaybeT_ tl) tr 358 | , bench "equalsMaybeT" $ nf (evalIB . equalsMaybeT tl) tr 359 | , bench "equalsMaybe_" $ nf (evalIB . equalsMaybe_ tl) tr 360 | , bench "equalsBool_" $ nf (evalIB . equalsBool_ tl) tr 361 | , bench "equals (lib)" $ nf (evalIB . equals tl) tr 362 | ] 363 | 364 | 365 | xxx = fooN 10 366 | x0 = foo16 xxx xxx xxx xxx 367 | xA = foo16 bar0 xxx xxx xxx 368 | xB = foo16 xxx bar0 xxx xxx 369 | xC = foo16 xxx xxx bar0 xxx 370 | xD = foo16 xxx xxx xxx bar0 371 | in 372 | defaultMain 373 | {- 374 | [ bgroup "x0.xA" $ mkBGroup x0 xA 375 | , bgroup "x0.xB" $ mkBGroup x0 xB 376 | , bgroup "x0.xC" $ mkBGroup x0 xC 377 | , bgroup "x0.xD" $ mkBGroup x0 xD 378 | , bgroup "x0.x0" $ mkBGroup x0 x0 379 | ] 380 | -} 381 | [ bgroup "g1zr" $ mkBGroup g1z g1r 382 | , bgroup "g2zr" $ mkBGroup g2z g2r 383 | , bgroup "g3zr" $ mkBGroup g3z g3r 384 | , bgroup "g4zr" $ mkBGroup g4z g4r 385 | -- 386 | , bgroup "f1zr" $ mkBGroup f1z f1r 387 | , bgroup "f2zr" $ mkBGroup f2z f2r 388 | , bgroup "f3zr" $ mkBGroup f3z f3r 389 | , bgroup "f4zr" $ mkBGroup f4z f4r 390 | -- 391 | , bgroup "f1zz" $ mkBGroup f1z f1z 392 | , bgroup "f2zz" $ mkBGroup f2z f2z 393 | , bgroup "f3zz" $ mkBGroup f3z f3z 394 | , bgroup "f4zz" $ mkBGroup f4z f4z 395 | ] 396 | 397 | ---------------------------------------------------------------- 398 | ----------------------------------------------------------- fin. 399 | -------------------------------------------------------------------------------- /test/correctness/TestInteractive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 3 | ---------------------------------------------------------------- 4 | -- 2021.10.17 5 | -- | 6 | -- Module : TestInteractive 7 | -- Copyright : Copyright (c) 2009--2021 wren gayle romano 8 | -- License : BSD 9 | -- Maintainer : wren@cpan.org 10 | -- Stability : test 11 | -- Portability : non-portable 12 | -- 13 | -- An interactive testbed for playing around with things. 14 | ---------------------------------------------------------------- 15 | module TestInteractive where 16 | import Data.Foldable 17 | import Data.Traversable 18 | import Data.List.Extras.Pair 19 | import Control.Applicative 20 | import Control.Monad.Identity 21 | import Control.Monad.Error 22 | import Control.Monad.MaybeK 23 | import Control.Monad.EitherK 24 | import Control.Unification 25 | import Control.Unification.Types 26 | import Control.Unification.IntVar 27 | ---------------------------------------------------------------- 28 | ---------------------------------------------------------------- 29 | 30 | data S a = S String [a] 31 | deriving (Read, Show, Eq, Ord, Functor, Foldable, Traversable) 32 | 33 | instance Unifiable S where 34 | zipMatch (S a xs) (S b ys) 35 | | a == b = fmap (S a) (pair xs ys) 36 | | otherwise = Nothing 37 | 38 | type STerm = UTerm S IntVar 39 | 40 | s :: String -> [STerm] -> STerm 41 | s = (UTerm .) . S 42 | 43 | foo1 :: STerm -> STerm 44 | foo1 x = s "foo" [x] 45 | 46 | foo2 :: STerm -> STerm -> STerm 47 | foo2 x y = s "foo" [x,y] 48 | 49 | bar1 :: STerm -> STerm 50 | bar1 x = s "bar" [x] 51 | 52 | baz0 :: STerm 53 | baz0 = s "baz" [] 54 | 55 | -- N.B., don't go deeper than about 15 if you're printing the term. 56 | fooN :: Int -> STerm 57 | fooN n 58 | | n <= 0 = baz0 59 | | otherwise = let t = fooN $! n-1 in foo2 t t 60 | 61 | fooNxl n 62 | | n <= 0 = return baz0 63 | | otherwise = do 64 | x <- UVar <$> freeVar 65 | t <- fooNxl $! n-1 66 | return (foo2 x t) 67 | 68 | fooNxr n 69 | | n <= 0 = return baz0 70 | | otherwise = do 71 | x <- UVar <$> freeVar 72 | t <- fooNxr $! n-1 73 | return (foo2 t x) 74 | 75 | withNVars :: (Show a) => Int -> ([STerm] -> IntBindingT S Identity a) -> IO () 76 | withNVars = \n io -> print . runIdentity . runIntBindingT $ go [] n io 77 | where 78 | go xs 0 io = io (reverse xs) 79 | go xs n io = do x <- freeVar ; go (UVar x : xs) (n-1) io 80 | 81 | test1 = withNVars 2 $ \[x,y] -> runEitherKT $ do 82 | let t10 = bar1 baz0 83 | t1x = bar1 x 84 | t2xy = foo2 x y 85 | t200 = foo2 baz0 baz0 86 | -- 87 | _ <- unify t10 t1x 88 | _ <- unify x y 89 | -- This should succeed, but will fail if the visited-set doesn't backtrack properly when coming up from recursion 90 | unify t200 t2xy 91 | 92 | unifies [] = return () 93 | unifies [_] = return () 94 | unifies (x:xs) = go xs x 95 | where 96 | go [] _ = return () 97 | go (x:xs) y = unify x y >>= go xs 98 | 99 | 100 | unifiesOccurs [] = return () 101 | unifiesOccurs [_] = return () 102 | unifiesOccurs (x:xs) = go xs x 103 | where 104 | go [] _ = return () 105 | go (x:xs) y = unifyOccurs x y >>= go xs 106 | 107 | {- 108 | A stupid benchmark demonstrating the occurs-check removal. We use @t@ to ensure the whole tree gets filled in since @tl@ and @tr@ are linear terms and we can unify them with each other by doing one bindVar 109 | 110 | print 111 | . runIdentity 112 | . runIntBindingT 113 | $ do 114 | tl <- fooNxl 15 115 | tr <- fooNxr 15 116 | let t = fooN 15 117 | runEitherKT (unifies [tl,t,tr]) 118 | -- unifiesOccurs [tl,t,tr] 119 | -- unifies/Occurs [tl,tr,t] 120 | -- unifies/Occurs [tl,t,tr,t] 121 | return () 122 | -} 123 | ---------------------------------------------------------------- 124 | ----------------------------------------------------------- fin. 125 | -------------------------------------------------------------------------------- /test/experiments/feature-structures/FeatureStructure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor 2 | , DeriveFoldable 3 | , DeriveTraversable 4 | #-} 5 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 6 | ---------------------------------------------------------------- 7 | -- ~ 2021.10.17 8 | -- | 9 | -- Module : FeatureStructure 10 | -- Copyright : Copyright (c) 2012--2021 wren gayle romano 11 | -- License : BSD 12 | -- Maintainer : wren@cpan.org 13 | -- Stability : experimental 14 | -- Portability : non-portable 15 | -- 16 | -- An implementation of feature structures, to test for feasibility. 17 | ---------------------------------------------------------------- 18 | module FeatureStructure where 19 | 20 | import Prelude hiding 21 | ( mapM, mapM_, sequence, foldr, foldr1, foldl, foldl1 22 | , any, all, and, or, elem 23 | ) 24 | import qualified Data.Map as M 25 | import Data.Foldable 26 | import Data.Traversable 27 | import Control.Applicative 28 | import Control.Unification 29 | import Control.Unification.IntVar 30 | import Control.Monad.Error (ErrorT(..)) 31 | import Control.Monad.Identity (Identity(..)) 32 | ---------------------------------------------------------------- 33 | ---------------------------------------------------------------- 34 | 35 | type FSTerm k = UTerm (FS k) IntVar 36 | 37 | newtype FS k a = FS (M.Map k a) 38 | deriving (Show, Functor, Foldable, Traversable) 39 | 40 | type FSError k = UnificationFailure (FS k) IntVar 41 | 42 | evalFS 43 | :: ErrorT (FSError k) (IntBindingT (FS k) Identity) a 44 | -> Either (FSError k) a 45 | evalFS 46 | = runIdentity 47 | . evalIntBindingT 48 | . runErrorT 49 | 50 | emptyFS :: Ord k => FSTerm k 51 | emptyFS = UTerm $ FS M.empty 52 | 53 | conFS :: Ord k => k -> FSTerm k -> FSTerm k 54 | conFS k = UTerm . FS . M.singleton k 55 | 56 | consFS :: Ord k => [(k, FSTerm k)] -> FSTerm k 57 | consFS = UTerm . FS . M.fromList 58 | 59 | flatFS :: Ord k => [k] -> FSTerm k 60 | flatFS = UTerm . FS . M.fromList . map (\k -> (k, emptyFS)) 61 | 62 | 63 | -- BUG: need the new containers library to actually merge efficiently 64 | instance (Ord k) => Unifiable (FS k) where 65 | zipMatch (FS ls) (FS rs) = 66 | Just . FS $ M.unionWith (\(Left l) (Left r) -> Right (l,r)) 67 | (fmap Left ls) 68 | (fmap Left rs) 69 | 70 | 71 | ---------------------------------------------------------------- 72 | ----------------------------------------------------------- fin. 73 | -------------------------------------------------------------------------------- /test/experiments/putting/PuttingDM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses 2 | , FlexibleInstances 3 | , FlexibleContexts 4 | , GeneralizedNewtypeDeriving 5 | , DeriveFunctor 6 | , DeriveFoldable 7 | , DeriveTraversable 8 | , TypeSynonymInstances 9 | #-} 10 | {-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-deprecations #-} 11 | ---------------------------------------------------------------- 12 | -- ~ 2021.10.17 13 | -- | 14 | -- Module : PuttingDM 15 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 16 | -- License : BSD 17 | -- Maintainer : wren@cpan.org 18 | -- Stability : experimental 19 | -- Portability : non-portable 20 | -- 21 | -- An implementation of Hindley--Damas--Milner a la Peyton Jones, 22 | -- Vytiniotis, Weirich, and Shields /Practical type inference for/ 23 | -- /arbitrary-rank types/ using the unification-fd library. This 24 | -- is mainly here for testing and debugging, rather than for actual 25 | -- use. 26 | ---------------------------------------------------------------- 27 | module Putting where 28 | 29 | import Prelude hiding 30 | ( mapM, mapM_, sequence, foldr, foldr1, foldl, foldl1 31 | , any, all, and, or, elem 32 | ) 33 | import qualified Data.Map as M 34 | import qualified Data.Set as S 35 | import Data.List ((\\)) 36 | import Data.Maybe (fromMaybe) 37 | import Data.Foldable 38 | import Data.Traversable 39 | import Control.Applicative 40 | import Control.Arrow (first, second) 41 | import Control.Monad.Trans (MonadTrans(..)) 42 | import Control.Monad.Error (Error(..), MonadError(..), ErrorT(..)) 43 | import Control.Monad.Identity (Identity(..)) 44 | import Control.Monad.Reader (MonadReader(..), asks, ReaderT(..), runReaderT) 45 | import Control.Monad.State (MonadState(..), State, execState) 46 | import Control.Monad.State.UnificationExtras (modify') 47 | import Control.Unification hiding (unify, lookupVar) 48 | import qualified Control.Unification as U 49 | import Control.Unification.IntVar 50 | ---------------------------------------------------------------- 51 | ---------------------------------------------------------------- 52 | 53 | type Name = String 54 | type Uniq = Int 55 | data Term 56 | = Var Name -- x 57 | | Lit Int -- 3 58 | | App Term Term -- f x 59 | | Lam Name Term -- \x. x 60 | | Let Name Term Term -- let x = f y in x+1 61 | | Ann Term Sigma -- x :: t 62 | deriving (Show) 63 | 64 | type Sigma = Type 65 | type Rho = Type -- No top-level ForAll 66 | type Tau = Type -- No ForAlls anywhere 67 | type Type = UTerm Ty MetaTv 68 | data Ty t 69 | = ForAll [TyVar] t -- Forall type 70 | | Fun t t -- Function type 71 | | TyCon TyCon -- Type constants 72 | | TyVar TyVar -- Always bound by a ForAll 73 | deriving (Show, Functor, Foldable, Traversable) 74 | type MetaTv = IntVar -- N.B., invariant: metas can only be bound to Tau! 75 | data TyVar 76 | = BoundTv Name -- A type variable bound by a ForAll 77 | | SkolemTv Name Uniq -- A skolem constant; the Name is just to improve error messages 78 | deriving (Show, Eq, Ord) 79 | data TyCon 80 | = IntT 81 | | BoolT 82 | deriving (Show, Eq) 83 | 84 | -- | Build a function type (abstractly). 85 | (==>) :: Type -> Type -> Type 86 | arg ==> res = UTerm (Fun arg res) 87 | 88 | -- | The integer type (abstractly). 89 | intType :: Tau 90 | intType = UTerm (TyCon IntT) 91 | 92 | -- | The boolean type (abstractly). 93 | boolType :: Tau 94 | boolType = UTerm (TyCon BoolT) 95 | 96 | instance Unifiable Ty where 97 | zipMatch (ForAll vls tl) (ForAll vrs tr) 98 | | and $ zipWith (==) vls vrs = Just $ ForAll vls (Right(tl,tr)) 99 | 100 | zipMatch (Fun tl1 tl2) (Fun tr1 tr2) 101 | = Just $ Fun (Right(tl1,tr1)) (Right(tl2,tr2)) 102 | 103 | zipMatch (TyCon cl) (TyCon cr) 104 | | cl == cr = Just $ TyCon cl 105 | 106 | zipMatch (TyVar vl) (TyVar vr) 107 | | vl == vr = Just $ TyVar vl 108 | 109 | zipMatch _ _ = Nothing 110 | 111 | ---------------------------------------------------------------- 112 | 113 | type TCState = M.Map Name Type 114 | 115 | data TCFailure 116 | = OccursFailure IntVar (UTerm Ty IntVar) 117 | | MismatchFailure (Ty (UTerm Ty IntVar)) (Ty (UTerm Ty IntVar)) 118 | | CheckFailure String 119 | | LookupVarFailure Name 120 | deriving (Show) 121 | 122 | instance Fallible Ty IntVar TCFailure where 123 | occursFailure = OccursFailure 124 | mismatchFailure = MismatchFailure 125 | 126 | instance Error TCFailure where 127 | noMsg = CheckFailure "" 128 | strMsg = CheckFailure 129 | 130 | -- | The type-checker monad. 131 | newtype Tc a = 132 | TC { unTC :: 133 | ReaderT TCState -- Gamma: types for term-variables 134 | (ErrorT TCFailure -- possibility for failure 135 | (IntBindingT Ty -- unification metavariables 136 | Identity)) 137 | a } 138 | deriving 139 | ( Functor 140 | , Applicative 141 | , Monad 142 | , MonadReader TCState 143 | , MonadError TCFailure 144 | ) 145 | 146 | 147 | evalTC :: Tc a -> Either TCFailure a 148 | evalTC 149 | = runIdentity 150 | . evalIntBindingT 151 | . runErrorT 152 | . flip runReaderT M.empty 153 | . unTC 154 | 155 | 156 | -- | Type inference can fail. 157 | check :: Bool -> String -> Tc () 158 | check True _ = return () 159 | check False msg = throwError $ CheckFailure msg 160 | 161 | 162 | -- | Look up a 'TyVar' in Gamma. 163 | lookupVar :: Name -> Tc Sigma 164 | lookupVar x = do 165 | mb <- asks $ M.lookup x 166 | case mb of 167 | Nothing -> throwError $ LookupVarFailure x 168 | Just t -> return t 169 | 170 | 171 | -- | Extend Gamma locally. 172 | extendVarEnv :: Name -> Sigma -> Tc a -> Tc a 173 | extendVarEnv x t m = local (M.insert x t) m 174 | 175 | 176 | -- | Get Gamma. 177 | getEnvTypes :: Tc [Sigma] 178 | getEnvTypes = M.elems <$> ask 179 | 180 | 181 | unify :: Tau -> Tau -> Tc () 182 | unify tl tr = TC . lift $ tl =:= tr >> return () 183 | 184 | 185 | -- | Make (MetaTv tv), where tv is fresh 186 | newMetaTyVar :: Tc Tau 187 | newMetaTyVar = TC . lift . lift $ UVar <$> freeVar 188 | 189 | 190 | -- | Make a fresh skolem TyVar for some given TyVar 191 | newSkolemTyVar :: TyVar -> Tc TyVar 192 | newSkolemTyVar tv = SkolemTv (tyVarName tv) <$> newUnique 193 | where 194 | -- HACK: this became ambiguous since 2012, thus requiring the inline signature on getVarID... 195 | newUnique :: Tc Uniq 196 | newUnique = TC . lift . lift $ (getVarID :: IntVar -> Int) <$> freeVar 197 | 198 | tyVarName :: TyVar -> Name 199 | tyVarName (BoundTv name) = name 200 | tyVarName (SkolemTv name _) = name 201 | 202 | 203 | -- | Return the free metavariables in the list of types. 204 | getMetaTyVars :: [Type] -> Tc [MetaTv] 205 | getMetaTyVars = TC . lift . lift . U.getFreeVarsAll 206 | 207 | 208 | -- | Return all the free type-variables in the list of types. (The 209 | -- free ones must be Skolems.) This is monadic because it respects 210 | -- the metavariable bindings. 211 | getFreeTyVars :: [Type] -> Tc [TyVar] 212 | getFreeTyVars = fmap freeTyVars . zonkTypeAll 213 | where 214 | -- The strange name ``zonkType'' comes from the paper. This 215 | -- definition optimizes over doing @mapM zonkType@ with the 216 | -- definition that shows up later on (using 'U.applyBindings') 217 | zonkTypeAll :: [Type] -> Tc [Type] 218 | zonkTypeAll = TC . lift . U.applyBindingsAll 219 | 220 | -- TODO: could optimize this to take advantage of sharing... 221 | -- TODO: need to debug/check this 222 | freeTyVars :: [Type] -> [TyVar] 223 | freeTyVars ts0 = 224 | S.toList . snd $ execState (mapM_ go ts0) (S.empty, S.empty) 225 | where 226 | go :: Type -> State (S.Set TyVar, S.Set TyVar) () 227 | go (UTerm(ForAll ns ty)) = do 228 | bound_ns <- fst <$> get 229 | modify' (first (S.union $ S.fromList ns)) 230 | go ty 231 | modify' (first (const bound_ns)) 232 | go (UTerm(Fun arg res)) = go arg >> go res 233 | go (UTerm(TyCon _tc)) = return () 234 | go (UTerm(TyVar n)) = do 235 | bound_ns <- fst <$> get 236 | if S.member n bound_ns 237 | then return () 238 | else modify' (second (S.insert n)) 239 | go (UVar _tv) = undefined 240 | 241 | 242 | readTv :: MetaTv -> Tc (Maybe Type) 243 | readTv = TC . lift . lift . U.lookupVar 244 | 245 | 246 | writeTv :: MetaTv -> Type -> Tc () 247 | writeTv tv = TC . lift . lift . bindVar tv 248 | 249 | ---------------------------------------------------------------- 250 | 251 | inferRho :: Term -> Tc Rho 252 | {- 253 | -- Algorithm W: 254 | inferRho (Lit _) = return intType 255 | inferRho (App fun arg) = do 256 | fun_ty <- inferRho fun 257 | arg_ty <- inferRho arg 258 | res_ty <- newMetaTyVar 259 | unify fun_ty (arg_ty ==> res_ty) 260 | return res_ty 261 | ... 262 | 263 | -- Algorithm M: 264 | -} 265 | inferRho expr = do 266 | exp_ty <- newMetaTyVar 267 | checkRho expr exp_ty 268 | return exp_ty 269 | 270 | 271 | checkRho :: Term -> Rho -> Tc () 272 | 273 | checkRho (Lit _) exp_ty = 274 | unify intType exp_ty 275 | 276 | checkRho (App fun arg) exp_ty = do 277 | fun_ty <- inferRho fun 278 | (arg_ty, res_ty) <- unifyFun fun_ty 279 | checkRho arg arg_ty 280 | unify res_ty exp_ty 281 | 282 | checkRho (Lam var body) exp_ty = do 283 | (pat_ty, body_ty) <- unifyFun exp_ty 284 | extendVarEnv var pat_ty (checkRho body body_ty) 285 | 286 | checkRho (Var v) exp_ty = do 287 | v_sigma <- lookupVar v 288 | instSigma v_sigma exp_ty 289 | 290 | checkRho (Let v rhs body) exp_ty = do 291 | v_sigma <- inferSigma rhs 292 | extendVarEnv v v_sigma (checkRho body exp_ty) 293 | 294 | checkRho (Ann body ann_ty) exp_ty = do 295 | body_ty <- inferSigma body 296 | subsCheck body_ty ann_ty 297 | instSigma ann_ty exp_ty 298 | 299 | 300 | unifyFun :: Rho -> Tc (Rho, Rho) 301 | unifyFun (UTerm(Fun arg_ty res_ty)) = return (arg_ty, res_ty) 302 | unifyFun fun_ty = do 303 | arg_ty <- newMetaTyVar 304 | res_ty <- newMetaTyVar 305 | unify fun_ty (arg_ty ==> res_ty) 306 | return (arg_ty,res_ty) 307 | 308 | 309 | instSigma :: Sigma -> Rho -> Tc () 310 | instSigma sigma exp_ty = do 311 | rho <- instantiate sigma 312 | unify rho exp_ty 313 | 314 | 315 | inferSigma :: Term -> Tc Sigma 316 | inferSigma e = do 317 | res_ty <- inferRho e 318 | env_tys <- getEnvTypes 319 | env_tvs <- getMetaTyVars env_tys 320 | res_tvs <- getMetaTyVars [res_ty] 321 | let forall_tvs = res_tvs \\ env_tvs -- -> -- BUG: syntax highlighting 322 | quantify forall_tvs res_ty 323 | 324 | 325 | subsCheck :: Type -> Type -> Tc () 326 | 327 | subsCheck sigma1 sigma2@(UTerm(ForAll _ _)) = do -- Rule SKOL 328 | (skol_tvs, rho2') <- skolemise sigma2 329 | subsCheck sigma1 rho2' 330 | esc_tvs <- getFreeTyVars [sigma1] 331 | let bad_tvs = filter (`elem` esc_tvs) skol_tvs 332 | check (null bad_tvs) "Type not polymorphic enough" 333 | 334 | subsCheck sigma1@(UTerm(ForAll _ _)) rho2 = do -- Rule INST 335 | rho1' <- instantiate sigma1 336 | subsCheck rho1' rho2 337 | 338 | subsCheck rho1 rho2 = -- Rule MONO 339 | unify rho1 rho2 340 | 341 | 342 | -- | Instantiate the topmost ForAlls of the argument type with 343 | -- flexible type variables. 344 | instantiate :: Sigma -> Tc Rho 345 | instantiate (UTerm(ForAll tvs ty)) = do 346 | tvs' <- mapM (\_ -> newMetaTyVar) tvs 347 | return (substTy tvs tvs' ty) 348 | instantiate ty = return ty 349 | 350 | 351 | skolemise :: Sigma -> Tc ([TyVar], Rho) 352 | skolemise (UTerm(ForAll tvs ty)) = do 353 | sks <- mapM newSkolemTyVar tvs 354 | return (sks, substTy tvs (map (UTerm . TyVar) sks) ty) 355 | skolemise ty = return ([], ty) 356 | 357 | 358 | type Env = [(TyVar, Tau)] 359 | 360 | -- Replace the specified quantified type variables by 361 | -- given meta type variables 362 | -- No worries about capture, because the two kinds of type 363 | -- variable are distinct 364 | substTy :: [TyVar] -> [Type] -> Type -> Sigma 365 | substTy tvs tys ty = go (tvs `zip` tys) ty 366 | where 367 | go :: Env -> Type -> Type 368 | go env (UTerm(Fun arg res)) = UTerm$Fun (go env arg) (go env res) 369 | go env (UTerm(TyVar n)) = fromMaybe (UTerm$TyVar n) (lookup n env) 370 | go _ (UVar tv) = UVar tv 371 | go _ (UTerm(TyCon tc)) = UTerm$TyCon tc 372 | go env (UTerm(ForAll ns rho)) = UTerm$ForAll ns (go env' rho) 373 | where 374 | env' = [(n,ty') | (n,ty') <- env, not (n `elem` ns)] 375 | 376 | -- Quantify over the specified type variables (all flexible) 377 | quantify :: [MetaTv] -> Rho -> Tc Sigma 378 | quantify = undefined 379 | {- 380 | -- Not in scope: tyVarBndrs, allBinders 381 | quantify tvs ty = do 382 | mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way 383 | ty' <- zonkType ty -- of doing the substitution 384 | return (ForAll new_bndrs ty') 385 | where 386 | used_bndrs = tyVarBndrs ty -- Avoid quantified type variables in use 387 | new_bndrs = take (length tvs) (allBinders \\ used_bndrs) 388 | bind (tv, name) = writeTv tv (UTerm(TyVar name)) 389 | 390 | where 391 | -- The strange name ``zonkType'' comes from the paper. 392 | zonkType :: Type -> Tc Type 393 | zonkType = TC . lift . U.applyBindings 394 | -} 395 | 396 | ---------------------------------------------------------------- 397 | ----------------------------------------------------------- fin. 398 | -------------------------------------------------------------------------------- /test/experiments/putting/PuttingHR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses 2 | , FlexibleInstances 3 | , FlexibleContexts 4 | , GeneralizedNewtypeDeriving 5 | , DeriveFunctor 6 | , DeriveFoldable 7 | , DeriveTraversable 8 | , TypeSynonymInstances 9 | #-} 10 | {-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-deprecations #-} 11 | ---------------------------------------------------------------- 12 | -- ~ 2021.10.17 13 | -- | 14 | -- Module : PuttingHR 15 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 16 | -- License : BSD 17 | -- Maintainer : wren@cpan.org 18 | -- Stability : experimental 19 | -- Portability : non-portable 20 | -- 21 | -- An implementation of higher-ranked type checking a la Peyton 22 | -- Jones, Vytiniotis, Weirich, and Shields /Practical type inference/ 23 | -- /for arbitrary-rank types/ using the unification-fd library. This 24 | -- is mainly here for testing and debugging, rather than for actual 25 | -- use. 26 | ---------------------------------------------------------------- 27 | module Putting where 28 | 29 | import Prelude hiding 30 | ( mapM, mapM_, sequence, foldr, foldr1, foldl, foldl1 31 | , any, all, and, or, elem, concat 32 | ) 33 | import qualified Data.Map as M 34 | import Data.List ((\\)) 35 | import Data.Maybe (fromMaybe) 36 | import Data.IORef 37 | import Data.Foldable 38 | import Data.Traversable 39 | import Control.Applicative 40 | import Control.Monad (liftM) 41 | import Control.Monad.Error (Error(..), MonadError(..), ErrorT(..)) 42 | import Control.Monad.Reader (MonadReader(..), asks, ReaderT(..), runReaderT) 43 | import Control.Monad.Trans (MonadTrans(..)) 44 | import Control.Unification hiding (unify, lookupVar) 45 | import Control.Unification.IntVar 46 | ---------------------------------------------------------------- 47 | ---------------------------------------------------------------- 48 | 49 | type Name = String 50 | 51 | -- To add multi-branch constructs like case and conditionals, see "unification under a mixed prefix" for typing it etc. However, apparently that will type fewer programs than using the equivalence relation induced by two-way subsumption... It also looses the property that if $\Gamma' \vdash^{poly}_\Downarrow t : \sigma$ and $\vdash^{dsk} \Gamma \leq \Gamma'$ then $\Gamma \vdash^poly_\Downarrow t : \sigma$. (Though the checkingness can be regained by adding type annotations.) 52 | data Term 53 | = Var Name -- ^ @x@ 54 | | Lit Int -- ^ @3@ 55 | | App Term Term -- ^ @f x@ 56 | | Lam Name Term -- ^ @\x. x@ 57 | | ALam Name Sigma Term -- ^ @\(x::t). x@ 58 | | Let Name Term Term -- ^ @let x = f y in x+1@ 59 | | Ann Term Sigma -- ^ @x :: t@ 60 | deriving (Show) 61 | 62 | ---------------------------------------------------------------- 63 | 64 | type Sigma = Type 65 | type Rho = Type -- ^ No top-level @ForAll@ 66 | type Tau = Type -- ^ No @ForAll@s anywhere 67 | type Type = UTerm Ty MetaTv 68 | data Ty t 69 | = ForAll [TyVar] t -- ^ Forall type 70 | | Fun t t -- ^ Function type 71 | | TyCon TyCon -- ^ Type constants 72 | | TyVar TyVar -- ^ Always bound by a @ForAll@ 73 | deriving (Show, Functor, Foldable, Traversable) 74 | 75 | -- | Invariant: metas can only be bound to 'Tau' 76 | type MetaTv = IntVar 77 | 78 | data TyVar 79 | = BoundTv Name -- ^ A type variable bound by a @ForAll@ 80 | | SkolemTv Name Uniq -- ^ A skolem constant; the Name is just to improve error messages 81 | deriving (Show, Eq) 82 | 83 | type Uniq = Int 84 | 85 | data TyCon 86 | = IntT 87 | | BoolT 88 | deriving (Show, Eq) 89 | 90 | 91 | -- | Build a function type (abstractly). 92 | (==>) :: Type -> Type -> Type 93 | arg ==> res = UTerm (Fun arg res) 94 | 95 | 96 | -- | The integer type (abstractly). 97 | intType :: Tau 98 | intType = UTerm (TyCon IntT) 99 | 100 | -- | The boolean type (abstractly). 101 | boolType :: Tau 102 | boolType = UTerm (TyCon BoolT) 103 | 104 | 105 | instance Unifiable Ty where 106 | zipMatch (ForAll vls tl) (ForAll vrs tr) 107 | | and $ zipWith (==) vls vrs = Just $ ForAll vls (Right(tl,tr)) 108 | zipMatch (Fun tl1 tl2) (Fun tr1 tr2) 109 | = Just $ Fun (Right(tl1,tr1)) (Right(tl2,tr2)) 110 | zipMatch (TyCon cl) (TyCon cr) 111 | | cl == cr = Just $ TyCon cl 112 | zipMatch (TyVar vl) (TyVar vr) 113 | | vl == vr = Just $ TyVar vl 114 | zipMatch _ _ = Nothing 115 | 116 | ---------------------------------------------------------------- 117 | 118 | -- | Directionalities for rules which are polymorphic in checking 119 | -- vs inference. 120 | data Expected t 121 | = Check t 122 | | Infer (TcRef t) 123 | 124 | type TcRef a = IORef a -- TODO: replace by IVar, or something else closer to truth. (or break our invariant and just use a metavariable) 125 | 126 | newTcRef :: a -> Tc (TcRef a) 127 | newTcRef = TC . lift . lift . lift . newIORef -- TODO: liftIO or liftBase 128 | 129 | -- TODO: throw errors on writing twice. 130 | writeTcRef :: TcRef a -> a -> Tc () 131 | writeTcRef = ((TC . lift . lift . lift) .) . writeIORef 132 | 133 | readTcRef :: TcRef a -> Tc a 134 | readTcRef = TC . lift . lift . lift . readIORef 135 | 136 | ---------------------------------------------------------------- 137 | 138 | type TCState = M.Map Name Type 139 | 140 | data TCFailure 141 | = OccursFailure IntVar (UTerm Ty IntVar) 142 | | MismatchFailure (Ty (UTerm Ty IntVar)) (Ty (UTerm Ty IntVar)) 143 | | CheckFailure String 144 | | LookupVarFailure Name 145 | deriving (Show) 146 | 147 | instance Fallible Ty IntVar TCFailure where 148 | occursFailure = OccursFailure 149 | mismatchFailure = MismatchFailure 150 | 151 | instance Error TCFailure where 152 | noMsg = CheckFailure "" 153 | strMsg = CheckFailure 154 | 155 | -- | The type-checker monad. 156 | newtype Tc a = 157 | TC { unTC :: 158 | ReaderT TCState -- Gamma: types for term-variables 159 | (ErrorT TCFailure -- possibility for failure 160 | (IntBindingT Ty -- unification metavariables 161 | IO)) -- TcRefs for the inference direction 162 | a } 163 | deriving 164 | ( Functor 165 | , Applicative 166 | , Monad 167 | , MonadReader TCState 168 | , MonadError TCFailure 169 | ) 170 | 171 | 172 | evalTC :: Tc a -> IO (Either TCFailure a) 173 | evalTC 174 | = evalIntBindingT 175 | . runErrorT 176 | . flip runReaderT M.empty 177 | . unTC 178 | 179 | 180 | -- | Type inference can fail. 181 | check :: Bool -> String -> Tc () 182 | check True _ = return () 183 | check False msg = throwError $ CheckFailure msg 184 | 185 | 186 | -- | Look up a 'Var' in Gamma to get its type. 187 | lookupVar :: Name -> Tc Sigma 188 | lookupVar x = do 189 | mb <- asks (M.lookup x) 190 | case mb of 191 | Just t -> return t 192 | Nothing -> throwError $ LookupVarFailure x 193 | 194 | 195 | -- | Extend Gamma locally. 196 | extendVarEnv :: Name -> Sigma -> Tc a -> Tc a 197 | extendVarEnv x t m = local (M.insert x t) m 198 | 199 | 200 | -- | Get Gamma. 201 | getEnvTypes :: Tc [Sigma] 202 | getEnvTypes = liftM M.elems ask 203 | 204 | 205 | -- | Unify two types. Unification only affects metavariables. 206 | unify :: Tau -> Tau -> Tc () 207 | unify tl tr = TC $ lift (tl =:= tr >> return ()) 208 | 209 | 210 | -- | Make a fresh metavariable. 211 | newMetaTyVar :: Tc Tau 212 | newMetaTyVar = TC . liftM UVar . lift $ lift freeVar 213 | 214 | 215 | -- | Make a fresh skolem TyVar for some given TyVar 216 | newSkolemTyVar :: TyVar -> Tc TyVar 217 | newSkolemTyVar tv = liftM (SkolemTv $ tyVarName tv) newUnique 218 | where 219 | -- HACK: this became ambiguous since 2012, thus requiring the inline signature on getVarID... 220 | newUnique :: Tc Uniq 221 | newUnique = TC . lift . lift $ liftM (getVarID :: IntVar -> Int) freeVar 222 | 223 | tyVarName :: TyVar -> Name 224 | tyVarName (BoundTv name) = name 225 | tyVarName (SkolemTv name _) = name 226 | 227 | 228 | -- | Return the free metavariables in the list of types. 229 | getMetaTyVars :: [Type] -> Tc [MetaTv] 230 | getMetaTyVars = TC . lift . lift . getFreeVarsAll 231 | 232 | 233 | -- | Return all the free type-variables in the list of types. (The 234 | -- free ones must be Skolems.) This is monadic because it respects 235 | -- the metavariable bindings. 236 | getFreeTyVars :: [Type] -> Tc [TyVar] 237 | getFreeTyVars = undefined 238 | {- 239 | getFreeTyVars = liftM freeTyVars . mapM zonkType 240 | -} 241 | 242 | ---------------------------------------------------------------- 243 | 244 | -- | The plain infer-turnstile. 245 | inferRho :: Term -> Tc Rho 246 | inferRho expr = do 247 | ref <- newTcRef (error "inferRho: empty result") 248 | tcRho expr (Infer ref) 249 | readTcRef ref 250 | 251 | 252 | -- | The plain check-turnstile. 253 | -- Invariant: 'Rho' is in weak-prenex form. 254 | checkRho :: Term -> Rho -> Tc () 255 | checkRho expr ty = tcRho expr (Check ty) 256 | 257 | 258 | -- We replace 'unify' with 'instSigma' because the latter deals 259 | -- with Expecteds. 260 | -- | The plain delta-turnstile. 261 | -- Invariant: if the Expected is @Check ty@ then @ty@ is in weak-prenex 262 | -- form. 263 | tcRho :: Term -> Expected Rho -> Tc () 264 | tcRho (Lit _) exp_ty = 265 | instSigma intType exp_ty 266 | tcRho (App fun arg) exp_ty = do 267 | fun_ty <- inferRho fun 268 | (arg_ty, res_ty) <- unifyFun fun_ty 269 | checkSigma arg arg_ty 270 | instSigma res_ty exp_ty 271 | tcRho (Lam var body) (Infer ref) = do 272 | var_ty <- newMetaTyVar 273 | body_ty <- extendVarEnv var var_ty (inferRho body) 274 | writeTcRef ref (var_ty ==> body_ty) 275 | tcRho (Lam var body) (Check exp_ty) = do 276 | (pat_ty, body_ty) <- unifyFun exp_ty 277 | extendVarEnv var pat_ty (checkRho body body_ty) 278 | -- N.B., we can checkRho instead of checkSigma because of tcRho's 279 | -- invariant 280 | tcRho (ALam var var_ty body) (Infer ref) = do 281 | body_ty <- extendVarEnv var var_ty (inferRho body) 282 | writeTcRef ref (var_ty ==> body_ty) 283 | tcRho (ALam var var_ty body) (Check exp_ty) = do 284 | (arg_ty, body_ty) <- unifyFun exp_ty 285 | subsCheck arg_ty var_ty 286 | extendVarEnv var var_ty (checkRho body body_ty) 287 | tcRho (Var v) exp_ty = do 288 | v_sigma <- lookupVar v 289 | instSigma v_sigma exp_ty 290 | tcRho (Let v rhs body) exp_ty = do 291 | v_sigma <- inferSigma rhs 292 | extendVarEnv v v_sigma (tcRho body exp_ty) 293 | tcRho (Ann body ann_ty) exp_ty = do 294 | checkSigma body ann_ty 295 | instSigma ann_ty exp_ty 296 | {- 297 | tcRho (If e1 e2 e3) (Check rho) = do 298 | checkRho e1 boolType 299 | checkRho e2 rho 300 | checkRho e3 rho 301 | -- Use the equivalence relation induced by subsumption 302 | tcRho (If e1 e2 e3) (Infer ref) = do 303 | checkRho e1 boolType 304 | rho1 <- inferRho e2 305 | rho2 <- inferRho e3 306 | subsCheck rho1 rho2 307 | subsCheck rho2 rho1 308 | writeTcRef ref rho1 -- Arbitrarily choose rho1 instead of rho2. This infelicity could be circumvented by skolemising the return type and re-generalising at the top-level all of its quantified variables. 309 | -} 310 | 311 | 312 | unifyFun :: Rho -> Tc (Rho, Rho) 313 | unifyFun (UTerm(Fun arg_ty res_ty)) = return (arg_ty, res_ty) 314 | unifyFun fun_ty = do 315 | arg_ty <- newMetaTyVar 316 | res_ty <- newMetaTyVar 317 | unify fun_ty (arg_ty ==> res_ty) 318 | return (arg_ty,res_ty) 319 | 320 | 321 | -- N.B., that we can use subsCheckRho in lieu of subsCheck relies 322 | -- on the invariant. 323 | -- | The inst-delta-turnstile. 324 | -- Invariant: if the Expected is @Check ty@ then @ty@ is in weak-prenex 325 | -- form. 326 | instSigma :: Sigma -> Expected Rho -> Tc () 327 | instSigma sigma (Infer ref) = writeTcRef ref =<< instantiate sigma 328 | instSigma sigma (Check rho) = subsCheckRho sigma rho 329 | 330 | 331 | -- | The poly-check-turnstile. This is the (plain) SKOL rule, 332 | -- formerly a part of 'subsCheck'. 333 | checkSigma :: Term -> Sigma -> Tc () 334 | checkSigma expr sigma = do 335 | (skol_tvs, rho) <- skolemise sigma 336 | checkRho expr rho 337 | env_tys <- getEnvTypes 338 | esc_tvs <- getFreeTyVars (sigma : env_tys) 339 | let bad_tvs = filter (`elem` esc_tvs) skol_tvs 340 | check (null bad_tvs) "Type not polymorphic enough" 341 | 342 | 343 | -- | The poly-infer-turnstile. 344 | inferSigma :: Term -> Tc Sigma 345 | inferSigma e = do 346 | res_ty <- inferRho e 347 | env_tys <- getEnvTypes 348 | env_tvs <- getMetaTyVars env_tys 349 | res_tvs <- getMetaTyVars [res_ty] 350 | let forall_tvs = res_tvs \\ env_tvs -- -> -- BUG: syntax hilighting 351 | quantify forall_tvs res_ty 352 | {- 353 | where 354 | -- This all is no longer necessary. Just use (Data.List.\\) 355 | minus xs ys = filter (\x -> not $ elemBy eqVar x ys) xs 356 | 357 | -- From "Data.List", though it's not exported for some reason... 358 | elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool 359 | elemBy _ _ [] = False 360 | elemBy eq y (x:xs) = y `eq` x || elemBy eq y xs 361 | -} 362 | 363 | 364 | quantify :: [MetaTv] -> Rho -> Tc Sigma 365 | quantify = undefined 366 | {- 367 | -- Not in scope: zonkType, tyVarBndrs, allBinders, writeTv 368 | quantify tvs ty = do 369 | mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way 370 | ty' <- zonkType ty -- of doing the substitution 371 | return (ForAll new_bndrs ty') 372 | where 373 | used_bndrs = tyVarBndrs ty -- Avoid quantified type variables in use 374 | new_bndrs = take (length tvs) (allBinders \\ used_bndrs) 375 | bind (tv, name) = writeTv tv (TyVar name) 376 | -} 377 | 378 | 379 | -- | The dsk*-turnstile, our \"super-unifier\". 380 | -- Invariant: Rho is in weak-prenex form. 381 | subsCheckRho :: Sigma -> Rho -> Tc () 382 | subsCheckRho sigma1@(UTerm(ForAll _ _)) rho2 = do -- Rule SPEC/INST 383 | rho1 <- instantiate sigma1 384 | subsCheckRho rho1 rho2 385 | -- N.B., because of the invariant, we don't check ForAll on the second arg 386 | subsCheckRho t1 (UTerm(Fun a2 r2)) = do 387 | (a1,r1) <- unifyFun t1 388 | subsCheckFun a1 r1 a2 r2 389 | subsCheckRho (UTerm(Fun a1 r1)) t2 = do 390 | (a2,r2) <- unifyFun t2 391 | subsCheckFun a1 r1 a2 r2 392 | subsCheckRho tau1 tau2 = do -- Rule MONO 393 | unify tau1 tau2 -- Revert to ordinary unification 394 | 395 | 396 | subsCheckFun :: Sigma -> Rho -> Sigma -> Rho -> Tc () 397 | subsCheckFun arg1 res1 arg2 res2 = do -- Rule FUN 398 | subsCheck arg2 arg1 399 | subsCheckRho res1 res2 400 | 401 | 402 | -- | The dsk-turnstile, our \"super-unifier\". 403 | subsCheck :: Sigma -> Sigma -> Tc () 404 | subsCheck sigma1 sigma2 = do -- Rule DEEP-SKOL 405 | (skol_tvs, rho2) <- skolemise sigma2 406 | subsCheckRho sigma1 rho2 407 | esc_tvs <- getFreeTyVars [sigma1,sigma2] -- because sigma2 is not closed. 408 | let bad_tvs = filter (`elem` esc_tvs) skol_tvs 409 | check (null bad_tvs) "Subsumption check failed:..." 410 | {- 411 | (vcat 412 | [ text "Subsumption check failed:" 413 | , nest 2 (ppr sigma1) 414 | , text "is not as polymorphic as" 415 | , nest 2 (ppr sigma2) 416 | ]) 417 | -} 418 | 419 | 420 | -- | Instantiate the topmost ForAlls of the argument type with 421 | -- flexible type variables. 422 | instantiate :: Sigma -> Tc Rho 423 | instantiate (UTerm(ForAll tvs ty)) = do 424 | tvs' <- mapM (\_ -> newMetaTyVar) tvs 425 | return (substTy tvs tvs' ty) 426 | instantiate ty = return ty 427 | 428 | 429 | -- | The function pr(sigma). 430 | skolemise :: Sigma -> Tc ([TyVar], Rho) 431 | skolemise (UTerm(ForAll tvs ty)) = do -- Rule PRPOLY 432 | sks1 <- mapM newSkolemTyVar tvs 433 | (sks2, ty') <- skolemise (substTy tvs (map (UTerm . TyVar) sks1) ty) 434 | return (sks1 ++ sks2, ty') 435 | skolemise (UTerm(Fun arg_ty res_ty)) = do -- Rule PRFUN 436 | (sks, res_ty') <- skolemise res_ty 437 | return (sks, UTerm$Fun arg_ty res_ty') 438 | skolemise ty = do -- Rule PRMONO 439 | return ([], ty) 440 | 441 | 442 | type Env = [(TyVar, Tau)] 443 | 444 | -- Replace the specified quantified type variables by 445 | -- given meta type variables 446 | -- No worries about capture, because the two kinds of type 447 | -- variable are distinct 448 | substTy :: [TyVar] -> [Type] -> Type -> Sigma 449 | substTy tvs tys ty = go (tvs `zip` tys) ty 450 | where 451 | go :: Env -> Type -> Type 452 | go env (UTerm(Fun arg res)) = UTerm$Fun (go env arg) (go env res) 453 | go env (UTerm(TyVar n)) = fromMaybe (UTerm$TyVar n) (lookup n env) 454 | go _ (UVar tv) = UVar tv 455 | go _ (UTerm(TyCon tc)) = UTerm$TyCon tc 456 | go env (UTerm(ForAll ns rho)) = UTerm$ForAll ns (go env' rho) 457 | where 458 | env' = [(n,ty') | (n,ty') <- env, not (n `elem` ns)] 459 | 460 | ---------------------------------------------------------------- 461 | ----------------------------------------------------------- fin. 462 | -------------------------------------------------------------------------------- /test/experiments/putting/PuttingHRPlus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses 2 | , FlexibleInstances 3 | , FlexibleContexts 4 | , GeneralizedNewtypeDeriving 5 | , DeriveFunctor 6 | , DeriveFoldable 7 | , DeriveTraversable 8 | , TypeSynonymInstances 9 | #-} 10 | {-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-deprecations #-} 11 | ---------------------------------------------------------------- 12 | -- ~ 2021.10.17 13 | -- | 14 | -- Module : PuttingHR 15 | -- Copyright : Copyright (c) 2007--2021 wren gayle romano 16 | -- License : BSD 17 | -- Maintainer : wren@cpan.org 18 | -- Stability : experimental 19 | -- Portability : non-portable 20 | -- 21 | -- An implementation of higher-ranked type checking a la Peyton 22 | -- Jones, Vytiniotis, Weirich, and Shields /Practical type inference/ 23 | -- /for arbitrary-rank types/ using the unification-fd library. This 24 | -- is mainly here for testing and debugging, rather than for actual 25 | -- use. 26 | ---------------------------------------------------------------- 27 | module Putting where 28 | 29 | import Prelude hiding 30 | ( mapM, mapM_, sequence, foldr, foldr1, foldl, foldl1 31 | , any, all, and, or, elem, concat 32 | ) 33 | import qualified Prelude 34 | import qualified Text.PrettyPrint.HughesPJ as PP 35 | import qualified Data.Map as M 36 | import Data.List ((\\)) 37 | import Data.IORef 38 | import Data.Foldable 39 | import Data.Traversable 40 | import Control.Applicative 41 | import Control.Monad (liftM, zipWithM) 42 | import Control.Monad.Error (Error(..), MonadError(..), ErrorT(..)) 43 | import Control.Monad.Reader (MonadReader(..), asks, ReaderT(..), runReaderT) 44 | import Control.Monad.Trans (MonadTrans(..)) 45 | import Control.Unification hiding (unify, lookupVar) 46 | import Control.Unification.IntVar 47 | ---------------------------------------------------------------- 48 | ---------------------------------------------------------------- 49 | 50 | type Name = String 51 | 52 | -- To add multi-branch constructs like case and conditionals, see "unification under a mixed prefix" for typing it etc. However, apparently that will type fewer programs than using the equivalence relation induced by two-way subsumption... It also looses the property that if $\Gamma' \vdash^{poly}_\Downarrow t : \sigma$ and $\vdash^{dsk} \Gamma \leq \Gamma'$ then $\Gamma \vdash^poly_\Downarrow t : \sigma$. (Though the checkingness can be regained by adding type annotations.) 53 | data Term 54 | = Var Name -- ^ @x@ 55 | | Lit Int -- ^ @3@ 56 | | App Term Term -- ^ @f x@ 57 | -- Lam Name Term -- ^ @\x. x@ 58 | -- ALam Name Sigma Term -- ^ @\(x::t). x@ 59 | | PLam Pat Term -- ^ @\p. x@ 60 | | Let Name Term Term -- ^ @let x = f y in x+1@ 61 | | Ann Term Sigma -- ^ @x :: t@ 62 | -- For output only 63 | -- TyLam Name Term -- Type abstraction 64 | -- TyApp Term Tau -- Type application. N.B., predicativity 65 | deriving (Show) 66 | 67 | type ConName = Name 68 | data Pat 69 | = PWild -- ^ @_@ 70 | | PVar Name -- ^ @x@ 71 | | PAnn Pat Sigma -- ^ @p :: t@ 72 | | PCon ConName [Pat] -- ^ @K p1 p2@ 73 | deriving (Show) 74 | 75 | ---------------------------------------------------------------- 76 | 77 | type Sigma = Type 78 | type Rho = Type -- ^ No top-level @ForAll@ 79 | type Tau = Type -- ^ No @ForAll@s anywhere 80 | type Type = UTerm Ty MetaTv 81 | data Ty t 82 | = ForAll [TyVar] t -- ^ Forall type 83 | | Fun t t -- ^ Function type 84 | | TyCon TyCon -- ^ Type constants 85 | | TyVar TyVar -- ^ Always bound by a @ForAll@ 86 | deriving (Show, Functor, Foldable, Traversable) 87 | 88 | -- | Invariant: metas can only be bound to 'Tau' 89 | type MetaTv = IntVar 90 | 91 | data TyVar 92 | = BoundTv Name -- ^ A type variable bound by a @ForAll@ 93 | | SkolemTv Name Uniq -- ^ A skolem constant; the Name is just to improve error messages 94 | deriving (Show, Eq) 95 | 96 | type Uniq = Int 97 | 98 | data TyCon 99 | = IntT 100 | | BoolT 101 | deriving (Show, Eq) 102 | 103 | 104 | -- | Build a function type (abstractly). 105 | (==>) :: Type -> Type -> Type 106 | arg ==> res = UTerm (Fun arg res) 107 | 108 | 109 | -- | The integer type (abstractly). 110 | intType :: Tau 111 | intType = UTerm (TyCon IntT) 112 | 113 | 114 | instance Unifiable Ty where 115 | zipMatch (ForAll vls tl) (ForAll vrs tr) 116 | | and $ zipWith (==) vls vrs = Just $ ForAll vls (Right(tl,tr)) 117 | zipMatch (Fun tl1 tl2) (Fun tr1 tr2) 118 | = Just $ Fun (Right(tl1,tr1)) (Right(tl2,tr2)) 119 | zipMatch (TyCon cl) (TyCon cr) 120 | | cl == cr = Just $ TyCon cl 121 | zipMatch (TyVar vl) (TyVar vr) 122 | | vl == vr = Just $ TyVar vl 123 | zipMatch _ _ = Nothing 124 | 125 | ---------------------------------------------------------------- 126 | 127 | -- | Directionalities for rules which are polymorphic in checking 128 | -- vs inference. 129 | data Expected t 130 | = Check t 131 | | Infer (TcRef t) 132 | 133 | type TcRef a = IORef a -- TODO: replace by IVar, or something else closer to truth. (or break our invariant and just use a metavariable) 134 | 135 | newTcRef :: a -> Tc (TcRef a) 136 | newTcRef = TC . lift . lift . lift . newIORef -- TODO: liftIO or liftBase 137 | 138 | -- TODO: throw errors on writing twice. 139 | writeTcRef :: TcRef a -> a -> Tc () 140 | writeTcRef = ((TC . lift . lift . lift) .) . writeIORef 141 | 142 | readTcRef :: TcRef a -> Tc a 143 | readTcRef = TC . lift . lift . lift . readIORef 144 | 145 | ---------------------------------------------------------------- 146 | 147 | type TCState = M.Map Name Type 148 | 149 | data TCFailure 150 | = OccursFailure IntVar (UTerm Ty IntVar) 151 | | MismatchFailure (Ty (UTerm Ty IntVar)) (Ty (UTerm Ty IntVar)) 152 | | CheckFailure String 153 | | LookupVarFailure Name 154 | deriving (Show) 155 | 156 | instance Fallible Ty IntVar TCFailure where 157 | occursFailure = OccursFailure 158 | mismatchFailure = MismatchFailure 159 | 160 | instance Error TCFailure where 161 | noMsg = CheckFailure "" 162 | strMsg = CheckFailure 163 | 164 | -- TODO: we also need a Uniq supply 165 | -- | The type-checker monad. 166 | newtype Tc a = 167 | TC { unTC :: 168 | ReaderT TCState -- Gamma: types for term-variables 169 | (ErrorT TCFailure -- possibility for failure 170 | (IntBindingT Ty -- unification metavariables 171 | IO)) -- TcRefs for the inference direction 172 | a } 173 | deriving 174 | ( Functor 175 | , Applicative 176 | , Monad 177 | , MonadReader TCState 178 | , MonadError TCFailure 179 | ) 180 | 181 | 182 | evalTC :: Tc a -> IO (Either TCFailure a) 183 | evalTC 184 | = evalIntBindingT 185 | . runErrorT 186 | . flip runReaderT M.empty 187 | . unTC 188 | 189 | 190 | -- | Type inference can fail. 191 | check :: Bool -> String -> Tc () 192 | check True _ = return () 193 | check False msg = throwError $ CheckFailure msg 194 | 195 | 196 | -- | Look up a 'Var' in Gamma to get its type. 197 | lookupVar :: Name -> Tc Sigma 198 | lookupVar x = do 199 | mb <- asks (M.lookup x) 200 | case mb of 201 | Just t -> return t 202 | Nothing -> throwError $ LookupVarFailure x 203 | -- (PP.text "Not in scope:" <+> PP.quotes (pprName n)) 204 | 205 | 206 | -- | Extend Gamma locally. 207 | extendVarEnv :: Name -> Sigma -> Tc a -> Tc a 208 | extendVarEnv x t = local (M.insert x t) 209 | 210 | -- | Extend Gamma locally. 211 | extendVarEnvList :: [(Name,Sigma)] -> Tc a -> Tc a 212 | extendVarEnvList xts = local (M.union (M.fromList xts)) 213 | 214 | 215 | -- | Get Gamma. 216 | getEnvTypes :: Tc [Sigma] 217 | getEnvTypes = liftM M.elems ask 218 | 219 | 220 | -- | Unify two types. Unification only affects metavariables. 221 | unify :: Tau -> Tau -> Tc () 222 | unify tl tr = TC . lift $ (tl =:= tr >> return ()) 223 | 224 | 225 | -- | Make a fresh metavariable. 226 | newMetaTyVar :: Tc Tau 227 | newMetaTyVar = TC . liftM UVar . lift $ lift freeVar 228 | 229 | 230 | -- | Make a fresh skolem TyVar for some given TyVar 231 | newSkolemTyVar :: TyVar -> Tc TyVar 232 | newSkolemTyVar tv = liftM (UVar . SkolemTv $ tyVarName tv) newUnique 233 | where 234 | newUnique :: Tc Uniq 235 | newUnique = undefined -- TODO 236 | 237 | 238 | -- | Return the free metavariables in the list of types. 239 | getMetaTyVars :: [Type] -> Tc [MetaTv] 240 | getMetaTyVars = TC . lift . lift . getFreeVarsAll 241 | 242 | 243 | -- | Return all the free type-variables in the list of types. (The 244 | -- free ones must be Skolems.) This is monadic because it respects 245 | -- the metavariable bindings. This function takes account of zonking, and returns a set (no duplicates) of free type variables 246 | getFreeTyVars :: [Type] -> Tc [TyVar] 247 | getFreeTyVars = liftM freeTyVars . mapM zonkType 248 | 249 | 250 | -- | Eliminate any substitutions in the type 251 | zonkType :: Type -> Tc Type 252 | zonkType (UTerm(ForAll ns ty)) = UTerm . ForAll ns <$> zonkType ty 253 | zonkType (UTerm(Fun arg res)) = UTerm . Fun <$> zonkType arg <*> zonkType res 254 | zonkType (UTerm(TyCon tc)) = return . UTerm $ TyCon tc 255 | zonkType (UTerm(TyVar n)) = return . UTerm $ TyVar n 256 | zonkType _ = undefined 257 | {- 258 | zonkType (UVar(MetaTv tv)) = do 259 | mb_ty <- readTv tv 260 | case mb_ty of 261 | Nothing -> return . UVar $ MetaTv tv 262 | Just ty -> do 263 | ty' <- zonkType ty 264 | writeTv tv ty' -- "Short out" multiple hops 265 | return ty' 266 | -} 267 | 268 | ---------------------------------------------------------------- 269 | 270 | -- | The plain infer-turnstile. 271 | inferRho :: Term -> Tc Rho 272 | inferRho expr = do 273 | ref <- newTcRef (error "inferRho: empty result") 274 | tcRho expr (Infer ref) 275 | readTcRef ref 276 | 277 | 278 | -- | The plain check-turnstile. 279 | -- Invariant: 'Rho' is in weak-prenex form. 280 | checkRho :: Term -> Rho -> Tc () 281 | checkRho expr ty = tcRho expr (Check ty) 282 | 283 | 284 | -- We replace 'unify' with 'instSigma' because the latter deals with Expecteds. 285 | -- | The plain delta-turnstile. 286 | -- Invariant: if the Expected is @Check ty@ then @ty@ is in weak-prenex form. 287 | tcRho :: Term -> Expected Rho -> Tc () 288 | tcRho (Lit _) exp_ty = 289 | instSigma intType exp_ty 290 | tcRho (App fun arg) exp_ty = do 291 | fun_ty <- inferRho fun 292 | (arg_ty, res_ty) <- unifyFun fun_ty 293 | checkSigma arg arg_ty 294 | instSigma res_ty exp_ty 295 | {- 296 | tcRho (Lam var body) (Infer ref) = do 297 | var_ty <- newMetaTyVar 298 | body_ty <- extendVarEnv var var_ty (inferRho body) 299 | writeTcRef ref (var_ty ==> body_ty) 300 | tcRho (Lam var body) (Check exp_ty) = do 301 | (pat_ty, body_ty) <- unifyFun exp_ty 302 | extendVarEnv var pat_ty (checkRho body body_ty) 303 | -- N.B., we can checkRho instead of checkSigma because of tcRho's invariant 304 | 305 | tcRho (ALam var var_ty body) (Infer ref) = do 306 | body_ty <- extendVarEnv var var_ty (inferRho body) 307 | writeTcRef ref (var_ty ==> body_ty) 308 | tcRho (ALam var var_ty body) (Check exp_ty) = do 309 | (arg_ty, body_ty) <- unifyFun exp_ty 310 | subsCheck arg_ty var_ty 311 | extendVarEnv var var_ty (checkRho body body_ty) 312 | 313 | tcRho tm@(PLam pat body) (Infer ref) = do 314 | (pat', pat_ty, binds) <- inferPat pat 315 | (body', body_ty) <- extendVarEnvList binds (inferRho body) 316 | writeTcRef ref (pat_ty ==> body_ty) 317 | return (Lam pat' body') 318 | tcRho tm@(PLam pat body) (Check exp_ty) = do 319 | (pat_ty, res_ty) <- unifyFun exp_ty 320 | (pat', binds) <- checkPat pat pat_ty 321 | body' <- extendVarEnvList binds (checkRho body res_ty) 322 | return (Lam pat' body') 323 | -} 324 | tcRho (PLam pat body) (Infer ref) = do 325 | (binds, pat_ty) <- inferPat pat 326 | body_ty <- extendVarEnvList binds (inferRho body) 327 | writeTcRef ref (pat_ty ==> body_ty) 328 | tcRho (PLam pat body) (Check exp_ty) = do 329 | (pat_ty, res_ty) <- unifyFun exp_ty 330 | binds <- checkPat pat pat_ty 331 | extendVarEnvList binds (checkRho body res_ty) 332 | tcRho (Var v) exp_ty = do 333 | v_sigma <- lookupVar v 334 | instSigma v_sigma exp_ty 335 | tcRho (Let v rhs body) exp_ty = do 336 | v_sigma <- inferSigma rhs 337 | extendVarEnv v v_sigma (tcRho body exp_ty) 338 | tcRho (Ann body ann_ty) exp_ty = do 339 | checkSigma body ann_ty 340 | instSigma ann_ty exp_ty 341 | {- 342 | tcRho (If e1 e2 e3) (Check rho) = do 343 | checkRho e1 boolType 344 | checkRho e2 rho 345 | checkRho e3 rho 346 | -- Use the equivalence relation induced by subsumption 347 | tcRho (If e1 e2 e3) (Infer ref) = do 348 | checkRho e1 boolType 349 | rho1 <- inferRho e2 350 | rho2 <- inferRho e3 351 | subsCheck rho1 rho2 352 | subsCheck rho2 rho1 353 | writeTcRef ref rho1 -- Arbitrarily choose rho1 instead of rho2. This infelicity could be circumvented by skolemising the return type and re-generalising at the top-level all of its quantified variables. 354 | -} 355 | 356 | 357 | unifyFun :: Rho -> Tc (Rho, Rho) 358 | unifyFun (UTerm(Fun arg_ty res_ty)) = return (arg_ty, res_ty) 359 | unifyFun fun_ty = do 360 | arg_ty <- newMetaTyVar 361 | res_ty <- newMetaTyVar 362 | unify fun_ty (arg_ty ==> res_ty) 363 | return (arg_ty,res_ty) 364 | 365 | 366 | -- N.B., that we can use subsCheckRho in lieu of subsCheck relies on the invariant. 367 | -- | The inst-delta-turnstile. 368 | -- Invariant: if the Expected is @Check ty@ then @ty@ is in weak-prenex form. 369 | instSigma :: Sigma -> Expected Rho -> Tc () 370 | instSigma sigma (Infer ref) = writeTcRef ref =<< instantiate sigma 371 | instSigma sigma (Check rho) = subsCheckRho sigma rho 372 | 373 | 374 | -- | The poly-check-turnstile. This is the (plain) SKOL rule, formerly a part of 'subsCheck'. 375 | checkSigma :: Term -> Sigma -> Tc () 376 | checkSigma expr sigma = do 377 | (skol_tvs, rho) <- skolemise sigma 378 | checkRho expr rho 379 | env_tys <- getEnvTypes 380 | esc_tvs <- getFreeTyVars (sigma : env_tys) 381 | let bad_tvs = filter (`elem` esc_tvs) skol_tvs 382 | check (null bad_tvs) "Type not polymorphic enough" 383 | 384 | 385 | -- | The poly-infer-turnstile. 386 | inferSigma :: Term -> Tc Sigma 387 | inferSigma e = do 388 | res_ty <- inferRho e 389 | env_tys <- getEnvTypes 390 | env_tvs <- getMetaTyVars env_tys 391 | res_tvs <- getMetaTyVars [res_ty] 392 | let forall_tvs = res_tvs \\ env_tvs -- -> -- BUG: syntax hilighting 393 | quantify forall_tvs res_ty 394 | 395 | 396 | -- if translating to System F, subsCheck :: Sigma -> Sigma -> Tc (Term -> Term), where the return value is a coersion proving the subsumption. 397 | 398 | -- | The dsk*-turnstile, our \"super-unifier\". 399 | -- Invariant: Rho is in weak-prenex form. 400 | subsCheckRho :: Sigma -> Rho -> Tc () 401 | subsCheckRho sigma1@(UTerm(ForAll _ _)) rho2 = do -- Rule SPEC/INST 402 | rho1 <- instantiate sigma1 403 | subsCheckRho rho1 rho2 404 | -- N.B., because of the invariant, we don't check ForAll on the second arg 405 | subsCheckRho t1 (UTerm(Fun a2 r2)) = do 406 | (a1,r1) <- unifyFun t1 407 | subsCheckFun a1 r1 a2 r2 408 | subsCheckRho (UTerm(Fun a1 r1)) t2 = do 409 | (a2,r2) <- unifyFun t2 410 | subsCheckFun a1 r1 a2 r2 411 | subsCheckRho tau1 tau2 = do -- Rule MONO 412 | unify tau1 tau2 -- Revert to ordinary unification 413 | 414 | 415 | subsCheckFun :: Sigma -> Rho -> Sigma -> Rho -> Tc () 416 | subsCheckFun arg1 res1 arg2 res2 = do -- Rule FUN 417 | subsCheck arg2 arg1 418 | subsCheckRho res1 res2 419 | 420 | 421 | -- | The dsk-turnstile, our \"super-unifier\". 422 | subsCheck :: Sigma -> Sigma -> Tc () 423 | subsCheck sigma1 sigma2 = do -- Rule DEEP-SKOL 424 | (skol_tvs, rho2) <- skolemise sigma2 425 | subsCheckRho sigma1 rho2 426 | esc_tvs <- getFreeTyVars [sigma1,sigma2] -- because sigma2 is not closed. 427 | let bad_tvs = filter (`elem` esc_tvs) skol_tvs 428 | check (null bad_tvs) . PP.render $ PP.vcat 429 | [ PP.text "Subsumption check failed:" 430 | , PP.nest 2 (ppr sigma1) 431 | , PP.text "is not as polymorphic as" 432 | , PP.nest 2 (ppr sigma2) 433 | ] 434 | where 435 | ppr (Var n) = pprName n 436 | ppr (Lit i) = int i 437 | ppr (App e1 e2) = pprApp (App e1 e2) 438 | ppr (Lam v e) = PP.sep 439 | [ PP.char '\\' <> pprName v <> PP.text "." 440 | , ppr e 441 | ] 442 | ppr (ALam v t e) = PP.sep 443 | [ PP.char '\\' <> PP.parens (pprName v <> PP.text "::" <> ppr t) <> PP.text "." 444 | , ppr e 445 | ] 446 | ppr (Let v rhs b) = PP.sep 447 | [ PP.text "let {" 448 | , PP.nest 2 (pprName v <+> equals <+> ppr rhs <+> PP.char '}') 449 | , PP.text "in" 450 | , ppr b 451 | ] 452 | ppr (Ann e ty) = pprParendTerm e <+> PP.text "::" <+> pprParendType ty 453 | 454 | pprParendTerm :: Term -> PP.Doc 455 | pprParendTerm e 456 | | atomicTerm e = ppr e 457 | | otherwise = PP.parens (ppr e) 458 | 459 | pprApp :: Term -> PP.Doc 460 | pprApp e = go e [] 461 | where 462 | go (App e1 e2) es = go e1 (e2:es) 463 | go e' es = pprParendTerm e' <+> PP.sep (map pprParendTerm es) 464 | 465 | pprName :: Name -> PP.Doc 466 | pprName = PP.text 467 | 468 | 469 | -- | Instantiate the topmost ForAlls of the argument type with flexible type variables. 470 | instantiate :: Sigma -> Tc Rho 471 | instantiate (UTerm(ForAll tvs ty)) = do 472 | tvs' <- mapM (\_ -> newMetaTyVar) tvs 473 | return (substTy tvs (map MetaTv tvs') ty) 474 | instantiate ty = return ty 475 | 476 | 477 | -- | The function pr(sigma). 478 | skolemise :: Sigma -> Tc ([TyVar], Rho) 479 | skolemise (UTerm(ForAll tvs ty)) = do -- Rule PRPOLY 480 | sks1 <- mapM newSkolemTyVar tvs 481 | (sks2, ty') <- skolemise (substTy tvs (map (UTerm . TyVar) sks1) ty) 482 | return (sks1 ++ sks2, ty') 483 | skolemise (UTerm(Fun arg_ty res_ty)) = do -- Rule PRFUN 484 | (sks, res_ty') <- skolemise res_ty 485 | return (sks, UTerm$Fun arg_ty res_ty') 486 | skolemise ty = do -- Rule PRMONO 487 | return ([], ty) 488 | 489 | -- Quantify over the specified type variables (all flexible) 490 | quantify :: [MetaTv] -> Rho -> Tc Sigma 491 | quantify tvs ty = do 492 | mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way 493 | ty' <- zonkType ty -- of doing the substitution 494 | return (ForAll new_bndrs ty') 495 | where 496 | used_bndrs = tyVarBndrs ty -- Avoid quantified type variables in use 497 | new_bndrs = take (length tvs) (allBinders \\ used_bndrs) 498 | bind (tv, name) = writeTv tv (TyVar name) 499 | 500 | type Env = [(TyVar, Tau)] 501 | 502 | -- Replace the specified quantified type variables by 503 | -- given meta type variables 504 | -- No worries about capture, because the two kinds of type 505 | -- variable are distinct 506 | substTy :: [TyVar] -> [Type] -> Type -> Sigma 507 | substTy tvs tys ty = subst_ty (tvs `zip` tys) ty 508 | where 509 | subst_ty :: Env -> Type -> Type 510 | subst_ty env (Fun arg res) = Fun (subst_ty env arg) (subst_ty env res) 511 | subst_ty env (TyVar n) = fromMaybe (TyVar n) (lookup n env) 512 | subst_ty env (MetaTv tv) = MetaTv tv 513 | subst_ty env (TyCon tc) = TyCon tc 514 | subst_ty env (ForAll ns rho) = ForAll ns (subst_ty env' rho) 515 | where 516 | env' = [(n,ty') | (n,ty') <- env, not (n `elem` ns)] 517 | 518 | 519 | ---------------------------------------------------------------- 520 | 521 | inferPat :: Pat -> Tc ([(Name,Sigma)], Sigma) 522 | inferPat pat = do 523 | ref <- newTcRef (error "inferPat: empty result") 524 | binds <- tcPat pat (Infer ref) 525 | pat_ty <- readTcRef ref 526 | return (binds, pat_ty) 527 | 528 | checkPat :: Pat -> Sigma -> Tc [(Name,Sigma)] 529 | checkPat pat ty = tcPat pat (Check ty) 530 | 531 | tcPat :: Pat -> Expected Sigma -> Tc [(Name,Sigma)] 532 | tcPat PWild _ = 533 | return [] 534 | tcPat (PVar v) (Infer ref) = do 535 | ty <- newMetaTyVar 536 | writeTcRef ref ty 537 | return [(v,ty)] 538 | tcPat (PVar v) (Check ty) = 539 | return [(v, ty)] 540 | tcPat (PAnn p pat_ty) exp_ty = do 541 | binds <- checkPat p pat_ty 542 | instPatSigma pat_ty exp_ty 543 | return binds -- right? 544 | tcPat (PCon con ps) exp_ty = do 545 | (arg_tys, res_ty) <- instDataCon con 546 | envs <- zipWithM checkPat ps arg_tys 547 | instPatSigma res_ty exp_ty 548 | return (Prelude.concat envs) 549 | 550 | -- N.B., assumes predicative data types, i.e. no PolymorphicComponents (but then predicativity is assumed everywhere else too) 551 | instDataCon :: Name -> Tc ([Sigma], Tau) 552 | instDataCon = undefined 553 | 554 | instPatSigma :: Sigma -> Expected Sigma -> Tc () 555 | instPatSigma pat_ty (Infer ref) = writeTcRef ref pat_ty 556 | instPatSigma pat_ty (Check exp_ty) = subsCheck exp_ty pat_ty 557 | 558 | ---------------------------------------------------------------- 559 | ----------------------------------------------------------- fin. 560 | -------------------------------------------------------------------------------- /test/experiments/st-trail/Control/Monad/BacktrackST.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# OPTIONS_GHC -Wall -fwarn-tabs #-} 4 | ---------------------------------------------------------------- 5 | -- ~ 2021.10.17 6 | -- | 7 | -- Module : Control.Monad.BacktrackST 8 | -- Copyright : Copyright (c) 2008--2021 wren gayle romano 9 | -- License : BSD 10 | -- Maintainer : wren@cpan.org 11 | -- Stability : experimental 12 | -- Portability : maybe semi-portable (RankNTypes) 13 | -- 14 | -- This module defines a variant of the ST monad which supports 15 | -- backtracking via logging all writes to variables. 16 | ---------------------------------------------------------------- 17 | module Control.Monad.BacktrackST 18 | ( 19 | -- * Backtracking references for 'BacktrackST' 20 | BSTRef() 21 | , newBSTRef 22 | , readBSTRef 23 | , writeBSTRef 24 | -- * Backtracking ST monad 25 | , BacktrackST() 26 | , runBST 27 | , liftST 28 | ) where 29 | 30 | import Data.STRef 31 | import Data.Monoid 32 | import Control.Monad (MonadPlus(..), ap) 33 | import Control.Monad.ST 34 | import Control.Applicative (Applicative(..), Alternative(..)) 35 | ---------------------------------------------------------------- 36 | ---------------------------------------------------------------- 37 | 38 | -- STLog s ~ Done | UnWrite (STRef s a) a (STLog s) 39 | -- 40 | -- N.B., we store the list in reverse order, so that undoSTLog 41 | -- doesn't build up a deep stack (because we care about undoSTLog 42 | -- more than redoSTLog). Hence, mappend should always be called 43 | -- with arguments in the opposite order they were evaluated in. 44 | newtype STLog s = 45 | STLog (forall r. r -> (forall a. STRef s a -> a -> r -> r) -> r) 46 | 47 | 48 | nilSTL :: STLog s 49 | nilSTL = STLog const 50 | 51 | 52 | consSTL :: STRef s a -> a -> STLog s -> STLog s 53 | consSTL r x (STLog k) = STLog $ \n c -> c r x (k n c) 54 | 55 | 56 | {- 57 | snocSTL :: STLog s -> STRef s a -> a -> STLog s 58 | snocSTL (STLog k) r x = STLog $ \n c -> k (c r x n) c 59 | -} 60 | 61 | 62 | instance Monoid (STLog s) where 63 | mempty = nilSTL 64 | mappend (STLog kl) (STLog kr) = STLog $ \n c -> kl (kr n c) c 65 | 66 | 67 | -- | Write the old values back into memory from the log, undoing 68 | -- the side-effects of an ST action. 69 | undoSTLog :: STLog s -> ST s () 70 | undoSTLog (STLog k) = k (return ()) (\r x xs -> writeSTRef r x >> xs) 71 | 72 | 73 | {- 74 | -- This will work if we also track the new value in writeBSTRef. 75 | -- | Write the new values back into memory from the log, replaying 76 | -- (part of) an ST action. This only replays the side-effects as 77 | -- they occured the first time, it doesn't replay the whole ST 78 | -- action, which may have made choices depending on part of the 79 | -- environment not captured in the log. 80 | redoSTLog :: STLog s -> ST s () 81 | redoSTLog (STLog k) = k (return ()) (\r x x' xs -> xs >> writeSTRef r x') 82 | -} 83 | 84 | ---------------------------------------------------------------- 85 | 86 | -- | A mutable reference in the 'BacktrackST' monad. 87 | newtype BSTRef s a = BSTRef (STRef s a) 88 | 89 | 90 | newBSTRef :: a -> BacktrackST s (BSTRef s a) 91 | newBSTRef x = BST $ do 92 | r <- newSTRef x 93 | return (nilSTL, Just (BSTRef r)) 94 | 95 | 96 | readBSTRef :: BSTRef s a -> BacktrackST s a 97 | readBSTRef (BSTRef r) = BST $ do 98 | x <- readSTRef r 99 | return (nilSTL, Just x) 100 | 101 | 102 | writeBSTRef :: BSTRef s a -> a -> BacktrackST s () 103 | writeBSTRef (BSTRef r) x' = BST $ do 104 | x <- readSTRef r 105 | writeSTRef r x' 106 | return (consSTL r x nilSTL, Just ()) 107 | 108 | 109 | {- 110 | -- Don't write now, instead write while backtracking. This is proof 111 | -- that we shouldn't let clients access the log, lest they do odd 112 | -- things. 113 | writeOnFail :: BSTRef s a -> a -> BacktrackST s () 114 | writeOnFail (BSTRef r) x' = BST $ do 115 | return (consSTL r x' nilSTL, Just ()) 116 | -} 117 | 118 | ---------------------------------------------------------------- 119 | -- BacktrackST s ~ MaybeT (WriterT (STLog s) (ST s)) 120 | -- | The backtracking 'ST' monad. In order to support backtracking we log all writes so that we can revert them. Unfortunately, as it stands, the logging is incredibly naive and prone to space leaks. This will be corrected in the future. 121 | newtype BacktrackST s a = BST { unBST :: ST s (STLog s, Maybe a) } 122 | -- BUG: Fix it! 123 | -- (1) only log when necessary 124 | -- (2) perform log compaction to avoid redundant writes 125 | -- (3) I'm sure there are other major issues 126 | 127 | 128 | runBST :: (forall s. BacktrackST s a) -> Maybe a 129 | runBST m = runST (snd `fmap` unBST m) 130 | 131 | 132 | -- | Lift a raw @ST@ computation into @BacktrackST@. The raw @ST@ 133 | -- action can manipulate 'STRef's without logging, but it cannot 134 | -- access 'BSTRef's since we would not know how to undo the changes. 135 | liftST :: ST s a -> BacktrackST s a 136 | liftST = BST . fmap ((,) nilSTL . Just) 137 | 138 | 139 | instance Functor (BacktrackST s) where 140 | fmap f = BST . fmap (fmap (fmap f)) . unBST 141 | 142 | instance Applicative (BacktrackST s) where 143 | pure = return 144 | (<*>) = ap 145 | 146 | instance Alternative (BacktrackST s) where 147 | empty = mzero 148 | (<|>) = mplus 149 | 150 | instance Monad (BacktrackST s) where 151 | return = BST . return . (,) nilSTL . Just 152 | 153 | BST mx >>= f = BST $ do 154 | (qx,x) <- mx 155 | case x of 156 | Nothing -> return (qx,Nothing) 157 | Just x' -> do 158 | (qy,y) <- unBST $ f x' 159 | return (qy `mappend` qx, y) 160 | 161 | instance MonadPlus (BacktrackST s) where 162 | mzero = BST $ return (nilSTL, Nothing) 163 | 164 | BST ml `mplus` BST mr = BST $ do 165 | (ql,l) <- ml 166 | case l of 167 | Nothing -> undoSTLog ql >> mr 168 | Just _ -> return (ql,l) 169 | 170 | ---------------------------------------------------------------- 171 | ----------------------------------------------------------- fin. 172 | -------------------------------------------------------------------------------- /test/tutorial/tutorial1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor 2 | , DeriveFoldable 3 | , DeriveTraversable 4 | #-} 5 | {-# OPTIONS_GHC -Wall -fwarn-tabs 6 | -fno-warn-deprecations 7 | -fno-warn-missing-signatures 8 | -fno-warn-unused-do-bind 9 | #-} 10 | 11 | import Data.List.Extras.Pair (pairWith) 12 | import Data.Foldable 13 | import Data.Traversable 14 | import Control.Applicative 15 | import Control.Monad.Error (ErrorT(..), runErrorT) 16 | import Control.Monad.Identity (Identity(..)) 17 | import Control.Monad.Logic (Logic(), runLogic) 18 | import Control.Monad.Trans (MonadTrans(lift)) 19 | import Control.Unification 20 | import Control.Unification.IntVar 21 | 22 | ---------------------------------------------------------------- 23 | data T a = T String [a] 24 | deriving (Show, Functor, Foldable, Traversable) 25 | 26 | foo x y = UTerm$T "foo" [x,y] 27 | bar = UTerm$T "bar" [] 28 | baz x = UTerm$T "baz" [x] 29 | 30 | atom n = UTerm$T n [] 31 | 32 | instance Unifiable T where 33 | zipMatch (T m ls) (T n rs) 34 | | m /= n = Nothing 35 | | otherwise = 36 | T n <$> pairWith (\l r -> Right(l,r)) ls rs 37 | 38 | ---------------------------------------------------------------- 39 | -- Some aliases for simplifying type signatures: 40 | type PrologTerm = UTerm T IntVar 41 | type PrologFailure = UnificationFailure T IntVar 42 | type PrologBindingState = IntBindingState T 43 | type FallibleBindingMonad = ErrorT PrologFailure (IntBindingT T Identity) 44 | type PrologMonad = ErrorT PrologFailure (IntBindingT T Logic) 45 | 46 | ---------------------------------------------------------------- 47 | 48 | -- | @example1(X,Y,Z) :- X = Y, Y = Z.@ 49 | -- example1 :: PrologTerm -> PrologTerm -> PrologTerm -> Example 50 | example1 x y z = do 51 | x =:= y 52 | y =:= z 53 | 54 | -- | A more efficient implementation of 'example1'. 55 | -- example1' :: PrologTerm -> PrologTerm -> PrologTerm -> Example 56 | example1' x y z = do 57 | y' <- x =:= y 58 | y' =:= z 59 | 60 | 61 | -- N.B., This type signature is (unfortunately) necessary in order 62 | -- to avoid ambiguity when we discard the variable it returns. But, 63 | -- if you never discard the result, then you should be able to get 64 | -- away with commenting out the signature. 65 | getFreeVar 66 | :: (Applicative m, Monad m) 67 | => ErrorT PrologFailure (IntBindingT T m) PrologTerm 68 | getFreeVar = lift (UVar <$> freeVar) 69 | 70 | 71 | -- | @example2(X,Z) :- X = Y, Y = Z.@ 72 | -- example2 :: PrologTerm -> PrologTerm -> Example 73 | example2 x z = do 74 | y <- getFreeVar 75 | x =:= y 76 | y =:= z 77 | 78 | 79 | -- | @example3(X,Z) :- example1(X,Y,Z).@ 80 | -- example3 :: PrologTerm -> PrologTerm -> Example 81 | example3 x z = do 82 | y <- getFreeVar 83 | example1 x y z 84 | 85 | 86 | -- BUG: transformers-0.4.1.0 deprecated Control.Monad.Trans.Error 87 | -- (transformers-0.3.0.0 says it's fine). In order to use 88 | -- Control.Monad.Trans.Except, we need a monoid instance... so we'll 89 | -- need to redefine UnificationFailure to deal with all this 90 | -- 91 | -- | @example4(X) :- X = bar; X = backtrack.@ 92 | -- example4 :: PrologTerm -> Example 93 | example4 x = (x =:= bar) <|> (x =:= atom "backtrack") 94 | 95 | 96 | -- However, note that the semantics of 'example4' may not be what 97 | -- is expected. In particular, this example will fail with a 98 | -- @TermMismatch@ because the invocation of 'example4' commits to 99 | -- the success of its first branch, so that by the time we execute 100 | -- the last line of this example, we can't get the 'example4' 101 | -- invocation to backtrack and try the other branch. 102 | commitsTooEarly = do 103 | x <- getFreeVar 104 | example4 x 105 | x =:= atom "backtrack" 106 | 107 | {- However, both of these examples work just fine (since the first 108 | -- branch of 'example4' fails immediately). Thus, choice does indeed 109 | -- work, even if backtracking doesn't: 110 | 111 | choiceWorks1 = do 112 | x <- getFreeVar 113 | x =:= atom "backtrack" 114 | example4 x 115 | 116 | choiceWorks2 = do 117 | example4 (atom "backtrack") 118 | 119 | -} 120 | 121 | 122 | -- | Note that the semantics of this test may not be what is expected, 123 | -- depending on the exact monad stack used. In particular, for 124 | -- @FallibleBindingMonad@ it does not give Prolog's semantics! 125 | backtrackingTest = do 126 | x <- getFreeVar 127 | y <- getFreeVar 128 | (x =:= y >> failure) <|> return (foo x y) 129 | where 130 | failure = atom "a" =:= atom "b" 131 | 132 | ---------------------------------------------------------------- 133 | runFBM 134 | :: FallibleBindingMonad a 135 | -> (Either PrologFailure a, PrologBindingState) 136 | runFBM = runIdentity . runIntBindingT . runErrorT 137 | 138 | evalFBM :: FallibleBindingMonad a -> Either PrologFailure a 139 | evalFBM = runIdentity . evalIntBindingT . runErrorT 140 | 141 | execFBM :: FallibleBindingMonad a -> PrologBindingState 142 | execFBM = runIdentity . execIntBindingT . runErrorT 143 | 144 | 145 | runProlog 146 | :: PrologMonad a 147 | -> Maybe (Either PrologFailure a, PrologBindingState) 148 | runProlog = observeMaybe . runIntBindingT . runErrorT 149 | 150 | evalProlog :: PrologMonad a -> Maybe (Either PrologFailure a) 151 | evalProlog = observeMaybe . evalIntBindingT . runErrorT 152 | 153 | execProlog :: PrologMonad a -> Maybe PrologBindingState 154 | execProlog = observeMaybe . execIntBindingT . runErrorT 155 | 156 | observeMaybe :: Logic a -> Maybe a 157 | observeMaybe mx = runLogic mx (\a _ -> Just a) Nothing 158 | 159 | ---------------------------------------------------------------- 160 | ----------------------------------------------------------- fin. 161 | -------------------------------------------------------------------------------- /unification-fd.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: 2.2 2 | -- Cabal >=2.2 is required for: 3 | -- 4 | -- Since 2.1, the Cabal-Version must be the absolutely first thing 5 | -- in the file, even before comments. Also, no longer uses ">=". 6 | -- 7 | 8 | ---------------------------------------------------------------- 9 | -- wren gayle romano ~ 2025-02-11 10 | ---------------------------------------------------------------- 11 | 12 | Name: unification-fd 13 | Version: 0.12.0.2 14 | Build-Type: Simple 15 | Stability: experimental 16 | Homepage: https://wrengr.org/software/hackage.html 17 | Bug-Reports: https://github.com/wrengr/unification-fd/issues 18 | Author: wren gayle romano 19 | Maintainer: wren@cpan.org 20 | Copyright: 2007–2025 wren romano 21 | -- Cabal-2.2 requires us to say "BSD-3-Clause" not "BSD3" 22 | License: BSD-3-Clause 23 | License-File: LICENSE 24 | 25 | Category: Algebra, Algorithms, Compilers/Interpreters, Language, Logic, Unification 26 | Synopsis: Simple generic unification algorithms. 27 | Description: 28 | Generic functions for single-sorted first-order structural 29 | unification (think of programming in Prolog, or of the metavariables 30 | in type inference). 31 | 32 | Extra-source-files: 33 | AUTHORS, README.md, CHANGELOG 34 | 35 | -- Because of data-fix, we can no longer support GHC older than 8.6.1 36 | -- 37 | Tested-With: 38 | GHC ==8.6.5, 39 | GHC ==8.8.4, 40 | GHC ==8.10.3, 41 | GHC ==9.0.1, 42 | GHC ==9.2.4, 43 | GHC ==9.4.8, 44 | GHC ==9.6.5, 45 | GHC ==9.8.2, 46 | GHC ==9.10.1, 47 | GHC ==9.12.1 48 | 49 | Source-Repository head 50 | Type: git 51 | Location: https://github.com/wrengr/unification-fd.git 52 | 53 | ---------------------------------------------------------------- 54 | Library 55 | -- With Cabal-Version: >= 1.10, the Default-Language field is now required. 56 | Default-Language: Haskell98 57 | Hs-Source-Dirs: src 58 | Exposed-Modules: Data.Functor.Fixedpoint 59 | , Control.Monad.State.UnificationExtras 60 | , Control.Monad.MaybeK 61 | , Control.Monad.EitherK 62 | , Control.Unification 63 | , Control.Unification.Types 64 | , Control.Unification.STVar 65 | , Control.Unification.IntVar 66 | , Control.Unification.Ranked 67 | , Control.Unification.Ranked.STVar 68 | , Control.Unification.Ranked.IntVar 69 | 70 | -- TODO: Although most versions of mtl don't really care much 71 | -- about the version of base, the latest version (mtl-2.3.1) is 72 | -- exceptional in that they explicitly exclude base>=4.15&&<4.16. 73 | -- We should look into why, just in case that affects us too. 74 | -- 75 | -- To keep the core libs matching the Tested-With bounds above, see: 76 | -- 77 | Build-Depends: base >= 4.12 && < 4.22 78 | , containers >= 0.6.0 && < 0.8 79 | -- Require mtl-2 instead of monads-fd; because 80 | -- otherwise we get a clash mixing logict with 81 | -- StateT. And we want stuff from monads-fd, so 82 | -- we can't just fail over to the older mtl. 83 | -- 84 | -- NOTE: ghc>=8.4.1 ships with mtl>=2.2.2, so that's where 85 | -- our lower bound comes from (but any mtl>=2.0 should work). 86 | , mtl >= 2.2.2 && < 2.4 87 | -- NOTE: logict-0.7.1 introduced breakage, but that 88 | -- should be resolved now. Cf., 89 | -- 90 | -- 91 | , logict >= 0.4 && < 0.8.3 92 | -- FIXME: What all changed between 0.3.2 and 0.3.4? And why does my current GHC not want to try 0.3.4? 93 | , data-fix >= 0.3.2 && < 0.4 94 | 95 | ---------------------------------------------------------------- 96 | ----------------------------------------------------------- fin. 97 | --------------------------------------------------------------------------------