github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-19 12:51:52 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into heap-frames

Browse Source 
Co-Authored-By: Josh Vera <vera@github.com>
This commit is contained in:
Rick Winfrey 2018-11-01 15:29:45 -07:00
commit 4750d51bf6
253 changed files with 7155 additions and 5774 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.ghci
View File

@ -3,7 +3,7 @@
-- See docs/💡ProTip!.md
:undef pretty
:def pretty \ _ -> return (unlines [":set -interactive-print Semantic.Util.prettyShow"])
:def pretty \ _ -> return ":set -interactive-print Semantic.Util.Pretty.prettyShow"
-- See docs/💡ProTip!.md
:undef no-pretty

6
.gitmodules vendored
View File

@ -1,9 +1,6 @@
[submodule "vendor/hspec-expectations-pretty-diff"]
path = vendor/hspec-expectations-pretty-diff
url = https://github.com/rewinfrey/hspec-expectations-pretty-diff
[submodule "vendor/effects"]
path = vendor/effects
url = https://github.com/joshvera/effects.git
[submodule "vendor/haskell-tree-sitter"]
path = vendor/haskell-tree-sitter
url = https://github.com/tree-sitter/haskell-tree-sitter.git
@ -16,3 +13,6 @@
[submodule "vendor/semilattices"]
path = vendor/semilattices
url = https://github.com/robrix/semilattices.git
[submodule "vendor/fused-effects"]
path = vendor/fused-effects
url = https://github.com/robrix/fused-effects.git

14
.licenses/semantic/cabal/vector-th-unbox.txt → .licenses/semantic/cabal/MonadRandom.txt
View File

@ -1,12 +1,12 @@
---
type: cabal
name: vector-th-unbox
version: 0.2.1.6
summary: Deriver for Data.Vector.Unboxed using Template Haskell
name: MonadRandom
version: 0.5.1.1
summary: Random-number generation monad.
homepage:
license: bsd-3-clause
---
Copyright (c) 2012−2015, Liyang HU
Copyright (c) 2016, Brent Yorgey
All rights reserved.
@ -21,7 +21,7 @@ modification, are permitted provided that the following conditions are met:
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Liyang HU nor the names of other
* Neither the name of Brent Yorgey nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
@ -36,3 +36,7 @@ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Previous versions of this package were distributed under the simple
permissive license used on the Haskell Wiki; see OLD-LICENSE for
details.

4
.licenses/semantic/cabal/StateVar.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: StateVar
version: 1.1.1.0
version: 1.1.1.1
summary: State variables
homepage: https://github.com/haskell-opengl/StateVar
license: bsd-3-clause
@ -34,4 +34,4 @@ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
POSSIBILITY OF SUCH DAMAGE.

4
.licenses/semantic/cabal/algebraic-graphs.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: algebraic-graphs
version: 0.1.1.1
version: '0.2'
summary: A library for algebraic graph construction and transformation
homepage: https://github.com/snowleopard/alga
license: mit
@ -26,4 +26,4 @@ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
SOFTWARE.

46
.licenses/semantic/cabal/ansi-terminal.txt
View File

@ -1,30 +1,30 @@
---
type: cabal
name: ansi-terminal
version: 0.8.0.4
version: 0.8.1
summary: Simple ANSI terminal support, with Windows compatibility
homepage: https://github.com/feuerbach/ansi-terminal
license: bsd-3-clause
---
Copyright (c) 2008, Maximilian Bolingbroke
All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted
provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this list of
conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice, this list of
conditions and the following disclaimer in the documentation and/or other materials
provided with the distribution.
* Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to
endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Copyright (c) 2008, Maximilian Bolingbroke
All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted
provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this list of
conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice, this list of
conditions and the following disclaimer in the documentation and/or other materials
provided with the distribution.
* Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to
endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

4
.licenses/semantic/cabal/basement.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: basement
version: 0.0.7
version: 0.0.8
summary: Foundation scrap box of array & string
homepage: https://github.com/haskell-foundation/foundation
license: bsd-3-clause
@ -33,4 +33,4 @@ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
SUCH DAMAGE.

4
.licenses/semantic/cabal/cereal.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: cereal
version: 0.5.5.0
version: 0.5.7.0
summary: A binary serialization library
homepage: https://github.com/GaloisInc/cereal
license: bsd-3-clause
@ -35,4 +35,4 @@ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
POSSIBILITY OF SUCH DAMAGE.

2
.licenses/semantic/cabal/cmark-gfm.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: cmark-gfm
version: 0.1.4
version: 0.1.5
summary: Fast, accurate GitHub Flavored Markdown parser and renderer
homepage: https://github.com/kivikakk/cmark-gfm-hs
license: multiple

4
.licenses/semantic/cabal/dlist.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: dlist
version: 0.8.0.4
version: 0.8.0.5
summary: Difference lists
homepage: https://github.com/spl/dlist
license: bsd-3-clause
@ -36,4 +36,4 @@ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
.licenses/semantic/cabal/fastsum.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: fastsum
version: 0.1.0.0
version: 0.1.1.0
summary: A fast open-union type suitable for 100+ contained alternatives
homepage: https://github.com/patrickt/fastsum
license: bsd-3-clause

2
.licenses/semantic/cabal/foldl.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: foldl
version: 1.4.2
version: 1.4.5
summary: Composable, streaming, and efficient left folds
homepage:
license: bsd-3-clause

36
.licenses/semantic/cabal/foundation.txt
View File

@ -1,36 +0,0 @@
---
type: cabal
name: foundation
version: 0.0.20
summary: Alternative prelude with batteries and no dependencies
homepage: https://github.com/haskell-foundation/foundation
license: bsd-3-clause
---
Copyright (c) 2015-2017 Vincent Hanquez <vincent@snarc.org>
Copyright (c) 2017-2018 Foundation Maintainers
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.

20
.licenses/semantic/cabal/math-functions.txt → .licenses/semantic/cabal/fused-effects.txt
View File

@ -1,17 +1,17 @@
---
type: cabal
name: math-functions
version: 0.2.1.0
summary: Special functions and Chebyshev polynomials
homepage: https://github.com/bos/math-functions
license: bsd-2-clause
name: fused-effects
version: 0.1.0.0
summary: 'A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers.'
homepage: https://github.com/robrix/fused-effects
license: bsd-3-clause
---
Copyright (c) 2009, 2010 Bryan O'Sullivan
Copyright (c) 2018, Rob Rix and Patrick Thomson
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
@ -21,6 +21,10 @@ are met:
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Rob Rix nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

2
.licenses/semantic/cabal/ghc-typelits-extra.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: ghc-typelits-extra
version: 0.2.5
version: 0.2.6
summary: Additional type-level operations on GHC.TypeLits.Nat
homepage: https://www.clash-lang.org/
license: bsd-2-clause

2
.licenses/semantic/cabal/ghc-typelits-knownnat.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: ghc-typelits-knownnat
version: '0.5'
version: 0.5.1
summary: Derive KnownNat constraints from other KnownNat constraints
homepage: https://clash-lang.org/
license: bsd-2-clause

2
.licenses/semantic/cabal/ghc-typelits-natnormalise.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: ghc-typelits-natnormalise
version: 0.6.1
version: 0.6.2
summary: GHC typechecker plugin for types of kind GHC.TypeLits.Nat
homepage: https://www.clash-lang.org/
license: bsd-2-clause

2
.licenses/semantic/cabal/haskeline.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: haskeline
version: 0.7.4.2
version: 0.7.4.3
summary: A command-line interface for user input, written in Haskell.
homepage: https://github.com/judah/haskeline
license: bsd-2-clause

6
.licenses/semantic/cabal/haskell-lexer.txt
View File

@ -1,9 +1,9 @@
---
type: cabal
name: haskell-lexer
version: 1.0.1
version: 1.0.2
summary: A fully compliant Haskell 98 lexer.
homepage:
homepage: https://github.com/yav/haskell-lexer
license: mit
---
Copyright (c) 2008 Thomas Hallgren
@ -13,4 +13,4 @@ Permission is hereby granted, free of charge, to any person obtaining a copy of
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

4
.licenses/semantic/cabal/hourglass.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: hourglass
version: 0.2.11
version: 0.2.12
summary: simple performant time related library
homepage: https://github.com/vincenthz/hs-hourglass
license: bsd-3-clause
@ -32,4 +32,4 @@ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
SUCH DAMAGE.

4
.licenses/semantic/cabal/http-media.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: http-media
version: 0.7.1.2
version: 0.7.1.3
summary: Processing HTTP Content-Type and Accept headers
homepage: https://github.com/zmthy/http-media
license: mit
@ -25,4 +25,4 @@ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

4
.licenses/semantic/cabal/http-types.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: http-types
version: 0.12.1
version: 0.12.2
summary: Generic HTTP types for Haskell (for both client and server code).
homepage: https://github.com/aristidb/http-types
license: bsd-3-clause
@ -36,4 +36,4 @@ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

6
.licenses/semantic/cabal/integer-logarithms.txt
View File

@ -1,9 +1,9 @@
---
type: cabal
name: integer-logarithms
version: 1.0.2.1
version: 1.0.2.2
summary: Integer logarithms.
homepage: https://github.com/phadej/integer-logarithms
homepage: https://github.com/Bodigrim/integer-logarithms
license: mit
---
Copyright (c) 2011 Daniel Fischer, 2017 Oleg Grenrus
@ -21,4 +21,4 @@ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLI
LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

2
.licenses/semantic/cabal/invariant.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: invariant
version: '0.5'
version: 0.5.1
summary: Haskell98 invariant functors
homepage: https://github.com/nfrisby/invariant-functors
license: bsd-2-clause

7
.licenses/semantic/cabal/memory.txt
View File

@ -1,12 +1,13 @@
---
type: cabal
name: memory
version: 0.14.16
version: 0.14.18
summary: memory and related abstraction stuff
homepage: https://github.com/vincenthz/hs-memory
license: bsd-3-clause
---
Copyright (c) 2015 Vincent Hanquez <vincent@snarc.org>
Copyright (c) 2015-2018 Vincent Hanquez <vincent@snarc.org>
Copyright (c) 2017-2018 Nicolas Di Prima <nicolas@primetype.co.uk>
All rights reserved.
@ -33,4 +34,4 @@ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
SUCH DAMAGE.

2
.licenses/semantic/cabal/mwc-random.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: mwc-random
version: 0.13.6.0
version: 0.13.3.2
summary: Fast, high quality pseudo random number generation
homepage: https://github.com/bos/mwc-random
license: bsd-2-clause

4
.licenses/semantic/cabal/optparse-applicative.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: optparse-applicative
version: 0.14.2.0
version: 0.14.3.0
summary: Utilities and combinators for parsing command line options
homepage: https://github.com/pcapriotti/optparse-applicative
license: bsd-3-clause
@ -35,4 +35,4 @@ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

14
.licenses/semantic/cabal/parallel.txt
View File

@ -1,9 +1,9 @@
---
type: cabal
name: parallel
version: 3.2.1.1
version: 3.2.2.0
summary: Parallel programming library
homepage: https://github.com/haskell/parallel
homepage:
license: bsd-3-clause
---
This library (libraries/parallel) is derived from code from
@ -14,7 +14,7 @@ Glasgow, and distributable under a BSD-style license (see below).
The Glasgow Haskell Compiler License
Copyright 2004, The University Court of the University of Glasgow.
Copyright 2004, The University Court of the University of Glasgow.
All rights reserved.
Redistribution and use in source and binary forms, with or without
@ -22,14 +22,14 @@ modification, are permitted provided that the following conditions are met:
- Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
- Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
- Neither name of the University nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission.
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
@ -44,4 +44,4 @@ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------

2
.licenses/semantic/cabal/quickcheck-instances.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: quickcheck-instances
version: 0.3.18
version: 0.3.19
summary: Common quickcheck instances
homepage: https://github.com/phadej/qc-instances
license: bsd-3-clause

12
.licenses/semantic/cabal/stm.txt
View File

@ -1,14 +1,14 @@
---
type: cabal
name: stm
version: 2.4.5.0
version: 2.4.5.1
summary: Software Transactional Memory
homepage: https://wiki.haskell.org/Software_transactional_memory
license: bsd-3-clause
---
The Glasgow Haskell Compiler License
Copyright 2004, The University Court of the University of Glasgow.
Copyright 2004, The University Court of the University of Glasgow.
All rights reserved.
Redistribution and use in source and binary forms, with or without
@ -16,14 +16,14 @@ modification, are permitted provided that the following conditions are met:
- Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
- Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
- Neither name of the University nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission.
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
@ -36,4 +36,4 @@ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
DAMAGE.

4
.licenses/semantic/cabal/system-fileio.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: system-fileio
version: 0.3.16.3
version: 0.3.16.4
summary: Consistent filesystem interaction across GHC versions (deprecated)
homepage: https://github.com/fpco/haskell-filesystem
license: mit
@ -27,4 +27,4 @@ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.
OTHER DEALINGS IN THE SOFTWARE.

4
.licenses/semantic/cabal/text.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: text
version: 1.2.3.0
version: 1.2.3.1
summary: An efficient packed Unicode text type.
homepage: https://github.com/haskell/text
license: bsd-2-clause
@ -31,4 +31,4 @@ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

4
.licenses/semantic/cabal/these.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: these
version: 0.7.4
version: 0.7.5
summary: An either-or-both data type & a generalized 'zip with padding' typeclass
homepage: https://github.com/isomorphism/these
license: bsd-3-clause
@ -35,4 +35,4 @@ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

4
.licenses/semantic/cabal/time-locale-compat.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: time-locale-compat
version: 0.1.1.4
version: 0.1.1.5
summary: Compatibile module for time-format locale
homepage: https://github.com/khibino/haskell-time-locale-compat
license: bsd-3-clause
@ -35,4 +35,4 @@ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
.licenses/semantic/cabal/turtle.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: turtle
version: 1.5.10
version: 1.5.12
summary: Shell programming, Haskell-style
homepage:
license: bsd-3-clause

4
.licenses/semantic/cabal/unix-compat.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: unix-compat
version: 0.5.0.1
version: 0.5.1
summary: Portable POSIX-compatibility layer.
homepage: https://github.com/jystic/unix-compat
license: bsd-3-clause
@ -34,4 +34,4 @@ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

4
.licenses/semantic/cabal/vector-builder.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: vector-builder
version: 0.3.4.1
version: 0.3.6
summary: Vector builder
homepage: https://github.com/nikita-volkov/vector-builder
license: mit
@ -27,4 +27,4 @@ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.
OTHER DEALINGS IN THE SOFTWARE.

4
.licenses/semantic/cabal/x509.txt
View File

@ -1,7 +1,7 @@
---
type: cabal
name: x509
version: 1.7.3
version: 1.7.4
summary: X509 reader and writer
homepage: https://github.com/vincenthz/hs-certificate
license: bsd-3-clause
@ -32,4 +32,4 @@ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
SUCH DAMAGE.

8
bench/Main.hs → bench/evaluation/Main.hs
View File

@ -24,16 +24,16 @@ evaluateProject proxy parser paths = withOptions defaultOptions $ \ config logge
-- project—coercing the result into a string will suffice, though it throws off the
-- memory allocation results a bit.
pyEval :: FilePath -> Benchmarkable
pyEval p = whnfIO . fmap show . evalPythonProject $ ["bench/bench-fixtures/python/" <> p]
pyEval p = nfIO . evalPythonProject $ ["bench/bench-fixtures/python/" <> p]
rbEval :: FilePath -> Benchmarkable
rbEval p = whnfIO . fmap show . evalRubyProject $ ["bench/bench-fixtures/ruby/" <> p]
rbEval p = nfIO . evalRubyProject $ ["bench/bench-fixtures/ruby/" <> p]
pyCall :: FilePath -> Benchmarkable
pyCall p = whnfIO $ callGraphProject pythonParser (Proxy @'Language.Python) defaultOptions ["bench/bench-fixtures/python/" <> p]
pyCall p = nfIO $ callGraphProject pythonParser (Proxy @'Language.Python) defaultOptions ["bench/bench-fixtures/python/" <> p]
rbCall :: FilePath -> Benchmarkable
rbCall p = whnfIO $ callGraphProject rubyParser (Proxy @'Language.Ruby) defaultOptions ["bench/bench-fixtures/ruby/" <> p]
rbCall p = nfIO $ callGraphProject rubyParser (Proxy @'Language.Ruby) defaultOptions ["bench/bench-fixtures/ruby/" <> p]
main :: IO ()
main = defaultMain

75
semantic.cabal
View File

@ -19,7 +19,8 @@ library
hs-source-dirs: src
exposed-modules:
-- Analyses & term annotations
Analysis.Abstract.Caching
Analysis.Abstract.Caching.FlowInsensitive
, Analysis.Abstract.Caching.FlowSensitive
, Analysis.Abstract.Collecting
, Analysis.Abstract.Dead
, Analysis.Abstract.Graph
@ -35,28 +36,29 @@ library
, Assigning.Assignment.Table
-- Control structures & interfaces for abstract interpretation
, Control.Abstract
, Control.Abstract.Configuration
, Control.Abstract.Context
, Control.Abstract.Environment
, Control.Abstract.Evaluator
, Control.Abstract.Heap
, Control.Abstract.Hole
, Control.Abstract.Matching
, Control.Abstract.Modules
, Control.Abstract.Primitive
, Control.Abstract.PythonPackage
, Control.Abstract.Roots
, Control.Abstract.ScopeGraph
, Control.Abstract.TermEvaluator
, Control.Abstract.Value
-- Effects
, Control.Effect.Interpose
, Control.Effect.REPL
-- Matching and rewriting DSLs
, Control.Matching
, Control.Rewriting
-- Datatypes for abstract interpretation
, Data.Abstract.Address.Hole
, Data.Abstract.Address.Located
, Data.Abstract.Address.Monovariant
, Data.Abstract.Address.Precise
, Data.Abstract.BaseError
, Data.Abstract.Cache
, Data.Abstract.Configuration
, Data.Abstract.Declarations
, Data.Abstract.Environment
, Data.Abstract.Evaluatable
@ -82,15 +84,18 @@ library
, Data.Diff
, Data.Duration
, Data.Error
, Data.File
, Data.Functor.Both
, Data.Functor.Classes.Generic
, Data.Graph
, Data.Graph.ControlFlowVertex
, Data.Graph.TermVertex
, Data.Graph.DiffVertex
, Data.Handle
, Data.History
, Data.JSON.Fields
, Data.Language
, Data.Location
, Data.Map.Monoidal
, Data.Proto.DiffTree
, Data.Proto.ParseTree
@ -98,15 +103,16 @@ library
, Data.Project
, Data.Quieterm
, Data.Range
, Data.Record
, Data.Reprinting.Errors
, Data.Reprinting.Token
, Data.Reprinting.Fragment
, Data.Reprinting.Operator
, Data.Reprinting.Scope
, Data.Reprinting.Splice
, Data.Reprinting.Token
, Data.Semigroup.App
, Data.Scientific.Exts
, Data.Source
, Data.Span
, Data.SplitDiff
-- À la carte syntax types
, Data.Syntax
, Data.Syntax.Comment
@ -133,6 +139,12 @@ library
, Language.Haskell.Grammar
, Language.Haskell.Assignment
, Language.Haskell.Syntax
, Language.Haskell.Syntax.Constructor
, Language.Haskell.Syntax.Haskell
, Language.Haskell.Syntax.Identifier
, Language.Haskell.Syntax.Pattern
, Language.Haskell.Syntax.QuasiQuote
, Language.Haskell.Syntax.Type
, Language.JSON.Grammar
, Language.JSON.Assignment
, Language.JSON.PrettyPrint
@ -177,6 +189,7 @@ library
, Reprinting.Typeset
, Reprinting.Pipeline
-- High-level flow & operational functionality (logging, stats, etc.)
, Semantic.Analysis
, Semantic.AST
, Semantic.CLI
, Semantic.Config
@ -189,6 +202,7 @@ library
, Semantic.REPL
, Semantic.Resolution
, Semantic.Task
, Semantic.Task.Files
, Semantic.Telemetry
, Semantic.Telemetry.AsyncQueue
, Semantic.Telemetry.Haystack
@ -196,6 +210,7 @@ library
, Semantic.Telemetry.Stat
, Semantic.Timeout
, Semantic.Util
, Semantic.Util.Pretty
, Semantic.Util.Rewriting
, Semantic.Version
-- Serialization
@ -216,13 +231,14 @@ library
, cmark-gfm
, containers
, cryptohash
, deepseq
, directory
, directory-tree
, effects
, fastsum
, filepath
, free
, freer-cofreer
, fused-effects
, ghc-prim
, gitrev
, Glob
@ -243,6 +259,7 @@ library
, parsers
, prettyprinter
, pretty-show
, profunctors
, recursion-schemes
, reducers
, scientific
@ -276,6 +293,7 @@ library
, DeriveTraversable
, FlexibleContexts
, FlexibleInstances
, MonadFailDesugaring
, MultiParamTypeClasses
, OverloadedStrings
, RecordWildCards
@ -283,16 +301,16 @@ library
, StrictData
, TypeApplications
if flag(release)
ghc-options: -Wall -Werror -Wmissing-export-lists -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O1 -j
ghc-options: -Wall -Werror -Wmissing-export-lists -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O1 -j -DCOMPUTE_GIT_SHA
else
ghc-options: -Wall -Wmissing-export-lists -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O0 -j
ghc-options: -Wall -Wmissing-export-lists -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O0 -j +RTS -A128m -n2m -RTS
ghc-prof-options: -fprof-auto
executable semantic
hs-source-dirs: app
main-is: Main.hs
if flag(release)
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m" -static -j -O1 -j
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m" -static -j -O1 -j -DCOMPUTE_GIT_SHA
else
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m" -static -j -O0 -j
cc-options: -DU_STATIC_IMPLEMENTATION=1
@ -313,12 +331,18 @@ test-suite test
, Analysis.TypeScript.Spec
, Assigning.Assignment.Spec
, Control.Abstract.Evaluator.Spec
, Control.Rewriting.Spec
, Data.Abstract.Environment.Spec
, Data.Abstract.Path.Spec
, Data.Abstract.Name.Spec
, Data.Diff.Spec
, Data.Functor.Classes.Generic.Spec
, Data.Functor.Listable
, Data.Graph.Spec
, Data.Mergeable
, Data.Range.Spec
, Data.Scientific.Spec
, Data.Semigroup.App.Spec
, Data.Source.Spec
, Data.Term.Spec
, Diffing.Algorithm.RWS.Spec
@ -344,10 +368,10 @@ test-suite test
, bifunctors
, bytestring
, containers
, effects
, fastsum
, filepath
, free
, fused-effects
, Glob
, hashable
, haskell-tree-sitter
@ -373,6 +397,7 @@ test-suite test
, DeriveGeneric
, FlexibleContexts
, FlexibleInstances
, MonadFailDesugaring
, MultiParamTypeClasses
, OverloadedStrings
, RecordWildCards
@ -388,17 +413,29 @@ test-suite lint
build-depends: base
, hlint
test-suite doctests
test-suite parse-examples
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Doctests.hs
main-is: Examples.hs
default-language: Haskell2010
ghc-options: -dynamic -threaded -j
ghc-options: -threaded -rtsopts -with-rtsopts=-N -j
build-depends: base
, doctest
, bytestring
, directory
, fastsum
, filepath
, fused-effects
, Glob
, hspec >= 2.4.1
, hspec-core
, hspec-expectations-pretty-diff
, process
, semantic
default-extensions: RecordWildCards
, FlexibleContexts
benchmark evaluation
hs-source-dirs: bench
hs-source-dirs: bench/evaluation
type: exitcode-stdio-1.0
main-is: Main.hs
ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m -T" -static -j -O1

135
src/Analysis/Abstract/Caching.hs
View File

@ -1,135 +0,0 @@
{-# LANGUAGE GADTs, TypeOperators #-}
module Analysis.Abstract.Caching
( cachingTerms
, convergingModules
, caching
) where
import Control.Abstract.Configuration
import Control.Abstract
import Data.Abstract.Cache
import Data.Abstract.BaseError
import Data.Abstract.Environment
import Data.Abstract.Module
import Data.Abstract.Ref
import Prologue
-- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) effects)
=> Configuration term address value
-> TermEvaluator term address value effects (Set (Cached address value))
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
-- | Run an action with the given in-cache.
withOracle :: Member (Reader (Cache term address value)) effects
=> Cache term address value
-> TermEvaluator term address value effects a
-> TermEvaluator term address value effects a
withOracle cache = local (const cache)
-- | Look up the set of values for a given configuration in the out-cache.
lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) effects)
=> Configuration term address value
-> TermEvaluator term address value effects (Maybe (Set (Cached address value)))
lookupCache configuration = cacheLookup configuration <$> get
-- | Run an action, caching its result and 'Heap' under the given configuration.
cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) effects, Member (State (Heap address address value)) effects)
=> Configuration term address value
-> Set (Cached address value)
-> TermEvaluator term address value effects (ValueRef address value)
-> TermEvaluator term address value effects (ValueRef address value)
cachingConfiguration configuration values action = do
modify' (cacheSet configuration values)
result <- Cached <$> action <*> TermEvaluator getHeap
cachedValue result <$ modify' (cacheInsert configuration result)
putCache :: Member (State (Cache term address value)) effects
=> Cache term address value
-> TermEvaluator term address value effects ()
putCache = put
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
isolateCache :: Member (State (Cache term address value)) effects
=> TermEvaluator term address value effects a
-> TermEvaluator term address value effects (Cache term address value)
isolateCache action = putCache lowerBound *> action *> get
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
cachingTerms :: ( Cacheable term address value
, Corecursive term
, Member NonDet effects
, Member (Reader (Cache term address value)) effects
, Member (Reader (Live address)) effects
, Member (State (Cache term address value)) effects
, Member (State (Heap address address value)) effects
)
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address value))
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address value))
cachingTerms recur term = do
c <- getConfiguration (embedSubterm term)
cached <- lookupCache c
case cached of
Just pairs -> scatter pairs
Nothing -> do
pairs <- consultOracle c
cachingConfiguration c pairs (recur term)
convergingModules :: ( AbstractValue address value effects
, Cacheable term address value
, Member Fresh effects
, Member NonDet effects
, Member (Reader (Cache term address value)) effects
, Member (Reader (Live address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Cache term address value)) effects
, Member (State (Heap address address value)) effects
, Effects effects
, Member (Deref value) effects
, Member (Resumable (BaseError (AddressError address value))) effects
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects value)
-> SubtermAlgebra Module term (TermEvaluator term address value effects value)
convergingModules recur m = do
c <- getConfiguration (subterm (moduleBody m))
-- Convergence here is predicated upon an Eq instance, not α-equivalence
cache <- converge lowerBound (\ prevCache -> isolateCache $ do
TermEvaluator (putHeap (configurationHeap c))
-- We need to reset fresh generation so that this invocation converges.
resetFresh 0 $
-- This is subtle: though the calling context supports nondeterminism, we want
-- to corral all the nondeterminism that happens in this @eval@ invocation, so
-- that it doesn't "leak" to the calling context and diverge (otherwise this
-- would never complete). We don’t need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
withOracle prevCache (gatherM (const ()) (recur m)))
TermEvaluator (value =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
-- | Iterate a monadic action starting from some initial seed until the results converge.
--
-- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem
converge :: (Eq a, Monad m)
=> a -- ^ An initial seed value to iterate from.
-> (a -> m a) -- ^ A monadic action to perform at each iteration, starting from the result of the previous iteration or from the seed value for the first iteration.
-> m a -- ^ A computation producing the least fixed point (the first value at which the actions converge).
converge seed f = loop seed
where loop x = do
x' <- f x
if x' == x then
pure x
else
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address address value)) effects) => t (Cached address value) -> TermEvaluator term address value effects (ValueRef address value)
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value)
caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address value) ': State (Cache term address value) ': effects) a -> TermEvaluator term address value effects (Cache term address value, [a])
caching
= runState lowerBound
. runReader lowerBound
. runNonDet

221
src/Analysis/Abstract/Caching/FlowInsensitive.hs Normal file
View File

@ -0,0 +1,221 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators #-}
module Analysis.Abstract.Caching.FlowInsensitive
( cachingTerms
, convergingModules
, caching
) where
import Control.Abstract
import Data.Abstract.BaseError
import Data.Abstract.Environment
import Data.Abstract.Module
import Data.Abstract.Ref
import Data.Map.Monoidal as Monoidal
import Prologue
-- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: (Member (Reader (Cache term address)) sig, Carrier sig m, Ord address, Ord term)
=> Configuration term address
-> Evaluator term address value m (Set (ValueRef address))
consultOracle configuration = asks (fromMaybe mempty . cacheLookup configuration)
-- | Run an action with the given in-cache.
withOracle :: (Member (Reader (Cache term address)) sig, Carrier sig m)
=> Cache term address
-> Evaluator term address value m a
-> Evaluator term address value m a
withOracle cache = local (const cache)
-- | Look up the set of values for a given configuration in the out-cache.
lookupCache :: (Member (State (Cache term address)) sig, Carrier sig m, Ord address, Ord term)
=> Configuration term address
-> Evaluator term address value m (Maybe (Set (ValueRef address)))
lookupCache configuration = cacheLookup configuration <$> get
-- | Run an action, caching its result and 'Heap' under the given configuration.
cachingConfiguration :: (Member (State (Cache term address)) sig, Carrier sig m, Ord address, Ord term)
=> Configuration term address
-> Set (ValueRef address)
-> Evaluator term address value m (ValueRef address)
-> Evaluator term address value m (ValueRef address)
cachingConfiguration configuration values action = do
modify (cacheSet configuration values)
result <- action
result <$ modify (cacheInsert configuration result)
putCache :: (Member (State (Cache term address)) sig, Carrier sig m)
=> Cache term address
-> Evaluator term address value m ()
putCache = put
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
isolateCache :: (Member (State (Cache term address)) sig, Member (State (Heap address value)) sig, Carrier sig m)
=> Evaluator term address value m a
-> Evaluator term address value m (Cache term address, Heap address value)
isolateCache action = putCache lowerBound *> action *> ((,) <$> get <*> get)
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
cachingTerms :: ( Member (Env address) sig
, Member NonDet sig
, Member (Reader (Cache term address)) sig
, Member (Reader (Live address)) sig
, Member (State (Cache term address)) sig
, Carrier sig m
, Ord address
, Ord term
)
=> Open (Open (term -> Evaluator term address value m (ValueRef address)))
cachingTerms recur0 recur term = do
c <- getConfiguration term
cached <- lookupCache c
case cached of
Just values -> scatter values
Nothing -> do
values <- consultOracle c
cachingConfiguration c values (recur0 recur term)
convergingModules :: ( AbstractValue term address value m
, Eq value
, Member (Env address) sig
, Member Fresh sig
, Member NonDet sig
, Member (Reader (Cache term address)) sig
, Member (Reader (Live address)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (State (Cache term address)) sig
, Member (State (Heap address value)) sig
, Ord address
, Ord term
, Carrier sig m
, Effect sig
)
=> (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) address)
-> (Module (Either prelude term) -> Evaluator term address value m address)
convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty
convergingModules recur m@(Module _ (Right term)) = do
c <- getConfiguration term
heap <- getHeap
-- Convergence here is predicated upon an Eq instance, not α-equivalence
(cache, _) <- converge (lowerBound, heap) (\ (prevCache, _) -> isolateCache $ do
putEvalContext (configurationContext c)
-- We need to reset fresh generation so that this invocation converges.
resetFresh $
-- This is subtle: though the calling context supports nondeterminism, we want
-- to corral all the nondeterminism that happens in this @eval@ invocation, so
-- that it doesn't "leak" to the calling context and diverge (otherwise this
-- would never complete). We don’t need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
withOracle prevCache (raiseHandler runNonDet (recur m)))
address =<< maybe empty scatter (cacheLookup c cache)
-- | Iterate a monadic action starting from some initial seed until the results converge.
--
-- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem
converge :: (Eq a, Monad m)
=> a -- ^ An initial seed value to iterate from.
-> (a -> m a) -- ^ A monadic action to perform at each iteration, starting from the result of the previous iteration or from the seed value for the first iteration.
-> m a -- ^ A computation producing the least fixed point (the first value at which the actions converge).
converge seed f = loop seed
where loop x = do
x' <- f x
if x' == x then
pure x
else
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Foldable t, Member NonDet sig, Carrier sig m) => t (ValueRef address) -> Evaluator term address value m (ValueRef address)
scatter = foldMapA pure
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live address)) sig, Member (Env address) sig, Carrier sig m)
=> term
-> Evaluator term address value m (Configuration term address)
getConfiguration term = Configuration term <$> askRoots <*> getEvalContext
caching :: (Carrier sig m, Effect sig)
=> Evaluator term address value (AltC B (Eff
(ReaderC (Cache term address) (Eff
(StateC (Cache term address) (Eff
m)))))) a
-> Evaluator term address value m (Cache term address, [a])
caching
= raiseHandler (runState lowerBound)
. raiseHandler (runReader lowerBound)
. fmap toList
. raiseHandler runNonDet
data B a = E | L a | B (B a) (B a)
deriving (Functor)
instance Foldable B where
toList = flip go []
where go E rest = rest
go (L a) rest = a : rest
go (B a b) rest = go a (go b rest)
foldMap f = go
where go E = mempty
go (L a) = f a
go (B a b) = go a <> go b
null E = True
null _ = False
instance Traversable B where
traverse f = go
where go E = pure E
go (L a) = L <$> f a
go (B a b) = B <$> go a <*> go b
instance Applicative B where
pure = L
E <*> _ = E
L f <*> a = fmap f a
B l r <*> a = B (l <*> a) (r <*> a)
instance Alternative B where
empty = E
E <|> b = b
a <|> E = a
a <|> b = B a b
instance Monad B where
return = pure
E >>= _ = E
L a >>= f = f a
B l r >>= f = B (l >>= f) (r >>= f)
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
newtype Cache term address = Cache { unCache :: Monoidal.Map (Configuration term address) (Set (ValueRef address)) }
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address, ValueRef address), Semigroup)
-- | A single point in a program’s execution.
data Configuration term address = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live address -- ^ The set of rooted addresses.
, configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'.
}
deriving (Eq, Ord, Show)
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
cacheLookup :: (Ord address, Ord term) => Configuration term address -> Cache term address -> Maybe (Set (ValueRef address))
cacheLookup key = Monoidal.lookup key . unCache
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
cacheSet :: (Ord address, Ord term) => Configuration term address -> Set (ValueRef address) -> Cache term address -> Cache term address
cacheSet key value = Cache . Monoidal.insert key value . unCache
-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
cacheInsert :: (Ord address, Ord term) => Configuration term address -> ValueRef address -> Cache term address -> Cache term address
cacheInsert = curry cons
instance (Show term, Show address) => Show (Cache term address) where
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache

186
src/Analysis/Abstract/Caching/FlowSensitive.hs Normal file
View File

@ -0,0 +1,186 @@
{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, TypeOperators #-}
module Analysis.Abstract.Caching.FlowSensitive
( cachingTerms
, convergingModules
, caching
) where
import Control.Abstract
import Data.Abstract.BaseError
import Data.Abstract.Environment
import Data.Abstract.Module
import Data.Abstract.Ref
import Data.Map.Monoidal as Monoidal
import Prologue
-- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) sig, Carrier sig m)
=> Configuration term address value
-> Evaluator term address value m (Set (Cached address value))
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
-- | Run an action with the given in-cache.
withOracle :: (Member (Reader (Cache term address value)) sig, Carrier sig m)
=> Cache term address value
-> Evaluator term address value m a
-> Evaluator term address value m a
withOracle cache = local (const cache)
-- | Look up the set of values for a given configuration in the out-cache.
lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) sig, Carrier sig m)
=> Configuration term address value
-> Evaluator term address value m (Maybe (Set (Cached address value)))
lookupCache configuration = cacheLookup configuration <$> get
-- | Run an action, caching its result and 'Heap' under the given configuration.
cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) sig, Member (State (Heap address value)) sig, Carrier sig m)
=> Configuration term address value
-> Set (Cached address value)
-> Evaluator term address value m (ValueRef address)
-> Evaluator term address value m (ValueRef address)
cachingConfiguration configuration values action = do
modify (cacheSet configuration values)
result <- Cached <$> action <*> getHeap
cachedValue result <$ modify (cacheInsert configuration result)
putCache :: (Member (State (Cache term address value)) sig, Carrier sig m)
=> Cache term address value
-> Evaluator term address value m ()
putCache = put
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
isolateCache :: (Member (State (Cache term address value)) sig, Carrier sig m)
=> Evaluator term address value m a
-> Evaluator term address value m (Cache term address value)
isolateCache action = putCache lowerBound *> action *> get
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
cachingTerms :: ( Cacheable term address value
, Member NonDet sig
, Member (Reader (Cache term address value)) sig
, Member (Reader (Live address)) sig
, Member (State (Cache term address value)) sig
, Member (Env address) sig
, Member (State (Heap address value)) sig
, Carrier sig m
)
=> Open (Open (term -> Evaluator term address value m (ValueRef address)))
cachingTerms recur0 recur term = do
c <- getConfiguration term
cached <- lookupCache c
case cached of
Just pairs -> scatter pairs
Nothing -> do
pairs <- consultOracle c
cachingConfiguration c pairs (recur0 recur term)
convergingModules :: ( AbstractValue term address value m
, Cacheable term address value
, Member Fresh sig
, Member NonDet sig
, Member (Reader (Cache term address value)) sig
, Member (Reader (Live address)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (State (Cache term address value)) sig
, Member (Env address) sig
, Member (State (Heap address value)) sig
, Carrier sig m
, Effect sig
)
=> (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) address)
-> (Module (Either prelude term) -> Evaluator term address value m address)
convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty
convergingModules recur m@(Module _ (Right term)) = do
c <- getConfiguration term
-- Convergence here is predicated upon an Eq instance, not α-equivalence
cache <- converge lowerBound (\ prevCache -> isolateCache $ do
putHeap (configurationHeap c)
putEvalContext (configurationContext c)
-- We need to reset fresh generation so that this invocation converges.
resetFresh $
-- This is subtle: though the calling context supports nondeterminism, we want
-- to corral all the nondeterminism that happens in this @eval@ invocation, so
-- that it doesn't "leak" to the calling context and diverge (otherwise this
-- would never complete). We don’t need to use the values, so we 'gather' the
-- nondeterministic values into @()@.
withOracle prevCache (raiseHandler runNonDet (recur m)))
address =<< maybe empty scatter (cacheLookup c cache)
-- | Iterate a monadic action starting from some initial seed until the results converge.
--
-- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem
converge :: (Eq a, Monad m)
=> a -- ^ An initial seed value to iterate from.
-> (a -> m a) -- ^ A monadic action to perform at each iteration, starting from the result of the previous iteration or from the seed value for the first iteration.
-> m a -- ^ A computation producing the least fixed point (the first value at which the actions converge).
converge seed f = loop seed
where loop x = do
x' <- f x
if x' == x then
pure x
else
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Foldable t, Member NonDet sig, Member (State (Heap address value)) sig, Carrier sig m) => t (Cached address value) -> Evaluator term address value m (ValueRef address)
scatter = foldMapA (\ (Cached value heap') -> putHeap heap' $> value)
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live address)) sig, Member (Env address) sig, Member (State (Heap address value)) sig, Carrier sig m)
=> term
-> Evaluator term address value m (Configuration term address value)
getConfiguration term = Configuration term <$> askRoots <*> getEvalContext <*> getHeap
caching :: (Carrier sig m, Effect sig)
=> Evaluator term address value (AltC [] (Eff
(ReaderC (Cache term address value) (Eff
(StateC (Cache term address value) (Eff
m)))))) a
-> Evaluator term address value m (Cache term address value, [a])
caching
= raiseHandler (runState lowerBound)
. raiseHandler (runReader lowerBound)
. raiseHandler runNonDet
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuration term address value) (Set (Cached address value)) }
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address value, Cached address value), Semigroup)
-- | A single point in a program’s execution.
data Configuration term address value = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live address -- ^ The set of rooted addresses.
, configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'.
, configurationHeap :: Heap address value -- ^ The heap of values.
}
deriving (Eq, Ord, Show)
data Cached address value = Cached
{ cachedValue :: ValueRef address
, cachedHeap :: Heap address value
}
deriving (Eq, Ord, Show)
type Cacheable term address value = (Ord address, Ord term, Ord value)
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
cacheLookup :: Cacheable term address value => Configuration term address value -> Cache term address value -> Maybe (Set (Cached address value))
cacheLookup key = Monoidal.lookup key . unCache
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
cacheSet :: Cacheable term address value => Configuration term address value -> Set (Cached address value) -> Cache term address value -> Cache term address value
cacheSet key value = Cache . Monoidal.insert key value . unCache
-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
cacheInsert :: Cacheable term address value => Configuration term address value -> Cached address value -> Cache term address value -> Cache term address value
cacheInsert = curry cons
instance (Show term, Show address, Show value) => Show (Cache term address value) where
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache

22
src/Analysis/Abstract/Collecting.hs
View File

@ -1,25 +1,9 @@
{-# LANGUAGE TypeOperators #-}
module Analysis.Abstract.Collecting
( collectingTerms
, providingLiveSet
( providingLiveSet
) where
import Control.Abstract
import Prologue
-- | An analysis performing GC after every instruction.
collectingTerms :: ( Member (Reader (Live address)) effects
, Member (State (Heap address address value)) effects
, Ord address
, ValueRoots address value
)
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects value)
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects value)
collectingTerms recur term = do
roots <- TermEvaluator askRoots
v <- recur term
v <$ TermEvaluator (gc (roots <> valueRoots v))
providingLiveSet :: (Effectful (m address value), PureEffects effects) => m address value (Reader (Live address) ': effects) a -> m address value effects a
providingLiveSet = runReader lowerBound
providingLiveSet :: Carrier sig m => Evaluator term address value (ReaderC (Live address) (Eff m)) a -> Evaluator term address value m a
providingLiveSet = raiseHandler (runReader lowerBound)

27
src/Analysis/Abstract/Dead.hs
View File

@ -19,34 +19,33 @@ newtype Dead term = Dead { unDead :: Set term }
deriving instance Ord term => Reducer term (Dead term)
-- | Update the current 'Dead' set.
killAll :: Member (State (Dead term)) effects => Dead term -> TermEvaluator term address value effects ()
killAll :: (Member (State (Dead term)) sig, Carrier sig m) => Dead term -> Evaluator term address value m ()
killAll = put
-- | Revive a single term, removing it from the current 'Dead' set.
revive :: (Member (State (Dead term)) effects, Ord term) => term -> TermEvaluator term address value effects ()
revive t = modify' (Dead . delete t . unDead)
revive :: (Member (State (Dead term)) sig, Carrier sig m, Ord term) => term -> Evaluator term address value m ()
revive t = modify (Dead . delete t . unDead)
-- | Compute the set of all subterms recursively.
subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term
subterms term = term `cons` para (foldMap (uncurry cons)) term
revivingTerms :: ( Corecursive term
, Member (State (Dead term)) effects
revivingTerms :: ( Member (State (Dead term)) sig
, Ord term
, Carrier sig m
)
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
revivingTerms recur term = revive (embedSubterm term) *> recur term
=> Open (Open (term -> Evaluator term address value m a))
revivingTerms recur0 recur term = revive term *> recur0 recur term
killingModules :: ( Foldable (Base term)
, Member (State (Dead term)) effects
, Member (State (Dead term)) sig
, Ord term
, Recursive term
, Carrier sig m
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
killingModules recur m = killAll (subterms (subterm (moduleBody m))) *> recur m
=> Open (Module term -> Evaluator term address value m a)
killingModules recur m = killAll (subterms (moduleBody m)) *> recur m
providingDeadSet :: Effects effects => TermEvaluator term address value (State (Dead term) ': effects) a -> TermEvaluator term address value effects (Dead term, a)
providingDeadSet = runState lowerBound
providingDeadSet :: (Carrier sig m, Effect sig) => Evaluator term address value (StateC (Dead term) (Evaluator term address value m)) a -> Evaluator term address value m (Dead term, a)
providingDeadSet = runState lowerBound . runEvaluator

183
src/Analysis/Abstract/Graph.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators #-}
{-# LANGUAGE LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.Graph
( Graph(..)
, ControlFlowVertex(..)
@ -18,6 +18,8 @@ module Analysis.Abstract.Graph
import Algebra.Graph.Export.Dot hiding (vertexName)
import Control.Abstract hiding (Function(..))
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Address.Hole
import Data.Abstract.Address.Located
import Data.Abstract.BaseError
@ -29,11 +31,11 @@ import Data.Abstract.Package (PackageInfo (..))
import Data.ByteString.Builder
import Data.Graph
import Data.Graph.ControlFlowVertex
import Data.Record
import Data.Term
import Data.Location
import qualified Data.Map as Map
import qualified Data.Text.Encoding as T
import Prologue hiding (project)
import Prologue
style :: Style ControlFlowVertex Builder
style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier))
@ -62,139 +64,156 @@ style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier))
-- | Add vertices to the graph for evaluated identifiers.
graphingTerms :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Graph ControlFlowVertex)) effects
, Member (State (Map (Hole context (Located address)) ControlFlowVertex)) effects
, AbstractValue (Hole context (Located address)) value effects
, Member (Reader ControlFlowVertex) effects
, HasField fields Span
graphingTerms :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (State (Graph ControlFlowVertex)) sig
, Member (State (Map (Hole context (Located address)) ControlFlowVertex)) sig
, AbstractValue term (Hole context (Located address)) value m
, Member (Reader ControlFlowVertex) sig
, VertexDeclaration syntax
, Declarations1 syntax
, Ord address
, Ord context
, Foldable syntax
, Functor syntax
, term ~ Term syntax (Record fields)
, term ~ Term syntax Location
, Carrier sig m
)
=> SubtermAlgebra (Base term) term (TermEvaluator term (Hole context (Located address)) value effects (ValueRef (Hole context (Located address)) value)) -- TODO: Fix me. I added `value` to `(ValueRef (Hole context ...))`
-> SubtermAlgebra (Base term) term (TermEvaluator term (Hole context (Located address)) value effects (ValueRef (Hole context (Located address)) value)) -- TODO: Fix me. I added `value` to `(ValueRef (Hole context ...))`
graphingTerms recur term@(In a syntax) = do
=> Open (Open (term -> Evaluator term (Hole context (Located address)) value m (ValueRef (Hole context (Located address)))))
graphingTerms recur0 recur term@(Term (In a syntax)) = do
definedInModule <- currentModule
case toVertex a definedInModule (subterm <$> syntax) of
case toVertex a definedInModule syntax of
Just (v@Function{}, _) -> recurWithContext v
Just (v@Method{}, _) -> recurWithContext v
Just (v@Variable{..}, name) -> do
variableDefinition v
-- TODO: Fix me.
-- maybeAddr <- TermEvaluator (lookupEnv name)
-- case maybeAddr of
-- Just a -> do
-- defined <- gets (Map.lookup a)
-- maybe (pure ()) (appendGraph . connect (vertex v) . vertex) defined
-- _ -> pure ()
recur term
_ -> recur term
Just (v@Variable{..}, name) -> undefined -- do
-- variableDefinition v
-- maybeAddr <- lookupEnv name
-- case maybeAddr of
-- Just a -> do
-- defined <- gets (Map.lookup a)
-- maybe (pure ()) (appendGraph . connect (vertex v) . vertex) defined
-- _ -> pure ()
-- recur0 recur term
-- _ -> recur0 recur term
where
recurWithContext v = do
variableDefinition v
moduleInclusion v
local (const v) $ do
valRef <- recur term
-- TODO: Fix me.
-- addr <- TermEvaluator (Control.Abstract.address valRef)
-- modify' (Map.insert addr v)
pure valRef
local (const v) $ undefined -- do
-- valRef <- recur0 recur term
-- addr <- Control.Abstract.address valRef
-- modify (Map.insert addr v)
-- pure valRef
-- | Add vertices to the graph for evaluated modules and the packages containing them.
graphingPackages :: ( Member (Reader PackageInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
, Member (Reader ControlFlowVertex) effects
graphingPackages :: ( Member (Reader PackageInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Member (Reader ControlFlowVertex) sig
, Carrier sig m
, Monad m
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
=> Open (Module term -> m a)
graphingPackages recur m =
let v = moduleVertex (moduleInfo m) in packageInclusion v *> local (const v) (recur m)
-- | Add vertices to the graph for imported modules.
graphingModules :: forall term address value effects a
. ( Member (Modules address value) effects
, Member (Reader ModuleInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
, Member (Reader ControlFlowVertex) effects
, PureEffects effects
graphingModules :: ( Member (Modules address value) sig
, Member (Reader ModuleInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Member (Reader ControlFlowVertex) sig
, Carrier sig m
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
=> (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a)
-> (Module body -> Evaluator term address value m a)
graphingModules recur m = do
let v = moduleVertex (moduleInfo m)
appendGraph (vertex v)
local (const v) $
eavesdrop @(Modules address value) (\ m -> case m of
Load path -> includeModule path
Lookup path -> includeModule path
_ -> pure ())
(recur m)
eavesdrop (recur m) $ \case
Load path _ -> includeModule path
Lookup path _ -> includeModule path
_ -> pure ()
where
-- NB: path is null for Languages like Ruby that have module imports that require concrete value semantics.
includeModule path = let path' = if Prologue.null path then "unknown, concrete semantics required" else path
in moduleInclusion (moduleVertex (ModuleInfo path'))
{-# ANN graphingModules ("HLint: ignore Use ." :: String) #-}
-- | Add vertices to the graph for imported modules.
graphingModuleInfo :: forall term address value effects a
. ( Member (Modules address value) effects
, Member (Reader ModuleInfo) effects
, Member (State (Graph ModuleInfo)) effects
, PureEffects effects
graphingModuleInfo :: ( Member (Modules address value) sig
, Member (Reader ModuleInfo) sig
, Member (State (Graph ModuleInfo)) sig
, Carrier sig m
)
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
=> (Module body -> Evaluator term address value (EavesdropC address (Eff m)) a)
-> (Module body -> Evaluator term address value m a)
graphingModuleInfo recur m = do
appendGraph (vertex (moduleInfo m))
eavesdrop @(Modules address value) (\ eff -> case eff of
Load path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
Lookup path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
_ -> pure ())
(recur m)
eavesdrop (recur m) $ \case
Load path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
_ -> pure ()
eavesdrop :: (Carrier sig m, Member (Modules address) sig)
=> Evaluator term address value (EavesdropC address (Eff m)) a
-> (forall x . Modules address (Eff m) (Eff m x) -> Evaluator term address value m ())
-> Evaluator term address value m a
eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f) . interpret) m
newtype EavesdropC address m a = EavesdropC ((forall x . Modules address m (m x) -> m ()) -> m a)
runEavesdropC :: (forall x . Modules address m (m x) -> m ()) -> EavesdropC address m a -> m a
runEavesdropC f (EavesdropC m) = m f
instance (Carrier sig m, Member (Modules address) sig, Applicative m) => Carrier sig (EavesdropC address m) where
ret a = EavesdropC (const (ret a))
eff op
| Just eff <- prj op = EavesdropC (\ handler -> let eff' = handlePure (runEavesdropC handler) eff in handler eff' *> send eff')
| otherwise = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op))
-- | Add an edge from the current package to the passed vertex.
packageInclusion :: ( Effectful m
, Member (Reader PackageInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
, Monad (m effects)
packageInclusion :: ( Member (Reader PackageInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Carrier sig m
, Monad m
)
=> ControlFlowVertex
-> m effects ()
-> m ()
packageInclusion v = do
p <- currentPackage
appendGraph (vertex (packageVertex p) `connect` vertex v)
-- | Add an edge from the current module to the passed vertex.
moduleInclusion :: ( Effectful m
, Member (Reader ModuleInfo) effects
, Member (State (Graph ControlFlowVertex)) effects
, Monad (m effects)
moduleInclusion :: ( Member (Reader ModuleInfo) sig
, Member (State (Graph ControlFlowVertex)) sig
, Carrier sig m
, Monad m
)
=> ControlFlowVertex
-> m effects ()
-> m ()
moduleInclusion v = do
m <- currentModule
appendGraph (vertex (moduleVertex m) `connect` vertex v)
-- | Add an edge from the passed variable name to the context it originated within.
variableDefinition :: ( Member (State (Graph ControlFlowVertex)) effects
, Member (Reader ControlFlowVertex) effects
variableDefinition :: ( Member (State (Graph ControlFlowVertex)) sig
, Member (Reader ControlFlowVertex) sig
, Carrier sig m
, Monad m
)
=> ControlFlowVertex
-> TermEvaluator term (Hole context (Located address)) value effects ()
-> m ()
variableDefinition var = do
context <- ask
appendGraph $ vertex context `connect` vertex var
appendGraph (vertex context `connect` vertex var)
appendGraph :: (Effectful m, Member (State (Graph v)) effects) => Graph v -> m effects ()
appendGraph = modify' . (<>)
appendGraph :: (Member (State (Graph v)) sig, Carrier sig m, Monad m) => Graph v -> m ()
appendGraph = modify . (<>)
graphing :: (Effectful m, Effects effects, Functor (m (State (Graph ControlFlowVertex) : effects)))
=> m (State (Map (Hole context (Located address)) ControlFlowVertex) ': State (Graph ControlFlowVertex) ': effects) result -> m effects (Graph ControlFlowVertex, result)
graphing = runState mempty . fmap snd . runState lowerBound
graphing :: (Carrier sig m, Effect sig)
=> Evaluator term address value (StateC (Map address ControlFlowVertex) (Eff
(StateC (Graph ControlFlowVertex) (Eff
m)))) result
-> Evaluator term address value m (Graph ControlFlowVertex, result)
graphing = raiseHandler $ runState mempty . fmap snd . runState lowerBound

39
src/Analysis/Abstract/Tracing.hs
View File

@ -4,28 +4,41 @@ module Analysis.Abstract.Tracing
, tracing
) where
import Control.Abstract.Configuration
import Control.Abstract hiding (trace)
import Control.Monad.Effect.Writer
import Control.Effect.Writer
import Data.Abstract.Environment
import Data.Semigroup.Reducer as Reducer
import Prologue
-- | Trace analysis.
--
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
tracingTerms :: ( Corecursive term
, Member (Reader (Live address)) effects
, Member (State (Heap address address value)) effects
, Member (Writer (trace (Configuration term address value))) effects
tracingTerms :: ( Member (Env address) sig
, Member (State (Heap address address value)) sig
, Member (Writer (trace (Configuration term address value))) sig
, Carrier sig m
, Reducer (Configuration term address value) (trace (Configuration term address value))
)
=> trace (Configuration term address value)
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
tracingTerms proxy recur term = getConfiguration (embedSubterm term) >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term
-> Open (Open (term -> Evaluator term address value m a))
tracingTerms proxy recur0 recur term = getConfiguration term >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur0 recur term
trace :: Member (Writer (trace (Configuration term address value))) effects => trace (Configuration term address value) -> TermEvaluator term address value effects ()
trace :: (Member (Writer (trace (Configuration term address value))) sig, Carrier sig m) => trace (Configuration term address value) -> Evaluator term address value m ()
trace = tell
tracing :: (Monoid (trace (Configuration term address value)), Effects effects) => TermEvaluator term address value (Writer (trace (Configuration term address value)) ': effects) a -> TermEvaluator term address value effects (trace (Configuration term address value), a)
tracing = runWriter
tracing :: (Monoid (trace (Configuration term address value)), Carrier sig m, Effect sig) => Evaluator term address value (WriterC (trace (Configuration term address value)) (Evaluator term address value m)) a -> Evaluator term address value m (trace (Configuration term address value), a)
tracing = runWriter . runEvaluator
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Env address) sig, Member (State (Heap address value)) sig, Carrier sig m)
=> term
-> Evaluator term address value m (Configuration term address value)
getConfiguration term = Configuration term <$> getEvalContext <*> getHeap
-- | A single point in a program’s execution.
data Configuration term address value = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'.
, configurationHeap :: Heap address value -- ^ The heap of values.
}
deriving (Eq, Ord, Show)

1
src/Analysis/ConstructorName.hs
View File

@ -4,6 +4,7 @@ module Analysis.ConstructorName
) where
import Data.Sum
import GHC.Generics
import Prologue
-- | A typeclass to retrieve the name of the data constructor for a value.

158
src/Analysis/Declaration.hs
View File

@ -1,37 +1,37 @@
{-# LANGUAGE TypeOperators, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Declaration
( Declaration(..)
, HasDeclaration
, declarationAlgebra
) where
import Data.Abstract.Name (formatName)
import Data.Blob
import Data.Error (Error(..), showExpectation)
import Data.Language as Language
import Data.Range
import Data.Record
import Data.Source as Source
import Data.Span
import Data.Sum
import Prologue hiding (first, project)
import Control.Arrow hiding (first)
import qualified Data.Text as T
import Control.Rewriting hiding (apply)
import Data.Blob
import Data.Error (Error (..), showExpectation)
import Data.Language as Language
import Data.Location
import Data.Range
import Data.Source as Source
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Expression as Expression
import Data.Term
import qualified Data.Text as T
import Data.Term
import qualified Language.Markdown.Syntax as Markdown
import qualified Language.Ruby.Syntax as Ruby.Syntax
import Prologue hiding (project)
import qualified Language.TypeScript.Syntax as TypeScript.Syntax
-- | A declaration’s identifier and type.
data Declaration
= MethodDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language, declarationReceiver :: Maybe T.Text }
| ClassDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language }
| ImportDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language, declarationAlias :: T.Text, declarationSymbols :: [(T.Text, T.Text)] }
| FunctionDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language }
| HeadingDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language, declarationLevel :: Int }
| CallReference { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language, declarationImportIdentifier :: [T.Text] }
| ErrorDeclaration { declarationIdentifier :: T.Text, declarationText :: T.Text, declarationLanguage :: Language }
= MethodDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationReceiver :: Maybe Text }
| ClassDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
| ModuleDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
| FunctionDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
| HeadingDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language, declarationLevel :: Int }
| ErrorDeclaration { declarationIdentifier :: Text, declarationText :: Text, declarationSpan :: Span, declarationLanguage :: Language }
deriving (Eq, Generic, Show)
@ -45,13 +45,13 @@ data Declaration
-- If you’re getting errors about missing a 'CustomHasDeclaration' instance for your syntax type, you probably forgot step 1.
--
-- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
declarationAlgebra :: (HasField fields Range, HasField fields Span, Foldable syntax, HasDeclaration syntax)
=> Blob -> RAlgebra (TermF syntax (Record fields)) (Term syntax (Record fields)) (Maybe Declaration)
declarationAlgebra :: (Foldable syntax, HasDeclaration syntax)
=> Blob -> RAlgebra (TermF syntax Location) (Term syntax Location) (Maybe Declaration)
declarationAlgebra blob (In ann syntax) = toDeclaration blob ann syntax
-- | Types for which we can produce a 'Declaration' in 'Maybe'. There is exactly one instance of this typeclass
class HasDeclaration syntax where
toDeclaration :: (Foldable syntax, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term syntax (Record fields), Maybe Declaration) -> Maybe Declaration
toDeclaration :: (Foldable syntax) => Blob -> Location -> syntax (Term syntax Location, Maybe Declaration) -> Maybe Declaration
instance (HasDeclaration' syntax syntax) => HasDeclaration syntax where
toDeclaration = toDeclaration'
@ -61,7 +61,7 @@ instance (HasDeclaration' syntax syntax) => HasDeclaration syntax where
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
class HasDeclaration' whole syntax where
-- | Compute a 'Declaration' for a syntax type using its 'CustomHasDeclaration' instance, if any, or else falling back to the default definition (which simply returns 'Nothing').
toDeclaration' :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term whole (Record fields), Maybe Declaration) -> Maybe Declaration
toDeclaration' :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe Declaration) -> Maybe Declaration
-- | Define 'toDeclaration' using the 'CustomHasDeclaration' instance for a type if there is one or else use the default definition.
--
@ -75,22 +75,22 @@ instance (DeclarationStrategy syntax ~ strategy, HasDeclarationWithStrategy stra
-- | Types for which we can produce a customized 'Declaration'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions).
class CustomHasDeclaration whole syntax where
-- | Produce a customized 'Declaration' for a given syntax node.
customToDeclaration :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term whole (Record fields), Maybe Declaration) -> Maybe Declaration
customToDeclaration :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe Declaration) -> Maybe Declaration
-- | Produce a 'HeadingDeclaration' from the first line of the heading of a 'Markdown.Heading' node.
instance CustomHasDeclaration whole Markdown.Heading where
customToDeclaration Blob{..} ann (Markdown.Heading level terms _)
= Just $ HeadingDeclaration (headingText terms) mempty blobLanguage level
where headingText terms = getSource $ maybe (getField ann) sconcat (nonEmpty (headingByteRange <$> toList terms))
headingByteRange (Term (In ann _), _) = getField ann
= Just $ HeadingDeclaration (headingText terms) mempty (locationSpan ann) blobLanguage level
where headingText terms = getSource $ maybe (locationByteRange ann) sconcat (nonEmpty (headingByteRange <$> toList terms))
headingByteRange (Term (In ann _), _) = locationByteRange ann
getSource = firstLine . toText . flip Source.slice blobSource
firstLine = T.takeWhile (/= '\n')
-- | Produce an 'ErrorDeclaration' for 'Syntax.Error' nodes.
instance CustomHasDeclaration whole Syntax.Error where
customToDeclaration Blob{..} ann err@Syntax.Error{}
= Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (getField ann) err))) mempty blobLanguage
= Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (locationSpan ann) err))) mempty (locationSpan ann) blobLanguage
where formatTOCError e = showExpectation False (errorExpected e) (errorActual e) ""
-- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range').
@ -99,44 +99,66 @@ instance CustomHasDeclaration whole Declaration.Function where
-- Do not summarize anonymous functions
| isEmpty identifierAnn = Nothing
-- Named functions
| otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) (getFunctionSource blob (In ann decl)) blobLanguage
where isEmpty = (== 0) . rangeLength . getField
| otherwise = Just $ FunctionDeclaration (getSource blobSource identifierAnn) functionSource (locationSpan ann) blobLanguage
where isEmpty = (== 0) . rangeLength . locationByteRange
functionSource = getIdentifier (arr Declaration.functionBody) blob (In ann decl)
-- | Produce a 'MethodDeclaration' for 'Declaration.Method' nodes. If the method’s receiver is non-empty (defined as having a non-empty 'Range'), the 'declarationIdentifier' will be formatted as 'receiver.method_name'; otherwise it will be simply 'method_name'.
instance CustomHasDeclaration whole Declaration.Method where
customToDeclaration blob@Blob{..} ann decl@(Declaration.Method _ (Term (In receiverAnn receiverF), _) (Term (In identifierAnn _), _) _ _)
-- Methods without a receiver
| isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage Nothing
| isEmpty receiverAnn = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) blobLanguage Nothing
-- Methods with a receiver type and an identifier (e.g. (a *Type) in Go).
| blobLanguage == Go
, [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage (Just (getSource blobSource receiverType))
, [ _, Term (In receiverType _) ] <- toList receiverF = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) blobLanguage (Just (getSource blobSource receiverType))
-- Methods with a receiver (class methods) are formatted like `receiver.method_name`
| otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) (getMethodSource blob (In ann decl)) blobLanguage (Just (getSource blobSource receiverAnn))
where isEmpty = (== 0) . rangeLength . getField
| otherwise = Just $ MethodDeclaration (getSource blobSource identifierAnn) methodSource (locationSpan ann) blobLanguage (Just (getSource blobSource receiverAnn))
where
isEmpty = (== 0) . rangeLength . locationByteRange
methodSource = getIdentifier (arr Declaration.methodBody) blob (In ann decl)
-- | Produce a 'ClassDeclaration' for 'Declaration.Class' nodes.
instance CustomHasDeclaration whole Declaration.Class where
customToDeclaration blob@Blob{..} ann decl@(Declaration.Class _ (Term (In identifierAnn _), _) _ _)
= Just $ ClassDeclaration (getSource blobSource identifierAnn) (getClassSource blob (In ann decl)) blobLanguage
= Just $ ClassDeclaration (getSource blobSource identifierAnn) classSource (locationSpan ann) blobLanguage
where classSource = getIdentifier (arr Declaration.classBody) blob (In ann decl)
instance CustomHasDeclaration whole Ruby.Syntax.Class where
customToDeclaration blob@Blob{..} ann decl@(Ruby.Syntax.Class (Term (In identifierAnn _), _) _ _)
= Just $ ClassDeclaration (getSource blobSource identifierAnn) (getRubyClassSource blob (In ann decl)) blobLanguage
= Just $ ClassDeclaration (getSource blobSource identifierAnn) rubyClassSource (locationSpan ann) blobLanguage
where rubyClassSource = getIdentifier (arr Ruby.Syntax.classBody) blob (In ann decl)
getSource :: HasField fields Range => Source -> Record fields -> Text
getSource blobSource = toText . flip Source.slice blobSource . getField
instance CustomHasDeclaration whole Ruby.Syntax.Module where
customToDeclaration blob@Blob{..} ann decl@(Ruby.Syntax.Module (Term (In identifierAnn _), _) _)
= Just $ ModuleDeclaration (getSource blobSource identifierAnn) rubyModuleSource (locationSpan ann) blobLanguage
where rubyModuleSource = getIdentifier (arr Ruby.Syntax.moduleStatements >>> first) blob (In ann decl)
instance (Syntax.Identifier :< fs, Expression.MemberAccess :< fs) => CustomHasDeclaration (Sum fs) Expression.Call where
customToDeclaration Blob{..} _ (Expression.Call _ (Term (In fromAnn fromF), _) _ _)
| Just (Expression.MemberAccess (Term (In leftAnn leftF)) name) <- project fromF = Just $ CallReference (formatName name) mempty blobLanguage (memberAccess leftAnn leftF)
| Just (Syntax.Identifier name) <- project fromF = Just $ CallReference (formatName name) mempty blobLanguage []
| otherwise = Just $ CallReference (getSource fromAnn) mempty blobLanguage []
where
memberAccess modAnn termFOut
| Just (Expression.MemberAccess (Term (In leftAnn leftF)) name) <- project termFOut
= memberAccess leftAnn leftF <> [formatName name]
| otherwise = [getSource modAnn]
getSource = toText . flip Source.slice blobSource . getField
instance CustomHasDeclaration whole TypeScript.Syntax.Module where
customToDeclaration blob@Blob{..} ann decl@(TypeScript.Syntax.Module (Term (In identifierAnn _), _) _)
= Just $ ModuleDeclaration (getSource blobSource identifierAnn) tsModuleSource (locationSpan ann) blobLanguage
where tsModuleSource = getIdentifier (arr TypeScript.Syntax.moduleStatements >>> first) blob (In ann decl)
-- When encountering a Declaration-annotated term, we need to extract a Text
-- for the resulting Declaration's 'declarationIdentifier' field. This text
-- is constructed by slicing out text from the original blob corresponding
-- to a location, which is found via the passed-in rule.
getIdentifier :: Functor m
=> Rule () (m (Term syntax Location)) (Term syntax Location)
-> Blob
-> TermF m Location (Term syntax Location, a)
-> Text
getIdentifier finder Blob{..} (In a r)
= let declRange = locationByteRange a
bodyRange = locationByteRange <$> rewrite (finder >>^ annotation) () (fmap fst r)
-- Text-based gyrations to slice the identifier out of the provided blob source
sliceFrom = T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange
in either (const mempty) sliceFrom bodyRange
first :: Rule env [a] a
first = target >>= maybeM (Prologue.fail "empty list") . listToMaybe
getSource :: Source -> Location -> Text
getSource blobSource = toText . flip Source.slice blobSource . locationByteRange
-- | Produce a 'Declaration' for 'Sum's using the 'HasDeclaration' instance & therefore using a 'CustomHasDeclaration' instance when one exists & the type is listed in 'DeclarationStrategy'.
instance Apply (HasDeclaration' whole) fs => CustomHasDeclaration whole (Sum fs) where
@ -150,7 +172,7 @@ data Strategy = Default | Custom
--
-- You should probably be using 'CustomHasDeclaration' instead of this class; and you should not define new instances of this class.
class HasDeclarationWithStrategy (strategy :: Strategy) whole syntax where
toDeclarationWithStrategy :: (Foldable whole, HasField fields Range, HasField fields Span) => proxy strategy -> Blob -> Record fields -> syntax (Term whole (Record fields), Maybe Declaration) -> Maybe Declaration
toDeclarationWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Location -> syntax (Term whole Location, Maybe Declaration) -> Maybe Declaration
-- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.
@ -161,10 +183,11 @@ class HasDeclarationWithStrategy (strategy :: Strategy) whole syntax where
type family DeclarationStrategy syntax where
DeclarationStrategy Declaration.Class = 'Custom
DeclarationStrategy Ruby.Syntax.Class = 'Custom
DeclarationStrategy Ruby.Syntax.Module = 'Custom
DeclarationStrategy TypeScript.Syntax.Module = 'Custom
DeclarationStrategy Declaration.Function = 'Custom
DeclarationStrategy Declaration.Method = 'Custom
DeclarationStrategy Markdown.Heading = 'Custom
DeclarationStrategy Expression.Call = 'Custom
DeclarationStrategy Syntax.Error = 'Custom
DeclarationStrategy (Sum fs) = 'Custom
DeclarationStrategy a = 'Default
@ -177,32 +200,3 @@ instance HasDeclarationWithStrategy 'Default whole syntax where
-- | The 'Custom' strategy delegates the selection of the strategy to the 'CustomHasDeclaration' instance for the type.
instance CustomHasDeclaration whole syntax => HasDeclarationWithStrategy 'Custom whole syntax where
toDeclarationWithStrategy _ = customToDeclaration
getMethodSource :: HasField fields Range => Blob -> TermF Declaration.Method (Record fields) (Term syntax (Record fields), a) -> T.Text
getMethodSource Blob{..} (In a r)
= let declRange = getField a
bodyRange = getField <$> case r of
Declaration.Method _ _ _ _ (Term (In a' _), _) -> Just a'
in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
getFunctionSource :: HasField fields Range => Blob -> TermF Declaration.Function (Record fields) (Term syntax (Record fields), a) -> T.Text
getFunctionSource Blob{..} (In a r)
= let declRange = getField a
bodyRange = getField <$> case r of
Declaration.Function _ _ _ (Term (In a' _), _) -> Just a'
in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
getClassSource :: (HasField fields Range) => Blob -> TermF Declaration.Class (Record fields) (Term syntax (Record fields), a) -> T.Text
getClassSource Blob{..} (In a r)
= let declRange = getField a
bodyRange = getField <$> case r of
Declaration.Class _ _ _ (Term (In a' _), _) -> Just a'
in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange
getRubyClassSource :: (HasField fields Range) => Blob -> TermF Ruby.Syntax.Class (Record fields) (Term syntax (Record fields), a) -> T.Text
getRubyClassSource Blob{..} (In a r)
= let declRange = getField a
bodyRange = getField <$> case r of
Ruby.Syntax.Class _ _ (Term (In a' _), _) -> Just a'
in maybe mempty (T.stripEnd . toText . flip Source.slice blobSource . subtractRange declRange) bodyRange

9
src/Analysis/Decorator.hs
View File

@ -3,13 +3,12 @@ module Analysis.Decorator
( decoratorWithAlgebra
) where
import Data.Record
import Data.Term
import Prologue
-- | Lift an algebra into a decorator for terms annotated with records.
decoratorWithAlgebra :: Functor syntax
=> RAlgebra (TermF syntax (Record fs)) (Term syntax (Record fs)) a -- ^ An R-algebra on terms.
-> Term syntax (Record fs) -- ^ A term to decorate with values produced by the R-algebra.
-> Term syntax (Record (a ': fs)) -- ^ A term decorated with values produced by the R-algebra.
decoratorWithAlgebra alg = para $ \ c@(In a f) -> termIn (alg (fmap (second (rhead . termAnnotation)) c) :. a) (fmap snd f)
=> RAlgebra (TermF syntax a) (Term syntax a) b -- ^ An R-algebra on terms.
-> Term syntax a -- ^ A term to decorate with values produced by the R-algebra.
-> Term syntax b -- ^ A term decorated with values produced by the R-algebra.
decoratorWithAlgebra alg = para $ \ c@(In _ f) -> termIn (alg (fmap (second termAnnotation) c)) (fmap snd f)

14
src/Analysis/PackageDef.hs
View File

@ -6,10 +6,8 @@ module Analysis.PackageDef
) where
import Data.Blob
import Data.Range
import Data.Record
import Data.Location
import Data.Source as Source
import Data.Span
import Data.Sum
import Data.Term
import qualified Data.Text as T
@ -29,7 +27,7 @@ newtype PackageDef = PackageDef { moduleDefIdentifier :: T.Text }
-- If you’re getting errors about missing a 'CustomHasPackageDef' instance for your syntax type, you probably forgot step 1.
--
-- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
packageDefAlgebra :: (HasField fields Range, HasField fields Span, Foldable syntax, HasPackageDef syntax) => Blob -> RAlgebra (TermF syntax (Record fields)) (Term syntax (Record fields)) (Maybe PackageDef)
packageDefAlgebra :: (Foldable syntax, HasPackageDef syntax) => Blob -> RAlgebra (TermF syntax Location) (Term syntax Location) (Maybe PackageDef)
packageDefAlgebra blob (In ann syntax) = toPackageDef blob ann syntax
@ -38,7 +36,7 @@ packageDefAlgebra blob (In ann syntax) = toPackageDef blob ann syntax
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
class HasPackageDef syntax where
-- | Compute a 'PackageDef' for a syntax type using its 'CustomHasPackageDef' instance, if any, or else falling back to the default definition (which simply returns 'Nothing').
toPackageDef :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term whole (Record fields), Maybe PackageDef) -> Maybe PackageDef
toPackageDef :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe PackageDef) -> Maybe PackageDef
-- | Define 'toPackageDef' using the 'CustomHasPackageDef' instance for a type if there is one or else use the default definition.
--
@ -52,13 +50,13 @@ instance (PackageDefStrategy syntax ~ strategy, HasPackageDefWithStrategy strate
-- | Types for which we can produce a customized 'PackageDef'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions).
class CustomHasPackageDef syntax where
-- | Produce a customized 'PackageDef' for a given syntax node.
customToPackageDef :: (Foldable whole, HasField fields Range, HasField fields Span) => Blob -> Record fields -> syntax (Term whole (Record fields), Maybe PackageDef) -> Maybe PackageDef
customToPackageDef :: (Foldable whole) => Blob -> Location -> syntax (Term whole Location, Maybe PackageDef) -> Maybe PackageDef
instance CustomHasPackageDef Language.Go.Syntax.Package where
customToPackageDef Blob{..} _ (Language.Go.Syntax.Package (Term (In fromAnn _), _) _)
= Just $ PackageDef (getSource fromAnn)
where getSource = toText . flip Source.slice blobSource . getField
where getSource = toText . flip Source.slice blobSource . locationByteRange
-- | Produce a 'PackageDef' for 'Sum's using the 'HasPackageDef' instance & therefore using a 'CustomHasPackageDef' instance when one exists & the type is listed in 'PackageDefStrategy'.
instance Apply HasPackageDef fs => CustomHasPackageDef (Sum fs) where
@ -72,7 +70,7 @@ data Strategy = Default | Custom
--
-- You should probably be using 'CustomHasPackageDef' instead of this class; and you should not define new instances of this class.
class HasPackageDefWithStrategy (strategy :: Strategy) syntax where
toPackageDefWithStrategy :: (Foldable whole, HasField fields Range, HasField fields Span) => proxy strategy -> Blob -> Record fields -> syntax (Term whole (Record fields), Maybe PackageDef) -> Maybe PackageDef
toPackageDefWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Location -> syntax (Term whole Location, Maybe PackageDef) -> Maybe PackageDef
-- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.

25
src/Assigning/Assignment.hs
View File

@ -61,7 +61,7 @@
module Assigning.Assignment
-- Types
( Assignment
, Location
, L.Location(..)
-- Combinators
, branchNode
, leafNode
@ -97,11 +97,12 @@ module Assigning.Assignment
import Prologue
import Prelude hiding (fail)
import qualified Assigning.Assignment.Table as Table
import Control.Monad.Except (MonadError (..))
import Control.Monad.Free.Freer
import Data.AST
import Data.Error
import Data.Range
import Data.Record
import qualified Data.Location as L
import qualified Data.Source as Source (Source, slice, sourceBytes)
import Data.Span
import Data.Term
@ -120,8 +121,8 @@ leafNode sym = symbol sym *> source
-- | Wrap an 'Assignment' producing @syntax@ up into an 'Assignment' producing 'Term's.
toTerm :: Element syntax syntaxes
=> Assignment ast grammar (syntax (Term (Sum syntaxes) (Record Location)))
-> Assignment ast grammar (Term (Sum syntaxes) (Record Location))
=> Assignment ast grammar (syntax (Term (Sum syntaxes) L.Location))
-> Assignment ast grammar (Term (Sum syntaxes) L.Location)
toTerm syntax = termIn <$> location <*> (inject <$> syntax)
@ -132,7 +133,7 @@ type Assignment ast grammar = Freer (Tracing (AssignmentF ast grammar))
data AssignmentF ast grammar a where
End :: AssignmentF ast grammar ()
Location :: AssignmentF ast grammar (Record Location)
Location :: AssignmentF ast grammar L.Location
CurrentNode :: AssignmentF ast grammar (TermF ast (Node grammar) ())
Source :: AssignmentF ast grammar ByteString
Children :: Assignment ast grammar a -> AssignmentF ast grammar a
@ -159,7 +160,7 @@ tracing f = case getCallStack callStack of
-- | Zero-width production of the current location.
--
-- If assigning at the end of input or at the end of a list of children, the location will be returned as an empty Range and Span at the current offset. Otherwise, it will be the Range and Span of the current node.
location :: Assignment ast grammar (Record Location)
location :: Assignment ast grammar L.Location
location = tracing Location `Then` return
getLocals :: HasCallStack => Assignment ast grammar [Text]
@ -174,7 +175,7 @@ currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar)
currentNode = tracing CurrentNode `Then` return
-- | Zero-width match of a node with the given symbol, producing the current node’s location.
symbol :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar (Record Location)
symbol :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar L.Location
symbol s = tracing (Choose (Table.singleton s location) Nothing Nothing) `Then` return
-- | A rule to produce a node’s source as a ByteString.
@ -213,7 +214,7 @@ choice alternatives
mergeHandlers hs = Just (\ err -> asum (hs <*> [err]))
-- | Match and advance past a node with the given symbol.
token :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar (Record Location)
token :: (Enum grammar, Ix grammar, HasCallStack) => grammar -> Assignment ast grammar L.Location
token s = symbol s <* advance
@ -224,7 +225,7 @@ manyThrough step stop = go
nodeError :: CallStack -> [Either String grammar] -> Node grammar -> Error (Either String grammar)
nodeError cs expected Node{..} = Error nodeSpan expected (Just (Right nodeSymbol)) cs
nodeError cs expected n@Node{..} = Error (nodeSpan n) expected (Just (Right nodeSymbol)) cs
firstSet :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> [grammar]
@ -274,7 +275,7 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
anywhere node = case runTracing t of
End -> requireExhaustive (tracingCallSite t) ((), state) >>= uncurry yield
Location -> yield (Range stateOffset stateOffset :. Span statePos statePos :. Nil) state
Location -> yield (L.Location (Range stateOffset stateOffset) (Span statePos statePos)) state
Many rule -> fix (\ recur state -> (go rule state >>= \ (a, state') -> first (a:) <$> if state == state' then pure ([], state') else recur state') `catchError` const (pure ([], state))) state >>= uncurry yield
Alt (a:as) -> sconcat (flip yield state <$> a:|as)
Label child label -> go child state `catchError` (\ err -> throwError err { errorExpected = [Left label] }) >>= uncurry yield
@ -305,7 +306,7 @@ skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . n
-- | Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged.
advanceState :: State ast grammar -> State ast grammar
advanceState state@State{..}
| Term (In Node{..} _) : rest <- stateNodes = State (end nodeByteRange) (spanEnd nodeSpan) stateCallSites rest stateLocals
| Term (In node _) : rest <- stateNodes = State (end (nodeByteRange node)) (spanEnd (nodeSpan node)) stateCallSites rest stateLocals
| otherwise = state
-- | State kept while running 'Assignment's.
@ -386,7 +387,7 @@ instance Show1 f => Show1 (Tracing f) where
instance (Enum grammar, Ix grammar, Show grammar, Show1 ast) => Show1 (AssignmentF ast grammar) where
liftShowsPrec sp sl d a = case a of
End -> showString "End" . showChar ' ' . sp d ()
Location -> showString "Location" . sp d (Range 0 0 :. Span (Pos 1 1) (Pos 1 1) :. Nil)
Location -> showString "Location" . sp d (L.Location (Range 0 0) (Span (Pos 1 1) (Pos 1 1)))
CurrentNode -> showString "CurrentNode"
Source -> showString "Source" . showChar ' ' . sp d ""
Children a -> showsUnaryWith showChild "Children" d a

12
src/Assigning/Assignment/Deterministic.hs
View File

@ -14,7 +14,7 @@ import Data.Error
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.Range
import Data.Record
import Data.Location
import Data.Source as Source
import Data.Span
import qualified Data.Syntax as Syntax
@ -27,15 +27,15 @@ class (Alternative f, Ord symbol, Show symbol) => Assigning symbol f | f -> symb
branchNode :: symbol -> f a -> f a
toTerm :: (Element syntax syntaxes, Element Syntax.Error syntaxes)
=> f (syntax (Term (Sum syntaxes) (Record Location)))
-> f (Term (Sum syntaxes) (Record Location))
=> f (syntax (Term (Sum syntaxes) Location))
-> f (Term (Sum syntaxes) Location)
parseError :: ( Bounded symbol
, Element Syntax.Error syntaxes
, HasCallStack
, Assigning symbol f
)
=> f (Term (Sum syntaxes) (Record Location))
=> f (Term (Sum syntaxes) Location)
parseError = toTerm (leafNode maxBound $> Syntax.Error (Syntax.ErrorStack (Syntax.errorSite <$> getCallStack (freezeCallStack callStack))) [] (Just "ParseError") [])
@ -168,8 +168,8 @@ stateSpan :: State s -> Span
stateSpan state@(State _ _ []) = Span (statePos state) (statePos state)
stateSpan (State _ _ (s:_)) = astSpan s
stateLocation :: State s -> Record Location
stateLocation state = stateRange state :. stateSpan state :. Nil
stateLocation :: State s -> Location
stateLocation state = Location (stateRange state) (stateSpan state)
advanceState :: State s -> State s
advanceState state

2
src/Control/Abstract.hs
View File

@ -10,5 +10,5 @@ import Control.Abstract.Hole as X
import Control.Abstract.Modules as X
import Control.Abstract.Primitive as X
import Control.Abstract.Roots as X
import Control.Abstract.TermEvaluator as X
import Control.Abstract.ScopeGraph as X
import Control.Abstract.Value as X

14
src/Control/Abstract/Configuration.hs
View File

@ -1,14 +0,0 @@
module Control.Abstract.Configuration
( getConfiguration
) where
import Control.Abstract.Environment
import Control.Abstract.Heap
import Control.Abstract.Roots
import Control.Abstract.TermEvaluator
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live address)) effects, Member (State (Heap address address value)) effects)
=> term
-> TermEvaluator term address value effects (Configuration term address value)
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getHeap

26
src/Control/Abstract/Context.hs
View File

@ -12,9 +12,9 @@ module Control.Abstract.Context
, withCurrentCallStack
) where
import Control.Monad.Effect
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Control.Effect
import Control.Effect.Reader
import Control.Effect.State
import Data.Abstract.Module
import Data.Abstract.Package
import Data.Span
@ -22,38 +22,38 @@ import GHC.Stack
import Prologue
-- | Get the currently evaluating 'ModuleInfo'.
currentModule :: (Effectful m, Member (Reader ModuleInfo) effects) => m effects ModuleInfo
currentModule :: (Member (Reader ModuleInfo) sig, Carrier sig m) => m ModuleInfo
currentModule = ask
-- | Run an action with a locally-replaced 'ModuleInfo'.
withCurrentModule :: (Effectful m, Member (Reader ModuleInfo) effects) => ModuleInfo -> m effects a -> m effects a
withCurrentModule :: (Member (Reader ModuleInfo) sig, Carrier sig m) => ModuleInfo -> m a -> m a
withCurrentModule = local . const
-- | Get the currently evaluating 'PackageInfo'.
currentPackage :: (Effectful m, Member (Reader PackageInfo) effects) => m effects PackageInfo
currentPackage :: (Member (Reader PackageInfo) sig, Carrier sig m) => m PackageInfo
currentPackage = ask
-- | Run an action with a locally-replaced 'PackageInfo'.
withCurrentPackage :: (Effectful m, Member (Reader PackageInfo) effects) => PackageInfo -> m effects a -> m effects a
withCurrentPackage :: (Member (Reader PackageInfo) sig, Carrier sig m) => PackageInfo -> m a -> m a
withCurrentPackage = local . const
-- | Get the 'Span' of the currently-evaluating term (if any).
currentSpan :: (Effectful m, Member (Reader Span) effects) => m effects Span
currentSpan :: (Member (Reader Span) sig, Carrier sig m) => m Span
currentSpan = ask
-- | Run an action with a locally-replaced 'Span'.
withCurrentSpan :: (Effectful m, Member (Reader Span) effects) => Span -> m effects a -> m effects a
withCurrentSpan :: (Member (Reader Span) sig, Carrier sig m) => Span -> m a -> m a
withCurrentSpan = local . const
modifyChildSpan :: (Effectful m, Member (State Span) effects) => Span -> m effects a -> m effects a
modifyChildSpan span m = raiseEff (lowerEff m >>= (\a -> modify' (const span) >> pure a))
modifyChildSpan :: (Member (State Span) sig, Carrier sig m, Monad m) => Span -> m a -> m a
modifyChildSpan span m = m <* put span
-- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'.
withCurrentSrcLoc :: (Effectful m, Member (Reader ModuleInfo) effects, Member (Reader Span) effects) => SrcLoc -> m effects a -> m effects a
withCurrentSrcLoc :: (Member (Reader ModuleInfo) sig, Member (Reader Span) sig, Carrier sig m) => SrcLoc -> m a -> m a
withCurrentSrcLoc loc = withCurrentModule (moduleInfoFromSrcLoc loc) . withCurrentSpan (spanFromSrcLoc loc)
-- | Run an action with locally replaced 'ModuleInfo' & 'Span' derived from the Haskell call stack.
--
-- This is suitable for contextualizing builtins & other functionality intended for use from client code but defined in Haskell source.
withCurrentCallStack :: (Effectful m, Member (Reader ModuleInfo) effects, Member (Reader Span) effects) => CallStack -> m effects a -> m effects a
withCurrentCallStack :: (Member (Reader ModuleInfo) sig, Member (Reader Span) sig, Carrier sig m) => CallStack -> m a -> m a
withCurrentCallStack = maybe id (withCurrentSrcLoc . snd) . listToMaybe . getCallStack

214
src/Control/Abstract/Environment.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Environment
( Environment
, Exports
@ -19,6 +19,7 @@ module Control.Abstract.Environment
-- * Effects
, Env(..)
, runEnv
, EnvC(..)
, freeVariableError
, runEnvironmentError
, runEnvironmentErrorWith
@ -27,6 +28,8 @@ module Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Control.Abstract.ScopeGraph (Declaration(..))
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.BaseError
import Data.Abstract.Environment (Bindings, Environment, EvalContext(..), EnvironmentError(..))
import qualified Data.Abstract.Environment as Env
@ -37,22 +40,22 @@ import Data.Span
import Prologue
-- | Retrieve the current execution context
getEvalContext :: Member (Env address) effects => Evaluator address value effects (EvalContext address)
getEvalContext = send GetCtx
getEvalContext :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (EvalContext address)
getEvalContext = send (GetCtx ret)
-- | Retrieve the current environment
getEnv :: Member (Env address) effects
=> Evaluator address value effects (Environment address)
getEnv :: (Member (Env address) sig, Carrier sig m)
=> Evaluator term address value m (Environment address)
getEnv = ctxEnvironment <$> getEvalContext
-- | Replace the execution context. This is only for use in Analysis.Abstract.Caching.
putEvalContext :: Member (Env address) effects => EvalContext address -> Evaluator address value effects ()
putEvalContext = send . PutCtx
putEvalContext :: (Member (Env address) sig, Carrier sig m) => EvalContext address -> Evaluator term address value m ()
putEvalContext context = send (PutCtx context (ret ()))
withEvalContext :: Member (Env address) effects
withEvalContext :: (Member (Env address) sig, Carrier sig m)
=> EvalContext address
-> Evaluator address value effects a
-> Evaluator address value effects a
-> Evaluator term address value m a
-> Evaluator term address value m a
withEvalContext ctx comp = do
oldCtx <- getEvalContext
putEvalContext ctx
@ -61,103 +64,118 @@ withEvalContext ctx comp = do
pure value
-- | Add an export to the global export state.
export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects ()
export name alias addr = send (Export name alias addr)
export :: (Member (Env address) sig, Carrier sig m) => Name -> Name -> Maybe address -> Evaluator term address value m ()
export name alias addr = send (Export name alias addr (ret ()))
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address)
lookupEnv name = send (Lookup name)
lookupEnv :: (Member (Env address) sig, Carrier sig m) => Name -> Evaluator term address value m (Maybe address)
lookupEnv name = send (Lookup name ret)
-- | Bind a 'Name' to an address in the current scope.
bind :: Member (Env address) effects => Name -> address -> Evaluator address value effects ()
bind name addr = send (Bind name addr)
bind :: (Member (Env address) sig, Carrier sig m) => Name -> address -> Evaluator term address value m ()
bind name addr = send (Bind name addr (ret ()))
-- | Bind all of the names from an 'Environment' in the current scope.
bindAll :: Member (Env address) effects => Bindings address -> Evaluator address value effects ()
bindAll :: (Member (Env address) sig, Carrier sig m) => Bindings address -> Evaluator term address value m ()
bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.pairs
-- | Run an action in a new local scope.
locally :: forall address value effects a . Member (Env address) effects => Evaluator address value effects a -> Evaluator address value effects a
locally = send . Locally @_ @_ @address . lowerEff
locally :: forall term address value sig m a . (Member (Env address) sig, Carrier sig m) => Evaluator term address value m a -> Evaluator term address value m a
locally m = send (Locally @address m ret)
close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address)
close = send . Close
close :: (Member (Env address) sig, Carrier sig m) => Set Name -> Evaluator term address value m (Environment address)
close fvs = send (Close fvs ret)
self :: Member (Env address) effects => Evaluator address value effects (Maybe address)
self :: (Member (Env address) sig, Carrier sig m) => Evaluator term address value m (Maybe address)
self = ctxSelf <$> getEvalContext
-- -- | Look up or allocate an address for a 'Name'.
-- lookupOrAlloc :: ( Member (Allocator address) effects
-- , Member (Env address) effects
<<<<<<< HEAD
-- | Look up or allocate an address for a 'Name'.
-- lookupOrAlloc :: ( Member (Allocator address) sig
-- , Member (Env address) sig
-- , Carrier sig m
-- )
-- => Name
-- -> Evaluator address value effects address
-- -> Evaluator term address value m address
-- lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
-- letrec :: ( Member (Allocator address) effects
-- , Member (Deref value) effects
-- , Member (Env address) effects
-- , Member (State (Heap address address value)) effects
--
-- letrec :: ( Member (Allocator address) sig
-- , Member (Deref value) sig
-- , Member (Env address) sig
-- , Member (State (Heap address value)) sig
-- , Ord address
-- , Carrier sig m
-- )
-- => Declaration
-- -> Evaluator address value effects value
-- -> Evaluator address value effects (value, address)
-- letrec declaration body = do
-- addr <- lookupOrAlloc (name declaration)
-- v <- locally (bind (name declaration) addr *> body)
-- assign addr declaration v
-- => Name
-- -> Evaluator term address value m value
-- -> Evaluator term address value m (value, address)
-- letrec name body = do
-- addr <- lookupOrAlloc name
-- v <- locally (bind name addr *> body)
-- assign addr v
-- pure (v, addr)
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
-- letrec' :: ( Member (Allocator address) effects
-- , Member (Env address) effects
-- letrec' :: ( Member (Allocator address) sig
-- , Member (Env address) sig
-- , Carrier sig m
-- )
-- => Name
-- -> (address -> Evaluator address value effects a)
-- -> Evaluator address value effects a
-- -> (address -> Evaluator term address value m a)
-- -> Evaluator term address value m a
-- letrec' name body = do
-- addr <- lookupOrAlloc name
-- v <- locally (body addr)
-- v <$ bind name addr
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
variable :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
variable :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
)
=> Name
-> Evaluator address value effects (Address address)
-> Evaluator term address value m (Address address)
variable name = undefined -- lookupEnv name >>= maybeM (freeVariableError name)
-- Effects
data Env address m return where
Lookup :: Name -> Env address m (Maybe address)
Bind :: Name -> address -> Env address m ()
Close :: Set Name -> Env address m (Environment address)
Locally :: m a -> Env address m a
GetCtx :: Env address m (EvalContext address)
PutCtx :: EvalContext address -> Env address m ()
Export :: Name -> Name -> Maybe address -> Env address m ()
data Env address m k
= Lookup Name (Maybe address -> k)
| Bind Name address k
| Close (Set Name) (Environment address -> k)
| forall a . Locally (m a) (a -> k)
| GetCtx (EvalContext address -> k)
| PutCtx (EvalContext address) k
| Export Name Name (Maybe address) k
deriving instance Functor (Env address m)
instance HFunctor (Env address) where
hmap _ (Lookup name k) = Lookup name k
hmap _ (Bind name addr k) = Bind name addr k
hmap _ (Close names k) = Close names k
hmap f (Locally m k) = Locally (f m) k
hmap _ (GetCtx k) = GetCtx k
hmap _ (PutCtx ctx k) = PutCtx ctx k
hmap _ (Export name alias addr k) = Export name alias addr k
instance PureEffect (Env address)
instance Effect (Env address) where
handleState c dist (Request (Lookup name) k) = Request (Lookup name) (dist . (<$ c) . k)
handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (dist . (<$ c) . k)
handleState c dist (Request (Close names) k) = Request (Close names) (dist . (<$ c) . k)
handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c))) (dist . fmap k)
handleState c dist (Request GetCtx k) = Request GetCtx (dist . (<$ c) . k)
handleState c dist (Request (PutCtx e) k) = Request (PutCtx e) (dist . (<$ c) . k)
handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . k)
handle state handler (Lookup name k) = Lookup name (handler . (<$ state) . k)
handle state handler (Bind name addr k) = Bind name addr (handler . (<$ state) $ k)
handle state handler (Close names k) = Close names (handler . (<$ state) . k)
handle state handler (Locally action k) = Locally (handler (action <$ state)) (handler . fmap k)
handle state handler (GetCtx k) = GetCtx (handler . (<$ state) . k)
handle state handler (PutCtx e k) = PutCtx e (handler . (<$ state) $ k)
handle state handler (Export name alias addr k) = Export name alias addr (handler . (<$ state) $ k)
-- | Runs a computation in the context of an existing environment.
-- New bindings created in the computation are returned.
runEnv :: Effects effects
runEnv :: (Carrier sig m, Effect sig)
=> EvalContext address
-> Evaluator address value (Env address ': effects) a
-> Evaluator address value effects (Bindings address, a)
runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState initial . reinterpret2 handleEnv
-> Evaluator term address value (EnvC address (Eff m)) a
-> Evaluator term address value m (Bindings address, a)
runEnv initial = raiseHandler $ fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . runState lowerBound . runState initial . runEnvC . interpret
where -- TODO: If the set of exports is empty because no exports have been
-- defined, do we export all terms, or no terms? This behavior varies across
-- languages. We need better semantics rather than doing it ad-hoc.
@ -165,44 +183,48 @@ runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . r
| Exports.null ports = (binds, a)
| otherwise = (Exports.toBindings ports <> Env.aliasBindings (Exports.aliases ports) binds, a)
handleEnv :: forall address value effects a . Effects effects
=> Env address (Eff (Env address ': effects)) a
-> Evaluator address value (State (EvalContext address) ': State (Exports address) ': effects) a
handleEnv = \case
Lookup name -> Env.lookupEnv' name . ctxEnvironment <$> get
Bind name addr -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment))
Close names -> Env.intersect names . ctxEnvironment <$> get
Locally action -> do
modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment))
a <- reinterpret2 handleEnv (raiseEff action)
a <$ modify' (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment))
GetCtx -> get
PutCtx e -> put e
Export name alias addr -> modify (Exports.insert name alias addr)
newtype EnvC address m a = EnvC { runEnvC :: Eff (StateC (EvalContext address) (Eff (StateC (Exports address) m))) a }
freeVariableError :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
instance (Carrier sig m, Effect sig) => Carrier (Env address :+: sig) (EnvC address m) where
ret = EnvC . ret
eff = EnvC . handleSum (eff . R . R . handleCoercible) (\case
Lookup name k -> gets (Env.lookupEnv' name . ctxEnvironment) >>= runEnvC . k
Bind name addr k -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment)) >> runEnvC k
Close names k -> gets (Env.intersect names . ctxEnvironment) >>= runEnvC . k
Locally action k -> do
modify (\EvalContext{..} -> EvalContext ctxSelf (Env.push @address ctxEnvironment))
a <- runEnvC action
modify (\EvalContext{..} -> EvalContext ctxSelf (Env.pop @address ctxEnvironment))
runEnvC (k a)
GetCtx k -> get >>= runEnvC . k
PutCtx e k -> put e >> runEnvC k
Export name alias addr k -> modify (Exports.insert name alias addr) >> runEnvC k)
freeVariableError :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (EnvironmentError address))) sig
, Carrier sig m
)
=> Name
-> Evaluator address value effects address
-> Evaluator term address value m address
freeVariableError = throwEnvironmentError . FreeVariable
runEnvironmentError :: (Effectful (m address value), Effects effects)
=> m address value (Resumable (BaseError (EnvironmentError address)) ': effects) a
-> m address value effects (Either (SomeExc (BaseError (EnvironmentError address))) a)
runEnvironmentError = runResumable
runEnvironmentError :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ResumableC (BaseError (EnvironmentError address)) (Eff m)) a
-> Evaluator term address value m (Either (SomeError (BaseError (EnvironmentError address))) a)
runEnvironmentError = raiseHandler runResumable
runEnvironmentErrorWith :: (Effectful (m address value), Effects effects)
=> (forall resume . BaseError (EnvironmentError address) resume -> m address value effects resume)
-> m address value (Resumable (BaseError (EnvironmentError address)) ': effects) a
-> m address value effects a
runEnvironmentErrorWith = runResumableWith
runEnvironmentErrorWith :: Carrier sig m
=> (forall resume . BaseError (EnvironmentError address) resume -> Evaluator term address value m resume)
-> Evaluator term address value (ResumableWithC (BaseError (EnvironmentError address)) (Eff m)) a
-> Evaluator term address value m a
runEnvironmentErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwEnvironmentError :: ( Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
throwEnvironmentError :: ( Member (Resumable (BaseError (EnvironmentError address))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
)
=> EnvironmentError address resume
-> Evaluator address value effects resume
-> Evaluator term address value m resume
throwEnvironmentError = throwBaseError

92
src/Control/Abstract/Evaluator.hs
View File

@ -1,6 +1,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Evaluator
( Evaluator(..)
, raiseHandler
, Open
-- * Effects
, Return(..)
, earlyReturn
@ -9,33 +11,50 @@ module Control.Abstract.Evaluator
, LoopControl(..)
, throwBreak
, throwContinue
, throwAbort
, catchLoopControl
, runLoopControl
, module X
) where
import Control.Monad.Effect as X
import Control.Monad.Effect.Fresh as X
import Control.Monad.Effect.Exception as X
import qualified Control.Monad.Effect.Internal as Eff
import Control.Monad.Effect.NonDet as X
import Control.Monad.Effect.Reader as X
import Control.Monad.Effect.Resumable as X
import Control.Monad.Effect.State as X
import Control.Monad.Effect.Trace as X
import Control.Effect as X
import Control.Effect.Carrier
import Control.Effect.Error as X
import Control.Effect.Fresh as X
import Control.Effect.NonDet as X
import Control.Effect.Reader as X
import Control.Effect.Resumable as X
import Control.Effect.State as X
import Control.Effect.Trace as X
import Control.Monad.IO.Class
import Prologue hiding (MonadError(..))
import Data.Coerce
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types.
--
-- These parameters enable us to constrain the types of effects using them s.t. we can avoid both ambiguous types when they aren’t mentioned outside of the context, and lengthy, redundant annotations on the use sites of functions employing these effects.
--
-- These effects will typically include the environment, heap, module table, etc. effects necessary for evaluation of modules and terms, but may also include any other effects so long as they’re eventually handled.
newtype Evaluator address value effects a = Evaluator { runEvaluator :: Eff effects a }
deriving (Applicative, Effectful, Functor, Monad)
newtype Evaluator term address value m a = Evaluator { runEvaluator :: Eff m a }
deriving (Applicative, Functor, Monad)
deriving instance (Member NonDet sig, Carrier sig m) => Alternative (Evaluator term address value m)
deriving instance (Member (Lift IO) sig, Carrier sig m) => MonadIO (Evaluator term address value m)
instance Carrier sig m => Carrier sig (Evaluator term address value m) where
ret = Evaluator . ret
eff = Evaluator . eff . handlePure runEvaluator
-- | Raise a handler on 'Eff's into a handler on 'Evaluator's.
raiseHandler :: (Eff m a -> Eff n b)
-> Evaluator term address value m a
-> Evaluator term address value n b
raiseHandler = coerce
-- | An open-recursive function.
type Open a = a -> a
deriving instance Member NonDet effects => Alternative (Evaluator address value effects)
deriving instance Member (Lift IO) effects => MonadIO (Evaluator address value effects)
-- Effects
@ -43,36 +62,53 @@ deriving instance Member (Lift IO) effects => MonadIO (Evaluator address value e
newtype Return value = Return { unReturn :: value }
deriving (Eq, Ord, Show)
earlyReturn :: Member (Exc (Return value)) effects
earlyReturn :: ( Member (Error (Return value)) sig
, Carrier sig m
)
=> value
-> Evaluator address value effects value
-> Evaluator term address value m value
earlyReturn = throwError . Return
catchReturn :: (Member (Exc (Return value)) effects, Effectful (m address value)) => m address value effects value -> m address value effects value
catchReturn = Eff.raiseHandler (handleError (\ (Return addr) -> pure addr))
catchReturn :: (Member (Error (Return value)) sig, Carrier sig m) => Evaluator term address value m value -> Evaluator term address value m value
catchReturn = flip catchError (\ (Return value) -> pure value)
runReturn :: (Effectful (m address value), Effects effects) => m address value (Exc (Return value) ': effects) value -> m address value effects value
runReturn = Eff.raiseHandler (fmap (either unReturn id) . runError)
runReturn :: (Carrier sig m, Effect sig) => Evaluator term address value (ErrorC (Return value) (Eff m)) value -> Evaluator term address value m value
runReturn = raiseHandler $ fmap (either unReturn id) . runError
-- | Effects for control flow around loops (breaking and continuing).
data LoopControl value
= Break { unLoopControl :: value }
| Continue { unLoopControl :: value }
| Abort
deriving (Eq, Ord, Show)
throwBreak :: Member (Exc (LoopControl value)) effects
throwBreak :: (Member (Error (LoopControl value)) sig, Carrier sig m)
=> value
-> Evaluator address value effects value
-> Evaluator term address value m value
throwBreak = throwError . Break
throwContinue :: Member (Exc (LoopControl value)) effects
throwContinue :: (Member (Error (LoopControl value)) sig, Carrier sig m)
=> value
-> Evaluator address value effects value
-> Evaluator term address value m value
throwContinue = throwError . Continue
catchLoopControl :: (Member (Exc (LoopControl value)) effects, Effectful (m address value)) => m address value effects a -> (LoopControl value -> m address value effects a) -> m address value effects a
throwAbort :: forall term address sig m value a .
( Member (Error (LoopControl value)) sig
, Carrier sig m)
=> Evaluator term address value m a
throwAbort = throwError (Abort @address)
catchLoopControl :: (
Member (Error (LoopControl address)) sig
, Carrier sig m
)
=> Evaluator term address value m a
-> (LoopControl address -> Evaluator term address value m a)
-> Evaluator term address value m a
catchLoopControl = catchError
runLoopControl :: (Effectful (m address value), Effects effects) => m address value (Exc (LoopControl value) ': effects) value -> m address value effects value
runLoopControl = Eff.raiseHandler (fmap (either unLoopControl id) . runError)
runLoopControl :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ErrorC (LoopControl address) (Eff m)) value
-> Evaluator term address value m value
runLoopControl = raiseHandler $ fmap (either unLoopControl id) . runError

290
src/Control/Abstract/Heap.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances, ScopedTypeVariables #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances, ScopedTypeVariables #-}
module Control.Abstract.Heap
( Heap
, HeapError(..)
@ -22,7 +22,12 @@ module Control.Abstract.Heap
-- * Garbage collection
, gc
-- * Effects
, Allocator(..)
, runAllocator
, AllocatorC(..)
, Deref(..)
, runDeref
, DerefC(..)
, AddressError(..)
, runHeapError
, runAddressError
@ -33,7 +38,8 @@ module Control.Abstract.Heap
import Control.Abstract.Context (withCurrentCallStack)
import Control.Abstract.Evaluator
import Control.Abstract.Roots
import Data.Abstract.Configuration
import Control.Applicative (Alternative)
import Control.Effect.Carrier
import Data.Abstract.BaseError
import qualified Data.Abstract.Heap as Heap
import Data.Abstract.ScopeGraph (Path(..))
@ -48,62 +54,76 @@ import qualified Data.Map.Strict as Map
import Prologue
-- | Evaluates an action locally the scope and frame of the given frame address.
withScopeAndFrame :: forall address value effects m a. (
Effectful (m address value)
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (State (Heap address address value)) effects
, Member (State (ScopeGraph address)) effects
withScopeAndFrame :: forall address value m a sig. (
, Ord address
-- , Effectful (m address value) -- Don't think we need Effectful now.
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Member (State (Heap address address value)) sig
, Member (State (ScopeGraph address)) sig
, Carrier sig m
)
=> address
-> m address value effects a
-> m address value effects a
-> m address value m a -- Not sure about this one.
-> m address value m a
withScopeAndFrame address action = raiseEff $ do
scope <- lowerEff (scopeLookup @address @value address)
lowerEff $ withScope scope (withFrame address action)
scopeLookup :: forall address value effects. (Ord address, Member (Reader ModuleInfo) effects, Member (Reader Span) effects, Member (Resumable (BaseError (HeapError address))) effects, Member (State (Heap address address value)) effects, Member (State (ScopeGraph address)) effects) => address -> Evaluator address value effects address
scopeLookup :: forall address value sig m term. (
Ord address
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (State (Heap address address value)) sig
, Member (State (ScopeGraph address)) sig
, Carrier sig m
)
=> address
-> Evaluator term address value m address
scopeLookup address = maybeM (throwHeapError (LookupError address)) =<< Heap.scopeLookup address <$> get @(Heap address address value)
-- | Retrieve the heap.
getHeap :: Member (State (Heap address address value)) effects => Evaluator address value effects (Heap address address value)
getHeap :: (Member (State (Heap address address value)) sig, Carrier sig m) => Evaluator term address value m (Heap address address value)
getHeap = get
-- | Set the heap.
putHeap :: Member (State (Heap address address value)) effects => Heap address address value -> Evaluator address value effects ()
putHeap :: (Member (State (Heap address address value)) sig, Carrier sig m) => Heap address address value -> Evaluator term address value m ()
putHeap = put
-- | Update the heap.
modifyHeap :: Member (State (Heap address address value)) effects => (Heap address address value -> Heap address address value) -> Evaluator address value effects ()
modifyHeap = modify'
modifyHeap :: (Member (State (Heap address address value)) sig, Carrier sig m) => (Heap address address value -> Heap address address value) -> Evaluator term address value m ()
modifyHeap = modify
currentFrame :: forall address value effects. ( Member (State (Heap address address value)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (HeapError address))) effects
-- | Retrieve the heap.
currentFrame :: forall address value sig term m. (
Member (State (Heap address address value)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Carrier sig m
)
=> Evaluator address value effects address
=> Evaluator term address value m address
currentFrame = maybeM (throwHeapError EmptyHeapError) =<< (Heap.currentFrame <$> get @(Heap address address value))
putCurrentFrame :: forall address value effects. ( Member (State (Heap address address value)) effects ) => address -> Evaluator address value effects ()
putCurrentFrame :: forall address value sig m term. ( Member (State (Heap address address value)) sig, Carrier sig m ) => address -> Evaluator term address value m ()
putCurrentFrame address = modify @(Heap address address value) (\heap -> heap { Heap.currentFrame = Just address })
-- | Inserts a new frame into the heap with the given scope and links.
newFrame :: forall address value effects. (
Member (State (Heap address address value)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
newFrame :: forall address value sig m term. (
Member (State (Heap address address value)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Ord address
, Member (Allocator address) effects
, Member (State (ScopeGraph address)) effects
, Member Fresh effects
, Member (Allocator address) sig
, Member (State (ScopeGraph address)) sig
, Member Fresh sig
, Carrier sig m
)
=> address
-> Map EdgeLabel (Map address address)
-> Evaluator address value effects address
-> Evaluator term address value m address
newFrame scope links = do
name <- gensym
address <- alloc name
@ -112,14 +132,16 @@ newFrame scope links = do
-- | Evaluates the action within the frame of the given frame address.
withFrame :: forall address effects m value a. (
Member (Resumable (BaseError (HeapError address))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
Member (Resumable (BaseError (HeapError address))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Effectful (m address value)
, Member (State (Heap address address value)) effects)
, Member (State (Heap address address value)) sig
, Carrier sig m
)
=> address
-> m address value effects a
-> m address value effects a
-> m address value sig a -- Not sure about this `sig` here (substituting `sig` for `effects`)
-> m address value sig a
withFrame address action = raiseEff $ do
prevFrame <- (lowerEff (currentFrame @address @value))
modify @(Heap address address value) (\h -> h { Heap.currentFrame = Just address })
@ -143,17 +165,18 @@ withFrame address action = raiseEff $ do
-- | Define a declaration and assign the value of an action in the current frame.
define :: ( HasCallStack
, Member (Deref value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address address value)) effects
, Member (State (ScopeGraph address)) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (Deref value) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (State (Heap address address value)) sig
, Member (State (ScopeGraph address)) sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Ord address
, Carrier sig m
)
=> Declaration
-> Evaluator address value effects value
-> Evaluator address value effects value
-> Evaluator term address value m value
-> Evaluator term address value m value
define declaration def = withCurrentCallStack callStack $ do
span <- ask @Span -- TODO: This Span is most definitely wrong
addr <- declare declaration span Nothing
@ -161,20 +184,21 @@ define declaration def = withCurrentCallStack callStack $ do
value <$ assign addr value -- TODO: Stop passing in an Address of scopes.
-- | Associate an empty child scope with a declaration and then locally evaluate the body within an associated frame.
withChildFrame :: ( Member (Allocator address) effects
, Member (State (Heap address address value)) effects
, Member (State (ScopeGraph address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (Deref value) effects
withChildFrame :: ( Member (Allocator address) sig
, Member (State (Heap address address value)) sig
, Member (State (ScopeGraph address)) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Member (Deref value) sig
, Ord address
, Carrier sig m
)
=> Declaration
-> (address -> Evaluator address value effects a)
-> Evaluator address value effects a
-> (address -> Evaluator term address value m a)
-> Evaluator term address value m a
withChildFrame declaration body = do
scope <- newScope mempty
putDeclarationScope declaration scope
@ -182,45 +206,47 @@ withChildFrame declaration body = do
withScopeAndFrame frame (body frame)
-- | Dereference the given address in the heap, or fail if the address is uninitialized.
deref :: ( Member (Deref value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address address value)) effects
deref :: ( Member (Deref value) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (State (Heap address address value)) sig
, Ord address
, Carrier sig m
)
=> Address address
-> Evaluator address value effects value
-> Evaluator address value m value
-- TODO: THIS IS WRONG we need to call Heap.lookup
deref addr@Address{..} = gets (Heap.getSlot addr) >>= maybeM (throwAddressError (UnallocatedAddress address)) >>= send . DerefCell >>= maybeM (throwAddressError (UninitializedAddress address))
deref addr@Address{..} = gets (Heap.getSlot addr) >>= maybeM (throwAddressError (UnallocatedAddress address)) >>= send . flip DerefCell ret >>= maybeM (throwAddressError (UninitializedAddress address))
lookupDeclaration :: ( Member (State (Heap address address value)) effects
, Member (State (ScopeGraph address)) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member
(Resumable (BaseError (HeapError address))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
lookupDeclaration :: ( Member (State (Heap address address value)) sig
, Member (State (ScopeGraph address)) sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Ord address
, Carrier sig m
)
=> Declaration
-> Evaluator address value effects (Address address)
-> Evaluator term address value m (Address address)
lookupDeclaration decl = do
path <- lookupScopePath decl
frameAddress <- lookupFrameAddress path
pure (Address frameAddress (Heap.pathPosition path))
-- | Follow a path through the heap and return the frame address associated with the declaration.
lookupFrameAddress :: ( Member (State (Heap address address value)) effects
, Member (State (ScopeGraph address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (HeapError address))) effects
lookupFrameAddress :: ( Member (State (Heap address address value)) sig
, Member (State (ScopeGraph address)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Ord address
, Carrier sig m
)
=> Path address
-> Evaluator address value effects address
-> Evaluator term address value m address
lookupFrameAddress path = do
frameAddress <- currentFrame
go path frameAddress
@ -234,14 +260,16 @@ lookupFrameAddress path = do
Map.lookup nextScopeAddress scopeMap
maybe (throwHeapError $ LookupPathError path') (go path') frameAddress
frameLinks :: forall address value effects. ( Member (State (Heap address address value)) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
frameLinks :: forall address value sig m term. (
Member (State (Heap address address value)) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Ord address
, Carrier sig m
)
=> address
-> Evaluator address value effects (Map EdgeLabel (Map address address)) -- TODO: Change this to Map scope address
-> Evaluator term address value m (Map EdgeLabel (Map address address)) -- TODO: Change this to Map scope address
frameLinks address = maybeM (throwHeapError $ LookupLinksError address) . Heap.frameLinks address =<< get @(Heap address address value)
@ -254,28 +282,30 @@ frameLinks address = maybeM (throwHeapError $ LookupLinksError address) . Heap.f
-- | Write a value to the given frame address in the 'Heap'.
assign :: ( Member (Deref value) effects
, Member (State (Heap address address value)) effects
assign :: ( Member (Deref value) sig
, Member (State (Heap address address value)) sig
, Ord address
, Carrier sig m
)
=> Address address
-> value
-> Evaluator address value effects ()
-> Evaluator term address value m ()
assign addr value = do
heap <- getHeap
cell <- send (AssignCell value (fromMaybe lowerBound (Heap.getSlot addr heap)))
cell <- send (AssignCell value (fromMaybe lowerBound (Heap.getSlot addr heap)) ret)
putHeap (Heap.setSlot addr cell heap)
-- Garbage collection
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
gc :: ( Member (State (Heap address address value)) effects
gc :: ( Member (State (Heap address address value)) sig
, Ord address
, ValueRoots address value
, Carrier sig m
)
=> Live address -- ^ The set of addresses to consider rooted.
-> Evaluator address value effects ()
-> Evaluator term address value m ()
gc roots =
-- TODO: Implement frame garbage collection
undefined
@ -297,15 +327,48 @@ reachable roots heap = go mempty roots
-- Effects
data Deref value (m :: * -> *) return where
DerefCell :: Set value -> Deref value m (Maybe value)
AssignCell :: value -> Set value -> Deref value m (Set value)
instance PureEffect (Deref value)
data Allocator address (m :: * -> *) k
= Alloc Name (address -> k)
deriving (Functor)
instance HFunctor (Allocator address) where
hmap _ (Alloc name k) = Alloc name k
instance Effect (Allocator address) where
handle state handler (Alloc name k) = Alloc name (handler . (<$ state) . k)
runAllocator :: Carrier (Allocator address :+: sig) (AllocatorC address (Eff m))
=> Evaluator term address value (AllocatorC address (Eff m)) a
-> Evaluator term address value m a
runAllocator = raiseHandler $ runAllocatorC . interpret
newtype AllocatorC address m a = AllocatorC { runAllocatorC :: m a }
deriving (Alternative, Applicative, Functor, Monad)
data Deref value (m :: * -> *) k
= DerefCell (Set value) (Maybe value -> k)
| AssignCell value (Set value) (Set value -> k)
deriving (Functor)
instance HFunctor (Deref value) where
hmap _ (DerefCell cell k) = DerefCell cell k
hmap _ (AssignCell value cell k) = AssignCell value cell k
instance Effect (Deref value) where
handleState c dist (Request (DerefCell cell) k) = Request (DerefCell cell) (dist . (<$ c) . k)
handleState c dist (Request (AssignCell value cell) k) = Request (AssignCell value cell) (dist . (<$ c) . k)
handle state handler (DerefCell cell k) = DerefCell cell (handler . (<$ state) . k)
handle state handler (AssignCell value cell k) = AssignCell value cell (handler . (<$ state) . k)
runDeref :: Carrier (Deref value :+: sig) (DerefC address value (Eff m))
=> Evaluator term address value (DerefC address value (Eff m)) a
-> Evaluator term address value m a
runDeref = raiseHandler $ runDerefC . interpret
newtype DerefC address value m a = DerefC { runDerefC :: m a }
deriving (Alternative, Applicative, Functor, Monad)
data HeapError address resume where
EmptyHeapError :: HeapError address address
@ -347,6 +410,14 @@ data AddressError address value resume where
UnallocatedAddress :: address -> AddressError address value (Set value)
UninitializedAddress :: address -> AddressError address value value
instance (NFData address) => NFData1 (AddressError address value) where
liftRnf _ x = case x of
UnallocatedAddress a -> rnf a
UninitializedAddress a -> rnf a
instance (NFData address, NFData resume) => NFData (AddressError address value resume) where
rnf = liftRnf rnf
deriving instance Eq address => Eq (AddressError address value resume)
deriving instance Show address => Show (AddressError address value resume)
instance Show address => Show1 (AddressError address value) where
@ -356,23 +427,22 @@ instance Eq address => Eq1 (AddressError address value) where
liftEq _ (UnallocatedAddress a) (UnallocatedAddress b) = a == b
liftEq _ _ _ = False
throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
)
=> AddressError address body resume
-> Evaluator address value effects resume
-> Evaluator term address value m resume
throwAddressError = throwBaseError
runAddressError :: ( Effectful (m address value)
, Effects effects
)
=> m address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> m address value effects (Either (SomeExc (BaseError (AddressError address value))) a)
runAddressError = runResumable
runAddressError :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ResumableC (BaseError (AddressError address value)) (Eff m)) a
-> Evaluator term address value m (Either (SomeError (BaseError (AddressError address value))) a)
runAddressError = raiseHandler runResumable
runAddressErrorWith :: (Effectful (m address value), Effects effects)
=> (forall resume . (BaseError (AddressError address value)) resume -> m address value effects resume)
-> m address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> m address value effects a
runAddressErrorWith = runResumableWith
runAddressErrorWith :: Carrier sig m
=> (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume)
-> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff m)) a
-> Evaluator term address value m a
runAddressErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)

143
src/Control/Abstract/Modules.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE GADTs, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Control.Abstract.Modules
( ModuleResult
, lookupModule
@ -20,10 +20,13 @@ module Control.Abstract.Modules
) where
import Control.Abstract.Evaluator
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Environment
import Data.Abstract.BaseError
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Coerce
import Data.Language
import Data.Semigroup.Foldable (foldMap1)
import qualified Data.Set as Set
@ -35,60 +38,78 @@ import Data.Abstract.ScopeGraph
type ModuleResult address value = (ScopeGraph address, value)
-- | Retrieve an evaluated module, if any. @Nothing@ means we’ve never tried to load it, and @Just (env, value)@ indicates the result of a completed load.
lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (ModuleResult address value))
lookupModule = sendModules . Lookup
lookupModule :: (Member (Modules address value) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address value))
lookupModule = sendModules . flip Lookup ret
-- | Resolve a list of module paths to a possible module table entry.
resolve :: Member (Modules address value) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath)
resolve = sendModules . Resolve
resolve :: (Member (Modules address value) sig, Carrier sig m) => [FilePath] -> Evaluator term address value m (Maybe ModulePath)
resolve = sendModules . flip Resolve ret
listModulesInDir :: Member (Modules address value) effects => FilePath -> Evaluator address value effects [ModulePath]
listModulesInDir = sendModules . List
listModulesInDir :: (Member (Modules address value) sig, Carrier sig m) => FilePath -> Evaluator term address value m [ModulePath]
listModulesInDir = sendModules . flip List ret
-- | Require/import another module by name and return its environment and value.
--
-- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (ModuleResult address value)
require :: (Member (Modules address value) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address value)
require path = lookupModule path >>= maybeM (load path)
-- | Load another module by name and return its environment and value.
--
-- Always loads/evaluates.
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (ModuleResult address value)
load path = sendModules (Load path)
load :: (Member (Modules address value) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address value)
load path = sendModules (Load path ret)
data Modules address value (m :: * -> *) return where
Load :: ModulePath -> Modules address value m (ModuleResult address value)
Lookup :: ModulePath -> Modules address value m (Maybe (ModuleResult address value))
Resolve :: [FilePath] -> Modules address value m (Maybe ModulePath)
List :: FilePath -> Modules address value m [ModulePath]
data Modules address value (m :: * -> *) k
= Load ModulePath (ModuleResult address value -> k)
| Lookup ModulePath (Maybe (ModuleResult address value) -> k)
| Resolve [FilePath] (Maybe ModulePath -> k)
| List FilePath ([ModulePath] -> k)
deriving (Functor)
instance HFunctor (Modules address value) where
hmap _ = coerce
instance PureEffect (Modules address value)
instance Effect (Modules address value) where
handleState c dist (Request (Load path) k) = Request (Load path) (dist . (<$ c) . k)
handleState c dist (Request (Lookup path) k) = Request (Lookup path) (dist . (<$ c) . k)
handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (dist . (<$ c) . k)
handleState c dist (Request (List path) k) = Request (List path) (dist . (<$ c) . k)
handle state handler (Load path k) = Load path (handler . (<$ state) . k)
handle state handler (Lookup path k) = Lookup path (handler . (<$ state) . k)
handle state handler (Resolve paths k) = Resolve paths (handler . (<$ state) . k)
handle state handler (List path k) = List path (handler . (<$ state) . k)
sendModules :: Member (Modules address value) effects => Modules address value (Eff effects) return -> Evaluator address value effects return
sendModules :: ( Member (Modules address) sig
, Carrier sig m)
=> Modules address (Evaluator term address value m) (Evaluator term address value m return)
-> Evaluator term address value m return
sendModules = send
runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address value))))) effects
, Member (Resumable (BaseError (LoadError address value))) effects
, PureEffects effects
runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address value))))) sig
, Member (Resumable (BaseError (LoadError address))) sig
, Carrier sig m
)
=> Set ModulePath
-> Evaluator address value (Modules address value ': effects) a
-> Evaluator address value effects a
runModules paths = interpret $ \case
Load name -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name <$> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name))
Lookup path -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path <$> askModuleTable
Resolve names -> pure (find (`Set.member` paths) names)
List dir -> pure (filter ((dir ==) . takeDirectory) (toList paths))
-> Evaluator term address value (ModulesC address (Eff m)) a
-> Evaluator term address value m a
runModules paths = raiseHandler $ flip runModulesC paths . interpret
askModuleTable :: Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address value))))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module (ModuleResult address value))))
newtype ModulesC address m a = ModulesC { runModulesC :: Set ModulePath -> m a }
instance ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address value))))) sig
, Member (Resumable (BaseError (LoadError address))) sig
, Carrier sig m
, Monad m
)
=> Carrier (Modules address :+: sig) (ModulesC address m) where
ret = ModulesC . const . ret
eff op = ModulesC (\ paths -> handleSum (eff . handleReader paths runModulesC) (\case
Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k
Lookup path k -> askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path
Resolve names k -> runModulesC (k (find (`Set.member` paths) names)) paths
List dir k -> runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths) op)
askModuleTable :: (Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address value))))) sig, Carrier sig m) => m (ModuleTable (NonEmpty (Module (ModuleResult address value))))
askModuleTable = ask
@ -110,20 +131,23 @@ instance Show1 (LoadError address value) where
instance Eq1 (LoadError address value) where
liftEq _ (ModuleNotFoundError a) (ModuleNotFoundError b) = a == b
runLoadError :: (Effectful (m address value), Effects effects)
=> m address value (Resumable (BaseError (LoadError address value)) ': effects) a
-> m address value effects (Either (SomeExc (BaseError (LoadError address value))) a)
runLoadError = runResumable
instance NFData1 (LoadError address) where
liftRnf _ (ModuleNotFoundError p) = rnf p
runLoadErrorWith :: (Effectful (m address value), Effects effects)
=> (forall resume . (BaseError (LoadError address value)) resume -> m address value effects resume)
-> m address value (Resumable (BaseError (LoadError address value)) ': effects) a
-> m address value effects a
runLoadErrorWith = runResumableWith
runLoadError :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ResumableC (BaseError (LoadError address)) (Eff m)) a
-> Evaluator term address value m (Either (SomeError (BaseError (LoadError address))) a)
runLoadError = raiseHandler runResumable
throwLoadError :: Member (Resumable (BaseError (LoadError address value))) effects
=> LoadError address value resume
-> Evaluator address value effects resume
runLoadErrorWith :: Carrier sig m
=> (forall resume . (BaseError (LoadError address)) resume -> Evaluator term address value m resume)
-> Evaluator term address value (ResumableWithC (BaseError (LoadError address)) (Eff m)) a
-> Evaluator term address value m a
runLoadErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwLoadError :: (Member (Resumable (BaseError (LoadError address))) sig, Carrier sig m)
=> LoadError address resume
-> m resume
throwLoadError err@(ModuleNotFoundError name) = throwResumable $ BaseError (ModuleInfo name) emptySpan err
@ -143,22 +167,27 @@ instance Eq1 ResolutionError where
liftEq _ (NotFoundError a _ l1) (NotFoundError b _ l2) = a == b && l1 == l2
liftEq _ (GoImportError a) (GoImportError b) = a == b
liftEq _ _ _ = False
instance NFData1 ResolutionError where
liftRnf _ x = case x of
NotFoundError p ps l -> rnf p `seq` rnf ps `seq` rnf l
GoImportError p -> rnf p
runResolutionError :: (Effectful m, Effects effects)
=> m (Resumable (BaseError ResolutionError) ': effects) a
-> m effects (Either (SomeExc (BaseError ResolutionError)) a)
runResolutionError = runResumable
runResolutionError :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ResumableC (BaseError ResolutionError) (Eff m)) a
-> Evaluator term address value m (Either (SomeError (BaseError ResolutionError)) a)
runResolutionError = raiseHandler runResumable
runResolutionErrorWith :: (Effectful m, Effects effects)
=> (forall resume . (BaseError ResolutionError) resume -> m effects resume)
-> m (Resumable (BaseError ResolutionError) ': effects) a
-> m effects a
runResolutionErrorWith = runResumableWith
runResolutionErrorWith :: Carrier sig m
=> (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume)
-> Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff m)) a
-> Evaluator term address value m a
runResolutionErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwResolutionError :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
throwResolutionError :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Carrier sig m
)
=> ResolutionError resume
-> Evaluator address value effects resume
-> Evaluator term address value m resume
throwResolutionError = throwBaseError

142
src/Control/Abstract/Primitive.hs
View File

@ -1,19 +1,14 @@
{-# LANGUAGE FunctionalDependencies, UndecidableInstances, ScopedTypeVariables #-}
module Control.Abstract.Primitive
( define
, defineClass
( defineClass
, defineNamespace
, builtInPrint
, lambda
, Lambda(..)
) where
import Control.Abstract.Context
import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Control.Abstract.ScopeGraph
(Declaration (..), EdgeLabel (..), ScopeError, ScopeGraph, currentScope, declare, newScope, withScope, Allocator)
import Control.Abstract.ScopeGraph (Declaration (..), EdgeLabel (..), ScopeError, ScopeGraph, currentScope, declare, newScope, withScope, Allocator)
import Control.Abstract.Value
import Data.Abstract.BaseError
import Data.Abstract.Environment
@ -24,116 +19,59 @@ import qualified Data.Map.Strict as Map
import Data.Text (unpack)
import Prologue
defineClass :: ( AbstractValue address value effects
import Control.Abstract.Context
import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Control.Abstract.Value
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Name
import Prologue
defineClass :: ( AbstractValue term address value m
, Carrier sig m
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member Fresh effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (State (Heap address address value)) effects
, Member (State (ScopeGraph address)) effects
, Member (Allocator address) sig
, Member (Deref value) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (State (Heap address address value)) sig
, Member Fresh sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Member (State (Heap address address value)) sig
, Member (State (ScopeGraph address)) sig
, Ord address
)
=> Declaration
-> [value]
-> Evaluator address value effects a
-> Evaluator address value effects ()
-> Evaluator address value m a
-> Evaluator address value m ()
defineClass declaration superclasses body = void . define declaration $ do
withChildFrame declaration $ \frame -> do
_ <- body
klass declaration superclasses frame
defineNamespace :: ( AbstractValue address value effects
defineNamespace :: ( AbstractValue term address value m
, Carrier sig m
, HasCallStack
, Member (Allocator address) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member Fresh effects
, Member (Deref value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (State (Heap address address value)) effects
, Member (State (ScopeGraph address)) effects
, Member (Allocator address) sig
, Member (Deref value) sig
, Member (Env address) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (State (Heap address value)) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member Fresh sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Member (State (Heap address address value)) sig
, Member (State (ScopeGraph address)) sig
, Ord address
)
=> Declaration
-> Evaluator address value effects a
-> Evaluator address value effects ()
-> Evaluator address value m a
-> Evaluator address value m ()
defineNamespace declaration body = void . define declaration $ do
withChildFrame declaration $ \frame -> do
_ <- body
namespace declaration Nothing frame
-- | Construct a function from a Haskell function taking 'Name's as arguments.
--
-- The constructed function will have the same arity as the Haskell function. Nullary functions are constructed by providing an evaluator producing an address. Note that the constructed function must not contain free variables as they will not be captured by the closure, and/or will be garbage collected.
lambda :: ( HasCallStack
, Lambda address value effects fn
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> fn
-> Evaluator address value effects value
lambda body = withCurrentCallStack callStack (lambda' [] body)
-- | A class of types forming the body of 'lambda's. Note that there should in general only be two cases: a recursive case of functions taking 'Name's as parameters, and a base case of an 'Evaluator'.
class Lambda address value effects ty | ty -> address, ty -> value, ty -> effects where
lambda' :: [Name]
-> ty
-> Evaluator address value effects value
instance (Member Fresh effects, Lambda address value effects ret) => Lambda address value effects (Name -> ret) where
lambda' vars body = do
var <- Name.gensym
lambda' (var : vars) (body var)
{-# INLINE lambda' #-}
instance ( Member (Allocator address) effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (State (Heap address address value)) effects
, Member (State (ScopeGraph address)) effects
, Member Fresh effects
, Ord address
)
=> Lambda address value effects (Evaluator address value effects value) where
lambda' vars action = do
name <- Name.gensym
span <- ask @Span -- TODO: This span is probably wrong
currentScope' <- currentScope
address <- declare (Declaration name) span Nothing
let edges = Map.singleton Lexical [ currentScope' ]
functionScope <- newScope edges
currentFrame' <- currentFrame
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
functionFrame <- newFrame functionScope frameEdges
withScopeAndFrame functionFrame $ do
function name vars lowerBound action
{-# INLINE lambda' #-}
builtInPrint :: forall address value effects. ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address) effects
, Member (Deref value) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address address value)) effects
, Member (State (ScopeGraph address)) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member Trace effects
, Ord address
)
=> Evaluator address value effects value
-- TODO: This Declaration usage might be wrong. How do we know name exists.
builtInPrint =
lambda @address @value @effects @(Name -> Evaluator address value effects value) (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> pure unit) -- box unit)

120
src/Control/Abstract/PythonPackage.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, LambdaCase, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Abstract.PythonPackage
( runPythonPackaging, Strategy(..) ) where
@ -6,59 +6,91 @@ import Control.Abstract.Evaluator (LoopControl, Return)
import Control.Abstract.ScopeGraph (Allocator)
import Control.Abstract.Heap (Deref)
import Control.Abstract.Value
import Control.Monad.Effect (Effectful (..))
import qualified Control.Monad.Effect as Eff
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Evaluatable
import Data.Abstract.Name (name)
import Data.Abstract.Path (stripQuotes)
import Data.Abstract.Value.Concrete (Value (..), ValueError (..))
import Data.Coerce
import qualified Data.Map as Map
import Prologue
data Strategy = Unknown | Packages [Text] | FindPackages [Text]
deriving (Show, Eq)
runPythonPackaging :: forall effects address body a. (
Eff.PureEffects effects
runPythonPackaging :: ( Carrier sig m
, Ord address
, Show address
, Member Trace effects
, Member (Boolean (Value address body)) effects
, Member (State (Heap address address (Value address body))) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member Fresh effects
, Coercible body (Eff.Eff effects)
, Member (State Strategy) effects
, Member (Allocator address) effects
, Member (Deref (Value address body)) effects
, Member (Eff.Exc (LoopControl (Value address body))) effects
, Member (Eff.Exc (Return (Value address body))) effects
, Member (Eff.Reader ModuleInfo) effects
, Member (Eff.Reader PackageInfo) effects
, Member (Eff.Reader Span) effects
, Member (Function address (Value address body)) effects)
=> Evaluator address (Value address body) effects a
-> Evaluator address (Value address body) effects a
runPythonPackaging = Eff.interpose @(Function address (Value address body)) $ \case
Call callName super params -> do
case callName of
Closure _ _ name' paramNames _ _ -> do
let bindings = foldr (\ (name, value) rest -> Map.insert name value rest) lowerBound (zip paramNames params)
let asStrings address = asArray address >>= traverse asString
, Show term
, Member Trace sig
, Member (Boolean (Value address body)) sig
, Member (State (Heap address address (Value address body))) sig
, Member (Resumable (BaseError (AddressError address (Value address body)))) sig
, Member (Resumable (BaseError (ValueError address body))) sig
, Member Fresh sig
, Coercible body (Eff.Eff sig)
, Member (State Strategy) sig
, Member (Allocator address) sig
, Member (Deref (Value address body)) sig
, Member (Error (LoopControl (Value address body))) sig
, Member (Error (Return (Value address body))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Function address (Value address body)) sig)
=> Evaluator term address (Value address body) (PythonPackagingC term address (Eff m)) a
-> Evaluator term address (Value address body) m a
runPythonPackaging = raiseHandler (runPythonPackagingC . interpret)
if name "find_packages" == name' then do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings)
put (FindPackages as)
else if name "setup" == name' then do
packageState <- get
if packageState == Unknown then do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings)
put (Packages as)
else
pure ()
else pure ()
_ -> pure ()
call callName super params
Function name params vars body -> function name params vars (raiseEff body)
newtype PythonPackagingC term address m a = PythonPackagingC { runPythonPackagingC :: m a }
wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address (Eff m) a
wrap = PythonPackagingC . runEvaluator
instance ( Carrier sig m
, Member (Allocator address) sig
, Member (Boolean (Value address body)) sig
, Member (Deref (Value address body)) sig
, Member (Error (LoopControl address)) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Function address (Value address body)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address (Value address body)))) sig
, Member (Resumable (BaseError (ValueError address body))) sig
, Member (State (Heap address address (Value address body))) sig
, Member (State Strategy) sig
, Member Trace sig
, Ord address
, Show address
, Show term
)
=> Carrier sig (PythonPackagingC term address (Eff m)) where
ret = PythonPackagingC . ret
eff op
| Just e <- prj op = wrap $ case handleCoercible e of
Call callName super params k -> Evaluator . k =<< do
case callName of
Closure _ _ name' paramNames _ _ -> do
let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params)
let asStrings = deref >=> asArray >=> traverse (deref >=> asString)
if name "find_packages" == name' then do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings)
put (FindPackages as)
else if name "setup" == name' then do
packageState <- get
if packageState == Unknown then do
as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings)
put (Packages as)
else
pure ()
else pure ()
_ -> pure ()
call callName super params
Function name params body k -> function name params body >>= Evaluator . k
BuiltIn b k -> builtIn b >>= Evaluator . k
| otherwise = PythonPackagingC (eff (handleCoercible op))

4
src/Control/Abstract/Roots.hs
View File

@ -14,9 +14,9 @@ class ValueRoots address value where
valueRoots :: value -> Live address
-- | Retrieve the local 'Live' set.
askRoots :: Member (Reader (Live address)) effects => Evaluator address value effects (Live address)
askRoots :: (Member (Reader (Live address)) sig, Carrier sig m) => Evaluator term address value m (Live address)
askRoots = ask
-- | Run a computation with the given 'Live' set added to the local root set.
extraRoots :: (Member (Reader (Live address)) effects, Ord address) => Live address -> Evaluator address value effects a -> Evaluator address value effects a
extraRoots :: (Member (Reader (Live address)) sig, Carrier sig m, Ord address) => Live address -> Evaluator term address value m a -> Evaluator term address value m a
extraRoots roots = local (<> roots)

6
src/Control/Abstract/ScopeGraph.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE ExistentialQuantification, GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Control.Abstract.ScopeGraph
( lookup
, declare
@ -33,6 +33,10 @@ import Control.Abstract.Evaluator hiding (Local)
import Data.Abstract.Module
import Data.Abstract.BaseError
import Data.Abstract.Name hiding (name)
import Control.Abstract.Heap
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Name
import Data.Abstract.ScopeGraph (Declaration (..), EdgeLabel, Reference, ScopeGraph, Address(..), Scope(..))
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import qualified Data.Map.Strict as Map

30
src/Control/Abstract/TermEvaluator.hs
View File

@ -1,30 +0,0 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Abstract.TermEvaluator
( TermEvaluator(..)
, raiseHandler
, module X
) where
import Control.Abstract.Evaluator
import Control.Monad.Effect as X
import Control.Monad.Effect.Fresh as X
import Control.Monad.Effect.NonDet as X
import Control.Monad.Effect.Reader as X
import Control.Monad.Effect.Resumable as X
import Control.Monad.Effect.State as X
import Control.Monad.Effect.Trace as X
import Control.Monad.IO.Class
import Prologue
-- | Evaluators specialized to some specific term type.
--
-- This is used to constrain the term type so that inference for analyses can resolve it correctly, but should not be used for any of the term-agonstic machinery like builtins, Evaluatable instances, the mechanics of the heap & environment, etc.
newtype TermEvaluator term address value effects a = TermEvaluator { runTermEvaluator :: Evaluator address value effects a }
deriving (Applicative, Effectful, Functor, Monad)
deriving instance Member NonDet effects => Alternative (TermEvaluator term address value effects)
deriving instance Member (Lift IO) effects => MonadIO (TermEvaluator term address value effects)
raiseHandler :: (Evaluator address value effects a -> Evaluator address value effects' a') -> (TermEvaluator term address value effects a -> TermEvaluator term address value effects' a')
raiseHandler f = TermEvaluator . f . runTermEvaluator

335
src/Control/Abstract/Value.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, Rank2Types, ScopedTypeVariables #-}
{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, LambdaCase, Rank2Types, ScopedTypeVariables, TypeOperators #-}
module Control.Abstract.Value
( AbstractValue(..)
, AbstractIntro(..)
@ -6,22 +6,28 @@ module Control.Abstract.Value
-- * Value effects
-- $valueEffects
, function
, BuiltIn(..)
, builtIn
, call
, Function(..)
, runFunction
, FunctionC(..)
, boolean
, asBool
, ifthenelse
, disjunction
, Boolean(..)
, runBoolean
, BooleanC(..)
, while
, doWhile
, forLoop
, While(..)
, runWhile
, WhileC(..)
, makeNamespace
-- , address
, value
, rvalBox
, subtermValue
-- , subtermAddress
) where
import Control.Abstract.ScopeGraph (Declaration, ScopeGraph, ScopeError)
@ -30,8 +36,10 @@ import Control.Abstract.Evaluator
import Control.Abstract.Heap hiding (address)
import Control.Abstract.ScopeGraph (Allocator, currentScope, newScope, EdgeLabel(..), )
import qualified Control.Abstract.Heap as Heap
import Data.Abstract.Environment as Env
import Control.Effect.Carrier
import Data.Coerce
import Data.Abstract.BaseError
import Data.Abstract.Environment as Env
import Data.Abstract.Module
import Data.Abstract.Name
import Data.Abstract.Number as Number
@ -65,45 +73,120 @@ data Comparator
--
-- In the concrete domain, introductions & eliminations respectively construct & pattern match against values, while in abstract domains they respectively construct & project finite sets of discrete observations of abstract values. For example, an abstract domain modelling integers as a sign (-, 0, or +) would introduce abstract values by mapping integers to their sign and eliminate them by mapping signs back to some canonical integer, e.g. - -> -1, 0 -> 0, + -> 1.
function :: forall address value effects. Member (Function address value) effects => Name -> [Name] -> Set Name -> Evaluator address value effects value -> Evaluator address value effects value
function name params fvs (Evaluator body) = send @(Function address value) (Function name params fvs body)
function :: (Member (Function term address value) sig, Carrier sig m) => Maybe Name -> [Name] -> term -> Evaluator term address value m value
function name params body = sendFunction (Function name params body ret)
call :: Member (Function address value) effects => value -> address -> [value] -> Evaluator address value effects value
call fn self args = send (Call fn self args)
data BuiltIn
= Print
| Show
deriving (Eq, Ord, Show, Generic, NFData)
data Function address value m result where
Function :: Name -> [Name] -> Set Name -> m value -> Function address value m value
Call :: value -> address -> [value] -> Function address value m value
builtIn :: (Member (Function term address value) sig, Carrier sig m) => BuiltIn -> Evaluator term address value m value
builtIn = sendFunction . flip BuiltIn ret
call :: (Member (Function term address value) sig, Carrier sig m) => value -> address -> [address] -> Evaluator term address value m address
call fn self args = sendFunction (Call fn self args ret)
sendFunction :: (Member (Function term address value) sig, Carrier sig m) => Function term address value (Evaluator term address value m) (Evaluator term address value m a) -> Evaluator term address value m a
sendFunction = send
data Function term address value (m :: * -> *) k
= Function Name [Name] term (value -> k)
| BuiltIn BuiltIn (value -> k)
| Call value (Address address) [value] (value -> k)
deriving (Functor)
instance HFunctor (Function term address value) where
hmap _ = coerce
instance Effect (Function term address value) where
handle state handler (Function name params body k) = Function name params body (handler . (<$ state) . k)
handle state handler (BuiltIn builtIn k) = BuiltIn builtIn (handler . (<$ state) . k)
handle state handler (Call fn self addrs k) = Call fn self addrs (handler . (<$ state) . k)
runFunction :: Carrier (Function term address value :+: sig) (FunctionC term address value (Eff m))
=> (term -> Evaluator term address value (FunctionC term address value (Eff m)) address)
-> Evaluator term address value (FunctionC term address value (Eff m)) a
-> Evaluator term address value m a
runFunction eval = raiseHandler (flip runFunctionC (runEvaluator . eval) . interpret)
newtype FunctionC term address value m a = FunctionC { runFunctionC :: (term -> Eff (FunctionC term address value m) address) -> m a }
>>>>>>> master
instance PureEffect (Function address value) where
handle handler (Request (Function name params fvs body) k) = Request (Function name params fvs (handler body)) (handler . k)
handle handler (Request (Call fn self addrs) k) = Request (Call fn self addrs) (handler . k)
-- | Construct a boolean value in the abstract domain.
boolean :: Member (Boolean value) effects => Bool -> Evaluator address value effects value
boolean = send . Boolean
boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> m value
boolean = send . flip Boolean ret
-- | Extract a 'Bool' from a given value.
asBool :: Member (Boolean value) effects => value -> Evaluator address value effects Bool
asBool = send . AsBool
asBool :: (Member (Boolean value) sig, Carrier sig m) => value -> m Bool
asBool = send . flip AsBool ret
-- | Eliminate boolean values. TODO: s/boolean/truthy
ifthenelse :: Member (Boolean value) effects => value -> Evaluator address value effects a -> Evaluator address value effects a -> Evaluator address value effects a
ifthenelse :: (Member (Boolean value) sig, Carrier sig m, Monad m) => value -> m a -> m a -> m a
ifthenelse v t e = asBool v >>= \ c -> if c then t else e
-- | Compute the disjunction (boolean or) of two computed values. This should have short-circuiting semantics where applicable.
disjunction :: Member (Boolean value) effects => Evaluator address value effects value -> Evaluator address value effects value -> Evaluator address value effects value
disjunction (Evaluator a) (Evaluator b) = send (Disjunction a b)
data Boolean value (m :: * -> *) k
= Boolean Bool (value -> k)
| AsBool value (Bool -> k)
deriving (Functor)
data Boolean value m result where
Boolean :: Bool -> Boolean value m value
AsBool :: value -> Boolean value m Bool
Disjunction :: m value -> m value -> Boolean value m value
instance HFunctor (Boolean value) where
hmap _ = coerce
{-# INLINE hmap #-}
instance PureEffect (Boolean value) where
handle handler (Request (Boolean b) k) = Request (Boolean b) (handler . k)
handle handler (Request (AsBool v) k) = Request (AsBool v) (handler . k)
handle handler (Request (Disjunction a b) k) = Request (Disjunction (handler a) (handler b)) (handler . k)
instance Effect (Boolean value) where
handle state handler = \case
Boolean b k -> Boolean b (handler . (<$ state) . k)
AsBool v k -> AsBool v (handler . (<$ state) . k)
runBoolean :: Carrier (Boolean value :+: sig) (BooleanC value (Eff m))
=> Evaluator term address value (BooleanC value (Eff m)) a
-> Evaluator term address value m a
runBoolean = raiseHandler $ runBooleanC . interpret
newtype BooleanC value m a = BooleanC { runBooleanC :: m a }
-- | The fundamental looping primitive, built on top of 'ifthenelse'.
while :: (Member (While value) sig, Carrier sig m)
=> Evaluator term address value m value -- ^ Condition
-> Evaluator term address value m value -- ^ Body
-> Evaluator term address value m value
while cond body = send (While cond body ret)
-- | Do-while loop, built on top of while.
doWhile :: (Member (While value) sig, Carrier sig m)
=> Evaluator term address value m value -- ^ Body
-> Evaluator term address value m value -- ^ Condition
-> Evaluator term address value m value
doWhile body cond = body *> while cond body
-- | C-style for loops.
forLoop :: (Member (While value) sig, Member (Env address) sig, Carrier sig m)
=> Evaluator term address value m value -- ^ Initial statement
-> Evaluator term address value m value -- ^ Condition
-> Evaluator term address value m value -- ^ Increment/stepper
-> Evaluator term address value m value -- ^ Body
-> Evaluator term address value m value
forLoop initial cond step body =
locally (initial *> while cond (body *> step))
data While value m k
= While (m value) (m value) (value -> k)
deriving (Functor)
instance HFunctor (While value) where
hmap f (While cond body k) = While (f cond) (f body) k
runWhile :: Carrier (While value :+: sig) (WhileC value (Eff m))
=> Evaluator term address value (WhileC value (Eff m)) a
-> Evaluator term address value m a
runWhile = raiseHandler $ runWhileC . interpret
newtype WhileC value m a = WhileC { runWhileC :: m a }
class Show value => AbstractIntro value where
@ -142,142 +225,95 @@ class Show value => AbstractIntro value where
-- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
--
-- This allows us to abstract the choice of whether to evaluate under binders for different value types.
class AbstractIntro value => AbstractValue address value effects where
class AbstractIntro value => AbstractValue term address value carrier where
-- | Cast numbers to integers
castToInteger :: value -> Evaluator address value effects value
castToInteger :: value -> Evaluator term address value carrier value
-- | Lift a unary operator over a 'Num' to a function on 'value's.
liftNumeric :: (forall a . Num a => a -> a)
-> (value -> Evaluator address value effects value)
-> (value -> Evaluator term address value carrier value)
-- | Lift a pair of binary operators to a function on 'value's.
-- You usually pass the same operator as both arguments, except in the cases where
-- Haskell provides different functions for integral and fractional operations, such
-- as division, exponentiation, and modulus.
liftNumeric2 :: (forall a b. Number a -> Number b -> SomeNumber)
-> (value -> value -> Evaluator address value effects value)
-> (value -> value -> Evaluator term address value carrier value)
-- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
liftComparison :: Comparator -> (value -> value -> Evaluator address value effects value)
liftComparison :: Comparator -> (value -> value -> Evaluator term address value carrier value)
-- | Lift a unary bitwise operator to values. This is usually 'complement'.
liftBitwise :: (forall a . Bits a => a -> a)
-> (value -> Evaluator address value effects value)
-> (value -> Evaluator term address value carrier value)
-- | Lift a binary bitwise operator to values. The Integral constraint is
-- necessary to satisfy implementation details of Haskell left/right shift,
-- but it's fine, since these are only ever operating on integral values.
liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a)
-> (value -> value -> Evaluator address value effects value)
-> (value -> value -> Evaluator term address value carrier value)
unsignedRShift :: value -> value -> Evaluator address value effects value
unsignedRShift :: value -> value -> Evaluator term address value carrier value
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
tuple :: [value] -> Evaluator address value effects value
tuple :: [value] -> Evaluator term address value carrier value
-- | Construct an array of zero or more values.
array :: [value] -> Evaluator address value effects value
array :: [value] -> Evaluator term address value carrier value
asArray :: value -> Evaluator address value effects [value]
asArray :: value -> Evaluator term address value carrier [address]
-- | Extract the contents of a key-value pair as a tuple.
asPair :: value -> Evaluator address value effects (value, value)
asPair :: value -> Evaluator term address value carrier (value, value)
-- | Extract a 'Text' from a given value.
asString :: value -> Evaluator address value effects Text
asString :: value -> Evaluator term address value carrier Text
-- | @index x i@ computes @x[i]@, with zero-indexing.
index :: value -> value -> Evaluator address value effects value
index :: value -> value -> Evaluator term address value carrier value
-- | Build a class value from a name and environment.
klass :: Declaration -- ^ The new class's identifier
-> [value] -- ^ A list of superclasses
-> address -- ^ The frame address to capture
-> Evaluator address value effects value
-> address -- ^ The environment to capture
-> Evaluator term address value carrier value
-- | Build a namespace value from a name and environment stack
--
-- Namespaces model closures with monoidal environments.
namespace :: Declaration -- ^ The namespace's declaration
namespace :: Declaration -- ^ The namespace's identifier
-> Maybe value -- The ancestor of the namespace
-> address -- ^ The frame address to capture
-> Evaluator address value effects value
-> address -- ^ The environment to mappend
-> Evaluator term address value carrier value
-- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
scopedEnvironment :: address -> Evaluator address value effects (Maybe (Environment address))
-- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
--
-- The function argument takes an action which recurs through the loop.
loop :: (Evaluator address value effects value -> Evaluator address value effects value) -> Evaluator address value effects value
scopedEnvironment :: address -> Evaluator term address value carrier (Maybe (Environment address))
-- | C-style for loops.
forLoop :: ( AbstractValue address value effects
, Member (Boolean value) effects
, Member (Reader ModuleInfo) effects
, Member (State (Heap address address value)) effects
, Ord address
, Member (Reader Span) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Allocator address) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member Fresh effects
, Member (State (ScopeGraph address)) effects
)
=> Evaluator address value effects value -- ^ Initial statement
-> Evaluator address value effects value -- ^ Condition
-> Evaluator address value effects value -- ^ Increment/stepper
-> Evaluator address value effects value -- ^ Body
-> Evaluator address value effects value
forLoop initial cond step body = initial *> while cond (action *> step)
where
action = do
currentScope' <- currentScope
currentFrame' <- currentFrame
scopeAddr <- newScope (Map.singleton Lexical [ currentScope' ])
frame <- newFrame scopeAddr (Map.singleton Lexical (Map.singleton currentScope' currentFrame'))
withScopeAndFrame frame body
-- | The fundamental looping primitive, built on top of 'ifthenelse'.
while :: (AbstractValue address value effects, Member (Boolean value) effects)
=> Evaluator address value effects value
-> Evaluator address value effects value
-> Evaluator address value effects value
while cond body = loop $ \ continue -> do
this <- cond
ifthenelse this (body *> continue) (pure unit)
-- | Do-while loop, built on top of while.
doWhile :: (AbstractValue address value effects, Member (Boolean value) effects)
=> Evaluator address value effects value
-> Evaluator address value effects value
-> Evaluator address value effects value
doWhile body cond = loop $ \ continue -> body *> do
this <- cond
ifthenelse this continue (pure unit)
<<<<<<< HEAD
-- TODO rethink whether this function is necessary.
makeNamespace :: ( AbstractValue address value effects
, Member (Deref value) effects
, Member (Reader ModuleInfo) effects
, Member (State (ScopeGraph address)) effects
, Member (Allocator address) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Allocator address) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (State (Heap address address value)) effects
, Member Fresh effects
makeNamespace :: ( AbstractValue term address value sig
, Member (Deref value) sig
, Member (Reader ModuleInfo) sig
, Member (State (ScopeGraph address)) sig
, Member (Allocator address) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (Allocator address) sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Member (State (Heap address address value)) sig
, Member Fresh sig
, Carrier sig m
, Ord address
)
=> Declaration
-> Address address
-> Maybe (Address address)
-> Evaluator address value effects ()
-> Evaluator address value effects value
-> Evaluator term address value m ()
-> Evaluator term address value m value
makeNamespace declaration addr super body = do
super' <- traverse deref super
define declaration . withChildFrame declaration $ \frame -> do
@ -286,11 +322,13 @@ makeNamespace declaration addr super body = do
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
-- evaluateInScopedEnv :: ( AbstractValue address value effects
-- evaluateInScopedEnv :: ( AbstractValue term address value m
-- , Member (Env address) sig
-- , Carrier sig m
-- )
-- => address
-- -> Evaluator address value effects a
-- -> Evaluator address value effects a
-- -> Evaluator term address value m a
-- -> Evaluator term address value m a
-- evaluateInScopedEnv receiver term = do
-- scopedEnv <- scopedEnvironment receiver
-- env <- maybeM getEnv scopedEnv
@ -298,64 +336,43 @@ makeNamespace declaration addr super body = do
-- | Evaluates a 'Value' returning the referenced value
value :: ( AbstractValue address value effects
, Member (Deref value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address address value)) effects
value :: ( AbstractValue term address value sig
, Member (Deref value) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (State (Heap address address value)) sig
, Carrier sig m
, Ord address
)
=> ValueRef address value
-> Evaluator address value effects value
-> Evaluator term address value m value
value (Rval val) = pure val
value (LvalLocal name) = undefined
value (LvalMember slot) = undefined
-- | Evaluates a 'Subterm' to its rval
subtermValue :: ( AbstractValue address value effects
, Member (Deref value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address address value)) effects
, Ord address
)
=> Subterm term (Evaluator address value effects (ValueRef address value))
-> Evaluator address value effects value
subtermValue = value <=< subtermRef
-- | Returns the address of a value referenced by a 'ValueRef'
-- address :: ( AbstractValue address value effects
-- , Member (Env address) effects
-- , Member (Reader ModuleInfo) effects
-- , Member (Reader Span) effects
-- , Member (Resumable (BaseError (EnvironmentError address))) effects
-- address :: ( AbstractValue term address value m
-- , Carrier sig m
-- , Member (Env address) sig
-- , Member (Reader ModuleInfo) sig
-- , Member (Reader Span) sig
-- , Member (Resumable (BaseError (EnvironmentError address))) sig
-- )
-- => ValueRef address
-- -> Evaluator address value effects address
-- -> Evaluator term address value m address
-- address (LvalLocal var) = variable var
-- address (LvalMember ptr prop) = evaluateInScopedEnv ptr (variable prop)
-- address (Rval addr) = pure addr
-- | Evaluates a 'Subterm' to the address of its rval
-- subtermAddress :: ( AbstractValue address value effects
-- , Member (Env address) effects
-- , Member (Reader ModuleInfo) effects
-- , Member (Reader Span) effects
-- , Member (Resumable (BaseError (EnvironmentError address))) effects
-- )
-- => Subterm term (Evaluator address value effects (ValueRef address value))
-- -> Evaluator address value effects address
-- subtermAddress = address <=< subtermRef
-- | Convenience function for boxing a raw value and wrapping it in an Rval
rvalBox :: ( Member (Allocator address) effects
, Member (Deref value) effects
, Member Fresh effects
, Member (State (Heap address address value)) effects
rvalBox :: ( Member (Allocator address) sig
, Member (Deref value) sig
, Member Fresh sig
, Member (State (Heap address address value)) sig
, Carrier sig m
, Ord address
)
=> value
-> Evaluator address value effects (ValueRef address value)
-> Evaluator term address value m (ValueRef address)
rvalBox val = pure (Rval val)

49
src/Control/Effect/Interpose.hs Normal file
View File

@ -0,0 +1,49 @@
{-# LANGUAGE ExistentialQuantification, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Control.Effect.Interpose
( Interpose(..)
, interpose
, runInterpose
, InterposeC(..)
, Listener(..)
) where
import Control.Effect.Carrier
import Control.Effect.Internal
import Control.Effect.Sum
data Interpose eff m k
= forall a . Interpose (m a) (forall n x . eff n (n x) -> m x) (a -> k)
deriving instance Functor (Interpose eff m)
instance HFunctor (Interpose eff) where
hmap f (Interpose m h k) = Interpose (f m) (f . h) k
-- | Respond to requests for some specific effect with a handler.
--
-- The intercepted effects are not re-sent in the surrounding context; thus, the innermost nested 'interpose' listening for an effect will win, and the effect’s own handler will not get the chance to service the request.
--
-- Note that since 'Interpose' lacks an 'Effect' instance, only “pure” effects, i.e. effects which can be handled inside other effects using 'hmap' alone, can be run within the 'runInterpose' scope. This includes @Reader@, but not e.g. @State@ or @Error@.
interpose :: (Member (Interpose eff) sig, Carrier sig m)
=> m a
-> (forall n x . eff n (n x) -> m x)
-> m a
interpose m f = send (Interpose m f ret)
-- | Run an 'Interpose' effect.
runInterpose :: (Member eff sig, Carrier sig m, Monad m) => Eff (InterposeC eff m) a -> m a
runInterpose = flip runInterposeC Nothing . interpret
newtype InterposeC eff m a = InterposeC { runInterposeC :: Maybe (Listener eff m) -> m a }
newtype Listener eff m = Listener { runListener :: forall n x . eff n (n x) -> m x }
instance (Carrier sig m, Member eff sig, Monad m) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where
ret a = InterposeC (const (ret a))
eff op = InterposeC (\ listener -> handleSum (algOther listener) (alg listener) op)
where alg listener (Interpose m h k) = runInterposeC m (Just (Listener (flip runInterposeC listener . h))) >>= flip runInterposeC listener . k
algOther listener op
| Just listener <- listener
, Just eff <- prj op = runListener listener eff
| otherwise = eff (handleReader listener runInterposeC op)

53
src/Control/Effect/REPL.hs Normal file
View File

@ -0,0 +1,53 @@
{-# LANGUAGE KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-}
module Control.Effect.REPL
( REPL (..)
, REPLC (..)
, prompt
, output
, runREPL
) where
import Prologue
import Control.Effect
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Coerce
import System.Console.Haskeline
import qualified Data.Text as T
data REPL (m :: * -> *) k
= Prompt Text (Maybe Text -> k)
| Output Text k
deriving (Functor)
instance HFunctor REPL where
hmap _ = coerce
instance Effect REPL where
handle state handler (Prompt p k) = Prompt p (handler . (<$ state) . k)
handle state handler (Output s k) = Output s (handler (k <$ state))
prompt :: (Member REPL sig, Carrier sig m) => Text -> m (Maybe Text)
prompt p = send (Prompt p ret)
output :: (Member REPL sig, Carrier sig m) => Text -> m ()
output s = send (Output s (ret ()))
runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> Eff (REPLC m) a -> m a
runREPL prefs settings = flip runREPLC (prefs, settings) . interpret
newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a }
instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where
ret = REPLC . const . ret
eff op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case
Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= flip runREPLC args . k
Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> runREPLC k args) op)
cyan :: String
cyan = "\ESC[1;36m\STX"
plain :: String
plain = "\ESC[0m\STX"

7
src/Control/Abstract/Matching.hs → src/Control/Matching.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE GADTs, TypeOperators #-}
module Control.Abstract.Matching
module Control.Matching
( Matcher
, TermMatcher
, target
@ -9,6 +9,7 @@ module Control.Abstract.Matching
, matchM
, narrow
, narrow'
, purely
, succeeds
, fails
, runMatcher
@ -71,6 +72,10 @@ target = Target
ensure :: (t -> Bool) -> Matcher t ()
ensure f = target >>= \c -> guard (f c)
-- | Promote a pure function to a 'Matcher'.
purely :: (a -> b) -> Matcher a b
purely f = fmap f target
-- | 'matchm' takes a modification function and a new matcher action the target parameter of which
-- is the result of the modification function. If the modification function returns 'Just' when
-- applied to the current 'target', the given matcher is executed with the result of that 'Just'

417
src/Control/Rewriting.hs Normal file
View File

@ -0,0 +1,417 @@
{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
-- | This module provides 'Rule', a monadic DSL that abstracts the
-- details of rewriting a given datum into another type in some
-- effectful context. A term rewriter from @a@ to @b@ in some context
-- @m@ is similar in spirit to @a -> m b@ (the 'Kleisli' arrow), but
-- 'Rule' provides increased compositionality and generalizes well to
-- rewriting recursive structures at one or several levels, analogous
-- to 'cata' or 'para'. 'Rule's will be used both in refactoring (to
-- change properties of AST nodes) and in the reprinting pipeline (to
-- provide a configurable layout system).
--
-- Rules are composed with the 'Control.Category' methods, either
-- '>>>' for left-to-right composition or '<<<' for right-to-left.
-- They provide an 'Alternative' instance for choice.
--
-- Rewrite rules can be deterministic or nondeterministic, depending
-- on the inner monad by which they are parameterized. They support
-- failure and a form of try/catch without having to worry about the
-- details of exception handling.
module Control.Rewriting
( -- * Rule types
RuleM
, RewriteM
, Rule
, Rewrite
, TransformFailed (..)
-- * Reexports from Control.Arrow
, (>>>)
, (<<<)
, (&&&)
, (|||)
-- * Primitives
, target
, context
, localContext
-- * Building rules
, purely
, leafToRoot
, promote
, fromMatcher
-- * General-purpose combinators
, try
, apply
, tracing
-- * Combinators for operating on terms and sums
, projecting
, injecting
, insideSum
-- * Helpers for transforming/rewriting tree-like structures.
, everywhere
, somewhere
, somewhere'
-- * Helpers for generating and annotating Term values
, generate
, generate'
, modified
, markRefactored
-- * Running rules
, rewrite
, rewriteM
, runE
) where
import Prelude hiding (fail, id, (.))
import Prologue hiding (apply, try)
import Control.Arrow
import Control.Category
import Control.Effect
import Control.Effect.Trace
import Data.Functor.Identity
import Data.Profunctor
import qualified Data.Sum as Sum hiding (apply)
import Data.Text (pack)
import Control.Matching (Matcher, stepMatcher)
import Data.History as History
import Data.Term
-- | The fundamental type of rewriting rules. You can think of a
-- @RuleM env m from to@ as @env -> from -> m (Maybe to)@; in other words, a
-- Kleisli arrow with an immutable environment, supporting failure as
-- well as arbitrary effects in a monadic context. However, Rule
-- encompasses both 'cata' and 'para', so you can use them to fold
-- over 'Recursive' data types. Rules are covariant in their result
-- type and contravariant in their environment and input parameters.
data RuleM env (m :: * -> *) from to where
Then :: RuleM env m from a -> (a -> RuleM env m from b) -> RuleM env m from b
Dimap :: (a -> b) -> (c -> d) -> RuleM env m b c -> RuleM env m a d
Stop :: String -> RuleM env m from to
Alt :: RuleM env m from to -> RuleM env m from to -> RuleM env m from to
Pass :: RuleM env m a a
Comp :: RuleM env m b c -> RuleM env m a b -> RuleM env m a c
Split :: RuleM env m from to -> RuleM env m from' to' -> RuleM env m (from, from') (to, to')
Fanin :: RuleM env m from to -> RuleM env m from' to -> RuleM env m (Either from from') to
Context :: RuleM env m from env
Local :: (env' -> env) -> RuleM env m from to -> RuleM env' m from to
Promote :: m to -> RuleM env m from to
Recur :: ( Traversable f, Traversable g
, old ~ Term f ann, new ~ Term g ann
)
=> RuleM (env, old) m (f new) (g new)
-> RuleM env m old new
Somewhere :: ( Apply Functor fs, Apply Foldable fs, Apply Traversable fs
, f :< fs, g :< fs
, term ~ Term (Sum fs) ann
)
=> RuleM (env, term) m (f term) (g term)
-> (term -> g term -> term)
-> RuleM env m term term
-- | @a >>> b@ succeeds only if both @a@ and @b@ succeed. @id@ is the
-- identity rule that always succeeds; if you want to use it without
-- hiding Prelude's @id@, use 'target'.
instance Category (RuleM env m) where
id = Pass
(.) = Comp
instance Functor (RuleM env m from) where
fmap = rmap
instance Applicative (RuleM env m from) where
pure = arr . const
(<*>) = ap
instance Monad (RuleM env m from) where
(>>=) = Then
-- | This doesn't have a tremendous error message; you should
-- prefer 'fail'.
instance MonadPlus (RuleM env m from) where
mzero = Stop "MonadPlus.mzero"
-- | The message passed to 'fail' will be shown to the user
-- in a 'TransformFailed' exception.
instance MonadFail (RuleM env m from) where
fail = Stop
-- | @a <|> b@ succeeds if a or b succeeds.
instance Alternative (RuleM env m from) where
(<|>) = Alt
empty = Stop "Alternative.empty"
-- | You can map over the input type of a Rule contravariantly and the
-- output type covariantly, just like a function.
instance Profunctor (RuleM env m) where
dimap = Dimap
-- | You can use arrow operations and syntax, if you're feeling saucy.
-- This also provides the useful '&&&' operator, which runs
-- two rules and returns a tuple of the results.
instance Arrow (RuleM env m) where
arr f = Dimap id f id
(***) = Split
-- | This instance lets you use @if@ and @case@ in arrow syntax over
-- rules, and provides '|||', which lifts its arguments into
-- a single rule that takes 'Either' values and dispatches appropriately.
instance ArrowChoice (RuleM env m) where
f +++ g = (Left <$> f) ||| (Right <$> g)
(|||) = Fanin
-- | A 'RewriteM' is a 'RuleM' that does not change the type of its input.
type RewriteM env m item = RuleM env m item item
-- | 'Rule's and 'Rewrite's don't offer access to
-- their monad parameter.
type Rule env from to = forall m . RuleM env m from to
type Rewrite env item = Rule env item item
-- | Used to indicate failure and retrying.
-- TODO: look into using Data.Error.
newtype TransformFailed = TransformFailed Text deriving (Show, Eq)
--
-- Primitives defined in terms of 'Rule' constructors for
-- access to Rule-based state and effects.
--
-- | Extract the input parameter being considered by this rule.
-- An alias for 'id'.
target :: Rule env from from
target = id
-- | Extract the environment parameter within a rule.
context :: Rule env from env
context = Context
-- | Map a function over the environment parameter. Note that this is contravariant
-- rather than covariant, in contrast to 'Reader'.
localContext :: (newenv -> oldenv) -> Rule oldenv from to -> Rule newenv from to
localContext = Local
--
-- Building rules out of functions or monadic values.
--
-- | Builds a 'Rule' out of a function. Alias for 'arr'.
purely :: (from -> to) -> Rule env from to
purely = arr
-- | Promote a monadic value to a Rule in that monad. Analogous to
-- 'Control.Monad.Trans.lift', but 'RuleM' cannot be both an instance
-- of Category and of MonadTrans due to parameter order.
promote :: m to -> RuleM env m from to
promote = Promote
-- | Promote a 'Matcher' to a 'Rule'.
fromMatcher :: Matcher from to -> Rule env from to
fromMatcher m = target >>= \t -> maybeM (fail "fromMatcher") (stepMatcher t m)
-- | Promote a Rule from a recursive functor to one over terms, operating
-- leaf-to-root in the style of 'Data.Functor.Foldable.para'.
leafToRoot :: (Traversable f, Traversable g)
=> RuleM (env, Term f ann) m (f (Term g ann)) (g (Term g ann))
-> RuleM env m (Term f ann) (Term g ann)
leafToRoot = Recur
--
-- General-purpose combinators
--
-- | Try applying a 'Rewrite', falling back on the identity rule if it fails.
--
-- @
-- try x = x <|> id
-- @
try :: Rewrite env term -> Rewrite env term
try = (<|> id)
-- | Feed one datum into a Rule. Similar to '&'.
apply :: Rule env x to -> x -> Rule env from to
apply rule x = pure x >>> rule
-- | The identity rule, but one that emits a trace of the provided
-- string as a side-effect. Useful for naming rules, as in
-- @
-- tracing "rule fired" >>> someRule >>> tracing "rule completed"
-- @
tracing :: (Member Trace sig, Carrier sig m, Functor m) => String -> RewriteM env m item
tracing s = id >>= (\t -> promote (t <$ trace s))
--
-- Combinators for operating on Terms and Sums
--
-- | Project from a 'Sum' to a component of that sum, failing
-- if the projection fails.
projecting :: (f :< fs) => Rule env (Sum fs recur) (f recur)
projecting = target >>= Sum.projectGuard
-- | Inject a component into a 'Sum'. This always succeeds.
injecting :: (f :< fs) => Rule env (f recur) (Sum fs recur)
injecting = arr Sum.inject
-- | Promote a Rule over the components of 'Sum' values to
-- 'Sum's themselves.
--
-- @
-- insideSum x = projecting >>> x >>> injecting
-- @
--
insideSum :: (f :< fs, g :< gs)
=> RuleM env m (f recur) (g recur)
-> RuleM env m (Sum fs recur) (Sum gs recur)
insideSum x = projecting >>> x >>> injecting
--
-- Helpers for the leaf-to-root + insideSum idiom.
--
-- | Promote a 'Rule' over 'Sum' components everywhere inside a 'Term',
-- operating leaf-to-root and only succeeding if the 'Rule' can be applied everywhere.
everywhere :: ( Apply Functor fs, Apply Foldable fs, Apply Traversable fs, f :< fs
, Apply Functor gs, Apply Foldable gs, Apply Traversable gs, g :< gs
)
=> RuleM (env, Term (Sum fs) ann) m (f (Term (Sum gs) ann)) (g (Term (Sum gs) ann))
-> RuleM env m (Term (Sum fs) ann) (Term (Sum gs) ann)
everywhere = leafToRoot . insideSum
-- | @somewhere rule fn@, when applied to a 'Term' over 'Sum' values,
-- will recurse through the provided term in the style of a paramophism.
-- If the provided rule succeeds, the @fn@ function, which wraps the
-- result of the provided @rule@ back into a 'Term', is applied.
-- If at some stage the @rule@ does not succeed, no modifications
-- are made to that level (though they may affect the children
-- or parents of that level).
--
-- The finalizer function @fn@ is very often 'markRefactored', which ensures
-- that any term possessing a 'History' is marked as 'Refactored'.
somewhere :: ( Apply Functor fs, Apply Foldable fs, Apply Traversable fs
, f :< fs, g :< fs
)
=> Rule (env, Term (Sum fs) ann) (f (Term (Sum fs) ann)) (g (Term (Sum fs) ann))
-> (Term (Sum fs) ann -> g (Term (Sum fs) ann) -> Term (Sum fs) ann)
-> Rewrite env (Term (Sum fs) ann)
somewhere = Somewhere
-- | As 'somewhere', but the wrapper is implicit, extracting the needed annotation
-- history at each level from the original level.
somewhere' :: ( Apply Functor fs, Apply Foldable fs, Apply Traversable fs
, f :< fs, g :< fs
)
=> Rule (env, Term (Sum fs) ann) (f (Term (Sum fs) ann)) (g (Term (Sum fs) ann))
-> Rewrite env (Term (Sum fs) ann)
somewhere' = flip Somewhere (\x -> termIn (annotation x) . Sum.inject)
--
-- Helpers for termIn over a context and sum.
--
-- | Like termIn, except it uses the transform's context to get the current annotation.
-- Useful when a recursive rewrite rule has to add some subterms to a given term.
generate :: ( term ~ Term (Sum syn) ann
, f :< syn
)
=> f term -> Rule term a term
generate x = termIn <$> (termAnnotation <$> context) <*> pure (Sum.inject x)
-- | As 'generate', but operating in a tuple context of the sort you might see
-- in a 'leafToRoot' invocation.
generate' :: ( term ~ Term (Sum syn) ann
, f :< syn
)
=> f term -> Rule (env, term) a term
generate' x = termIn <$> (termAnnotation . snd <$> context) <*> pure (Sum.inject x)
-- | If we are operating in a History context, tag the provided sum
-- with a 'Refactored' annotation derived from the current context.
modified :: (Apply Functor syn, f :< syn, term ~ Term (Sum syn) History)
=> f term
-> Rule (env, term) a term
modified x = History.remark Refactored <$> generate' x
-- | Mark the provided functor with a 'Refactored' version of the original
-- 'Term'. This is useful for passing in to 'somewhere''.
markRefactored :: (Apply Functor fs, g :< fs)
=> Term (Sum fs) History
-> g (Term (Sum fs) History)
-> Term (Sum fs) History
markRefactored old t = remark Refactored (termIn (annotation old) (inject t))
--
-- Interpreters
--
-- | Apply a transform in an monadic context.
rewriteM :: Monad m
=> RuleM env m from to
-> env
-> from
-> m (Either TransformFailed to)
rewriteM r env from = runE env from r
-- | Apply a 'PureRule'.
rewrite :: RuleM env Identity from to
-> env
-> from
-> Either TransformFailed to
rewrite r env from = runIdentity $ runE env from r
cataM :: (Recursive t, Traversable (Base t), Monad m) => (Base t a -> m a) -> (t -> m a)
cataM phi = c where c = phi <=< (traverse c . project)
paraM :: (Corecursive from, Recursive from, Traversable (Base from), Monad m) => (Base from (from, to) -> m to) -> (from -> m to)
paraM f = liftM snd . cataM run
where run t = do
a <- f t
pure (embed $ fmap fst t, a)
eitherA :: Applicative f => (b -> f (Either a c)) -> Either a b -> f (Either a c)
eitherA = either (pure . Left)
-- | As 'rewriteM', but with some parameters reversed.
runE :: forall m env from to . Monad m
=> env
-> from
-> RuleM env m from to
-> m (Either TransformFailed to)
runE env from = \case
Then a f -> runE env from a >>= eitherA (runE env from) . fmap f
Dimap f g m -> fmap (fmap g) (runE env (f from) m)
Stop s -> pure . Left . TransformFailed . pack $ s
Pass -> pure . pure $ from
Promote p -> fmap Right p
Alt a b -> runE env from a >>= either (const (runE env from b)) (pure . Right)
Fanin a b -> runE env from id >>= eitherA (rewriteM a env ||| rewriteM b env)
Split a b -> runE env from id >>= eitherA (fmap bisequence . runKleisli prod)
where prod = Kleisli (rewriteM a env) *** Kleisli (rewriteM b env)
Local f m -> runE (f env) from m
Context -> pure . pure $ env
Comp a b -> runE env from b >>= eitherA (rewriteM a env)
Recur r -> paraM go from where
go (In ann recur) = eitherA hi (traverse snd recur)
where hi x = fmap (fmap (termIn ann)) (runE (env, termIn ann (fmap fst recur)) x r)
Somewhere r pin -> paraM go from where
go arg = let
orig = Term $ fmap fst arg
xformed = fmap Term (traverse snd arg)
in xformed & either (const (pure (Right orig))) (\given ->
-- We could pull out this projectTerm into a field on Somewhere itself,
-- but that seems like overkill for the time being.
projectTerm given & maybe (pure (Right given)) (\asSum ->
Right . either (const given) (pin given)
<$> runE (env, orig) asSum r))

21
src/Data/AST.hs
View File

@ -1,14 +1,12 @@
{-# LANGUAGE DataKinds #-}
module Data.AST
( Node (..)
, nodeSpan
, nodeByteRange
, AST
, Location
, nodeLocation
) where
import Data.Range
import Data.Record
import Data.Span
import Data.Location
import Data.Term
import Data.Aeson
import Data.Text (pack)
@ -19,8 +17,7 @@ type AST syntax grammar = Term syntax (Node grammar)
data Node grammar = Node
{ nodeSymbol :: !grammar
, nodeByteRange :: {-# UNPACK #-} !Range
, nodeSpan :: {-# UNPACK #-} !Span
, nodeLocation :: {-# UNPACK #-} !Location
}
deriving (Eq, Ord, Show)
@ -28,11 +25,11 @@ data Node grammar = Node
instance Show grammar => ToJSONFields (Node grammar) where
toJSONFields Node{..} =
[ "symbol" .= pack (show nodeSymbol)
, "span" .= nodeSpan
, "span" .= locationSpan nodeLocation
]
-- | A location specified as possibly-empty intervals of bytes and line/column positions.
type Location = '[Range, Span]
nodeSpan :: Node grammar -> Span
nodeSpan = locationSpan . nodeLocation
nodeLocation :: Node grammar -> Record Location
nodeLocation Node{..} = nodeByteRange :. nodeSpan :. Nil
nodeByteRange :: Node grammar -> Range
nodeByteRange = locationByteRange . nodeLocation

51
src/Data/Abstract/Address/Hole.hs
View File

@ -1,14 +1,12 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Hole
( Hole(..)
, toMaybe
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import Control.Effect.Carrier
import Control.Effect.Sum
import Prologue
data Hole context a = Partial context | Total a
@ -22,29 +20,26 @@ toMaybe (Partial _) = Nothing
toMaybe (Total a) = Just a
relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a
relocate = raiseEff . lowerEff
promoteA :: AllocatorC address m a -> AllocatorC (Hole context address) m a
promoteA = AllocatorC . runAllocatorC
instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
, Carrier sig m
, Monad m
)
=> Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where
ret = promoteA . ret
eff = handleSum
(AllocatorC . eff . handleCoercible)
(\ (Alloc name k) -> Total <$> promoteA (eff (L (Alloc name ret))) >>= k)
runAllocator :: PureEffects effects
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Hole context address) value (Allocator (Hole context address) ': effects) a
-> Evaluator (Hole context address) value effects a
runAllocator handler = interpret (handleAllocator handler)
promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a
promoteD = DerefC . runDerefC
handleAllocator :: (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
-> Allocator (Hole context address) (Eff (Allocator (Hole context address) ': effects)) a
-> Evaluator (Hole context address) value effects a
handleAllocator handler (Alloc name) = relocate (Total <$> handler (Alloc name))
runDeref :: PureEffects effects
=> (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Hole context address) value (Deref value ': effects) a
-> Evaluator (Hole context address) value effects a
runDeref handler = interpret (handleDeref handler)
handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
-> Deref value (Eff (Deref value ': effects)) a
-> Evaluator (Hole context address) value effects a
handleDeref handler (DerefCell cell) = relocate (handler (DerefCell cell))
handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))
instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
=> Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where
ret = promoteD . ret
eff = handleSum (DerefC . eff . handleCoercible) (\case
DerefCell cell k -> promoteD (eff (L (DerefCell cell ret))) >>= k
AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k)

62
src/Data/Abstract/Address/Located.hs
View File

@ -1,13 +1,11 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Located
( Located(..)
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Module (ModuleInfo)
import Data.Abstract.Name
import Data.Abstract.Package (PackageInfo)
@ -22,37 +20,29 @@ data Located address = Located
deriving (Eq, Ord, Show)
relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a
relocate = raiseEff . lowerEff
promoteA :: AllocatorC address m a -> AllocatorC (Located address) m a
promoteA = AllocatorC . runAllocatorC
instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
, Carrier sig m
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Monad m
)
=> Carrier (Allocator (Located address) :+: sig) (AllocatorC (Located address) m) where
ret = promoteA . ret
eff = handleSum
(AllocatorC . eff . handleCoercible)
(\ (Alloc name k) -> Located <$> promoteA (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= k)
runAllocator :: ( Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, PureEffects effects
)
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Located address) value (Allocator (Located address) ': effects) a
-> Evaluator (Located address) value effects a
runAllocator handler = interpret (handleAllocator handler)
promoteD :: DerefC address value m a -> DerefC (Located address) value m a
promoteD = DerefC . runDerefC
handleAllocator :: ( Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
)
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
-> Allocator (Located address) (Eff (Allocator (Located address) ': effects)) a
-> Evaluator (Located address) value effects a
handleAllocator handler (Alloc name) = relocate (Located <$> handler (Alloc name) <*> currentPackage <*> currentModule <*> pure name <*> ask)
runDeref :: PureEffects effects
=> (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Located address) value (Deref value ': effects) a
-> Evaluator (Located address) value effects a
runDeref handler = interpret (handleDeref handler)
handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
-> Deref value (Eff (Deref value ': effects)) a
-> Evaluator (Located address) value effects a
handleDeref handler (DerefCell cell) = relocate (handler (DerefCell cell))
handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))
instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
=> Carrier (Deref value :+: sig) (DerefC (Located address) value m) where
ret = promoteD . ret
eff = handleSum (DerefC . eff . handleCoercible) (\case
DerefCell cell k -> promoteD (eff (L (DerefCell cell ret))) >>= k
AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k)

39
src/Data/Abstract/Address/Monovariant.hs
View File

@ -1,13 +1,11 @@
{-# LANGUAGE GADTs, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Monovariant
( Monovariant(..)
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Name
import qualified Data.Set as Set
import Prologue
@ -20,26 +18,15 @@ instance Show Monovariant where
showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant
runAllocator :: PureEffects effects
=> Evaluator Monovariant value (Allocator Monovariant ': effects) a
-> Evaluator Monovariant value effects a
runAllocator = interpret handleAllocator
instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where
ret = AllocatorC . ret
eff = AllocatorC . handleSum
(eff . handleCoercible)
(\ (Alloc name k) -> runAllocatorC (k (Monovariant name)))
handleAllocator :: Allocator Monovariant (Eff (Allocator Monovariant ': effects)) a -> Evaluator Monovariant value effects a
handleAllocator (Alloc name) = pure (Monovariant name)
runDeref :: ( Member NonDet effects
, Ord value
, PureEffects effects
)
=> Evaluator Monovariant value (Deref value ': effects) a
-> Evaluator Monovariant value effects a
runDeref = interpret handleDeref
handleDeref :: ( Member NonDet effects
, Ord value
)
=> Deref value (Eff (Deref value ': effects)) a
-> Evaluator Monovariant value effects a
handleDeref (DerefCell cell) = traverse (foldMapA pure) (nonEmpty (toList cell))
handleDeref (AssignCell value cell) = pure (Set.insert value cell)
instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where
ret = DerefC . ret
eff = DerefC . handleSum (eff . handleCoercible) (\case
DerefCell cell k -> traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
AssignCell value cell k -> runDerefC (k (Set.insert value cell)))

36
src/Data/Abstract/Address/Precise.hs
View File

@ -1,39 +1,31 @@
{-# LANGUAGE GADTs, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Precise
( Precise(..)
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import Control.Effect.Carrier
import Control.Effect.Sum
import qualified Data.Set as Set
import Prologue
-- | 'Precise' models precise store semantics where only the 'Latest' value is taken. Everything gets it's own address (always makes a new allocation) which makes for a larger store.
newtype Precise = Precise { unPrecise :: Int }
deriving (Eq, Ord)
deriving (Eq, Ord, NFData)
instance Show Precise where
showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise
runAllocator :: ( Member Fresh effects
, PureEffects effects
)
=> Evaluator Precise value (Allocator Precise ': effects) a
-> Evaluator Precise value effects a
runAllocator = interpret handleAllocator
instance (Member Fresh sig, Carrier sig m, Monad m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where
ret = AllocatorC . ret
eff = AllocatorC . handleSum
(eff . handleCoercible)
(\ (Alloc _ k) -> Precise <$> fresh >>= runAllocatorC . k)
handleAllocator :: Member Fresh effects => Allocator Precise (Eff (Allocator Precise ': effects)) a -> Evaluator Precise value effects a
handleAllocator (Alloc _) = Precise <$> fresh
runDeref :: PureEffects effects
=> Evaluator Precise value (Deref value ': effects) a
-> Evaluator Precise value effects a
runDeref = interpret handleDeref
handleDeref :: Deref value (Eff (Deref value ': effects)) a -> Evaluator Precise value effects a
handleDeref (DerefCell cell) = pure (fst <$> Set.minView cell)
handleDeref (AssignCell value _) = pure (Set.singleton value)
instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where
ret = DerefC . ret
eff = DerefC . handleSum (eff . handleCoercible) (\case
DerefCell cell k -> runDerefC (k (fst <$> Set.minView cell))
AssignCell value _ k -> runDerefC (k (Set.singleton value)))

16
src/Data/Abstract/BaseError.hs
View File

@ -29,12 +29,20 @@ instance (Eq1 exc) => Eq1 (BaseError exc) where
instance Show1 exc => Show1 (BaseError exc) where
liftShowsPrec sl sp d (BaseError _ _ exc) = liftShowsPrec sl sp d exc
throwBaseError :: ( Member (Resumable (BaseError exc)) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader S.Span) effects
instance (NFData1 exc, NFData resume) => NFData (BaseError exc resume) where
rnf = liftRnf rnf
instance (NFData1 exc) => NFData1 (BaseError exc) where
liftRnf rnf' (BaseError i s e) = rnf i `seq` rnf s `seq` liftRnf rnf' e
throwBaseError :: ( Member (Resumable (BaseError exc)) sig
, Member (Reader M.ModuleInfo) sig
, Member (Reader S.Span) sig
, Carrier sig m
, Monad m
)
=> exc resume
-> Evaluator address value effects resume
-> m resume
throwBaseError err = do
moduleInfo <- currentModule
span <- currentSpan

48
src/Data/Abstract/Cache.hs
View File

@ -1,48 +0,0 @@
{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-}
module Data.Abstract.Cache
( Cache
, Cached (..)
, Cacheable
, cacheLookup
, cacheSet
, cacheInsert
, cacheKeys
) where
import Data.Abstract.Configuration
import Data.Abstract.Heap
import Data.Abstract.Ref
import Data.Map.Monoidal as Monoidal
import Prologue
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuration term address value) (Set (Cached address value)) }
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address value, Cached address value), Semigroup)
data Cached address value = Cached
{ cachedValue :: ValueRef address value
, cachedHeap :: Heap address address value
}
deriving (Eq, Ord, Show)
type Cacheable term address value = (Ord address, Ord term, Ord value)
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
cacheLookup :: Cacheable term address value => Configuration term address value -> Cache term address value -> Maybe (Set (Cached address value))
cacheLookup key = Monoidal.lookup key . unCache
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
cacheSet :: Cacheable term address value => Configuration term address value -> Set (Cached address value) -> Cache term address value -> Cache term address value
cacheSet key value = Cache . Monoidal.insert key value . unCache
-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
cacheInsert :: Cacheable term address value => Configuration term address value -> Cached address value -> Cache term address value -> Cache term address value
cacheInsert = curry cons
-- | Return all 'Configuration's in the provided cache.
cacheKeys :: Cache term address value -> [Configuration term address value]
cacheKeys = Monoidal.keys . unCache
instance (Show term, Show address, Show value) => Show (Cache term address value) where
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache

13
src/Data/Abstract/Configuration.hs
View File

@ -1,13 +0,0 @@
module Data.Abstract.Configuration ( Configuration (..) ) where
import Data.Abstract.Environment
import Data.Abstract.Heap
import Data.Abstract.Live
-- | A single point in a program’s execution.
data Configuration term address value = Configuration
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live address -- ^ The set of rooted addresses.
, configurationHeap :: Heap address address value -- ^ The heap of values.
}
deriving (Eq, Ord, Show)

4
src/Data/Abstract/Declarations.hs
View File

@ -7,7 +7,6 @@ module Data.Abstract.Declarations
import Data.Abstract.Name
import Data.Sum
import Data.Term
import Prologue
class Declarations syntax where
declaredName :: syntax -> Maybe Name
@ -20,9 +19,6 @@ class Declarations1 syntax where
liftDeclaredName :: (a -> Maybe Name) -> syntax a -> Maybe Name
liftDeclaredName _ _ = Nothing
instance Declarations t => Declarations (Subterm t a) where
declaredName = declaredName . subterm
deriving instance Declarations1 syntax => Declarations (Term syntax ann)
instance (Declarations recur, Declarations1 syntax) => Declarations (TermF syntax ann recur) where

27
src/Data/Abstract/Environment.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveAnyClass, DerivingStrategies, GADTs #-}
module Data.Abstract.Environment
( Environment(..)
@ -33,14 +33,10 @@ import qualified Data.Map as Map
import Prelude hiding (head, lookup)
import Prologue
-- $setup
-- >>> import Data.Abstract.Address.Precise
-- >>> let bright = push (insertEnv (name "foo") (Precise 0) lowerBound)
-- >>> let shadowed = insertEnv (name "foo") (Precise 1) bright
-- | A map of names to values. Represents a single scope level of an environment chain.
newtype Bindings address = Bindings { unBindings :: Map.Map Name address }
deriving (Eq, Ord)
deriving stock (Eq, Ord, Generic)
deriving anyclass (NFData)
instance Semigroup (Bindings address) where
(<>) (Bindings a) (Bindings b) = Bindings (a <> b)
@ -60,15 +56,22 @@ instance Show address => Show (Bindings address) where
-- All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific
-- scope for "a", then the next, and so on.
newtype Environment address = Environment { unEnvironment :: NonEmpty (Bindings address) }
deriving (Eq, Ord)
deriving stock (Eq, Ord, Generic)
deriving anyclass (NFData)
data EvalContext address = EvalContext { ctxSelf :: Maybe address, ctxEnvironment :: Environment address }
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Generic, NFData)
-- | Errors involving the environment.
data EnvironmentError address return where
FreeVariable :: Name -> EnvironmentError address address
instance NFData1 (EnvironmentError address) where
liftRnf _ (FreeVariable n) = rnf n
instance (NFData return) => NFData (EnvironmentError address return) where
rnf = liftRnf rnf
deriving instance Eq (EnvironmentError address return)
deriving instance Show (EnvironmentError address return)
instance Show1 (EnvironmentError address) where liftShowsPrec _ _ = showsPrec
@ -111,9 +114,6 @@ lookup :: Name -> Bindings address -> Maybe address
lookup name = Map.lookup name . unBindings
-- | Lookup a 'Name' in the environment.
--
-- >>> lookupEnv' (name "foo") shadowed
-- Just (Precise 1)
lookupEnv' :: Name -> Environment address -> Maybe address
lookupEnv' name = foldMapA (lookup name) . unEnvironment
@ -126,9 +126,6 @@ insertEnv :: Name -> address -> Environment address -> Environment address
insertEnv name addr (Environment (Bindings a :| as)) = Environment (Bindings (Map.insert name addr a) :| as)
-- | Remove a 'Name' from the environment.
--
-- >>> delete (name "foo") shadowed
-- Environment []
delete :: Name -> Environment address -> Environment address
delete name = trim . Environment . fmap (Bindings . Map.delete name . unBindings) . unEnvironment

279
src/Data/Abstract/Evaluatable.hs
View File

@ -2,14 +2,9 @@
module Data.Abstract.Evaluatable
( module X
, Evaluatable(..)
, ModuleEffects
, ValueEffects
, evaluate
, traceResolve
-- * Preludes
, HasPrelude(..)
-- * Postludes
, HasPostlude(..)
-- * Effects
, EvalError(..)
, throwEvalError
@ -26,158 +21,86 @@ import Control.Abstract.Context as X
import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn)
import Control.Abstract.Heap as X hiding (runAddressError, runAddressErrorWith)
import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError)
import Control.Abstract.Value as X hiding (Boolean(..), Function(..))
import Control.Abstract.ScopeGraph
import Control.Abstract.Value as X hiding (Boolean(..), Function(..), While(..))
import Data.Abstract.Declarations as X
import Data.Abstract.BaseError as X
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Name as X
import Data.Abstract.Ref as X
import Data.Coerce
import Data.Language
import Data.Scientific (Scientific)
import Data.Semigroup.App
import Data.Semigroup.Foldable
import Data.Sum
import Data.Sum hiding (project)
import Data.Term
import Prologue
-- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
class (Show1 constr, Foldable constr) => Evaluatable constr where
eval :: ( AbstractValue address value effects
eval :: ( AbstractValue term address value m
, Carrier sig m
, Declarations term
, FreeVariables term
, Member (Allocator address) effects
, Member (Boolean value) effects
, Member (Deref value) effects
, Member (State (ScopeGraph address)) effects
, Member (Exc (LoopControl value)) effects
, Member (Exc (Return value)) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Modules address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (State Span) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (Resumable (BaseError EvalError)) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member (State (Heap address address value)) effects
, Member Trace effects
, Member (Allocator address) sig
, Member (Boolean value) sig
, Member (While value) sig
, Member (Deref value) sig
, Member (ScopeEnv address) sig
, Member (State (ScopeGraph address)) sig
, Member (Error (LoopControl address)) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Function term address value) sig
, Member (Modules address value) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (State Span) sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (Resumable (BaseError (UnspecializedError value))) sig
, Member (Resumable (BaseError EvalError)) sig
, Member (Resumable (BaseError ResolutionError)) sig
, Member (State (Heap address address value)) sig
, Member Trace sig
, Ord address
)
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef address value))
eval expr = do
traverse_ subtermRef expr
=> (term -> Evaluator term address value m (ValueRef address value))
-> (constr term -> Evaluator term address value m (ValueRef address value))
eval recur expr = do
traverse_ recur expr
v <- throwUnspecializedError $ UnspecializedError ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "")
rvalBox v
type ModuleEffects address value rest
= Exc (LoopControl value)
': Exc (Return value)
': State (ScopeGraph address)
': Deref value
': Allocator address
': Reader ModuleInfo
': rest
type ValueEffects address value rest
= Function address value
': Boolean value
': rest
evaluate :: forall address value valueEffects term moduleEffects effects proxy lang. ( AbstractValue address value valueEffects
, Declarations term
, Effects effects
, Evaluatable (Base term)
, FreeVariables term
, HasPostlude lang
, HasPrelude lang
, Member Fresh effects
, Member (Modules address value) effects
, Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address value))))) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (State Span) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (Resumable (BaseError EvalError)) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (State (Heap address address value)) effects
, Member Trace effects
, Ord address
, Recursive term
, moduleEffects ~ ModuleEffects address value effects
, valueEffects ~ ValueEffects address value moduleEffects
)
=> proxy lang
-> (SubtermAlgebra Module term (TermEvaluator term address value moduleEffects value) -> SubtermAlgebra Module term (TermEvaluator term address value moduleEffects value))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value valueEffects (ValueRef address value)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value valueEffects (ValueRef address value)))
-> (forall x . Evaluator address value (Deref value ': Allocator address ': Reader ModuleInfo ': effects) x -> Evaluator address value (Reader ModuleInfo ': effects) x)
-> (forall x . Evaluator address value valueEffects x -> Evaluator address value moduleEffects x)
-> [Module term]
-> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address value))))
evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = ((do
(_, _) <- TermEvaluator . runInModule moduleInfoFromCallStack . runValue $ do
definePrelude lang
pure unit
foldr run ask modules) :: TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address value)))))
where
run :: Module term -> TermEvaluator term address value effects a -> TermEvaluator term address value effects a
run m rest = do
evaluated <- (raiseHandler
(runInModule (moduleInfo m))
(analyzeModule (subtermRef . moduleBody)
(evalModuleBody <$> m)) :: TermEvaluator term address value effects (ScopeGraph address, value))
-- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module.
local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest
evalModuleBody term = Subterm term (coerce runValue (do
foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term >>= TermEvaluator . value))
runInModule :: ModuleInfo -> Evaluator address value moduleEffects value -> Evaluator address value effects (ScopeGraph address, value)
runInModule info
= runReader info
. runAllocDeref
. runState lowerBound
. runReturn
. runLoopControl
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects ()
traceResolve :: (Show a, Show b, Member Trace sig, Carrier sig m) => a -> b -> Evaluator term address value m ()
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
-- Preludes
class HasPrelude (language :: Language) where
definePrelude :: ( AbstractValue address value effects
definePrelude :: ( AbstractValue term address value m
, Carrier sig m
, HasCallStack
, Member (Allocator address) effects
, Member (State (ScopeGraph address)) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Deref value) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address address value)) effects
, Member Trace effects
, Member (Allocator address) sig
, Member (State (ScopeGraph address)) sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (Deref value) sig
, Member Fresh sig
, Member (Function term address value) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address value))) sig
, Member (State (Heap address address value)) sig
, Member Trace sig
, Ord address
)
=> proxy language
-> Evaluator address value effects ()
-> Evaluator term address value m ()
definePrelude _ = pure ()
instance HasPrelude 'Go
@ -187,7 +110,7 @@ instance HasPrelude 'PHP
instance HasPrelude 'Python where
definePrelude _ =
void $ define (Declaration (X.name "print")) builtInPrint
define (Declaration (X.name "print")) (builtIn Print)
instance HasPrelude 'Ruby where
definePrelude :: forall address value effects proxy. ( AbstractValue address value effects
@ -198,7 +121,7 @@ instance HasPrelude 'Ruby where
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Deref value) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Function term address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
@ -209,46 +132,20 @@ instance HasPrelude 'Ruby where
=> proxy 'Ruby
-> Evaluator address value effects ()
definePrelude _ = do
define (Declaration (X.name "puts")) builtInPrint
define (Declaration (X.name "puts")) (builtIn Print)
defineClass (Declaration (X.name "Object")) [] $ do
define (Declaration (X.name "inspect")) (lambda @address @value @effects @(Evaluator address value effects value) (pure (string "<object>")))
define (Declaration (X.name "inspect")) (builtIn Show)
instance HasPrelude 'TypeScript where
definePrelude _ =
defineNamespace (Declaration (X.name "console")) $ do
define (Declaration (X.name "log")) builtInPrint
define (Declaration (X.name "log")) (builtIn Print)
instance HasPrelude 'JavaScript where
definePrelude _ = do
defineNamespace (Declaration (X.name "console")) $ do
define (Declaration (X.name "log")) builtInPrint
-- Postludes
class HasPostlude (language :: Language) where
postlude :: ( AbstractValue address value effects
, HasCallStack
, Member (Deref value) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member Trace effects
)
=> proxy language
-> Evaluator address value effects ()
postlude _ = pure ()
instance HasPostlude 'Go
instance HasPostlude 'Haskell
instance HasPostlude 'Java
instance HasPostlude 'PHP
instance HasPostlude 'Python
instance HasPostlude 'Ruby
instance HasPostlude 'TypeScript
instance HasPostlude 'JavaScript where
postlude _ = trace "JS postlude"
define (Declaration (X.name "log")) (builtIn Print)
-- Effects
@ -266,6 +163,18 @@ data EvalError return where
deriving instance Eq (EvalError return)
deriving instance Show (EvalError return)
instance NFData1 EvalError where
liftRnf _ x = case x of
NoNameError -> ()
IntegerFormatError i -> rnf i
FloatFormatError i -> rnf i
RationalFormatError i -> rnf i
DefaultExportError -> ()
ExportError p n -> rnf p `seq` rnf n
instance NFData return => NFData (EvalError return) where
rnf = liftRnf rnf
instance Eq1 EvalError where
liftEq _ NoNameError NoNameError = True
liftEq _ DefaultExportError DefaultExportError = True
@ -278,50 +187,60 @@ instance Eq1 EvalError where
instance Show1 EvalError where
liftShowsPrec _ _ = showsPrec
runEvalError :: (Effectful m, Effects effects) => m (Resumable (BaseError EvalError) ': effects) a -> m effects (Either (SomeExc (BaseError EvalError)) a)
runEvalError = runResumable
runEvalError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError EvalError) (Eff m)) a -> Evaluator term address value m (Either (SomeError (BaseError EvalError)) a)
runEvalError = raiseHandler runResumable
runEvalErrorWith :: (Effectful m, Effects effects) => (forall resume . (BaseError EvalError) resume -> m effects resume) -> m (Resumable (BaseError EvalError) ': effects) a -> m effects a
runEvalErrorWith = runResumableWith
runEvalErrorWith :: Carrier sig m => (forall resume . (BaseError EvalError) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError EvalError) (Eff m)) a -> Evaluator term address value m a
runEvalErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwEvalError :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError EvalError)) effects
throwEvalError :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError EvalError)) sig
, Carrier sig m
)
=> EvalError resume
-> Evaluator address value effects resume
-> Evaluator term address value m resume
throwEvalError = throwBaseError
data UnspecializedError a b where
UnspecializedError :: String -> UnspecializedError value value
instance NFData1 (UnspecializedError a) where
liftRnf _ (UnspecializedError s) = rnf s
instance NFData b => NFData (UnspecializedError a b) where
rnf = liftRnf rnf
deriving instance Eq (UnspecializedError a b)
deriving instance Show (UnspecializedError a b)
instance Eq1 (UnspecializedError a) where
liftEq _ (UnspecializedError a) (UnspecializedError b) = a == b
instance Show1 (UnspecializedError a) where
liftShowsPrec _ _ = showsPrec
runUnspecialized :: (Effectful (m value), Effects effects)
=> m value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> m value effects (Either (SomeExc (BaseError (UnspecializedError value))) a)
runUnspecialized = runResumable
runUnspecialized :: (Carrier sig m, Effect sig)
=> Evaluator term address value (ResumableC (BaseError (UnspecializedError value)) (Eff m)) a
-> Evaluator term address value m (Either (SomeError (BaseError (UnspecializedError value))) a)
runUnspecialized = raiseHandler runResumable
runUnspecializedWith :: (Effectful (m value), Effects effects)
=> (forall resume . BaseError (UnspecializedError value) resume -> m value effects resume)
-> m value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> m value effects a
runUnspecializedWith = runResumableWith
runUnspecializedWith :: Carrier sig m
=> (forall resume . BaseError (UnspecializedError value) resume -> Evaluator term address value m resume)
-> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError value)) (Eff m)) a
-> Evaluator term address value m a
runUnspecializedWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError value))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
)
=> UnspecializedError value resume
-> Evaluator address value effects resume
-> Evaluator term address value m resume
throwUnspecializedError = throwBaseError
@ -329,11 +248,11 @@ throwUnspecializedError = throwBaseError
-- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'.
instance (Apply Evaluatable fs, Apply Show1 fs, Apply Foldable fs) => Evaluatable (Sum fs) where
eval = apply @Evaluatable eval
eval eval' = apply @Evaluatable (eval eval')
-- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax.
instance (Evaluatable s, Show a) => Evaluatable (TermF s a) where
eval = eval . termFOut
eval eval' = eval eval' . termFOut
-- NOTE: Use 'Data.Syntax.Statements' instead of '[]' if you need imperative eval semantics.
@ -345,4 +264,4 @@ instance (Evaluatable s, Show a) => Evaluatable (TermF s a) where
-- 3. Only the last statement’s return value is returned.
instance Evaluatable [] where
-- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists.
eval = maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty
eval eval = maybe (rvalBox unit) (runApp . foldMap1 (App . eval)) . nonEmpty

3
src/Data/Abstract/FreeVariables.hs
View File

@ -24,9 +24,6 @@ class FreeVariables1 syntax where
default liftFreeVariables :: (Foldable syntax) => (a -> Set Name) -> syntax a -> Set Name
liftFreeVariables = foldMap
instance FreeVariables t => FreeVariables (Subterm t a) where
freeVariables = freeVariables . subterm
deriving instance FreeVariables1 syntax => FreeVariables (Term syntax ann)
instance (FreeVariables recur, FreeVariables1 syntax) => FreeVariables (TermF syntax ann recur) where

6
src/Data/Abstract/Heap.hs
View File

@ -25,7 +25,6 @@ import Data.Semigroup.Reducer
import Prologue
import Prelude hiding (lookup)
data Frame scopeAddress frameAddress value = Frame {
scopeAddress :: scopeAddress
, links :: Map EdgeLabel (Map scopeAddress frameAddress)
@ -33,8 +32,9 @@ data Frame scopeAddress frameAddress value = Frame {
}
deriving (Eq, Ord, Show)
data Heap scopeAddress frameAddress value = Heap { currentFrame :: Maybe frameAddress, heap :: Map frameAddress (Frame scopeAddress frameAddress value) }
deriving (Eq, Ord, Show)
-- | A map of frame addresses onto Frames.
data Heap scopeAddress frameAddress value = Heap { currentFrame :: Maybe frameAddress, heap :: Monoidal.Map frameAddress (Frame scopeAddress frameAddress value) }
deriving (Eq, Foldable, Lower, Monoid, Ord, Semigroup, Generic, NFData, Show)
instance Lower (Heap scopeAddress frameAddress value) where
lowerBound = Heap lowerBound lowerBound

8
src/Data/Abstract/Module.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-}
module Data.Abstract.Module
( Module(..)
, moduleForBlob
@ -13,7 +15,8 @@ import Prologue
import System.FilePath.Posix
data Module body = Module { moduleInfo :: ModuleInfo, moduleBody :: body }
deriving (Eq, Foldable, Functor, Ord, Traversable)
deriving stock (Eq, Foldable, Functor, Ord, Traversable, Generic)
deriving anyclass (NFData)
instance Show body => Show (Module body) where
showsPrec d Module{..} = showsBinaryWith showsPrec showsPrec "Module" d (modulePath moduleInfo) moduleBody
@ -32,7 +35,8 @@ moduleForBlob rootDir Blob{..} = Module info
type ModulePath = FilePath
newtype ModuleInfo = ModuleInfo { modulePath :: ModulePath }
deriving (Eq, Ord)
deriving stock (Eq, Ord, Generic)
deriving anyclass (NFData)
instance Show ModuleInfo where
showsPrec d = showsUnaryWith showsPrec "ModuleInfo" d . modulePath

6
src/Data/Abstract/ModuleTable.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveAnyClass, DerivingStrategies, GeneralizedNewtypeDeriving #-}
module Data.Abstract.ModuleTable
( ModulePath
, ModuleTable (..)
@ -21,7 +21,9 @@ import Prologue
import System.FilePath.Posix
newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModulePath a }
deriving (Eq, Foldable, Functor, Generic1, Lower, Monoid, Ord, Semigroup, Traversable)
deriving stock (Eq, Foldable, Functor, Generic1, Generic, Ord, Traversable)
deriving newtype (Lower, Monoid, Semigroup)
deriving anyclass (NFData)
singleton :: ModulePath -> a -> ModuleTable a
singleton name = ModuleTable . Map.singleton name

14
src/Data/Abstract/Name.hs
View File

@ -8,8 +8,8 @@ module Data.Abstract.Name
, formatName
) where
import Control.Monad.Effect
import Control.Monad.Effect.Fresh
import Control.Effect
import Control.Effect.Fresh
import Data.Aeson
import qualified Data.Char as Char
import Data.Text (Text)
@ -24,7 +24,7 @@ import qualified Proto3.Wire.Encode as Encode
data Name
= Name Text
| I Int
deriving (Eq, Ord, MessageField)
deriving (Eq, Ord, MessageField, Generic, NFData)
instance HasDefault Name where
def = Name mempty
@ -36,7 +36,7 @@ instance Primitive Name where
primType _ = Bytes
-- | Generate a fresh (unused) name for use in synthesized variables/closures/etc.
gensym :: (Functor (m effs), Member Fresh effs, Effectful m) => m effs Name
gensym :: (Member Fresh sig, Carrier sig m, Functor m) => m Name
gensym = I <$> fresh
-- | Construct a 'Name' from a 'Text'.
@ -48,17 +48,13 @@ nameI :: Int -> Name
nameI = I
-- | Extract a human-readable 'Text' from a 'Name'.
-- Sample outputs can be found in @Data.Abstract.Name.Spec@.
formatName :: Name -> Text
formatName (Name name) = name
formatName (I i) = Text.pack $ '_' : (alphabet !! a) : replicate n 'ʹ'
where alphabet = ['a'..'z']
(n, a) = i `divMod` length alphabet
-- $
-- >>> I 0
-- "_a"
-- >>> I 26
-- "_aʹ"
instance Show Name where
showsPrec _ = prettyShowString . Text.unpack . formatName
where prettyShowString str = showChar '"' . foldr ((.) . prettyChar) id str . showChar '"'

6
src/Data/Abstract/Number.hs
View File

@ -32,6 +32,12 @@ data Number a where
deriving instance Eq a => Eq (Number a)
instance NFData (Number a) where
rnf a = case a of
Integer i -> rnf i
Ratio r -> rnf r
Decimal d -> rnf d
instance Show (Number a) where
show (Integer i) = show i
show (Ratio r) = show r

4
src/Data/Abstract/Package.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-}
module Data.Abstract.Package
( Package (..)
, PackageInfo (..)
@ -18,7 +20,7 @@ data PackageInfo = PackageInfo
{ packageName :: PackageName
, packageResolutions :: Map.Map FilePath FilePath
}
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Generic, NFData)
-- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed.
data Package term = Package

24
src/Data/Abstract/ScopeGraph.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, DuplicateRecordFields, TupleSections #-}
{-# LANGUAGE GADTs, DeriveAnyClass, DuplicateRecordFields, TupleSections #-}
module Data.Abstract.ScopeGraph
( Address(..)
, associatedScope
@ -32,14 +32,14 @@ import Prologue
import qualified Data.Sequence as Seq
data Address address = Address { address :: address, position :: Position }
deriving (Eq, Show, Ord)
deriving (Eq, Show, Ord, Generic, NFData)
-- Offsets and frame addresses in the heap should be addresses?
data Scope address = Scope {
edges :: Map EdgeLabel [address] -- Maybe Map EdgeLabel [Path scope]?
, references :: Map Reference (Path address)
, declarations :: Seq (Declaration, (Span, Maybe address))
} deriving (Eq, Show, Ord)
data Scope scopeAddress = Scope {
edges :: Map EdgeLabel [scopeAddress] -- Maybe Map EdgeLabel [Path scope]?
, references :: Map Reference (Path scopeAddress)
, declarations :: Seq (Declaration, (Span, Maybe scopeAddress))
} deriving (Eq, Show, Ord, Generic, NFData)
newtype Position = Position { unPosition :: Int }
deriving (Eq, Show, Ord)
@ -52,6 +52,8 @@ instance Ord scope => Lower (ScopeGraph scope) where
deriving instance Eq address => Eq (ScopeGraph address)
deriving instance Show address => Show (ScopeGraph address)
deriving instance Ord address => Ord (ScopeGraph address)
deriving instance Generic (ScopeGraph address)
deriving instance NFData scope => NFData (ScopeGraph scope)
data Path scope where
-- | Construct a direct path to a declaration.
@ -62,6 +64,8 @@ data Path scope where
deriving instance Eq scope => Eq (Path scope)
deriving instance Show scope => Show (Path scope)
deriving instance Ord scope => Ord (Path scope)
deriving instance Generic (Path scope)
deriving instance NFData scope => NFData (Path scope)
-- Returns the declaration of a path.
pathDeclaration :: Path scope -> Declaration
@ -214,12 +218,12 @@ associatedScope declaration g@ScopeGraph{..} = go (Map.keys graph)
go [] = Nothing
newtype Reference = Reference { name :: Name }
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Generic, NFData)
newtype Declaration = Declaration { name :: Name }
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Generic, NFData)
-- | The type of edge from a scope to its parent scopes.
-- Either a lexical edge or an import edge in the case of non-lexical edges.
data EdgeLabel = Lexical | Import | Export
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Generic, NFData)

95
src/Data/Abstract/Value/Abstract.hs
View File

@ -1,11 +1,14 @@
{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Value.Abstract
( Abstract (..)
, runFunction
, runBoolean
, runWhile
) where
import Control.Abstract as Abstract
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.BaseError
import Data.Abstract.Environment as Env
import Prologue
@ -15,25 +18,26 @@ data Abstract = Abstract
deriving (Eq, Ord, Show)
runFunction :: ( Member (Allocator address) effects
, Member (Deref Abstract) effects
, Member (Exc (Return Abstract)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State Span) effects
, Member (State (ScopeGraph address)) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Resumable (BaseError (AddressError address Abstract))) effects
, Member (State (Heap address address Abstract)) effects
, Ord address
, PureEffects effects
)
=> Evaluator address Abstract (Function address Abstract ': effects) a
-> Evaluator address Abstract effects a
runFunction = interpret $ \case
Function name params _ body -> do
instance ( Member (Allocator address) sig
, Member (Deref Abstract) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (State Span) effects
, Member (State (ScopeGraph address)) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (Resumable (BaseError (AddressError address Abstract))) sig
, Member (State (Heap address address Abstract)) sig
, Ord address
, Carrier sig m
)
=> Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Eff m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
Function _ params body k -> runEvaluator $ do
functionSpan <- ask @Span -- TODO: This might be wrong
declare (Declaration name) functionSpan Nothing
currentScope' <- currentScope
@ -42,7 +46,7 @@ runFunction = interpret $ \case
currentFrame' <- currentFrame
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
functionFrame <- newFrame functionScope frameEdges
withScopeAndFrame functionFrame $ do
Evaluator . flip runFunctionC eval . k =<< withScopeAndFrame functionFrame $ do
-- TODO: Use scope graph and heap graph
for_ params $ \name -> do
span <- get @Span -- TODO: This span is probably wrong
@ -51,18 +55,30 @@ runFunction = interpret $ \case
-- assign tvar values to names in the frame of the function?
assign address Abstract
catchReturn (runFunction (Evaluator body))
Call _ _ params -> do
pure Abstract
BuiltIn _ k -> runFunctionC (k Abstract) eval
Call _ _ params k -> runEvaluator $ do
pure Abstract >>= Evaluator . flip runFunctionC eval . k) op)
runBoolean :: ( Member NonDet effects
, PureEffects effects
)
=> Evaluator address Abstract (Boolean Abstract ': effects) a
-> Evaluator address Abstract effects a
runBoolean = interpret $ \case
Boolean _ -> pure Abstract
AsBool _ -> pure True <|> pure False
Disjunction a b -> runBoolean (Evaluator (a <|> b))
instance (Carrier sig m, Alternative m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where
ret = BooleanC . ret
eff = BooleanC . handleSum (eff . handleCoercible) (\case
Boolean _ k -> runBooleanC (k Abstract)
AsBool _ k -> runBooleanC (k True) <|> runBooleanC (k False))
instance ( Member (Abstract.Boolean Abstract) sig
, Carrier sig m
, Alternative m
, Monad m
)
=> Carrier (While Abstract :+: sig) (WhileC Abstract m) where
ret = WhileC . ret
eff = WhileC . handleSum
(eff . handleCoercible)
(\ (Abstract.While cond body k) -> do
cond' <- runWhileC cond
ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)))
instance Ord address => ValueRoots address Abstract where
@ -83,14 +99,15 @@ instance AbstractIntro Abstract where
kvPair _ _ = Abstract
null = Abstract
instance ( Member (Allocator address) effects
, Member (Deref Abstract) effects
, Member Fresh effects
, Member NonDet effects
, Member (State (Heap address address Abstract)) effects
instance ( Member (Allocator address) sig
, Member (Deref Abstract) sig
, Member Fresh sig
, Member NonDet sig
, Member (State (Heap address address Abstract)) sig
, Ord address
, Carrier sig m
)
=> AbstractValue address Abstract effects where
=> AbstractValue term address Abstract m where
array _ = pure Abstract
tuple _ = pure Abstract
@ -116,6 +133,4 @@ instance ( Member (Allocator address) effects
liftComparison _ _ _ = pure Abstract
loop f = f empty
castToInteger _ = pure Abstract

376
src/Data/Abstract/Value/Concrete.hs
View File

@ -1,34 +1,36 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances, LambdaCase, ScopedTypeVariables #-}
{-# LANGUAGE DeriveAnyClass, GADTs, RankNTypes, TypeOperators, UndecidableInstances, LambdaCase, ScopedTypeVariables #-}
module Data.Abstract.Value.Concrete
( Value (..)
, ValueError (..)
, ClosureBody (..)
, runFunction
, runBoolean
, runValueError
, runValueErrorWith
) where
import Control.Abstract.ScopeGraph (Allocator)
import qualified Control.Abstract as Abstract
import Control.Abstract hiding (Boolean(..), Function(..))
import Control.Abstract hiding (Boolean(..), Function(..), While(..))
import Control.Effect.Carrier
import Control.Effect.Interpose
import Control.Effect.Sum
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable (UnspecializedError(..))
import Data.Abstract.Environment (Environment, Bindings, EvalContext(..))
import qualified Data.Abstract.Environment as Env
import Data.Abstract.FreeVariables
import Data.Abstract.Name
import qualified Data.Abstract.Number as Number
import Data.Bits
import Data.Coerce
import Data.List (genericIndex, genericLength)
import Data.Scientific (Scientific, coefficient, normalize)
import Data.Scientific.Exts
import qualified Data.Set as Set
import Data.Text (pack)
import Data.Word
import Prologue
import qualified Data.Map.Strict as Map
data Value address body
= Closure PackageInfo ModuleInfo Name [Name] (ClosureBody (Value address body) body) address
data Value term address
= Closure PackageInfo ModuleInfo Name [Name] (Either BuiltIn term) address
| Unit
| Boolean Bool
| Integer (Number.Number Integer)
@ -41,111 +43,140 @@ data Value address body
| Array [(Value address body)]
| Class Declaration [(Value address body)] address
| Namespace Name (Maybe address) (Bindings address)
| KVPair (Value address body) (Value address body)
| Hash [Value address body]
| KVPair (Value term address) (Value term address)
| Hash [Value term address]
| Null
| Hole
deriving (Eq, Ord, Show)
data ClosureBody value body = ClosureBody { closureBodyId :: Int, closureBody :: body value }
instance Eq (ClosureBody address body) where
(==) = (==) `on` closureBodyId
instance Ord (ClosureBody address body) where
compare = compare `on` closureBodyId
instance Show (ClosureBody address body) where
showsPrec d (ClosureBody i _) = showsUnaryWith showsPrec "ClosureBody" d i
deriving (Eq, Ord, Show, Generic, NFData)
instance Ord address => ValueRoots address (Value address body) where
instance Ord address => ValueRoots address (Value term address) where
valueRoots v
| Closure _ _ _ _ _ env <- v = undefined -- Env.addresses env
| otherwise = mempty
| otherwise = mempty
runFunction :: forall address effects body a. ( Member (Allocator address) effects
, Member (Deref (Value address body)) effects
, Member (Exc (Return (Value address body))) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (State Span) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (State (Heap address address (Value address body))) effects
, Member (State (ScopeGraph address)) effects
, Ord address
, PureEffects effects
)
=> (body (Value address body) -> Evaluator address (Value address body) (Abstract.Function address (Value address body) ': effects) (Value address body))
-> (Evaluator address (Value address body) (Abstract.Function address (Value address body) ': effects) (Value address body) -> body (Value address body))
-> Evaluator address (Value address body) (Abstract.Function address (Value address body) ': effects) a
-> Evaluator address (Value address body) effects a
runFunction toEvaluator fromEvaluator = interpret $ \case
Abstract.Function name params fvs body -> do
packageInfo <- currentPackage
moduleInfo <- currentModule
i <- fresh
-- TODO: Declare all params
span <- get @Span
declare (Declaration name) span Nothing
instance ( FreeVariables term
, Member (Allocator address) sig
, Member (Deref (Value term address)) sig
, Member (Env address) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (Resumable (BaseError (ValueError term address))) sig
, Member (State (Heap address (Value term address))) sig
, Member Trace sig
, Ord address
, Carrier sig m
, Show address
, Show term
)
=> Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Eff m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
Abstract.Function name params body k -> runEvaluator $ do
packageInfo <- currentPackage
moduleInfo <- currentModule
i <- fresh
-- TODO: Declare all params
span <- get @Span
declare (Declaration name) span Nothing
currentScope' <- currentScope
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
scope <- newScope lexicalEdges
currentScope' <- currentScope
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
scope <- newScope lexicalEdges
withScope scope $ do
for_ params $ \name -> do
span <- get @Span -- TODO: This is definitely wrong
declare (Declaration name) span Nothing
withScope scope $ do
for_ params $ \name -> do
span <- get @Span -- TODO: This is definitely wrong
declare (Declaration name) span Nothing
let closure = (Closure packageInfo moduleInfo name params (ClosureBody i (fromEvaluator (Evaluator body))) scope)
address <- lookupDeclaration (Declaration name)
assign address closure
pure closure
Abstract.Call op self params -> do
case op of
Closure packageInfo moduleInfo _ names (ClosureBody _ body) scope -> do
-- Evaluate the bindings and body with the closure’s package/module info in scope in order to
-- charge them to the closure's origin.
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
currentScope' <- currentScope
currentFrame' <- currentFrame
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
frameAddress <- newFrame scope frameEdges
withFrame frameAddress $ do
for_ (zip names params) $ \(name, param) -> do
addr <- lookupDeclaration (Declaration name)
assign addr param
catchReturn (runFunction toEvaluator fromEvaluator (toEvaluator body))
_ -> throwValueError (CallError op)
runBoolean :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, PureEffects effects
)
=> Evaluator address (Value address body) (Abstract.Boolean (Value address body) ': effects) a
-> Evaluator address (Value address body) effects a
runBoolean = interpret $ \case
Abstract.Boolean b -> pure $! Boolean b
Abstract.AsBool (Boolean b) -> pure b
Abstract.AsBool other -> throwValueError $! BoolError other
Abstract.Disjunction a b -> do
a' <- runBoolean (Evaluator a)
a'' <- runBoolean (asBool a')
if a'' then pure a' else runBoolean (Evaluator b)
let closure = (Closure packageInfo moduleInfo name params (Right body) scope)
address <- lookupDeclaration (Declaration name)
assign address closure
pure closure >>= Evaluator . flip runFunctionC eval . k
Abstract.BuiltIn builtIn k -> do
packageInfo <- currentPackage
moduleInfo <- currentModule
runFunctionC (k (Closure packageInfo moduleInfo Nothing [] (Left builtIn) lowerBound)) eval
Abstract.Call op self params k -> runEvaluator $ do
boxed <- case op of
Closure _ _ _ _ (Left Print) _ -> traverse (deref >=> trace . show) params *> pure Unit
Closure _ _ _ _ (Left Show) _ -> deref self >>= pure . String . pack . show
Closure packageInfo moduleInfo _ names (Right body) env -> do
-- Evaluate the bindings and body with the closure’s package/module info in scope in order to
-- charge them to the closure's origin.
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
currentScope' <- currentScope
currentFrame' <- currentFrame
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
frameAddress <- newFrame scope frameEdges
withFrame frameAddress $ do
for_ (zip names params) $ \(name, param) -> do
addr <- lookupDeclaration (Declaration name)
assign addr param
catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body)))
_ -> throwValueError (CallError op)
Evaluator $ runFunctionC (k boxed) eval) op)
instance AbstractHole (Value address body) where
instance ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (ValueError term address))) sig
, Carrier sig m
, Monad m
)
=> Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where
ret = BooleanC . ret
eff = BooleanC . handleSum (eff . handleCoercible) (\case
Abstract.Boolean b k -> runBooleanC . k $! Boolean b
Abstract.AsBool (Boolean b) k -> runBooleanC (k b)
Abstract.AsBool other k -> throwBaseError (BoolError other) >>= runBooleanC . k)
instance ( Carrier sig m
, Member (Deref (Value term address)) sig
, Member (Abstract.Boolean (Value term address)) sig
, Member (Error (LoopControl address)) sig
, Member (Interpose (Resumable (BaseError (UnspecializedError (Value term address))))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (State (Heap address (Value term address))) sig
, Ord address
, Show address
, Show term
)
=> Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff m)) where
ret = WhileC . ret
eff = WhileC . handleSum (eff . handleCoercible) (\case
Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) (runEvaluator (loop (\continue -> do
cond' <- Evaluator (runWhileC cond)
-- `interpose` is used to handle 'UnspecializedError's and abort out of the
-- loop, otherwise under concrete semantics we run the risk of the
-- conditional always being true and getting stuck in an infinite loop.
ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit))))
(\(Resumable (BaseError _ _ (UnspecializedError _)) _) -> throwError (Abort @address))
>>= runWhileC . k)
where
loop x = catchLoopControl @address (fix x) $ \case
Break value -> deref value
Abort -> pure unit
-- FIXME: Figure out how to deal with this. Ruby treats this as the result
-- of the current block iteration, while PHP specifies a breakout level
-- and TypeScript appears to take a label.
Continue _ -> loop x
instance AbstractHole (Value term address) where
hole = Hole
instance Show address => AbstractIntro (Value address body) where
instance (Show address, Show term) => AbstractIntro (Value term address) where
unit = Unit
integer = Integer . Number.Integer
string = String
@ -159,15 +190,16 @@ instance Show address => AbstractIntro (Value address body) where
null = Null
-- materializeEnvironment :: ( Member (Deref (Value address body)) effects
-- , Member (Reader ModuleInfo) effects
-- , Member (Reader Span) effects
-- , Member (Resumable (BaseError (AddressError address (Value address body)))) effects
-- , Member (State (Heap address address (Value address body))) effects
-- materializeEnvironment :: ( Member (Deref (Value term address)) sig
-- , Member (Reader ModuleInfo) sig
-- , Member (Reader Span) sig
-- , Member (Resumable (BaseError (AddressError address (Value term address)))) sig
-- , Member (State (Heap address (Value term address))) sig
-- , Ord address
-- , Carrier sig m
-- )
-- => Value address body
-- -> Evaluator address (Value address body) effects (Maybe (Environment address))
-- => Value term address
-- -> Evaluator term address (Value term address) m (Maybe (Environment address))
-- materializeEnvironment val = do
-- ancestors <- rec val
-- pure (Env.Environment <$> nonEmpty ancestors)
@ -175,36 +207,37 @@ instance Show address => AbstractIntro (Value address body) where
-- rec val = do
-- supers <- concat <$> traverse (deref >=> rec) (parents val)
-- pure . maybe [] (: supers) $ bindsFrom val
--
-- bindsFrom = \case
-- Class _ _ binds -> Just binds
-- Namespace _ _ binds -> Just binds
-- _ -> Nothing
--
-- parents = \case
-- Class _ supers _ -> supers
-- Namespace _ supers _ -> toList supers
-- _ -> []
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( Coercible body (Eff effects)
, Member (Allocator address) effects
, Member (Abstract.Boolean (Value address body)) effects
, Member (Deref (Value address body)) effects
, Member (Exc (LoopControl (Value address body))) effects
, Member (Exc (Return (Value address body))) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (State (Heap address address (Value address body))) effects
, Member Trace effects
instance ( Member (Allocator address) sig
, Member (Abstract.Boolean (Value term address)) sig
, Member (Deref (Value term address)) sig
, Member (Error (LoopControl address)) sig
, Member (Error (Return address)) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (ValueError term address))) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (State (Heap address address (Value term address))) sig
, Member Trace sig
, Ord address
, Show address
, Show term
, Carrier sig m
)
=> AbstractValue address (Value address body) effects where
=> AbstractValue term address (Value term address) m where
asPair val
| KVPair k v <- val = pure (k, v)
| otherwise = throwValueError $ KeyValueError val
@ -269,13 +302,9 @@ instance ( Coercible body (Eff effects)
tentative x i j = attemptUnsafeArithmetic (x i j)
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
specialize :: ( AbstractValue address (Value address body) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError address body))) effects
)
specialize :: AbstractValue term address (Value term address) m
=> Either ArithException Number.SomeNumber
-> Evaluator address (Value address body) effects (Value address body)
-> Evaluator term address (Value term address) m (Value term address)
specialize (Left exc) = throwValueError (ArithmeticError exc)
specialize (Right (Number.SomeNumber (Number.Integer i))) = pure $ integer i
specialize (Right (Number.SomeNumber (Number.Ratio r))) = pure $ rational r
@ -294,7 +323,7 @@ instance ( Coercible body (Eff effects)
where
-- Explicit type signature is necessary here because we're passing all sorts of things
-- to these comparison functions.
go :: (AbstractValue address (Value address body) effects, Member (Abstract.Boolean (Value address body)) effects, Ord a) => a -> a -> Evaluator address (Value address body) effects (Value address body)
go :: (AbstractValue term address (Value term address) m, Ord a) => a -> a -> Evaluator term address (Value term address) m (Value term address)
go l r = case comparator of
Concrete f -> boolean (f l r)
Generalized -> pure $ integer (orderingToInt (compare l r))
@ -324,36 +353,50 @@ instance ( Coercible body (Eff effects)
ourShift :: Word64 -> Int -> Integer
ourShift a b = toInteger (shiftR a b)
loop x = catchLoopControl (fix x) (\ control -> case control of
Break value -> pure value
-- FIXME: Figure out how to deal with this. Ruby treats this as the result of the current block iteration, while PHP specifies a breakout level and TypeScript appears to take a label.
Continue _ -> loop x)
castToInteger (Integer (Number.Integer i)) = pure (Integer (Number.Integer i))
castToInteger (Float (Number.Decimal i)) = pure (Integer (Number.Integer (coefficient (normalize i))))
castToInteger i = throwValueError (NumericError i)
-- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance.
data ValueError address body resume where
StringError :: Value address body -> ValueError address body Text
BoolError :: Value address body -> ValueError address body Bool
IndexError :: Value address body -> Value address body -> ValueError address body (Value address body)
NamespaceError :: Prelude.String -> ValueError address body (Bindings address)
CallError :: Value address body -> ValueError address body (Value address body)
NumericError :: Value address body -> ValueError address body (Value address body)
Numeric2Error :: Value address body -> Value address body -> ValueError address body (Value address body)
ComparisonError :: Value address body -> Value address body -> ValueError address body (Value address body)
BitwiseError :: Value address body -> ValueError address body (Value address body)
Bitwise2Error :: Value address body -> Value address body -> ValueError address body (Value address body)
KeyValueError :: Value address body -> ValueError address body (Value address body, Value address body)
ArrayError :: Value address body -> ValueError address body [(Value address body)]
data ValueError term address resume where
StringError :: Value term address -> ValueError term address Text
BoolError :: Value term address -> ValueError term address Bool
IndexError :: Value term address -> Value term address -> ValueError term address (Value term address)
NamespaceError :: Prelude.String -> ValueError term address (Bindings address)
CallError :: Value term address -> ValueError term address (Value term address)
NumericError :: Value term address -> ValueError term address (Value term address)
Numeric2Error :: Value term address -> Value term address -> ValueError term address (Value term address)
ComparisonError :: Value term address -> Value term address -> ValueError term address (Value term address)
BitwiseError :: Value term address -> ValueError term address (Value term address)
Bitwise2Error :: Value term address -> Value term address -> ValueError term address (Value term address)
KeyValueError :: Value term address -> ValueError term address (Value term address, Value term address)
ArrayError :: Value term address -> ValueError term address [(Value term address)]
-- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
ArithmeticError :: ArithException -> ValueError address body (Value address body)
ArithmeticError :: ArithException -> ValueError term address (Value term address)
-- Out-of-bounds error
BoundsError :: [Value address body] -> Prelude.Integer -> ValueError address body (Value address body)
BoundsError :: [Value term address] -> Prelude.Integer -> ValueError term address (Value term address)
instance (NFData term, NFData address) => NFData1 (ValueError term address) where
liftRnf _ x = case x of
StringError i -> rnf i
BoolError i -> rnf i
IndexError i j -> rnf i `seq` rnf j
NamespaceError i -> rnf i
CallError i -> rnf i
NumericError i -> rnf i
Numeric2Error i j -> rnf i `seq` rnf j
ComparisonError i j -> rnf i `seq` rnf j
BitwiseError i -> rnf i
Bitwise2Error i j -> rnf i `seq` rnf j
KeyValueError i -> rnf i
ArrayError i -> rnf i
ArithmeticError i -> i `seq` ()
BoundsError i j -> rnf i `seq` rnf j
instance Eq address => Eq1 (ValueError address body) where
instance (NFData term, NFData address, NFData resume) => NFData (ValueError term address resume) where
rnf = liftRnf rnf
instance (Eq address, Eq term) => Eq1 (ValueError term address) where
liftEq _ (StringError a) (StringError b) = a == b
liftEq _ (NamespaceError a) (NamespaceError b) = a == b
liftEq _ (CallError a) (CallError b) = a == b
@ -367,25 +410,26 @@ instance Eq address => Eq1 (ValueError address body) where
liftEq _ (BoundsError a b) (BoundsError c d) = (a == c) && (b == d)
liftEq _ _ _ = False
deriving instance Show address => Show (ValueError address body resume)
instance Show address => Show1 (ValueError address body) where
deriving instance (Show address, Show term) => Show (ValueError term address resume)
instance (Show address, Show term) => Show1 (ValueError term address) where
liftShowsPrec _ _ = showsPrec
runValueError :: (Effectful (m address (Value address body)), Effects effects)
=> m address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> m address (Value address body) effects (Either (SomeExc (BaseError (ValueError address body))) a)
runValueError = runResumable
runValueError :: (Carrier sig m, Effect sig)
=> Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) (Eff m)) a
-> Evaluator term address (Value term address) m (Either (SomeError (BaseError (ValueError term address))) a)
runValueError = Evaluator . runResumable . runEvaluator
runValueErrorWith :: (Effectful (m address (Value address body)), Effects effects)
=> (forall resume . BaseError (ValueError address body) resume -> m address (Value address body) effects resume)
-> m address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> m address (Value address body) effects a
runValueErrorWith = runResumableWith
runValueErrorWith :: Carrier sig m
=> (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume)
-> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff m)) a
-> Evaluator term address (Value term address) m a
runValueErrorWith f = Evaluator . runResumableWith (runEvaluator . f) . runEvaluator
throwValueError :: ( Member (Resumable (BaseError (ValueError address body))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
throwValueError :: ( Member (Resumable (BaseError (ValueError term address))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
)
=> ValueError address body resume
-> Evaluator address (Value address body) effects resume
=> ValueError term address resume
-> Evaluator term address (Value term address) m resume
throwValueError = throwBaseError

238
src/Data/Abstract/Value/Type.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances, LambdaCase, ScopedTypeVariables #-}
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Value.Type
( Type (..)
, TypeError (..)
@ -8,12 +8,15 @@ module Data.Abstract.Value.Type
, unify
, runFunction
, runBoolean
, runWhile
) where
import Control.Abstract.ScopeGraph
import qualified Control.Abstract as Abstract
import Control.Abstract hiding (Boolean(..), Function(..), raiseHandler)
import Control.Monad.Effect.Internal (raiseHandler)
import Control.Abstract hiding (Boolean(..), Function(..), While(..))
import Control.Effect.Carrier
import Control.Effect.Sum
import Data.Abstract.Environment as Env
import Data.Abstract.BaseError
import Data.Semigroup.Foldable (foldMap1)
import qualified Data.Map as Map
@ -86,40 +89,41 @@ instance Ord1 TypeError where
instance Show1 TypeError where liftShowsPrec _ _ = showsPrec
runTypeError :: (Effectful m, Effects effects) => m (Resumable (BaseError TypeError) ': effects) a -> m effects (Either (SomeExc (BaseError TypeError)) a)
runTypeError = runResumable
runTypeError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError TypeError) (Eff m)) a -> Evaluator term address value m (Either (SomeError (BaseError TypeError)) a)
runTypeError = raiseHandler runResumable
runTypeErrorWith :: (Effectful m, Effects effects) => (forall resume . (BaseError TypeError) resume -> m effects resume) -> m (Resumable (BaseError TypeError) ': effects) a -> m effects a
runTypeErrorWith = runResumableWith
runTypeErrorWith :: Carrier sig m => (forall resume . (BaseError TypeError) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError TypeError) (Eff m)) a -> Evaluator term address value m a
runTypeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f)
throwTypeError :: ( Member (Resumable (BaseError TypeError)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
throwTypeError :: ( Member (Resumable (BaseError TypeError)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Carrier sig m
, Monad m
)
=> TypeError resume
-> Evaluator address value effects resume
-> m resume
throwTypeError = throwBaseError
runTypeMap :: ( Effectful m
, Effects effects
)
=> m (State TypeMap ': effects) a
-> m effects a
runTypeMap = raiseHandler (runState emptyTypeMap >=> pure . snd)
runTypeMap :: (Carrier sig m, Effect sig)
=> Evaluator term address Type (StateC TypeMap (Eff m)) a
-> Evaluator term address Type m a
runTypeMap = raiseHandler $ fmap snd . runState emptyTypeMap
runTypes :: ( Effectful m
, Effects effects
)
=> m (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-> m effects (Either (SomeExc (BaseError TypeError)) a)
runTypes :: (Carrier sig m, Effect sig)
=> Evaluator term address Type (ResumableC (BaseError TypeError) (Eff
(StateC TypeMap (Eff
m)))) a
-> Evaluator term address Type m (Either (SomeError (BaseError TypeError)) a)
runTypes = runTypeMap . runTypeError
runTypesWith :: ( Effectful m
, Effects effects
)
=> (forall resume . (BaseError TypeError) resume -> m (State TypeMap ': effects) resume)
-> m (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-> m effects a
runTypesWith :: (Carrier sig m, Effect sig)
=> (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap (Eff m)) resume)
-> Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff
(StateC TypeMap (Eff
m)))) a
-> Evaluator term address Type m a
runTypesWith with = runTypeMap . runTypeErrorWith with
-- TODO: change my name?
@ -128,21 +132,22 @@ newtype TypeMap = TypeMap { unTypeMap :: Map.Map TName Type }
emptyTypeMap :: TypeMap
emptyTypeMap = TypeMap Map.empty
modifyTypeMap :: ( Effectful m
, Member (State TypeMap) effects
modifyTypeMap :: ( Member (State TypeMap) sig
, Carrier sig m
, Monad m
)
=> (Map.Map TName Type -> Map.Map TName Type)
-> m effects ()
-> m ()
modifyTypeMap f = modify (TypeMap . f . unTypeMap)
-- | Prunes substituted type variables
prune :: ( Effectful m
, Monad (m effects)
, Member (State TypeMap) effects
prune :: ( Member (State TypeMap) sig
, Carrier sig m
, Monad m
)
=> Type
-> m effects Type
prune (Var id) = Map.lookup id . unTypeMap <$> get >>= \case
-> m Type
prune (Var id) = gets (Map.lookup id . unTypeMap) >>= \case
Just ty -> do
pruned <- prune ty
modifyTypeMap (Map.insert id pruned)
@ -152,13 +157,13 @@ prune ty = pure ty
-- | Checks whether a type variable name occurs within another type. This
-- function is used in 'substitute' to prevent unification of infinite types
occur :: ( Effectful m
, Monad (m effects)
, Member (State TypeMap) effects
occur :: ( Member (State TypeMap) sig
, Carrier sig m
, Monad m
)
=> TName
-> Type
-> m effects Bool
-> m Bool
occur id = prune >=> \case
Int -> pure False
Bool -> pure False
@ -183,14 +188,16 @@ occur id = prune >=> \case
eitherM f (a, b) = (||) <$> f a <*> f b
-- | Substitutes a type variable name for another type
substitute :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State TypeMap) effects
substitute :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError TypeError)) sig
, Member (State TypeMap) sig
, Carrier sig m
, Monad m
)
=> TName
-> Type
-> Evaluator address value effects Type
-> m Type
substitute id ty = do
infiniteType <- occur id ty
ty <- if infiniteType
@ -200,14 +207,16 @@ substitute id ty = do
pure ty
-- | Unify two 'Type's.
unify :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State TypeMap) effects
unify :: ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError TypeError)) sig
, Member (State TypeMap) sig
, Carrier sig m
, Monad m
)
=> Type
-> Type
-> Evaluator address value effects Type
-> m Type
unify a b = do
a' <- prune a
b' <- prune b
@ -229,27 +238,27 @@ instance Ord address => ValueRoots address Type where
valueRoots _ = mempty
runFunction :: ( Member (Allocator address) effects
, Member (Deref Type) effects
, Member (Exc (Return Type)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (Resumable (BaseError (AddressError address Type))) effects
, Member (State (Heap address address Type)) effects
, Member (State (ScopeGraph address)) effects
, Member (Resumable (BaseError (ScopeError address))) effects
, Member (Resumable (BaseError (HeapError address))) effects
, Member (State TypeMap) effects
, Ord address
, PureEffects effects
)
=> Evaluator address Type (Abstract.Function address Type ': effects) a
-> Evaluator address Type effects a
runFunction = interpret $ \case
Abstract.Function name params _ body -> do
instance ( Member (Allocator address) sig
, Member (Deref Type) sig
, Member (Error (Return Type)) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (State Span) sig
, Member (Resumable (BaseError TypeError)) sig
, Member (Resumable (BaseError (AddressError address Type))) sig
, Member (State (Heap address address Type)) sig
, Member (State (ScopeGraph address)) sig
, Member (Resumable (BaseError (ScopeError address))) sig
, Member (Resumable (BaseError (HeapError address))) sig
, Member (State TypeMap) sig
, Ord address
, Carrier sig m
)
=> Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Eff m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case
Abstract.Function _ params body k -> runEvaluator $ do
functionSpan <- ask @Span -- TODO: This might be wrong
declare (Declaration name) functionSpan Nothing
@ -260,7 +269,7 @@ runFunction = interpret $ \case
let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame')
functionFrame <- newFrame functionScope frameEdges
-- TODO: Store the frame
withScopeAndFrame functionFrame $ do
let value = withScopeAndFrame functionFrame $ do
(_, tvars) <- foldr (\ name rest -> do
tvar <- Var <$> fresh
span <- get @Span -- TODO: This span is probably wrong
@ -270,29 +279,48 @@ runFunction = interpret $ \case
assign address tvar
bimap id (tvar :) <$> rest) (pure (undefined, [])) params
-- TODO: We may still want to represent this as a closure and not a function type
(zeroOrMoreProduct tvars :->) <$> (catchReturn (runFunction (Evaluator body)))
(catchReturn (runFunction (Evaluator body)))
value >>= Evaluator . flip runFunctionC eval . k . (zeroOrMoreProduct tvars :->)
Abstract.Call op _ paramTypes -> do
tvar <- fresh
let needed = zeroOrMoreProduct paramTypes :-> Var tvar
unified <- op `unify` needed
case unified of
_ :-> ret -> pure ret
actual -> throwTypeError (UnificationError needed actual)
Abstract.BuiltIn Print k -> runFunctionC (k (String :-> Unit)) eval
Abstract.BuiltIn Show k -> runFunctionC (k (Object :-> String)) eval
Abstract.Call op _ paramTypes k -> runEvaluator $ do
tvar <- fresh
let needed = zeroOrMoreProduct paramTypes :-> Var tvar
unified <- op `unify` needed
boxed <- case unified of
_ :-> ret -> pure ret
actual -> throwTypeError (UnificationError needed actual)
Evaluator $ runFunctionC (k boxed) eval) op)
runBoolean :: ( Member NonDet effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State TypeMap) effects
, PureEffects effects
)
=> Evaluator address Type (Abstract.Boolean Type ': effects) a
-> Evaluator address Type effects a
runBoolean = interpret $ \case
Abstract.Boolean _ -> pure Bool
Abstract.AsBool t -> unify t Bool *> (pure True <|> pure False)
Abstract.Disjunction t1 t2 -> (runBoolean (Evaluator t1) >>= unify Bool) <|> (runBoolean (Evaluator t2) >>= unify Bool)
instance ( Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError TypeError)) sig
, Member (State TypeMap) sig
, Carrier sig m
, Alternative m
, Monad m
)
=> Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where
ret = BooleanC . ret
eff = BooleanC . handleSum (eff . handleCoercible) (\case
Abstract.Boolean _ k -> runBooleanC (k Bool)
Abstract.AsBool t k -> unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False)))
instance ( Member (Abstract.Boolean Type) sig
, Carrier sig m
, Alternative m
, Monad m
)
=> Carrier (Abstract.While Type :+: sig) (WhileC Type m) where
ret = WhileC . ret
eff = WhileC . handleSum
(eff . handleCoercible)
(\ (Abstract.While cond body k) -> do
cond' <- runWhileC cond
ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit)))
instance AbstractHole Type where
@ -312,19 +340,19 @@ instance AbstractIntro Type where
null = Null
-- | Discard the value arguments (if any), constructing a 'Type' instead.
instance ( Member (Allocator address) effects
, Member (Deref Type) effects
, Member Fresh effects
, Member NonDet effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address Type))) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State (Heap address address Type)) effects
, Member (State TypeMap) effects
instance ( Member (Allocator address) sig
, Member (Deref Type) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (AddressError address Type))) sig
, Member (Resumable (BaseError TypeError)) sig
, Member (State (Heap address address Type)) sig
, Member (State TypeMap) sig
, Ord address
, Carrier sig m
)
=> AbstractValue address Type effects where
=> AbstractValue term address Type m where
array fieldTypes = do
var <- fresh
Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes
@ -371,6 +399,4 @@ instance ( Member (Allocator address) effects
(Int, Float) -> pure Int
_ -> unify left right $> Bool
loop f = f empty
castToInteger t = unify t (Int :+ Float :+ Rational) $> Int

43
src/Data/Algebra.hs
View File

@ -2,20 +2,12 @@
module Data.Algebra
( FAlgebra
, RAlgebra
, OpenFAlgebra
, OpenRAlgebra
, Subterm(..)
, SubtermAlgebra
, embedSubterm
, embedTerm
, foldSubterms
, fToR
, fToOpenR
, rToOpenR
, openFToOpenR
) where
import Data.Bifunctor
import Data.Functor.Classes.Generic as X
import Data.Functor.Foldable ( Base
, Corecursive(embed)
@ -35,25 +27,10 @@ type FAlgebra f a = f a -> a
-- See also 'FAlgebra'.
type RAlgebra f t a = f (t, a) -> a
-- | An open-recursive F-algebra on some 'Recursive' type @t@.
--
-- The recursion is “open” because instead of being applied from the leaves towards the root like a regular 'FAlgebra', the functor (@f@) is populated with the original values (@b@), and each is evaluated via the continuation (@(b -> a)@).
--
-- See also 'FAlgebra'.
type OpenFAlgebra f a = forall b . (b -> a) -> f b -> a
-- | An open-recursive R-algebra on some 'Recursive' type @t@.
--
-- See also 'RAlgebra' & 'OpenFAlgebra'.
type OpenRAlgebra f t a = forall b . (b -> (t, a)) -> f b -> a
-- | A subterm and its computed value, used in 'SubtermAlgebra'.
data Subterm t a = Subterm { subterm :: !t, subtermRef :: !a }
deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
instance Bifunctor Subterm where
bimap f g (Subterm a b) = Subterm (f a) (g b)
instance Eq t => Eq1 (Subterm t) where liftEq = genericLiftEq
instance Ord t => Ord1 (Subterm t) where liftCompare = genericLiftCompare
instance Show t => Show1 (Subterm t) where liftShowsPrec = genericLiftShowsPrec
@ -69,23 +46,3 @@ foldSubterms algebra = go where go = algebra . fmap (Subterm <*> go) . project
-- | Extract a term from the carrier tuple associated with a paramorphism. See also 'embedSubterm'.
embedTerm :: Corecursive t => Base t (t, a) -> t
embedTerm e = embed (fst <$> e)
-- | Extract a term from said term's 'Base' functor populated with 'Subterm' fields.
embedSubterm :: Corecursive t => Base t (Subterm t a) -> t
embedSubterm e = embed (subterm <$> e)
-- | Promote an 'FAlgebra' into an 'RAlgebra' (by dropping the original parameter).
fToR :: Functor (Base t) => FAlgebra (Base t) a -> RAlgebra (Base t) t a
fToR f = f . fmap snd
-- | Promote an 'FAlgebra' into an 'OpenRAlgebra' (by 'fmap'ing the action over the structure and dropping the original parameter).
fToOpenR :: Functor (Base t) => FAlgebra (Base t) a -> OpenRAlgebra (Base t) t a
fToOpenR alg f = alg . fmap (snd . f)
-- | Promote an 'RAlgebra' into an 'OpenRAlgebra' (by 'fmap'ing the action over the structure).
rToOpenR :: Functor f => RAlgebra f t a -> OpenRAlgebra f t a
rToOpenR alg f = alg . fmap f
-- | Promote an 'OpenFAlgebra' into an 'OpenRAlgebra' (by dropping the original parameter).
openFToOpenR :: OpenFAlgebra (Base t) a -> OpenRAlgebra (Base t) t a
openFToOpenR alg = alg . fmap snd

45
src/Data/Blob.hs
View File

@ -1,13 +1,17 @@
{-# LANGUAGE DeriveAnyClass #-}
module Data.Blob
( Blob(..)
, Blobs(..)
, decodeBlobs
, nullBlob
, sourceBlob
, noLanguageForBlob
, BlobPair
, These(..)
, blobPairDiffing
, blobPairInserting
, blobPairDeleting
, decodeBlobPairs
, languageForBlobPair
, languageTagForBlobPair
, pathForBlobPair
@ -15,22 +19,30 @@ module Data.Blob
) where
import Prologue
import Proto3.Suite
import Data.Aeson
import Control.Effect
import Control.Effect.Error
import Data.Aeson
import qualified Data.ByteString.Lazy as BL
import Proto3.Suite
import qualified Proto3.Wire.Decode as Decode
import qualified Proto3.Wire.Encode as Encode
import Data.JSON.Fields
import Data.Language
import Data.Source as Source
import qualified Proto3.Wire.Encode as Encode
import qualified Proto3.Wire.Decode as Decode
-- | The source, path, and language of a blob.
data Blob = Blob
{ blobSource :: Source -- ^ The UTF-8 encoded source text of the blob.
, blobPath :: FilePath -- ^ The file path to the blob.
{ blobSource :: Source -- ^ The UTF-8 encoded source text of the blob.
, blobPath :: FilePath -- ^ The file path to the blob.
, blobLanguage :: Language -- ^ The language of this blob.
}
deriving (Show, Eq, Generic, Message, Named)
newtype Blobs a = Blobs { blobs :: [a] }
deriving (Generic, FromJSON)
instance FromJSON Blob where
parseJSON = withObject "Blob" $ \b -> inferringLanguage
<$> b .: "content"
@ -48,6 +60,16 @@ inferringLanguage src pth lang
| knownLanguage lang = Blob src pth lang
| otherwise = Blob src pth (languageForFilePath pth)
decodeBlobs :: BL.ByteString -> Either String [Blob]
decodeBlobs = fmap blobs <$> eitherDecode
-- | An exception indicating that we’ve tried to diff or parse a blob of unknown language.
newtype NoLanguageForBlob = NoLanguageForBlob FilePath
deriving (Eq, Exception, Ord, Show, Typeable)
noLanguageForBlob :: (Member (Error SomeException) sig, Carrier sig m) => FilePath -> m a
noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
-- | Represents a blobs suitable for diffing which can be either a blob to
-- delete, a blob to insert, or a pair of blobs to diff.
type BlobPair = Join These Blob
@ -55,8 +77,8 @@ type BlobPair = Join These Blob
instance Message BlobPair where
encodeMessage _ pair = case pair of
(Join (These a b)) -> Encode.embedded 1 (encodeMessage 1 a) <> Encode.embedded 2 (encodeMessage 1 b)
(Join (This a)) -> Encode.embedded 1 (encodeMessage 1 a)
(Join (That b)) -> Encode.embedded 2 (encodeMessage 1 b)
(Join (This a)) -> Encode.embedded 1 (encodeMessage 1 a)
(Join (That b)) -> Encode.embedded 2 (encodeMessage 1 b)
decodeMessage _ = Join <$> (these <|> this <|> that)
where
embeddedAt parser = Decode.at (Decode.embedded'' parser)
@ -100,8 +122,8 @@ languageForBlobPair (Join (These a b))
= blobLanguage b
pathForBlobPair :: BlobPair -> FilePath
pathForBlobPair (Join (This Blob{..})) = blobPath
pathForBlobPair (Join (That Blob{..})) = blobPath
pathForBlobPair (Join (This Blob{..})) = blobPath
pathForBlobPair (Join (That Blob{..})) = blobPath
pathForBlobPair (Join (These _ Blob{..})) = blobPath
languageTagForBlobPair :: BlobPair -> [(String, String)]
@ -117,3 +139,6 @@ pathKeyForBlobPair blobs = case bimap blobPath blobPath (runJoin blobs) of
instance ToJSONFields Blob where
toJSONFields Blob{..} = [ "path" .= blobPath, "language" .= blobLanguage ]
decodeBlobPairs :: BL.ByteString -> Either String [BlobPair]
decodeBlobPairs = fmap blobs <$> eitherDecode

9
src/Data/Diff.hs
View File

@ -12,7 +12,6 @@ module Data.Diff
, mergeF
, merging
, diffPatches
, stripDiff
) where
import Data.Aeson
@ -23,7 +22,6 @@ import Data.Functor.Classes
import Data.Functor.Foldable
import Data.JSON.Fields
import Data.Patch
import Data.Record
import Data.Term
import Text.Show
import Prologue
@ -88,13 +86,6 @@ diffPatches = para $ \ diff -> case diff of
Merge merge -> foldMap snd merge
-- | Strips the head annotation off a diff annotated with non-empty records.
stripDiff :: Functor syntax
=> Diff syntax (Record (h1 ': t1)) (Record (h2 ': t2))
-> Diff syntax (Record t1) (Record t2)
stripDiff = bimap rtail rtail
type instance Base (Diff syntax ann1 ann2) = DiffF syntax ann1 ann2
instance Functor syntax => Recursive (Diff syntax ann1 ann2) where project = unDiff

66
src/Data/File.hs Normal file
View File

@ -0,0 +1,66 @@
{-# LANGUAGE RankNTypes #-}
module Data.File
( File (..)
, file
, toFile
, readBlobFromFile
, readBlobFromFile'
, readBlobsFromDir
, readFilePair
, maybeThese
) where
import Prologue
import qualified Data.ByteString as B
import System.FilePath.Glob
import System.FilePath.Posix
import Data.Blob
import Data.Language
import Data.Source
data File = File
{ filePath :: FilePath
, fileLanguage :: Language
} deriving (Eq, Ord, Show)
file :: FilePath -> File
file path = File path (languageForFilePath path)
where languageForFilePath = languageForType . takeExtension
-- This is kind of a wart; Blob and File should be two views of
-- the same higher-kinded datatype.
toFile :: Blob -> File
toFile (Blob _ p l) = File p l
-- | Read a utf8-encoded file to a 'Blob'.
readBlobFromFile :: forall m. MonadIO m => File -> m (Maybe Blob)
readBlobFromFile (File "/dev/null" _) = pure Nothing
readBlobFromFile (File path language) = do
raw <- liftIO $ B.readFile path
pure . Just . sourceBlob path language . fromUTF8 $ raw
-- | Read a utf8-encoded file to a 'Blob', raising an IOError if it can't be found.
readBlobFromFile' :: MonadIO m => File -> m Blob
readBlobFromFile' file = do
maybeFile <- readBlobFromFile file
maybeM (Prelude.fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile
readBlobsFromDir :: MonadIO m => FilePath -> m [Blob]
readBlobsFromDir path = do
paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
let paths' = fmap (\p -> File p (languageForFilePath p)) paths
blobs <- traverse readBlobFromFile paths'
pure (catMaybes blobs)
readFilePair :: forall m. (MonadFail m, MonadIO m) => File -> File -> m BlobPair
readFilePair a b = Join <$> join (maybeThese <$> readBlobFromFile a <*> readBlobFromFile b)
maybeThese :: MonadFail m => Maybe a -> Maybe b -> m (These a b)
maybeThese a b = case (a, b) of
(Just a, Nothing) -> pure (This a)
(Nothing, Just b) -> pure (That b)
(Just a, Just b) -> pure (These a b)
_ -> Prologue.fail "expected file pair with content on at least one side"

41
src/Data/Graph.hs
View File

@ -19,44 +19,24 @@ import qualified Algebra.Graph as G
import qualified Algebra.Graph.AdjacencyMap as A
import Algebra.Graph.Class (connect, overlay, vertex)
import qualified Algebra.Graph.Class as Class
import Control.Monad.Effect
import Control.Monad.Effect.State
import qualified Algebra.Graph.ToGraph as Class
import Control.Effect
import Control.Effect.State
import Data.Aeson
import qualified Data.Set as Set
-- | An algebraic graph with 'Ord', 'Semigroup', and 'Monoid' instances.
newtype Graph vertex = Graph { unGraph :: G.Graph vertex }
deriving (Alternative, Applicative, Eq, Foldable, Functor, Class.Graph, Monad, Show, Class.ToGraph, Traversable)
deriving (Alternative, Applicative, Eq, Foldable, Functor, Monad, Show, Class.Graph, Class.ToGraph, Traversable, NFData)
simplify :: Ord vertex => Graph vertex -> Graph vertex
simplify (Graph graph) = Graph (G.simplify graph)
-- | Sort a graph’s vertices topologically.
--
-- >>> topologicalSort (Class.path "ab")
-- "ba"
--
-- >>> topologicalSort (Class.path "abc")
-- "cba"
--
-- >>> topologicalSort ((vertex 'a' `connect` vertex 'b') `connect` vertex 'c')
-- "cba"
--
-- >>> topologicalSort (vertex 'a' `connect` (vertex 'b' `connect` vertex 'c'))
-- "cba"
--
-- >>> topologicalSort ((vertex 'a' `connect` vertex 'b') <> (vertex 'a' `connect` vertex 'c'))
-- "cba"
--
-- >>> topologicalSort (Class.path "abd" <> Class.path "acd")
-- "dcba"
--
-- >>> topologicalSort (Class.path "aba")
-- "ab"
-- | Sort a graph’s vertices topologically. Specced in @Data.Graph.Spec@.
topologicalSort :: forall v . Ord v => Graph v -> [v]
topologicalSort = go . toAdjacencyMap . G.transpose . unGraph
topologicalSort = go . Class.toAdjacencyMap . G.transpose . unGraph
where go :: A.AdjacencyMap v -> [v]
go graph
= visitedOrder . fst
@ -65,15 +45,15 @@ topologicalSort = go . toAdjacencyMap . G.transpose . unGraph
. traverse_ visit
. A.vertexList
$ graph
where visit :: v -> Eff '[State (Visited v)] ()
where visit :: (Member (State (Visited v)) sig, Carrier sig m, Monad m) => v -> m ()
visit v = do
isMarked <- Set.member v . visitedVertices <$> get
if isMarked then
pure ()
else do
modify' (extendVisited (Set.insert v))
modify (extendVisited (Set.insert v))
traverse_ visit (Set.toList (A.postSet v graph))
modify' (extendOrder (v :))
modify (extendOrder (v :))
data Visited v = Visited { visitedVertices :: !(Set v), visitedOrder :: [v] }
@ -83,9 +63,6 @@ extendVisited f (Visited a b) = Visited (f a) b
extendOrder :: ([v] -> [v]) -> Visited v -> Visited v
extendOrder f (Visited a b) = Visited a (f b)
toAdjacencyMap :: Ord v => G.Graph v -> A.AdjacencyMap v
toAdjacencyMap = Class.toGraph
vertexList :: Ord v => Graph v -> [v]
vertexList = G.vertexList . unGraph

34
src/Data/Graph/ControlFlowVertex.hs
View File

@ -22,7 +22,7 @@ import Data.Abstract.Package (PackageInfo (..))
import Data.Aeson
import Data.Graph (VertexTag (..))
import qualified Data.Graph as G
import Data.Record
import Data.Location
import Data.Span
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
@ -30,7 +30,7 @@ import qualified Data.Syntax.Expression as Expression
import Data.Term
import qualified Data.Text as T
import GHC.Exts (fromList)
import Prologue hiding (packageName)
import Prologue
import Proto3.Suite
import qualified Proto3.Suite as PB
import qualified Proto3.Wire.Encode as Encode
@ -43,7 +43,7 @@ data ControlFlowVertex
| Variable { vertexName :: Text, vertexModuleName :: Text, vertexSpan :: Span }
| Method { vertexName :: Text, vertexModuleName :: Text, vertexSpan :: Span }
| Function { vertexName :: Text, vertexModuleName :: Text, vertexSpan :: Span }
deriving (Eq, Ord, Show, Generic, Hashable, Named)
deriving (Eq, Ord, Show, Generic, Hashable, Named, NFData)
packageVertex :: PackageInfo -> ControlFlowVertex
packageVertex (PackageInfo name _) = Package (formatName name)
@ -155,20 +155,20 @@ instance Message (G.Edge ControlFlowVertex) where
-- 'Name's for terms with symbolic names like Identifiers and Declarations.
class VertexDeclaration syntax where
toVertex :: (Declarations1 syntax, Foldable syntax, HasField fields Span)
=> Record fields
toVertex :: (Declarations1 syntax, Foldable syntax)
=> Location
-> ModuleInfo
-> syntax (Term syntax (Record fields))
-> syntax (Term syntax Location)
-> Maybe (ControlFlowVertex, Name)
instance (VertexDeclaration' syntax syntax) => VertexDeclaration syntax where
toVertex = toVertex'
class VertexDeclaration' whole syntax where
toVertex' :: (Declarations1 whole, Foldable whole, HasField fields Span)
=> Record fields
toVertex' :: (Declarations1 whole, Foldable whole)
=> Location
-> ModuleInfo
-> syntax (Term whole (Record fields))
-> syntax (Term whole Location)
-> Maybe (ControlFlowVertex, Name)
instance (VertexDeclarationStrategy syntax ~ strategy, VertexDeclarationWithStrategy strategy whole syntax) => VertexDeclaration' whole syntax where
@ -185,11 +185,11 @@ type family VertexDeclarationStrategy syntax where
VertexDeclarationStrategy syntax = 'Default
class VertexDeclarationWithStrategy (strategy :: Strategy) whole syntax where
toVertexWithStrategy :: (Declarations1 whole, Foldable whole, HasField fields Span)
toVertexWithStrategy :: (Declarations1 whole, Foldable whole)
=> proxy strategy
-> Record fields
-> Location
-> ModuleInfo
-> syntax (Term whole (Record fields))
-> syntax (Term whole Location)
-> Maybe (ControlFlowVertex, Name)
-- | The 'Default' strategy produces 'Nothing'.
@ -200,16 +200,16 @@ instance Apply (VertexDeclaration' whole) fs => VertexDeclarationWithStrategy 'C
toVertexWithStrategy _ ann info = apply @(VertexDeclaration' whole) (toVertex' ann info)
instance VertexDeclarationWithStrategy 'Custom whole Syntax.Identifier where
toVertexWithStrategy _ ann info (Syntax.Identifier name) = Just (variableVertex (formatName name) info (getField ann), name)
toVertexWithStrategy _ ann info (Syntax.Identifier name) = Just (variableVertex (formatName name) info (locationSpan ann), name)
instance VertexDeclarationWithStrategy 'Custom whole Declaration.Function where
toVertexWithStrategy _ ann info term@Declaration.Function{} = (\n -> (functionVertex (formatName n) info (getField ann), n)) <$> liftDeclaredName declaredName term
toVertexWithStrategy _ ann info term@Declaration.Function{} = (\n -> (functionVertex (formatName n) info (locationSpan ann), n)) <$> liftDeclaredName declaredName term
instance VertexDeclarationWithStrategy 'Custom whole Declaration.Method where
toVertexWithStrategy _ ann info term@Declaration.Method{} = (\n -> (methodVertex (formatName n) info (getField ann), n)) <$> liftDeclaredName declaredName term
toVertexWithStrategy _ ann info term@Declaration.Method{} = (\n -> (methodVertex (formatName n) info (locationSpan ann), n)) <$> liftDeclaredName declaredName term
instance VertexDeclarationWithStrategy 'Custom whole whole => VertexDeclarationWithStrategy 'Custom whole Expression.MemberAccess where
toVertexWithStrategy proxy ann info (Expression.MemberAccess (Term (In lhsAnn lhs)) name) =
case toVertexWithStrategy proxy lhsAnn info lhs of
Just (Variable n _ _, _) -> Just (variableVertex (n <> "." <> formatName name) info (getField ann), name)
_ -> Just (variableVertex (formatName name) info (getField ann), name)
Just (Variable n _ _, _) -> Just (variableVertex (n <> "." <> formatName name) info (locationSpan ann), name)
_ -> Just (variableVertex (formatName name) info (locationSpan ann), name)

60
src/Data/Handle.hs Normal file
View File

@ -0,0 +1,60 @@
{-# LANGUAGE GADTs #-}
module Data.Handle
( Handle (..)
, getHandle
, stdin
, stdout
, stderr
, readBlobsFromHandle
, readBlobPairsFromHandle
, readFromHandle
, openFileForReading
) where
import Prologue
import Data.Aeson
import qualified Data.ByteString.Lazy as BL
import System.Exit
import qualified System.IO as IO
import Data.Blob
data Handle mode where
ReadHandle :: IO.Handle -> Handle 'IO.ReadMode
WriteHandle :: IO.Handle -> Handle 'IO.WriteMode
deriving instance Eq (Handle mode)
deriving instance Show (Handle mode)
getHandle :: Handle mode -> IO.Handle
getHandle (ReadHandle handle) = handle
getHandle (WriteHandle handle) = handle
stdin :: Handle 'IO.ReadMode
stdin = ReadHandle IO.stdin
stdout :: Handle 'IO.WriteMode
stdout = WriteHandle IO.stdout
stderr :: Handle 'IO.WriteMode
stderr = WriteHandle IO.stderr
openFileForReading :: FilePath -> IO (Handle 'IO.ReadMode)
openFileForReading path = ReadHandle <$> IO.openFile path IO.ReadMode
-- | Read JSON encoded blobs from a handle.
readBlobsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob]
readBlobsFromHandle = fmap blobs <$> readFromHandle
-- | Read JSON encoded blob pairs from a handle.
readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
readBlobPairsFromHandle = fmap blobs <$> readFromHandle
readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a
readFromHandle (ReadHandle h) = do
input <- liftIO $ BL.hGetContents h
case eitherDecode input of
Left e -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
Right d -> pure d

20
src/Data/History.hs
View File

@ -6,8 +6,7 @@ module Data.History
, remark
) where
import Data.Record
import Data.Range
import Data.Location
-- | 'History' values, when attached to a given 'Term', describe the ways in
-- which that term was modified during a refactoring pass, if any.
@ -22,17 +21,16 @@ data History
-- | Convert a 'Term' annotated with a 'Range' to one annotated with a 'History'.
mark :: Functor f
=> (Range -> History)
-> f (Record (Range ': fields))
-> f (Record (History ': fields))
mark f = fmap go where go (r :. a) = f r :. a
-> f Location
-> f History
mark f = fmap (f . locationByteRange)
-- | Change the 'History' annotation on a 'Term'.
remark :: Functor f
=> (Range -> History)
-> f (Record (History ': fields))
-> f (Record (History ': fields))
-> f History
-> f History
remark f = fmap go where
go (r :. a) = x :. a where
x = case r of
Refactored r -> f r
Unmodified r -> f r
go h = case h of
Refactored l -> f l
Unmodified l -> f l

Some files were not shown because too many files have changed in this diff Show More