diff --git a/.ghci b/.ghci index 18b1832d2..639be4528 100644 --- a/.ghci +++ b/.ghci @@ -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 diff --git a/.gitmodules b/.gitmodules index ab0a3b52a..ec2d6059a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -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 diff --git a/.licenses/semantic/cabal/vector-th-unbox.txt b/.licenses/semantic/cabal/MonadRandom.txt similarity index 82% rename from .licenses/semantic/cabal/vector-th-unbox.txt rename to .licenses/semantic/cabal/MonadRandom.txt index f620b6c8b..1942db1cb 100644 --- a/.licenses/semantic/cabal/vector-th-unbox.txt +++ b/.licenses/semantic/cabal/MonadRandom.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/StateVar.txt b/.licenses/semantic/cabal/StateVar.txt index d4a5831f7..c88c2cded 100644 --- a/.licenses/semantic/cabal/StateVar.txt +++ b/.licenses/semantic/cabal/StateVar.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/algebraic-graphs.txt b/.licenses/semantic/cabal/algebraic-graphs.txt index ea964a517..7cfa147c4 100644 --- a/.licenses/semantic/cabal/algebraic-graphs.txt +++ b/.licenses/semantic/cabal/algebraic-graphs.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/ansi-terminal.txt b/.licenses/semantic/cabal/ansi-terminal.txt index e454763f9..b2902b86f 100644 --- a/.licenses/semantic/cabal/ansi-terminal.txt +++ b/.licenses/semantic/cabal/ansi-terminal.txt @@ -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. \ No newline at end of file +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. diff --git a/.licenses/semantic/cabal/basement.txt b/.licenses/semantic/cabal/basement.txt index 5acb74860..5895ff0b2 100644 --- a/.licenses/semantic/cabal/basement.txt +++ b/.licenses/semantic/cabal/basement.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/cereal.txt b/.licenses/semantic/cabal/cereal.txt index b1ed9aed0..996e67246 100644 --- a/.licenses/semantic/cabal/cereal.txt +++ b/.licenses/semantic/cabal/cereal.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/cmark-gfm.txt b/.licenses/semantic/cabal/cmark-gfm.txt index f9d254976..26ea8021e 100644 --- a/.licenses/semantic/cabal/cmark-gfm.txt +++ b/.licenses/semantic/cabal/cmark-gfm.txt @@ -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 diff --git a/.licenses/semantic/cabal/dlist.txt b/.licenses/semantic/cabal/dlist.txt index 2a0879a1c..c048d8f4c 100644 --- a/.licenses/semantic/cabal/dlist.txt +++ b/.licenses/semantic/cabal/dlist.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/fastsum.txt b/.licenses/semantic/cabal/fastsum.txt index 9c2fb6960..2f5158b66 100644 --- a/.licenses/semantic/cabal/fastsum.txt +++ b/.licenses/semantic/cabal/fastsum.txt @@ -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 diff --git a/.licenses/semantic/cabal/foldl.txt b/.licenses/semantic/cabal/foldl.txt index 79f52cc9e..6e21ad152 100644 --- a/.licenses/semantic/cabal/foldl.txt +++ b/.licenses/semantic/cabal/foldl.txt @@ -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 diff --git a/.licenses/semantic/cabal/foundation.txt b/.licenses/semantic/cabal/foundation.txt deleted file mode 100644 index ca08d2c28..000000000 --- a/.licenses/semantic/cabal/foundation.txt +++ /dev/null @@ -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 -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. diff --git a/.licenses/semantic/cabal/math-functions.txt b/.licenses/semantic/cabal/fused-effects.txt similarity index 68% rename from .licenses/semantic/cabal/math-functions.txt rename to .licenses/semantic/cabal/fused-effects.txt index d9ab9f393..f9130ee89 100644 --- a/.licenses/semantic/cabal/math-functions.txt +++ b/.licenses/semantic/cabal/fused-effects.txt @@ -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 diff --git a/.licenses/semantic/cabal/ghc-typelits-extra.txt b/.licenses/semantic/cabal/ghc-typelits-extra.txt index 45883551c..4af508430 100644 --- a/.licenses/semantic/cabal/ghc-typelits-extra.txt +++ b/.licenses/semantic/cabal/ghc-typelits-extra.txt @@ -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 diff --git a/.licenses/semantic/cabal/ghc-typelits-knownnat.txt b/.licenses/semantic/cabal/ghc-typelits-knownnat.txt index 648e54960..7d6798624 100644 --- a/.licenses/semantic/cabal/ghc-typelits-knownnat.txt +++ b/.licenses/semantic/cabal/ghc-typelits-knownnat.txt @@ -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 diff --git a/.licenses/semantic/cabal/ghc-typelits-natnormalise.txt b/.licenses/semantic/cabal/ghc-typelits-natnormalise.txt index 97170d80b..c6785312d 100644 --- a/.licenses/semantic/cabal/ghc-typelits-natnormalise.txt +++ b/.licenses/semantic/cabal/ghc-typelits-natnormalise.txt @@ -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 diff --git a/.licenses/semantic/cabal/haskeline.txt b/.licenses/semantic/cabal/haskeline.txt index b3e6a5259..c65bc1c34 100644 --- a/.licenses/semantic/cabal/haskeline.txt +++ b/.licenses/semantic/cabal/haskeline.txt @@ -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 diff --git a/.licenses/semantic/cabal/haskell-lexer.txt b/.licenses/semantic/cabal/haskell-lexer.txt index a11b919cd..b4e5faab0 100644 --- a/.licenses/semantic/cabal/haskell-lexer.txt +++ b/.licenses/semantic/cabal/haskell-lexer.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/hourglass.txt b/.licenses/semantic/cabal/hourglass.txt index 780ee9a5e..063d30b8e 100644 --- a/.licenses/semantic/cabal/hourglass.txt +++ b/.licenses/semantic/cabal/hourglass.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/http-media.txt b/.licenses/semantic/cabal/http-media.txt index 746cf018d..1013aec70 100644 --- a/.licenses/semantic/cabal/http-media.txt +++ b/.licenses/semantic/cabal/http-media.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/http-types.txt b/.licenses/semantic/cabal/http-types.txt index d46e4d174..edff5095d 100644 --- a/.licenses/semantic/cabal/http-types.txt +++ b/.licenses/semantic/cabal/http-types.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/integer-logarithms.txt b/.licenses/semantic/cabal/integer-logarithms.txt index e22678e34..2169bbc90 100644 --- a/.licenses/semantic/cabal/integer-logarithms.txt +++ b/.licenses/semantic/cabal/integer-logarithms.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/invariant.txt b/.licenses/semantic/cabal/invariant.txt index 56dead591..05ae0b45e 100644 --- a/.licenses/semantic/cabal/invariant.txt +++ b/.licenses/semantic/cabal/invariant.txt @@ -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 diff --git a/.licenses/semantic/cabal/memory.txt b/.licenses/semantic/cabal/memory.txt index 71c3649be..aef83462c 100644 --- a/.licenses/semantic/cabal/memory.txt +++ b/.licenses/semantic/cabal/memory.txt @@ -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 +Copyright (c) 2015-2018 Vincent Hanquez +Copyright (c) 2017-2018 Nicolas Di Prima 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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/mwc-random.txt b/.licenses/semantic/cabal/mwc-random.txt index 4dcd6661c..0a916cb09 100644 --- a/.licenses/semantic/cabal/mwc-random.txt +++ b/.licenses/semantic/cabal/mwc-random.txt @@ -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 diff --git a/.licenses/semantic/cabal/optparse-applicative.txt b/.licenses/semantic/cabal/optparse-applicative.txt index 056bb64fd..098fe0095 100644 --- a/.licenses/semantic/cabal/optparse-applicative.txt +++ b/.licenses/semantic/cabal/optparse-applicative.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/parallel.txt b/.licenses/semantic/cabal/parallel.txt index 6c1187a0a..e4959295c 100644 --- a/.licenses/semantic/cabal/parallel.txt +++ b/.licenses/semantic/cabal/parallel.txt @@ -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. ------------------------------------------------------------------------------ +----------------------------------------------------------------------------- \ No newline at end of file diff --git a/.licenses/semantic/cabal/quickcheck-instances.txt b/.licenses/semantic/cabal/quickcheck-instances.txt index ca3b0d89f..22755f8b7 100644 --- a/.licenses/semantic/cabal/quickcheck-instances.txt +++ b/.licenses/semantic/cabal/quickcheck-instances.txt @@ -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 diff --git a/.licenses/semantic/cabal/stm.txt b/.licenses/semantic/cabal/stm.txt index f9e939a80..31b7164ea 100644 --- a/.licenses/semantic/cabal/stm.txt +++ b/.licenses/semantic/cabal/stm.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/system-fileio.txt b/.licenses/semantic/cabal/system-fileio.txt index 4fabfcc5d..459bf70d9 100644 --- a/.licenses/semantic/cabal/system-fileio.txt +++ b/.licenses/semantic/cabal/system-fileio.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/text.txt b/.licenses/semantic/cabal/text.txt index 02bde9312..4a00a5f94 100644 --- a/.licenses/semantic/cabal/text.txt +++ b/.licenses/semantic/cabal/text.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/these.txt b/.licenses/semantic/cabal/these.txt index fdf952411..859f6e3f7 100644 --- a/.licenses/semantic/cabal/these.txt +++ b/.licenses/semantic/cabal/these.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/time-locale-compat.txt b/.licenses/semantic/cabal/time-locale-compat.txt index 62f7aa1ec..6b468a273 100644 --- a/.licenses/semantic/cabal/time-locale-compat.txt +++ b/.licenses/semantic/cabal/time-locale-compat.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/turtle.txt b/.licenses/semantic/cabal/turtle.txt index fe13fc082..9601ec42e 100644 --- a/.licenses/semantic/cabal/turtle.txt +++ b/.licenses/semantic/cabal/turtle.txt @@ -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 diff --git a/.licenses/semantic/cabal/unix-compat.txt b/.licenses/semantic/cabal/unix-compat.txt index 77a13c922..826bb78ea 100644 --- a/.licenses/semantic/cabal/unix-compat.txt +++ b/.licenses/semantic/cabal/unix-compat.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/vector-builder.txt b/.licenses/semantic/cabal/vector-builder.txt index 627b8ba54..1e6cd9787 100644 --- a/.licenses/semantic/cabal/vector-builder.txt +++ b/.licenses/semantic/cabal/vector-builder.txt @@ -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. \ No newline at end of file diff --git a/.licenses/semantic/cabal/x509.txt b/.licenses/semantic/cabal/x509.txt index bf711cf7c..c0999bc09 100644 --- a/.licenses/semantic/cabal/x509.txt +++ b/.licenses/semantic/cabal/x509.txt @@ -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. \ No newline at end of file diff --git a/bench/Main.hs b/bench/evaluation/Main.hs similarity index 83% rename from bench/Main.hs rename to bench/evaluation/Main.hs index 8c16435f6..2eb122822 100644 --- a/bench/Main.hs +++ b/bench/evaluation/Main.hs @@ -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 diff --git a/semantic.cabal b/semantic.cabal index 43710e719..65e9e7bb7 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -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 diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs deleted file mode 100644 index 774f8742f..000000000 --- a/src/Analysis/Abstract/Caching.hs +++ /dev/null @@ -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 diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs new file mode 100644 index 000000000..5a71c26e4 --- /dev/null +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -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 diff --git a/src/Analysis/Abstract/Caching/FlowSensitive.hs b/src/Analysis/Abstract/Caching/FlowSensitive.hs new file mode 100644 index 000000000..63de56b6c --- /dev/null +++ b/src/Analysis/Abstract/Caching/FlowSensitive.hs @@ -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 diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 9f350e941..72f72d58b 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -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) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 35e8e7198..799b5889d 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -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 diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index e3e78ed8b..cec4a96a2 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -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 diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 73c65b459..4ba6d9e6f 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -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) diff --git a/src/Analysis/ConstructorName.hs b/src/Analysis/ConstructorName.hs index df233b44f..7ec370049 100644 --- a/src/Analysis/ConstructorName.hs +++ b/src/Analysis/ConstructorName.hs @@ -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. diff --git a/src/Analysis/Declaration.hs b/src/Analysis/Declaration.hs index 991fbadcf..178a8176f 100644 --- a/src/Analysis/Declaration.hs +++ b/src/Analysis/Declaration.hs @@ -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 diff --git a/src/Analysis/Decorator.hs b/src/Analysis/Decorator.hs index 7769addd4..413ad7b16 100644 --- a/src/Analysis/Decorator.hs +++ b/src/Analysis/Decorator.hs @@ -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) diff --git a/src/Analysis/PackageDef.hs b/src/Analysis/PackageDef.hs index 4696666d9..149a7ecb9 100644 --- a/src/Analysis/PackageDef.hs +++ b/src/Analysis/PackageDef.hs @@ -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. diff --git a/src/Assigning/Assignment.hs b/src/Assigning/Assignment.hs index 0d1da6604..b77465a34 100644 --- a/src/Assigning/Assignment.hs +++ b/src/Assigning/Assignment.hs @@ -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 diff --git a/src/Assigning/Assignment/Deterministic.hs b/src/Assigning/Assignment/Deterministic.hs index 9f6082eb5..b1fcc8d64 100644 --- a/src/Assigning/Assignment/Deterministic.hs +++ b/src/Assigning/Assignment/Deterministic.hs @@ -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 diff --git a/src/Control/Abstract.hs b/src/Control/Abstract.hs index 6d2a2aa05..486480038 100644 --- a/src/Control/Abstract.hs +++ b/src/Control/Abstract.hs @@ -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 diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs deleted file mode 100644 index abae33ddc..000000000 --- a/src/Control/Abstract/Configuration.hs +++ /dev/null @@ -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 diff --git a/src/Control/Abstract/Context.hs b/src/Control/Abstract/Context.hs index 1581dec06..0195977e8 100644 --- a/src/Control/Abstract/Context.hs +++ b/src/Control/Abstract/Context.hs @@ -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 diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 2d29cce2a..56275b86f 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -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 diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index a7e34c96e..6ff3b37f4 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -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 diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 89c026256..d32214106 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -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) diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index ac7c6dda5..d602a8f77 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -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 diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index c1661e8d4..8d5075db7 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -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) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index 5fe96ccfa..269e372da 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -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)) diff --git a/src/Control/Abstract/Roots.hs b/src/Control/Abstract/Roots.hs index b39e428c1..20ea02ed1 100644 --- a/src/Control/Abstract/Roots.hs +++ b/src/Control/Abstract/Roots.hs @@ -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) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 0039378e9..3dc95c519 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -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 diff --git a/src/Control/Abstract/TermEvaluator.hs b/src/Control/Abstract/TermEvaluator.hs deleted file mode 100644 index 8d448ef5c..000000000 --- a/src/Control/Abstract/TermEvaluator.hs +++ /dev/null @@ -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 diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 3b5cc221b..a34d4189f 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -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) diff --git a/src/Control/Effect/Interpose.hs b/src/Control/Effect/Interpose.hs new file mode 100644 index 000000000..553f9cf26 --- /dev/null +++ b/src/Control/Effect/Interpose.hs @@ -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) diff --git a/src/Control/Effect/REPL.hs b/src/Control/Effect/REPL.hs new file mode 100644 index 000000000..aafe3ba1d --- /dev/null +++ b/src/Control/Effect/REPL.hs @@ -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" diff --git a/src/Control/Abstract/Matching.hs b/src/Control/Matching.hs similarity index 97% rename from src/Control/Abstract/Matching.hs rename to src/Control/Matching.hs index eeb4b8b4e..a25c2c23d 100644 --- a/src/Control/Abstract/Matching.hs +++ b/src/Control/Matching.hs @@ -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' diff --git a/src/Control/Rewriting.hs b/src/Control/Rewriting.hs new file mode 100644 index 000000000..2758028ea --- /dev/null +++ b/src/Control/Rewriting.hs @@ -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)) diff --git a/src/Data/AST.hs b/src/Data/AST.hs index 79e0e8c62..30d482cd5 100644 --- a/src/Data/AST.hs +++ b/src/Data/AST.hs @@ -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 diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs index 6feb5219f..85a6dfa1b 100644 --- a/src/Data/Abstract/Address/Hole.hs +++ b/src/Data/Abstract/Address/Hole.hs @@ -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) diff --git a/src/Data/Abstract/Address/Located.hs b/src/Data/Abstract/Address/Located.hs index 36fcd3d90..4604c77e1 100644 --- a/src/Data/Abstract/Address/Located.hs +++ b/src/Data/Abstract/Address/Located.hs @@ -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) diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs index 55e35edb6..bb2a430fa 100644 --- a/src/Data/Abstract/Address/Monovariant.hs +++ b/src/Data/Abstract/Address/Monovariant.hs @@ -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))) diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index 9159e79e6..1b1611429 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -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))) diff --git a/src/Data/Abstract/BaseError.hs b/src/Data/Abstract/BaseError.hs index 92f33c924..62b65ed58 100644 --- a/src/Data/Abstract/BaseError.hs +++ b/src/Data/Abstract/BaseError.hs @@ -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 diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs deleted file mode 100644 index e72a42911..000000000 --- a/src/Data/Abstract/Cache.hs +++ /dev/null @@ -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 diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs deleted file mode 100644 index a5c9577b9..000000000 --- a/src/Data/Abstract/Configuration.hs +++ /dev/null @@ -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) diff --git a/src/Data/Abstract/Declarations.hs b/src/Data/Abstract/Declarations.hs index 494db37e0..77b00102d 100644 --- a/src/Data/Abstract/Declarations.hs +++ b/src/Data/Abstract/Declarations.hs @@ -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 diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 82a09040e..1e0ecfaf1 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -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 diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 4d6db5624..22d89f5ee 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -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 ""))) + 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 diff --git a/src/Data/Abstract/FreeVariables.hs b/src/Data/Abstract/FreeVariables.hs index 0010904e2..637936c26 100644 --- a/src/Data/Abstract/FreeVariables.hs +++ b/src/Data/Abstract/FreeVariables.hs @@ -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 diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index 44d777bda..cb08e8987 100644 --- a/src/Data/Abstract/Heap.hs +++ b/src/Data/Abstract/Heap.hs @@ -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 diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index 5d495ecbf..c1f6f37fb 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -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 diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index 5efcc0ca9..773efad03 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -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 diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index ddfee1e89..dc6cd96a0 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -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 '"' diff --git a/src/Data/Abstract/Number.hs b/src/Data/Abstract/Number.hs index f03dcf8f7..a8ce0beb0 100644 --- a/src/Data/Abstract/Number.hs +++ b/src/Data/Abstract/Number.hs @@ -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 diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 529599b16..d5cfd349b 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -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 diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index d9c5aea45..f5dd9d4b3 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -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) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 1746ea90c..8a931ccb4 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -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 diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 46c1abfc2..d3c607955 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -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 diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 120f3fd8d..c1429edc6 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -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 diff --git a/src/Data/Algebra.hs b/src/Data/Algebra.hs index 6e6a1df7e..738a4d61c 100644 --- a/src/Data/Algebra.hs +++ b/src/Data/Algebra.hs @@ -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 diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index c29a17669..12779922c 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -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 diff --git a/src/Data/Diff.hs b/src/Data/Diff.hs index f33396281..73f33c6a6 100644 --- a/src/Data/Diff.hs +++ b/src/Data/Diff.hs @@ -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 diff --git a/src/Data/File.hs b/src/Data/File.hs new file mode 100644 index 000000000..a4b4667b8 --- /dev/null +++ b/src/Data/File.hs @@ -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" diff --git a/src/Data/Graph.hs b/src/Data/Graph.hs index dd97b167e..e48ce0a95 100644 --- a/src/Data/Graph.hs +++ b/src/Data/Graph.hs @@ -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 diff --git a/src/Data/Graph/ControlFlowVertex.hs b/src/Data/Graph/ControlFlowVertex.hs index 906f9e214..03a644860 100644 --- a/src/Data/Graph/ControlFlowVertex.hs +++ b/src/Data/Graph/ControlFlowVertex.hs @@ -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) diff --git a/src/Data/Handle.hs b/src/Data/Handle.hs new file mode 100644 index 000000000..2792cc4cb --- /dev/null +++ b/src/Data/Handle.hs @@ -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 diff --git a/src/Data/History.hs b/src/Data/History.hs index 2602d0a7c..c2c052cbc 100644 --- a/src/Data/History.hs +++ b/src/Data/History.hs @@ -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 diff --git a/src/Data/JSON/Fields.hs b/src/Data/JSON/Fields.hs index b4b8dcf18..2014a3d4c 100644 --- a/src/Data/JSON/Fields.hs +++ b/src/Data/JSON/Fields.hs @@ -12,6 +12,7 @@ import Data.Aeson import qualified Data.Map as Map import Data.Sum (Apply (..), Sum) import qualified Data.Text as Text +import GHC.Generics import Prologue class ToJSONFields a where diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 8770f2426..37e24c901 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -33,7 +33,7 @@ data Language | Ruby | TypeScript | PHP - deriving (Eq, Generic, Ord, Read, Show, Bounded, Hashable, ToJSON, Named, Enum, MessageField) + deriving (Eq, Generic, Ord, Read, Show, Bounded, Hashable, ToJSON, Named, Enum, MessageField, NFData) class SLanguage (lang :: Language) where reflect :: proxy lang -> Language diff --git a/src/Data/Location.hs b/src/Data/Location.hs new file mode 100644 index 000000000..64f84957b --- /dev/null +++ b/src/Data/Location.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Data.Location + ( Location(..) + , Span(..) + , Range(..) + ) where + +import Prologue (Generic, NFData (..)) + +import Data.JSON.Fields +import Data.Range +import Data.Span + +data Location + = Location + { locationByteRange :: {-# UNPACK #-} Range + , locationSpan :: {-# UNPACK #-} Span + } + deriving (Eq, Ord, Show, Generic, NFData) + +instance ToJSONFields Location where + toJSONFields Location{..} = toJSONFields locationByteRange <> toJSONFields locationSpan + +instance Semigroup Location where + (Location r1 sp1) <> (Location r2 sp2) = Location (r1 <> r2) (sp1 <> sp2) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 3711fd1b2..50e234656 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -20,7 +20,7 @@ import Prelude hiding (lookup) import Prologue hiding (Map) newtype Map key value = Map { unMap :: Map.Map key value } - deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, ToJSON, Traversable) + deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, ToJSON, Traversable, NFData) singleton :: key -> value -> Map key value diff --git a/src/Data/Project.hs b/src/Data/Project.hs index da3684e2f..cd9530e48 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -11,21 +11,21 @@ module Data.Project ( , projectName , projectFiles , readFile - -- * Files - , File (..) - , file + , readProjectFromPaths ) where import Prelude hiding (readFile) -import Prologue hiding (throwError) +import Prologue -import Control.Monad.Effect -import Control.Monad.Effect.Exception +import Control.Effect +import Control.Effect.Error import Data.Blob +import Data.File import Data.Language import qualified Data.Text as T import Proto3.Suite import System.FilePath.Posix +import Semantic.IO -- | A 'ProjectF' contains all the information that semantic needs -- to execute an analysis, diffing, or graphing pass. It is higher-kinded @@ -73,28 +73,14 @@ projectExtensions = extensionsForLanguage . projectLanguage projectFiles :: Project -> [File] projectFiles = fmap toFile . projectBlobs -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 - newtype ProjectException = FileNotFound FilePath deriving (Show, Eq, Typeable, Exception) -readFile :: Member (Exc SomeException) effs +readFile :: (Member (Error SomeException) sig, Applicative m, Carrier sig m) => Project -> File - -> Eff effs (Maybe Blob) + -> m (Maybe Blob) readFile Project{..} f = let p = filePath f candidate = find (\b -> blobPath b == p) projectBlobs @@ -102,3 +88,17 @@ readFile Project{..} f = | p == "/dev/null" -> pure Nothing | isJust candidate -> pure candidate | otherwise -> throwError (SomeException (FileNotFound p)) + +readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project +readProjectFromPaths maybeRoot path lang excludeDirs = do + isDir <- isDirectory path + let rootDir = if isDir + then fromMaybe path maybeRoot + else fromMaybe (takeDirectory path) maybeRoot + + paths <- liftIO $ findFilesInDir rootDir exts excludeDirs + blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths + pure $ Project rootDir blobs lang excludeDirs + where + toFile path = File path lang + exts = extensionsForLanguage lang diff --git a/src/Data/Quieterm.hs b/src/Data/Quieterm.hs index e1bf4b61e..be6c6e9db 100644 --- a/src/Data/Quieterm.hs +++ b/src/Data/Quieterm.hs @@ -4,6 +4,7 @@ module Data.Quieterm , quieterm ) where +import Control.DeepSeq import Data.Abstract.Declarations (Declarations) import Data.Abstract.FreeVariables (FreeVariables) import Data.Functor.Classes @@ -36,5 +37,11 @@ instance Show1 syntax => Show1 (Quieterm syntax) where instance Show1 syntax => Show (Quieterm syntax ann) where showsPrec = liftShowsPrec (const (const id)) (const id) +instance NFData1 f => NFData1 (Quieterm f) where + liftRnf rnf = go where go x = liftRnf2 rnf go (unQuieterm x) + +instance (NFData1 f, NFData a) => NFData (Quieterm f a) where + rnf = liftRnf rnf + quieterm :: (Recursive term, Base term ~ TermF syntax ann) => term -> Quieterm syntax ann quieterm = cata Quieterm diff --git a/src/Data/Range.hs b/src/Data/Range.hs index 7dba51c39..7465c0130 100644 --- a/src/Data/Range.hs +++ b/src/Data/Range.hs @@ -17,7 +17,7 @@ import Proto3.Wire.Decode as Decode -- | A half-open interval of integers, defined by start & end indices. data Range = Range { start :: {-# UNPACK #-} !Int, end :: {-# UNPACK #-} !Int } - deriving (Eq, Show, Generic, Named) + deriving (Eq, Generic, Named, NFData) emptyRange :: Range emptyRange = Range 0 0 @@ -40,19 +40,16 @@ subtractRange range1 range2 = Range (start range1) (end range1 - rangeLength (Ra -- Instances --- $setup --- >>> import Test.QuickCheck --- >>> instance Arbitrary Range where arbitrary = Range <$> arbitrary <*> arbitrary - --- $ --- Associativity: --- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: Range) +-- | The associativity of this instance is specced in @Data.Range.Spec@. instance Semigroup Range where Range start1 end1 <> Range start2 end2 = Range (min start1 start2) (max end1 end2) instance Ord Range where a <= b = start a <= start b +instance Show Range where + showsPrec _ Range{..} = showChar '[' . shows start . showString " .. " . shows end . showChar ']' + instance ToJSONFields Range where toJSONFields Range{..} = ["sourceRange" .= [ start, end ]] diff --git a/src/Data/Record.hs b/src/Data/Record.hs deleted file mode 100644 index 761c2473c..000000000 --- a/src/Data/Record.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-} -module Data.Record - ( Record (..) - , HasField (..) - , rhead - , rtail - ) where - -import Data.Aeson -import Data.JSON.Fields -import Data.Kind -import Prologue - --- | A type-safe, extensible record structure. --- | --- | This is heavily inspired by Aaron Levinā€™s [Extensible Effects in the van Laarhoven Free Monad](http://aaronlevin.ca/post/136494428283/extensible-effects-in-the-van-laarhoven-free-monad). -data Record :: [*] -> * where - Nil :: Record '[] - (:.) :: h -> Record t -> Record (h ': t) - -infixr 0 :. - --- | Get the first element of a non-empty record. -rhead :: Record (head ': tail) -> head -rhead (head_ :. _) = head_ - --- | Get the first element of a non-empty record. -rtail :: Record (head ': tail) -> Record tail -rtail (_ :. tail_) = tail_ - - --- Classes - --- | HasField enables indexing a Record by (phantom) type tags. -class HasField (fields :: [*]) (field :: *) where - getField :: Record fields -> field - setField :: Record fields -> field -> Record fields - -type family ConstrainAll (toConstraint :: * -> Constraint) (fs :: [*]) :: Constraint where - ConstrainAll toConstraint (f ': fs) = (toConstraint f, ConstrainAll toConstraint fs) - ConstrainAll _ '[] = () - - --- Instances - --- OVERLAPPABLE is required for the HasField instances so that we can handle the two cases: either the head of the non-empty h-list is the requested field, or it isnā€™t. The third possible case (the h-list is empty) is rejected at compile-time. - -instance {-# OVERLAPPABLE #-} HasField fields field => HasField (notIt ': fields) field where - getField (_ :. t) = getField t - setField (h :. t) f = h :. setField t f - -instance {-# OVERLAPPABLE #-} HasField (field ': fields) field where - getField (h :. _) = h - setField (_ :. t) f = f :. t - - -instance (Show h, Show (Record t)) => Show (Record (h ': t)) where - showsPrec n (h :. t) = showParen (n > 0) $ showsPrec 1 h . showString " :. " . shows t - -instance Show (Record '[]) where - showsPrec _ Nil = showString "Nil" - -instance (Eq h, Eq (Record t)) => Eq (Record (h ': t)) where - (h1 :. t1) == (h2 :. t2) = h1 == h2 && t1 == t2 - -instance Eq (Record '[]) where - _ == _ = True - - -instance (Ord h, Ord (Record t)) => Ord (Record (h ': t)) where - (h1 :. t1) `compare` (h2 :. t2) = let h = h1 `compare` h2 in - if h == EQ then t1 `compare` t2 else h - -instance Ord (Record '[]) where - _ `compare` _ = EQ - - -instance (Semigroup head, Semigroup (Record tail)) => Semigroup (Record (head ': tail)) where - (h1 :. t1) <> (h2 :. t2) = (h1 <> h2) :. (t1 <> t2) - -instance Semigroup (Record '[]) where - _ <> _ = Nil - - -instance (ToJSONFields h, ToJSONFields (Record t)) => ToJSONFields (Record (h ': t)) where - toJSONFields (h :. t) = toJSONFields h <> toJSONFields t - -instance ToJSONFields (Record '[]) where - toJSONFields _ = [] - - -instance ToJSONFields (Record fs) => ToJSON (Record fs) where - toJSON = object . toJSONFields - toEncoding = pairs . mconcat . toJSONFields - - -instance (Lower h, Lower (Record t)) => Lower (Record (h ': t)) where - lowerBound = lowerBound :. lowerBound - -instance Lower (Record '[]) where - lowerBound = Nil diff --git a/src/Data/Reprinting/Errors.hs b/src/Data/Reprinting/Errors.hs index c887c5b2d..6f686710d 100644 --- a/src/Data/Reprinting/Errors.hs +++ b/src/Data/Reprinting/Errors.hs @@ -1,12 +1,13 @@ module Data.Reprinting.Errors ( TranslationError (..) ) where import Data.Reprinting.Token +import Data.Reprinting.Scope -- | Represents failure occurring in a 'Concrete' machine during the translation -- phases of the reprinting pipeline. data TranslationError - = UnbalancedPair Context [Context] + = UnbalancedPair Scope [Scope] -- ^ Thrown if an unbalanced 'Enter'/'Exit' pair is encountered. - | NoTranslation Element [Context] + | NoTranslation Element [Scope] -- ^ Thrown if no translation found for a given element. deriving (Eq, Show) diff --git a/src/Data/Reprinting/Fragment.hs b/src/Data/Reprinting/Fragment.hs new file mode 100644 index 000000000..c92a0c833 --- /dev/null +++ b/src/Data/Reprinting/Fragment.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE RankNTypes #-} + +module Data.Reprinting.Fragment + ( Fragment(..) + , copy + , insert + , defer + ) where + +import Data.Machine +import Data.Text (Text) + +import Data.Reprinting.Scope +import Data.Reprinting.Token + +-- | An intermediate representation of concrete syntax in the reprinting pipeline. +data Fragment + = Verbatim Text + -- ^ Verbatim copy of original 'Text' (un-refactored). + | New Element [Scope] Text + -- ^ New 'Text' to be inserted, along with original 'Element' and `Scope` + -- allowing later steps to re-write. + | Defer Element [Scope] + -- ^ To be handled further down the pipeline. + deriving (Eq, Show) + +-- | Copy along some original, un-refactored 'Text'. +copy :: Text -> Plan k Fragment () +copy = yield . Verbatim + +-- | Insert some new 'Text'. +insert :: Element -> [Scope] -> Text -> Plan k Fragment () +insert el c = yield . New el c + +-- | Defer processing an element to a later stage. +defer :: Element -> [Scope] -> Plan k Fragment () +defer el = yield . Defer el diff --git a/src/Data/Reprinting/Operator.hs b/src/Data/Reprinting/Operator.hs new file mode 100644 index 000000000..0df8bf813 --- /dev/null +++ b/src/Data/Reprinting/Operator.hs @@ -0,0 +1,12 @@ +module Data.Reprinting.Operator + ( Operator (..) + ) where + +-- | A sum type representing every concievable infix operator a +-- language can define. These are handled by instances of 'Concrete' +-- and given appropriate precedence. +data Operator + = Add + | Multiply + | Subtract + deriving (Show, Eq) diff --git a/src/Data/Reprinting/Scope.hs b/src/Data/Reprinting/Scope.hs new file mode 100644 index 000000000..afbe26d00 --- /dev/null +++ b/src/Data/Reprinting/Scope.hs @@ -0,0 +1,37 @@ +module Data.Reprinting.Scope + ( Scope (..) + , precedenceOf + , imperativeDepth + ) where + +import Data.Reprinting.Operator + +-- | A 'Scope' represents a scope in which other tokens can be +-- interpreted. For example, in the 'Imperative' context a 'TSep' +-- could be a semicolon or newline, whereas in a 'List' context a +-- 'TSep' is probably going to be a comma. +data Scope + = List + | Hash + | Pair + | Method + | Function + | Call + | Params + | Return + | If + | InfixL Operator Int + | Imperative + deriving (Show, Eq) + +precedenceOf :: [Scope] -> Int +precedenceOf cs = case filter isInfix cs of + (InfixL _ n:_) -> n + _ -> 0 + where isInfix (InfixL _ _) = True + isInfix _ = False + + +-- | Depth of imperative scope. +imperativeDepth :: [Scope] -> Int +imperativeDepth = length . filter (== Imperative) diff --git a/src/Data/Reprinting/Splice.hs b/src/Data/Reprinting/Splice.hs index d491e89f1..56230f14a 100644 --- a/src/Data/Reprinting/Splice.hs +++ b/src/Data/Reprinting/Splice.hs @@ -20,30 +20,7 @@ import Prologue hiding (Element) import Data.Machine -import Data.Reprinting.Token - --- | An intermediate representation of concrete syntax in the reprinting pipeline. -data Fragment - = Verbatim Text - -- ^ Verbatim copy of original 'Text' (un-refactored). - | New Element [Context] Text - -- ^ New 'Text' to be inserted, along with original 'Element' and `Context` - -- allowing later steps to re-write. - | Defer Element [Context] - -- ^ To be handled further down the pipeline. - deriving (Eq, Show) - --- | Copy along some original, un-refactored 'Text'. -copy :: Text -> Plan k Fragment () -copy = yield . Verbatim - --- | Insert some new 'Text'. -insert :: Element -> [Context] -> Text -> Plan k Fragment () -insert el c = yield . New el c - --- | Defer processing an element to a later stage. -defer :: Element -> [Context] -> Plan k Fragment () -defer el = yield . Defer el +import Data.Reprinting.Fragment -- | The final representation of concrete syntax in the reprinting pipeline. data Splice diff --git a/src/Data/Reprinting/Token.hs b/src/Data/Reprinting/Token.hs index cf0474244..fa8dd1642 100644 --- a/src/Data/Reprinting/Token.hs +++ b/src/Data/Reprinting/Token.hs @@ -4,21 +4,18 @@ module Data.Reprinting.Token , isControl , Element (..) , Control (..) - , Context (..) - , imperativeDepth - , precedenceOf - , Operator (..) ) where import Data.Text (Text) import Data.Source (Source) +import Data.Reprinting.Scope -- | 'Token' encapsulates 'Element' and 'Control' tokens, as well as sliced -- portions of the original 'Source' for a given AST. data Token = Chunk Source -- ^ Verbatim 'Source' from AST, unmodified. - | TElement Element -- ^ Content token to be rendered. - | TControl Control -- ^ AST's context. + | Element Element -- ^ Content token to be rendered. + | Control Control -- ^ AST's context. deriving (Show, Eq) isChunk :: Token -> Bool @@ -26,7 +23,7 @@ isChunk (Chunk _) = True isChunk _ = False isControl :: Token -> Bool -isControl (TControl _) = True +isControl (Control _) = True isControl _ = False -- | 'Element' tokens describe atomic pieces of source code to be @@ -34,15 +31,15 @@ isControl _ = False -- and are interpreted into language-specific representations at a -- later point in the reprinting pipeline. data Element - = Run Text -- ^ A literal chunk of text. - | Truth Bool -- ^ A boolean value. - | Nullity -- ^ @null@ or @nil@ or some other zero value. - | TSep -- ^ Some sort of delimiter, interpreted in some 'Context'. - | TSym -- ^ Some sort of symbol, interpreted in some 'Context'. - | TThen - | TElse - | TOpen -- ^ The beginning of some 'Context', such as an @[@ or @{@. - | TClose -- ^ The opposite of 'TOpen'. + = Run Text -- ^ A literal chunk of text. + | Truth Bool -- ^ A boolean value. + | Nullity -- ^ @null@ or @nil@ or some other zero value. + | Sep -- ^ Some sort of delimiter, interpreted in some 'Context'. + | Sym -- ^ Some sort of symbol, interpreted in some 'Context'. + | Then + | Else + | Open -- ^ The beginning of some 'Context', such as an @[@ or @{@. + | Close -- ^ The opposite of 'TOpen'. deriving (Eq, Show) -- | 'Control' tokens describe information about some AST's context. @@ -50,46 +47,7 @@ data Element -- the page, they are needed to provide information as to how deeply -- subsequent entries in the pipeline should indent. data Control - = Enter Context - | Exit Context + = Enter Scope + | Exit Scope | Log String deriving (Eq, Show) - --- | A 'Context' represents a scope in which other tokens can be --- interpreted. For example, in the 'Imperative' context a 'TSep' --- could be a semicolon or newline, whereas in a 'List' context a --- 'TSep' is probably going to be a comma. -data Context - = TList - | THash - | TPair - | TMethod - | TFunction - | TCall - | TParams - | TReturn - | TIf - | TInfixL Operator Int - | Imperative - deriving (Show, Eq) - -precedenceOf :: [Context] -> Int -precedenceOf cs = case filter isInfix cs of - (TInfixL _ n:_) -> n - _ -> 0 - where isInfix (TInfixL _ _) = True - isInfix _ = False - - --- | Depth of imperative scope. -imperativeDepth :: [Context] -> Int -imperativeDepth = length . filter (== Imperative) - --- | A sum type representing every concievable infix operator a --- language can define. These are handled by instances of 'Concrete' --- and given appropriate precedence. -data Operator - = Add - | Multiply - | Subtract - deriving (Show, Eq) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index c11ff1a08..54455a986 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -6,33 +6,20 @@ module Data.Semigroup.App import Control.Applicative --- $setup --- >>> import Test.QuickCheck --- >>> instance Arbitrary (f a) => Arbitrary (App f a) where arbitrary = App <$> arbitrary ; shrink = map App . shrink . runApp --- >>> instance Arbitrary (f a) => Arbitrary (AppMerge f a) where arbitrary = AppMerge <$> arbitrary ; shrink = map AppMerge . shrink . runAppMerge - -- | 'Semigroup' under '*>'. newtype App f a = App { runApp :: f a } deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) --- $ Associativity: --- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: App Maybe Integer) instance Applicative f => Semigroup (App f a) where App a <> App b = App (a *> b) - -- | 'Semigroup' and 'Monoid' under '<*>' and '<>'. newtype AppMerge f a = AppMerge { runAppMerge :: f a } deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) --- $ Associativity: --- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String) instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b) --- $ Identity: --- prop> \ a -> mempty <> a == (a :: AppMerge Maybe String) --- prop> \ a -> a <> mempty == (a :: AppMerge Maybe String) instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where mempty = AppMerge (pure mempty) mappend = (<>) diff --git a/src/Data/Span.hs b/src/Data/Span.hs index d40b300f9..b8e1d70af 100644 --- a/src/Data/Span.hs +++ b/src/Data/Span.hs @@ -24,18 +24,21 @@ data Pos = Pos { posLine :: !Int , posColumn :: !Int } - deriving (Show, Read, Eq, Ord, Generic, Hashable) + deriving (Eq, Ord, Generic, Hashable, NFData) -- | A Span of position information data Span = Span { spanStart :: Pos , spanEnd :: Pos } - deriving (Show, Read, Eq, Ord, Generic, Hashable, Named) + deriving (Eq, Ord, Generic, Hashable, Named, NFData) -- Instances +instance Show Pos where + showsPrec _ Pos{..} = showChar '[' . shows posLine . showString ", " . shows posColumn . showChar ']' + instance Named Pos where nameOf _ = "Position" instance Message Pos where encodeMessage _ Pos{..} = encodeMessageField 1 posLine <> encodeMessageField 2 posColumn @@ -61,6 +64,9 @@ instance HasDefault Pos where def = lowerBound @Pos +instance Show Span where + showsPrec _ Span{..} = shows spanStart . showString " - " . shows spanEnd + instance Message Span where encodeMessage _ Span{..} = Encode.embedded 1 (encodeMessage 1 spanStart) <> Encode.embedded 2 (encodeMessage 1 spanEnd) decodeMessage _ = Span <$> embeddedAt (decodeMessage 1) 1 <*> embeddedAt (decodeMessage 1) 2 diff --git a/src/Data/SplitDiff.hs b/src/Data/SplitDiff.hs deleted file mode 100644 index 0c040f3bd..000000000 --- a/src/Data/SplitDiff.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Data.SplitDiff - ( SplitPatch (..) - , getRange - ) where - -import Control.Monad.Free -import Data.Range -import Data.Record -import Data.Term - --- | A patch to only one side of a diff. -data SplitPatch a - = SplitInsert { splitTerm :: a } - | SplitDelete { splitTerm :: a } - | SplitReplace { splitTerm :: a } - deriving (Foldable, Eq, Functor, Show, Traversable) - --- | Get the range of a SplitDiff. -getRange :: HasField fields Range => SplitDiff f (Record fields) -> Range -getRange diff = getField $ case diff of - Free annotated -> termFAnnotation annotated - Pure patch -> termAnnotation (splitTerm patch) - --- | A diff with only one sideā€™s annotations. -type SplitDiff syntax ann = Free (TermF syntax ann) (SplitPatch (Term syntax ann)) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 226913c4f..436b213cc 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -2,15 +2,13 @@ {-# OPTIONS_GHC -Wno-missing-export-lists -Wno-redundant-constraints -fno-warn-orphans #-} -- For HasCallStack module Data.Syntax where -import Data.Abstract.Evaluatable +import Data.Abstract.Evaluatable hiding (Empty, Error) import Data.Aeson (ToJSON(..), object) -import Data.AST import Data.Char (toLower) import Data.JSON.Fields import Data.Range -import Data.Record +import Data.Location import qualified Data.Set as Set -import Data.Span import Data.Sum import Data.Term import GHC.Types (Constraint) @@ -18,7 +16,7 @@ import GHC.TypeLits import Diffing.Algorithm hiding (Empty) import Prelude import Prologue -import Reprinting.Tokenize hiding (Context, Element) +import Reprinting.Tokenize hiding (Element) import qualified Assigning.Assignment as Assignment import qualified Data.Error as Error import Proto3.Suite.Class @@ -54,16 +52,16 @@ makeTerm1' syntax = case toList syntax of _ -> error "makeTerm1': empty structure" -- | Construct an empty term at the current position. -emptyTerm :: (HasCallStack, Empty :< syntaxes, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) +emptyTerm :: (HasCallStack, Empty :< syntaxes, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Location) emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty - where startLocation ann = Range (start (getField ann)) (start (getField ann)) :. Span (spanStart (getField ann)) (spanStart (getField ann)) :. Nil + where startLocation Location{..} = Location (Range (start locationByteRange) (start locationByteRange)) (Span (spanStart locationSpan) (spanStart locationSpan)) -- | Catch assignment errors into an error term. -handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) +handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Location) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) Location) handleError = flip Assignment.catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source) -- | Catch parse errors into an error term. -parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) +parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) Location) parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack $ errorSite <$> getCallStack (freezeCallStack callStack)) [] (Just "ParseError") []) -- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term. @@ -157,14 +155,14 @@ instance Message1 [] where newtype Identifier a = Identifier { name :: Name } deriving newtype (Eq, Ord, Show) deriving stock (Foldable, Functor, Generic1, Traversable) - deriving anyclass (Diffable, Hashable1, Message1, Named1, ToJSONFields1) + deriving anyclass (Diffable, Hashable1, Message1, Named1, ToJSONFields1, NFData1) instance Eq1 Identifier where liftEq = genericLiftEq instance Ord1 Identifier where liftCompare = genericLiftCompare instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Identifier where - eval (Identifier name) = pure (LvalLocal name) + eval _ (Identifier name) = pure (LvalLocal name) instance Tokenize Identifier where tokenize = yield . Run . formatName . Data.Syntax.name @@ -179,7 +177,7 @@ instance Declarations1 Identifier where newtype AccessibilityModifier a = AccessibilityModifier { contents :: Text } deriving newtype (Eq, Ord, Show) deriving stock (Foldable, Functor, Generic1, Traversable) - deriving anyclass (Declarations1, Diffable, FreeVariables1, Hashable1, Message1, Named1, ToJSONFields1) + deriving anyclass (Declarations1, Diffable, FreeVariables1, Hashable1, Message1, Named1, ToJSONFields1, NFData1) instance Eq1 AccessibilityModifier where liftEq = genericLiftEq instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare @@ -192,21 +190,21 @@ instance Evaluatable AccessibilityModifier -- -- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'. data Empty a = Empty - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Empty where liftEq _ _ _ = True instance Ord1 Empty where liftCompare _ _ _ = EQ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty" instance Evaluatable Empty where - eval _ = rvalBox unit + eval _ _ = rvalBox unit instance Tokenize Empty where tokenize = ignore -- | Syntax representing a parsing or assignment error. data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable, NFData1) instance Eq1 Error where liftEq = genericLiftEq instance Ord1 Error where liftCompare = genericLiftCompare @@ -235,7 +233,7 @@ unError span Error{..} = Error.Error span errorExpected errorActual stack where stack = fromCallSiteList $ unErrorSite <$> unErrorStack errorCallStack data ErrorSite = ErrorSite { errorMessage :: String, errorLocation :: SrcLoc } - deriving (Eq, Show, Generic, Named, Message) + deriving (Eq, Show, Generic, Named, Message, NFData) errorSite :: (String, SrcLoc) -> ErrorSite errorSite = uncurry ErrorSite @@ -245,7 +243,7 @@ unErrorSite ErrorSite{..} = (errorMessage, errorLocation) newtype ErrorStack = ErrorStack { unErrorStack :: [ErrorSite] } deriving stock (Eq, Show, Generic) - deriving anyclass (Named, Message) + deriving anyclass (Named, Message, NFData) deriving newtype (MessageField) instance HasDefault ErrorStack where @@ -291,7 +289,7 @@ instance Ord ErrorStack where data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a } - deriving (Declarations1, Eq, Foldable, FreeVariables1, Functor, Generic1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Eq, Foldable, FreeVariables1, Functor, Generic1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable, NFData1) instance Diffable Context where subalgorithmFor blur focus (Context n s) = Context <$> traverse blur n <*> focus s @@ -305,7 +303,7 @@ instance Ord1 Context where liftCompare = genericLiftCompare instance Show1 Context where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Context where - eval Context{..} = subtermRef contextSubject + eval eval Context{..} = eval contextSubject instance Tokenize Context where tokenize Context{..} = sequenceA_ (sepTrailing contextTerms) *> contextSubject diff --git a/src/Data/Syntax/Comment.hs b/src/Data/Syntax/Comment.hs index f357b690b..d4177bb38 100644 --- a/src/Data/Syntax/Comment.hs +++ b/src/Data/Syntax/Comment.hs @@ -11,14 +11,14 @@ import Reprinting.Tokenize as Token -- | An unnested comment (line or block). newtype Comment a = Comment { commentContent :: Text } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Comment where liftEq = genericLiftEq instance Ord1 Comment where liftCompare = genericLiftCompare instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Comment where - eval _ = rvalBox unit + eval _ _ = rvalBox unit instance Tokenize Comment where tokenize = yield . Run . commentContent @@ -30,7 +30,7 @@ instance Tokenize Comment where -- | HashBang line (e.g. `#!/usr/bin/env node`) newtype HashBang a = HashBang { value :: Text } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 HashBang where liftEq = genericLiftEq instance Ord1 HashBang where liftCompare = genericLiftCompare diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 5d943fe2d..93bc44821 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -1,20 +1,21 @@ -{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, TupleSections #-} +{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, TupleSections, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Declaration where +import Control.Abstract.ScopeGraph import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import Control.Abstract.ScopeGraph import Data.JSON.Fields +import qualified Data.Map.Strict as Map +import qualified Data.Reprinting.Scope as Scope import qualified Data.Set as Set import Diffing.Algorithm import Prologue import Proto3.Suite.Class -import qualified Data.Map.Strict as Map import Reprinting.Tokenize data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, ToJSONFields1, Named1, Message1, NFData1) instance Diffable Function where equivalentBySubterm = Just . functionName @@ -27,19 +28,18 @@ instance Show1 Function where liftShowsPrec = genericLiftShowsPrec -- TODO: How should we represent function types, where applicable? instance Evaluatable Function where - eval Function{..} = do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm functionName)) - -- TODO: Fix me. - -- (_, addr) <- letrec name (function (Just name) (paramNames functionParameters) (freeVariables functionBody) (subtermAddress functionBody)) + eval _ Function{..} = do + -- name <- maybeM (throwEvalError NoNameError) (declaredName functionName) + -- (_, addr) <- letrec name (function (Just name) (paramNames functionParameters) functionBody) -- bind name addr -- pure (Rval addr) - -- where paramNames = foldMap (maybeToList . declaredName . subterm) - rvalBox unit + -- where paramNames = foldMap (maybeToList . declaredName) + undefined instance Tokenize Function where - tokenize Function{..} = within' TFunction $ do + tokenize Function{..} = within' Scope.Function $ do functionName - within' TParams $ sequenceA_ (sep functionParameters) + within' Scope.Params $ sequenceA_ (sep functionParameters) functionBody instance Declarations1 Function where @@ -50,7 +50,7 @@ instance FreeVariables1 Function where data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Method where liftEq = genericLiftEq instance Ord1 Method where liftCompare = genericLiftCompare @@ -62,19 +62,17 @@ instance Diffable Method where -- Evaluating a Method creates a closure and makes that value available in the -- local environment. instance Evaluatable Method where - eval Method{..} = do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm methodName)) - -- TODO: Fix me. - -- (_, addr) <- letrec name (function (Just name) (paramNames methodParameters) (freeVariables methodBody) (subtermAddress methodBody)) + eval _ Method{..} = undefined + -- name <- maybeM (throwEvalError NoNameError) (declaredName methodName) + -- (_, addr) <- letrec name (function (Just name) (paramNames methodParameters) methodBody) -- bind name addr -- pure (Rval addr) - -- where paramNames = foldMap (maybeToList . declaredName . subterm) - rvalBox unit + -- where paramNames = foldMap (maybeToList . declaredName) -instance Tokenize Method where - tokenize Method{..} = within' TMethod $ do +instance Tokenize Data.Syntax.Declaration.Method where + tokenize Method{..} = within' Scope.Method $ do methodName - within' TParams $ sequenceA_ (sep methodParameters) + within' Scope.Params $ sequenceA_ (sep methodParameters) methodBody instance Declarations1 Method where @@ -86,7 +84,7 @@ instance FreeVariables1 Method where -- | A method signature in TypeScript or a method spec in Go. data MethodSignature a = MethodSignature { methodSignatureContext :: ![a], methodSignatureName :: !a, methodSignatureParameters :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 MethodSignature where liftEq = genericLiftEq instance Ord1 MethodSignature where liftCompare = genericLiftCompare @@ -97,7 +95,7 @@ instance Evaluatable MethodSignature newtype RequiredParameter a = RequiredParameter { requiredParameter :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 RequiredParameter where liftEq = genericLiftEq instance Ord1 RequiredParameter where liftCompare = genericLiftCompare @@ -108,7 +106,7 @@ instance Evaluatable RequiredParameter newtype OptionalParameter a = OptionalParameter { optionalParameter :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 OptionalParameter where liftEq = genericLiftEq instance Ord1 OptionalParameter where liftCompare = genericLiftCompare @@ -123,19 +121,19 @@ instance Evaluatable OptionalParameter -- TODO: It would be really nice to have a more meaningful type contained in here than [a] -- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript. newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 VariableDeclaration where liftEq = genericLiftEq instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable VariableDeclaration where - eval (VariableDeclaration []) = rvalBox unit - eval (VariableDeclaration decs) = do - for_ decs $ \declaration -> do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm declaration)) + eval _ (VariableDeclaration []) = rvalBox unit + eval eval (VariableDeclaration decs) = do + addresses <- for decs $ \declaration -> do + name <- maybeM (throwEvalError NoNameError) (declaredName declaration) (span, valueRef) <- do - ref <- subtermRef declaration + ref <- eval declaration subtermSpan <- get @Span pure (subtermSpan, ref) @@ -151,7 +149,7 @@ instance Declarations a => Declarations (VariableDeclaration a) where -- | A TypeScript/Java style interface declaration to implement. data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationSuperInterfaces :: ![a], interfaceDeclarationBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare @@ -166,7 +164,7 @@ instance Declarations a => Declarations (InterfaceDeclaration a) where -- | A public field definition such as a field definition in a JavaScript class. data PublicFieldDefinition a = PublicFieldDefinition { publicFieldContext :: ![a], publicFieldPropertyName :: !a, publicFieldValue :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 PublicFieldDefinition where liftEq = genericLiftEq instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare @@ -174,16 +172,16 @@ instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for PublicFieldDefinition instance Evaluatable PublicFieldDefinition where - eval PublicFieldDefinition{..} = do + eval _ PublicFieldDefinition{..} = do span <- ask @Span - propertyName <- maybeM (throwEvalError NoNameError) (declaredName (subterm publicFieldPropertyName)) + propertyName <- maybeM (throwEvalError NoNameError) (declaredName publicFieldPropertyName) declare (Declaration propertyName) span Nothing rvalBox unit data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Variable where liftEq = genericLiftEq instance Ord1 Variable where liftCompare = genericLiftCompare @@ -193,7 +191,7 @@ instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Variable data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Declarations a => Declarations (Class a) where declaredName (Class _ name _ _) = declaredName name @@ -206,33 +204,35 @@ instance Ord1 Class where liftCompare = genericLiftCompare instance Show1 Class where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Class where - eval Class{..} = do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm classIdentifier)) + eval eval Class{..} = do + name <- maybeM (throwEvalError NoNameError) (declaredName classIdentifier) span <- ask @Span -- Run the action within the class's scope. currentScope' <- currentScope supers <- for classSuperclasses $ \superclass -> do name <- maybeM (throwEvalError NoNameError) (declaredName (subterm superclass)) - associatedScope (Declaration name) - - -- let imports = (Import,) <$> (fmap pure . catMaybes $ supers) - -- current = maybe mempty (fmap (Lexical, ) . pure . pure) currentScope' - -- edges = Map.fromList (imports <> current) - -- childScope <- newScope edges - -- declare (Declaration name) span (Just childScope) - - -- withScope childScope $ do - -- (_, addr) <- letrec name $ do - -- void $ subtermValue classBody - -- classBinds <- Env.head <$> getEnv - -- klass (Declaration name) (catMaybes supers) classBinds -- TODO: Update klass definition - -- pure (Rval addr) - rvalBox unit + scope <- associatedScope (Declaration name) + -- (scope,) <$> (eval superclass >>= address) + -- + -- let imports = (Import,) <$> (fmap pure . catMaybes $ fst <$> supers) + -- current = maybe mempty (fmap (Lexical, ) . pure . pure) currentScope' + -- edges = Map.fromList (imports <> current) + -- childScope <- newScope edges + -- declare (Declaration name) span (Just childScope) + -- + -- withScope childScope $ do + -- (_, addr) <- letrec name $ do + -- void $ eval classBody + -- classBinds <- Env.head <$> getEnv + -- klass name (snd <$> supers) classBinds + -- bind name addr + -- pure (Rval addr) + undefined -- | A decorator in Python data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Decorator where liftEq = genericLiftEq instance Ord1 Decorator where liftCompare = genericLiftCompare @@ -246,7 +246,7 @@ instance Evaluatable Decorator -- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift. data Datatype a = Datatype { datatypeContext :: a, datatypeName :: a, datatypeConstructors :: [a], datatypeDeriving :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq instance Ord1 Data.Syntax.Declaration.Datatype where liftCompare = genericLiftCompare @@ -258,7 +258,7 @@ instance Evaluatable Data.Syntax.Declaration.Datatype -- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift. data Constructor a = Constructor { constructorContext :: [a], constructorName :: a, constructorFields :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq instance Ord1 Data.Syntax.Declaration.Constructor where liftCompare = genericLiftCompare @@ -270,7 +270,7 @@ instance Evaluatable Data.Syntax.Declaration.Constructor -- | Comprehension (e.g. ((a for b in c if a()) in Python) data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Comprehension where liftEq = genericLiftEq instance Ord1 Comprehension where liftCompare = genericLiftCompare @@ -282,7 +282,7 @@ instance Evaluatable Comprehension -- | A declared type (e.g. `a []int` in Go). data Type a = Type { typeName :: !a, typeKind :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Type where liftEq = genericLiftEq instance Ord1 Type where liftCompare = genericLiftCompare @@ -294,21 +294,26 @@ instance Evaluatable Type -- | Type alias declarations in Javascript/Haskell, etc. data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: !a, typeAliasKind :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 TypeAlias where liftEq = genericLiftEq instance Ord1 TypeAlias where liftCompare = genericLiftCompare instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for TypeAlias instance Evaluatable TypeAlias where - eval TypeAlias{..} = do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm typeAliasIdentifier)) - kindName <- maybeM (throwEvalError NoNameError) (declaredName (subterm typeAliasKind)) - span <- ask @Span - address <- declare (Declaration name) span Nothing -- TODO: Also need to declare the alias via an Alias edge? - kindAddress <- lookupDeclaration (Declaration kindName) -- TODO: Validate the path? Also assumes the type is declared. - rvalBox unit -- TODO: Return Address here? + eval eval TypeAlias{..} = do + -- name <- maybeM (throwEvalError NoNameError) (declaredName typeAliasIdentifier) + -- addr <- eval typeAliasKind >>= address + -- bind name addr + -- pure (Rval addr) + + -- name <- maybeM (throwEvalError NoNameError) (declaredName (subterm typeAliasIdentifier)) + -- kindName <- maybeM (throwEvalError NoNameError) (declaredName (subterm typeAliasKind)) + -- span <- ask @Span + -- address <- declare (Declaration name) span Nothing -- TODO: Also need to declare the alias via an Alias edge? + -- kindAddress <- lookupDeclaration (Declaration kindName) -- TODO: Validate the path? Also assumes the type is declared. + -- rvalBox unit -- TODO: Return Address here? + undefined instance Declarations a => Declarations (TypeAlias a) where declaredName TypeAlias{..} = declaredName typeAliasIdentifier diff --git a/src/Data/Syntax/Directive.hs b/src/Data/Syntax/Directive.hs index 4817fdbf6..c503c31e6 100644 --- a/src/Data/Syntax/Directive.hs +++ b/src/Data/Syntax/Directive.hs @@ -13,23 +13,23 @@ import Proto3.Suite.Class -- A file directive like the Ruby constant `__FILE__`. data File a = File - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 File where liftEq = genericLiftEq instance Ord1 File where liftCompare = genericLiftCompare instance Show1 File where liftShowsPrec = genericLiftShowsPrec instance Evaluatable File where - eval File = rvalBox =<< (string . T.pack . modulePath <$> currentModule) + eval _ File = rvalBox =<< (string . T.pack . modulePath <$> currentModule) -- A line directive like the Ruby constant `__LINE__`. data Line a = Line - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Line where liftEq = genericLiftEq instance Ord1 Line where liftCompare = genericLiftCompare instance Show1 Line where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Line where - eval Line = rvalBox =<< (integer . fromIntegral . posLine . spanStart <$> currentSpan) + eval _ Line = rvalBox =<< (integer . fromIntegral . posLine . spanStart <$> currentSpan) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index ab7d864e9..720abcae0 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -1,231 +1,233 @@ -{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, DuplicateRecordFields #-} +{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Expression where -import Control.Abstract.ScopeGraph as ScopeGraph -import Data.Abstract.Evaluatable hiding (Member) -import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv) -import Data.Bits -import Data.Fixed -import Data.JSON.Fields -import Diffing.Algorithm hiding (Delete) -import Prologue hiding (index, Member, This, null) import Prelude hiding (null) +import Prologue hiding (This, index, null) + +import Data.Fixed import Proto3.Suite.Class -import Reprinting.Tokenize + +import Control.Abstract.ScopeGraph as ScopeGraph +import Data.Abstract.Evaluatable as Abstract hiding (Member, Void) +import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv) +import Data.JSON.Fields +import qualified Data.Reprinting.Scope as Scope +import Diffing.Algorithm hiding (Delete) +import Reprinting.Tokenize +import qualified Data.Reprinting.Token as Token -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell. data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Call where liftEq = genericLiftEq instance Ord1 Call where liftCompare = genericLiftCompare instance Show1 Call where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Call where - eval Call{..} = do - op <- subtermValue callFunction - -- TODO: Fix me. - -- recv <- box unit - -- args <- traverse subtermAddress callParams + eval eval Call{..} = do + -- op <- eval callFunction >>= Abstract.value + -- recv <- box unit -- TODO + -- args <- traverse (eval >=> address) callParams -- Rval <$> call op recv args - rvalBox unit + undefined instance Tokenize Call where - tokenize Call{..} = within TCall $ do + tokenize Call{..} = within Scope.Call $ do -- TODO: callContext callFunction - within' TParams $ sequenceA_ (sep callParams) + within' Scope.Params $ sequenceA_ (sep callParams) callBlock data LessThan a = LessThan { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 LessThan where liftEq = genericLiftEq instance Ord1 LessThan where liftCompare = genericLiftCompare instance Show1 LessThan where liftShowsPrec = genericLiftShowsPrec instance Evaluatable LessThan where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go x = case x of (LessThan a b) -> liftComparison (Concrete (<)) a b data LessThanEqual a = LessThanEqual { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 LessThanEqual where liftEq = genericLiftEq instance Ord1 LessThanEqual where liftCompare = genericLiftCompare instance Show1 LessThanEqual where liftShowsPrec = genericLiftShowsPrec instance Evaluatable LessThanEqual where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go x = case x of (LessThanEqual a b) -> liftComparison (Concrete (<=)) a b data GreaterThan a = GreaterThan { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 GreaterThan where liftEq = genericLiftEq instance Ord1 GreaterThan where liftCompare = genericLiftCompare instance Show1 GreaterThan where liftShowsPrec = genericLiftShowsPrec instance Evaluatable GreaterThan where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go x = case x of (GreaterThan a b) -> liftComparison (Concrete (>)) a b data GreaterThanEqual a = GreaterThanEqual { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 GreaterThanEqual where liftEq = genericLiftEq instance Ord1 GreaterThanEqual where liftCompare = genericLiftCompare instance Show1 GreaterThanEqual where liftShowsPrec = genericLiftShowsPrec instance Evaluatable GreaterThanEqual where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go x = case x of (GreaterThanEqual a b) -> liftComparison (Concrete (>=)) a b data Equal a = Equal { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Equal where liftEq = genericLiftEq instance Ord1 Equal where liftCompare = genericLiftCompare instance Show1 Equal where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Equal where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go x = case x of -- TODO: in PHP and JavaScript, the equals operator performs type coercion. -- We need some mechanism to customize this behavior per-language. (Equal a b) -> liftComparison (Concrete (==)) a b data StrictEqual a = StrictEqual { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 StrictEqual where liftEq = genericLiftEq instance Ord1 StrictEqual where liftCompare = genericLiftCompare instance Show1 StrictEqual where liftShowsPrec = genericLiftShowsPrec instance Evaluatable StrictEqual where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go x = case x of -- TODO: in PHP and JavaScript, the equals operator performs type coercion. -- We need some mechanism to customize this behavior per-language. (StrictEqual a b) -> liftComparison (Concrete (==)) a b data Comparison a = Comparison { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Comparison where liftEq = genericLiftEq instance Ord1 Comparison where liftCompare = genericLiftCompare instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Comparison where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go x = case x of (Comparison a b) -> liftComparison (Concrete (==)) a b data Plus a = Plus { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Plus where liftEq = genericLiftEq instance Ord1 Plus where liftCompare = genericLiftCompare instance Show1 Plus where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Plus where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go (Plus a b) = liftNumeric2 add a b where add = liftReal (+) instance Tokenize Plus where - tokenize Plus{..} = within' (TInfixL Add 6) $ lhs *> yield TSym <* rhs + tokenize Plus{..} = within' (Scope.InfixL Add 6) $ lhs *> yield Token.Sym <* rhs data Minus a = Minus { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Minus where liftEq = genericLiftEq instance Ord1 Minus where liftCompare = genericLiftCompare instance Show1 Minus where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Minus where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go (Minus a b) = liftNumeric2 sub a b where sub = liftReal (-) instance Tokenize Minus where - tokenize Minus{..} = within' (TInfixL Subtract 6) $ lhs *> yield TSym <* rhs + tokenize Minus{..} = within' (Scope.InfixL Subtract 6) $ lhs *> yield Token.Sym <* rhs data Times a = Times { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Times where liftEq = genericLiftEq instance Ord1 Times where liftCompare = genericLiftCompare instance Show1 Times where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Times where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go (Times a b) = liftNumeric2 mul a b where mul = liftReal (*) instance Tokenize Times where - tokenize Times{..} = within' (TInfixL Multiply 7) $ lhs *> yield TSym <* rhs + tokenize Times{..} = within' (Scope.InfixL Multiply 7) $ lhs *> yield Token.Sym <* rhs data DividedBy a = DividedBy { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 DividedBy where liftEq = genericLiftEq instance Ord1 DividedBy where liftCompare = genericLiftCompare instance Show1 DividedBy where liftShowsPrec = genericLiftShowsPrec instance Evaluatable DividedBy where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go (DividedBy a b) = liftNumeric2 div' a b where div' = liftIntegralFrac div (/) data Modulo a = Modulo { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Modulo where liftEq = genericLiftEq instance Ord1 Modulo where liftCompare = genericLiftCompare instance Show1 Modulo where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Modulo where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go (Modulo a b) = liftNumeric2 mod'' a b where mod'' = liftIntegralFrac mod mod' data Power a = Power { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Power where liftEq = genericLiftEq instance Ord1 Power where liftCompare = genericLiftCompare instance Show1 Power where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Power where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go (Power a b) = liftNumeric2 liftedExponent a b newtype Negate a = Negate { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Negate where liftEq = genericLiftEq instance Ord1 Negate where liftCompare = genericLiftCompare instance Show1 Negate where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Negate where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go (Negate a) = liftNumeric negate a data FloorDivision a = FloorDivision { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 FloorDivision where liftEq = genericLiftEq instance Ord1 FloorDivision where liftCompare = genericLiftCompare instance Show1 FloorDivision where liftShowsPrec = genericLiftShowsPrec instance Evaluatable FloorDivision where - eval t = rvalBox =<< (traverse subtermValue t >>= go) where + eval eval t = rvalBox =<< (traverse (eval >=> Abstract.value) t >>= go) where go (FloorDivision a b) = liftNumeric2 liftedFloorDiv a b -- | Regex matching operators (Ruby's =~ and ~!) data Matches a = Matches { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Matches where liftEq = genericLiftEq instance Ord1 Matches where liftCompare = genericLiftCompare @@ -233,7 +235,7 @@ instance Show1 Matches where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Matches data NotMatches a = NotMatches { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 NotMatches where liftEq = genericLiftEq instance Ord1 NotMatches where liftCompare = genericLiftCompare @@ -241,40 +243,42 @@ instance Show1 NotMatches where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NotMatches data Or a = Or { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Or where liftEq = genericLiftEq instance Ord1 Or where liftCompare = genericLiftCompare instance Show1 Or where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Or where - eval (Or a b) = disjunction (subtermValue a) (subtermValue b) >>= rvalBox + eval eval (Or a b) = do + a' <- eval a >>= Abstract.value + ifthenelse a' (rvalBox a') (eval b) data And a = And { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 And where liftEq = genericLiftEq instance Ord1 And where liftCompare = genericLiftCompare instance Show1 And where liftShowsPrec = genericLiftShowsPrec instance Evaluatable And where - eval t = rvalBox =<< go (fmap subtermValue t) where + eval eval t = rvalBox =<< go (fmap (eval >=> Abstract.value) t) where go (And a b) = do cond <- a ifthenelse cond b (pure cond) newtype Not a = Not { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Not where liftEq = genericLiftEq instance Ord1 Not where liftCompare = genericLiftCompare instance Show1 Not where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Not where - eval t = rvalBox =<< go (fmap subtermValue t) where + eval eval t = rvalBox =<< go (fmap (eval >=> Abstract.value) t) where go (Not a) = a >>= asBool >>= boolean . not data XOr a = XOr { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 XOr where liftEq = genericLiftEq instance Ord1 XOr where liftCompare = genericLiftCompare @@ -282,52 +286,52 @@ instance Show1 XOr where liftShowsPrec = genericLiftShowsPrec instance Evaluatable XOr where -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands - eval t = rvalBox =<< go (fmap subtermValue t) where + eval eval t = rvalBox =<< go (fmap (eval >=> Abstract.value) t) where go (XOr a b) = liftA2 (/=) (a >>= asBool) (b >>= asBool) >>= boolean -- | Javascript delete operator newtype Delete a = Delete { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Delete where liftEq = genericLiftEq instance Ord1 Delete where liftCompare = genericLiftCompare instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Delete where - eval (Delete a) = do - -- TODO: Fix me. - -- valueRef <- subtermRef a + eval eval (Delete a) = do + -- valueRef <- eval a -- addr <- address valueRef -- dealloc addr - rvalBox unit + -- rvalBox unit + undefined -- | A sequence expression such as Javascript or C's comma operator. data SequenceExpression a = SequenceExpression { firstExpression :: !a, secondExpression :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 SequenceExpression where liftEq = genericLiftEq instance Ord1 SequenceExpression where liftCompare = genericLiftCompare instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec instance Evaluatable SequenceExpression where - eval (SequenceExpression a b) = - subtermValue a >> subtermRef b + eval eval (SequenceExpression a b) = + eval a >> eval b -- | Javascript void operator newtype Void a = Void { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Void where liftEq = genericLiftEq instance Ord1 Void where liftCompare = genericLiftCompare instance Show1 Void where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Void where - eval (Void a) = - subtermValue a >> rvalBox null + eval eval (Void a) = + eval a >> rvalBox null -- | Javascript typeof operator newtype Typeof a = Typeof { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Typeof where liftEq = genericLiftEq instance Ord1 Typeof where liftCompare = genericLiftCompare @@ -338,97 +342,97 @@ instance Evaluatable Typeof -- | Bitwise operators. data BOr a = BOr { left :: a, right :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 BOr where liftEq = genericLiftEq instance Ord1 BOr where liftCompare = genericLiftCompare instance Show1 BOr where liftShowsPrec = genericLiftShowsPrec instance Evaluatable BOr where - eval (BOr a b) = do - a' <- subtermValue a >>= castToInteger - b' <- subtermValue b >>= castToInteger + eval eval (BOr a b) = do + a' <- eval a >>= Abstract.value >>= castToInteger + b' <- eval b >>= Abstract.value >>= castToInteger liftBitwise2 (.|.) a' b' >>= rvalBox data BAnd a = BAnd { left :: a, right :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 BAnd where liftEq = genericLiftEq instance Ord1 BAnd where liftCompare = genericLiftCompare instance Show1 BAnd where liftShowsPrec = genericLiftShowsPrec instance Evaluatable BAnd where - eval (BAnd a b) = do - a' <- subtermValue a >>= castToInteger - b' <- subtermValue b >>= castToInteger + eval eval (BAnd a b) = do + a' <- eval a >>= Abstract.value >>= castToInteger + b' <- eval b >>= Abstract.value >>= castToInteger liftBitwise2 (.&.) a' b' >>= rvalBox data BXOr a = BXOr { left :: a, right :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 BXOr where liftEq = genericLiftEq instance Ord1 BXOr where liftCompare = genericLiftCompare instance Show1 BXOr where liftShowsPrec = genericLiftShowsPrec instance Evaluatable BXOr where - eval (BXOr a b) = do - a' <- subtermValue a >>= castToInteger - b' <- subtermValue b >>= castToInteger + eval eval (BXOr a b) = do + a' <- eval a >>= Abstract.value >>= castToInteger + b' <- eval b >>= Abstract.value >>= castToInteger liftBitwise2 xor a' b' >>= rvalBox data LShift a = LShift { left :: a, right :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 LShift where liftEq = genericLiftEq instance Ord1 LShift where liftCompare = genericLiftCompare instance Show1 LShift where liftShowsPrec = genericLiftShowsPrec instance Evaluatable LShift where - eval (LShift a b) = do - a' <- subtermValue a >>= castToInteger - b' <- subtermValue b >>= castToInteger + eval eval (LShift a b) = do + a' <- eval a >>= Abstract.value >>= castToInteger + b' <- eval b >>= Abstract.value >>= castToInteger liftBitwise2 shiftL' a' b' >>= rvalBox where shiftL' a b = shiftL a (fromIntegral (toInteger b)) data RShift a = RShift { left :: a, right :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 RShift where liftEq = genericLiftEq instance Ord1 RShift where liftCompare = genericLiftCompare instance Show1 RShift where liftShowsPrec = genericLiftShowsPrec instance Evaluatable RShift where - eval (RShift a b) = do - a' <- subtermValue a >>= castToInteger - b' <- subtermValue b >>= castToInteger + eval eval (RShift a b) = do + a' <- eval a >>= Abstract.value >>= castToInteger + b' <- eval b >>= Abstract.value >>= castToInteger liftBitwise2 shiftR' a' b' >>= rvalBox where shiftR' a b = shiftR a (fromIntegral (toInteger b)) data UnsignedRShift a = UnsignedRShift { left :: a, right :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 UnsignedRShift where liftEq = genericLiftEq instance Ord1 UnsignedRShift where liftCompare = genericLiftCompare instance Show1 UnsignedRShift where liftShowsPrec = genericLiftShowsPrec instance Evaluatable UnsignedRShift where - eval (UnsignedRShift a b) = do - a' <- subtermValue a >>= castToInteger - b' <- subtermValue b >>= castToInteger + eval eval (UnsignedRShift a b) = do + a' <- eval a >>= Abstract.value >>= castToInteger + b' <- eval b >>= Abstract.value >>= castToInteger unsignedRShift a' b' >>= rvalBox newtype Complement a = Complement { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Complement where liftEq = genericLiftEq instance Ord1 Complement where liftCompare = genericLiftCompare instance Show1 Complement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Complement where - eval (Complement a) = do - a' <- subtermValue a >>= castToInteger + eval eval (Complement a) = do + a' <- eval a >>= Abstract.value >>= castToInteger liftBitwise complement a' >>= rvalBox -- | Member Access (e.g. a.b) data MemberAccess a = MemberAccess { lhs :: a, rhs :: Name } - deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Declarations1 MemberAccess where liftDeclaredName _ MemberAccess{..} = Just rhs @@ -438,26 +442,23 @@ instance Ord1 MemberAccess where liftCompare = genericLiftCompare instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec instance Evaluatable MemberAccess where - eval (MemberAccess obj propName) = do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm obj)) + eval eval (MemberAccess obj propName) = do + name <- maybeM (throwEvalError NoNameError) (declaredName obj) reference (Reference name) (Declaration name) childScope <- associatedScope (Declaration name) - -- TODO: Fix me. - -- ptr <- subtermAddress obj + -- ptr <- eval obj >>= address -- case childScope of -- Just childScope -> withScope childScope $ reference (Reference propName) (Declaration propName) -- Nothing -> -- -- TODO: Throw an ReferenceError because we can't find the associated child scope for `obj`. -- pure () - -- - -- pure $! LvalMember ptr propName - rvalBox unit + undefined -- | Subscript (e.g a[1]) data Subscript a = Subscript { lhs :: a, rhs :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Subscript where liftEq = genericLiftEq instance Ord1 Subscript where liftCompare = genericLiftCompare @@ -466,11 +467,11 @@ instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec -- TODO: Finish Eval instance for Subscript -- TODO return a special LvalSubscript instance here instance Evaluatable Subscript where - eval (Subscript l [r]) = Rval <$> join (index <$> subtermValue l <*> subtermValue r) - eval (Subscript _ _) = rvalBox =<< throwUnspecializedError (UnspecializedError "Eval unspecialized for subscript with slices") + eval eval (Subscript l [r]) = Rval <$> join (index <$> (eval l >>= Abstract.value) <*> (eval r >>= Abstract.value)) + eval _ (Subscript _ _) = rvalBox =<< throwUnspecializedError (UnspecializedError "Eval unspecialized for subscript with slices") data Member a = Member { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Member where liftEq = genericLiftEq instance Ord1 Member where liftCompare = genericLiftCompare @@ -480,7 +481,7 @@ instance Evaluatable Member where -- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop)) data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, enumerationStep :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Enumeration where liftEq = genericLiftEq instance Ord1 Enumeration where liftCompare = genericLiftCompare @@ -492,7 +493,7 @@ instance Evaluatable Enumeration -- | InstanceOf (e.g. a instanceof b in JavaScript data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 InstanceOf where liftEq = genericLiftEq instance Ord1 InstanceOf where liftCompare = genericLiftCompare @@ -504,7 +505,7 @@ instance Evaluatable InstanceOf -- | ScopeResolution (e.g. import a.b in Python or a::b in C++) newtype ScopeResolution a = ScopeResolution { scopes :: NonEmpty a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Hashable1 ScopeResolution where liftHashWithSalt = foldl instance Eq1 ScopeResolution where liftEq = genericLiftEq @@ -512,15 +513,13 @@ instance Ord1 ScopeResolution where liftCompare = genericLiftCompare instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ScopeResolution where - eval (ScopeResolution xs) = undefined - -- TODO: Fix me. - -- Rval <$> foldl1 f (fmap subtermAddress xs) - -- where f ns id = ns >>= flip evaluateInScopedEnv id + eval eval (ScopeResolution xs) = undefined -- Rval <$> foldl1 f (fmap (eval >=> address) xs) + -- where f ns id = ns >>= flip evaluateInScopedEnv id -- | A non-null expression such as Typescript or Swift's ! expression. newtype NonNullExpression a = NonNullExpression { nonNullExpression :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 NonNullExpression where liftEq = genericLiftEq instance Ord1 NonNullExpression where liftCompare = genericLiftCompare @@ -532,7 +531,7 @@ instance Evaluatable NonNullExpression -- | An await expression in Javascript or C#. newtype Await a = Await { awaitSubject :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Await where liftEq = genericLiftEq instance Ord1 Await where liftCompare = genericLiftCompare @@ -541,14 +540,14 @@ instance Show1 Await where liftShowsPrec = genericLiftShowsPrec -- TODO: Improve this to model asynchrony or capture some data suggesting async calls are not a problem. -- We are currently dealing with an asynchronous construct synchronously. instance Evaluatable Await where - eval (Await a) = subtermRef a + eval eval (Await a) = eval a -- | An object constructor call in Javascript, Java, etc. newtype New a = New { newSubject :: [a] } - deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Declarations1 New where - liftDeclaredName _ (New []) = Nothing + liftDeclaredName _ (New []) = Nothing liftDeclaredName declaredName (New (subject : _)) = declaredName subject instance Eq1 New where liftEq = genericLiftEq @@ -557,18 +556,18 @@ instance Show1 New where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for New instance Evaluatable New where - eval New{..} = do + eval _ New{..} = do case newSubject of [] -> pure () (subject : _) -> do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm subject)) + name <- maybeM (throwEvalError NoNameError) (declaredName subject) reference (Reference name) (Declaration name) -- TODO: Traverse subterms and instantiate frames from the corresponding scope rvalBox unit -- | A cast expression to a specified type. data Cast a = Cast { castSubject :: !a, castType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Cast where liftEq = genericLiftEq instance Ord1 Cast where liftCompare = genericLiftCompare @@ -577,23 +576,19 @@ instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Cast data Super a = Super - deriving (Diffable, Eq, Foldable, Functor, Generic1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Hashable1, Named1, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Hashable1, Named1, Message1, NFData1) instance Eq1 Super where liftEq = genericLiftEq instance Ord1 Super where liftCompare = genericLiftCompare instance Show1 Super where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Super where - eval Super = undefined - -- TODO: Fix me. - -- Rval <$> (maybeM (box unit) =<< self) + eval _ Super = undefined -- Rval <$> (maybeM (box unit) =<< self) data This a = This - deriving (Diffable, Eq, Foldable, Functor, Generic1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Hashable1, Named1, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Hashable1, Named1, Message1, NFData1) instance Eq1 This where liftEq = genericLiftEq instance Ord1 This where liftCompare = genericLiftCompare instance Show1 This where liftShowsPrec = genericLiftShowsPrec instance Evaluatable This where - eval This = undefined - -- TODO: Fix me. - -- Rval <$> (maybeM (box unit) =<< self) + eval _ This = undefined -- Rval <$> (maybeM (box unit) =<< self) diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index b8dda3235..3f562431c 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -18,7 +18,7 @@ import Text.Read (readMaybe) -- Boolean newtype Boolean a = Boolean { booleanContent :: Bool } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) true :: Boolean a true = Boolean True @@ -31,7 +31,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Boolean where - eval (Boolean x) = boolean x >>= rvalBox + eval _ (Boolean x) = boolean x >>= rvalBox instance Tokenize Boolean where tokenize = yield . Truth . booleanContent @@ -40,7 +40,7 @@ instance Tokenize Boolean where -- | A literal integer of unspecified width. No particular base is implied. newtype Integer a = Integer { integerContent :: Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare @@ -48,7 +48,7 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow instance Evaluatable Data.Syntax.Literal.Integer where -- TODO: We should use something more robust than shelling out to readMaybe. - eval (Data.Syntax.Literal.Integer x) = + eval _ (Data.Syntax.Literal.Integer x) = rvalBox =<< (integer <$> either (const (throwEvalError (IntegerFormatError x))) pure (parseInteger x)) instance Tokenize Data.Syntax.Literal.Integer where @@ -57,14 +57,14 @@ instance Tokenize Data.Syntax.Literal.Integer where -- | A literal float of unspecified width. newtype Float a = Float { floatContent :: Text } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Data.Syntax.Literal.Float where - eval (Float s) = + eval _ (Float s) = rvalBox =<< (float <$> either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s)) instance Tokenize Data.Syntax.Literal.Float where @@ -72,14 +72,14 @@ instance Tokenize Data.Syntax.Literal.Float where -- Rational literals e.g. `2/3r` newtype Rational a = Rational { value :: Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompare instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Data.Syntax.Literal.Rational where - eval (Rational r) = + eval _ (Rational r) = let trimmed = T.takeWhile (/= 'r') r parsed = readMaybe @Prelude.Integer (T.unpack trimmed) @@ -87,7 +87,7 @@ instance Evaluatable Data.Syntax.Literal.Rational where -- Complex literals e.g. `3 + 2i` newtype Complex a = Complex { value :: Text } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Data.Syntax.Literal.Complex where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Complex where liftCompare = genericLiftCompare @@ -99,7 +99,7 @@ instance Evaluatable Complex -- Strings, symbols newtype String a = String { stringElements :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.String where liftCompare = genericLiftCompare @@ -111,7 +111,7 @@ instance Show1 Data.Syntax.Literal.String where liftShowsPrec = genericLiftShows instance Evaluatable Data.Syntax.Literal.String newtype Character a = Character { characterContent :: Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Data.Syntax.Literal.Character where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Character where liftCompare = genericLiftCompare @@ -121,7 +121,7 @@ instance Evaluatable Data.Syntax.Literal.Character -- | An interpolation element within a string literal. newtype InterpolationElement a = InterpolationElement { interpolationBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 InterpolationElement where liftEq = genericLiftEq instance Ord1 InterpolationElement where liftCompare = genericLiftCompare @@ -132,21 +132,21 @@ instance Evaluatable InterpolationElement -- | A sequence of textual contents within a string literal. newtype TextElement a = TextElement { textElementContent :: Text } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 TextElement where liftEq = genericLiftEq instance Ord1 TextElement where liftCompare = genericLiftCompare instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TextElement where - eval (TextElement x) = rvalBox (string x) + eval _ (TextElement x) = rvalBox (string x) instance Tokenize TextElement where tokenize = yield . Run . textElementContent -- | A sequence of textual contents within a string literal. newtype EscapeSequence a = EscapeSequence { value :: Text } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 EscapeSequence where liftEq = genericLiftEq instance Ord1 EscapeSequence where liftCompare = genericLiftCompare @@ -156,19 +156,19 @@ instance Show1 EscapeSequence where liftShowsPrec = genericLiftShowsPrec instance Evaluatable EscapeSequence data Null a = Null - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Null where liftEq = genericLiftEq instance Ord1 Null where liftCompare = genericLiftCompare instance Show1 Null where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable Null where eval _ = rvalBox null +instance Evaluatable Null where eval _ _ = rvalBox null instance Tokenize Null where tokenize _ = yield Nullity newtype Symbol a = Symbol { symbolElements :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Symbol where liftEq = genericLiftEq instance Ord1 Symbol where liftCompare = genericLiftCompare @@ -178,17 +178,17 @@ instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Symbol newtype SymbolElement a = SymbolElement { symbolContent :: Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 SymbolElement where liftEq = genericLiftEq instance Ord1 SymbolElement where liftCompare = genericLiftCompare instance Show1 SymbolElement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable SymbolElement where - eval (SymbolElement s) = rvalBox (symbol s) + eval _ (SymbolElement s) = rvalBox (symbol s) newtype Regex a = Regex { regexContent :: Text } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Regex where liftEq = genericLiftEq instance Ord1 Regex where liftCompare = genericLiftCompare @@ -198,66 +198,62 @@ instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Regex instance Evaluatable Regex where - eval (Regex x) = rvalBox (regex x) + eval _ (Regex x) = rvalBox (regex x) -- Collections newtype Array a = Array { arrayElements :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Array where liftEq = genericLiftEq instance Ord1 Array where liftCompare = genericLiftCompare instance Show1 Array where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Array where - eval (Array a) = undefined - -- TODO: Fix me. - -- rvalBox =<< array =<< traverse subtermAddress a + eval eval (Array a) = undefined -- rvalBox =<< array =<< traverse (eval >=> address) a instance Tokenize Array where tokenize = list . arrayElements newtype Hash a = Hash { hashElements :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Hash where liftEq = genericLiftEq instance Ord1 Hash where liftCompare = genericLiftCompare instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Hash where - eval t = rvalBox =<< (Eval.hash <$> traverse (subtermValue >=> asPair) (hashElements t)) + eval eval t = rvalBox =<< (Eval.hash <$> traverse (eval >=> Eval.value >=> asPair) (hashElements t)) instance Tokenize Hash where tokenize = Tok.hash . hashElements data KeyValue a = KeyValue { key :: !a, value :: !a } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 KeyValue where liftEq = genericLiftEq instance Ord1 KeyValue where liftCompare = genericLiftCompare instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec instance Evaluatable KeyValue where - eval (fmap subtermValue -> KeyValue{..}) = + eval eval (fmap (eval >=> Eval.value) -> KeyValue{..}) = rvalBox =<< (kvPair <$> key <*> value) instance Tokenize KeyValue where tokenize (KeyValue k v) = pair k v newtype Tuple a = Tuple { tupleContents :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Tuple where liftEq = genericLiftEq instance Ord1 Tuple where liftCompare = genericLiftCompare instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Tuple where - eval (Tuple cs) = undefined - -- TODO: Fix me. - -- rvalBox =<< tuple =<< traverse subtermAddress cs + eval eval (Tuple cs) = undefined -- rvalBox =<< tuple =<< traverse (eval >=> address) cs newtype Set a = Set { setElements :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Set where liftEq = genericLiftEq instance Ord1 Set where liftCompare = genericLiftCompare @@ -271,7 +267,7 @@ instance Evaluatable Set -- | A declared pointer (e.g. var pointer *int in Go) newtype Pointer a = Pointer { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Pointer where liftEq = genericLiftEq instance Ord1 Pointer where liftCompare = genericLiftCompare @@ -283,7 +279,7 @@ instance Evaluatable Pointer -- | A reference to a pointer's address (e.g. &pointer in Go) newtype Reference a = Reference { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Reference where liftEq = genericLiftEq instance Ord1 Reference where liftCompare = genericLiftCompare diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index bf9feb99c..d753adbd3 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -2,18 +2,21 @@ {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Statement where -import Data.Abstract.Evaluatable -import Control.Abstract.ScopeGraph +import Prologue + import qualified Data.Map.Strict as Map import Data.Aeson (ToJSON1 (..)) -import Data.JSON.Fields import Data.Semigroup.App import Data.Semigroup.Foldable -import Diffing.Algorithm -import Prelude -import Prologue import Proto3.Suite.Class + +import Data.Abstract.Evaluatable as Abstract +import Control.Abstract.ScopeGraph +import Data.JSON.Fields +import Diffing.Algorithm import Reprinting.Tokenize +import qualified Data.Reprinting.Token as Token +import qualified Data.Reprinting.Scope as Scope -- | Imperative sequence of statements/declarations s.t.: -- @@ -21,7 +24,7 @@ import Reprinting.Tokenize -- 2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and -- 3. Only the last statementā€™s return value is returned. newtype Statements a = Statements { statements :: [a] } - deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Statements where liftEq = genericLiftEq instance Ord1 Statements where liftCompare = genericLiftCompare @@ -29,38 +32,38 @@ instance Show1 Statements where liftShowsPrec = genericLiftShowsPrec instance ToJSON1 Statements instance Evaluatable Statements where - eval (Statements xs) = do - currentScope' <- currentScope + eval eval (Statements xs) = do + currentScope' <- currentScope -- TODO: currentScope should return a Maybe scope <- newScope (Map.singleton Lexical [ currentScope' ]) - withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs) + withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . eval)) (nonEmpty xs) instance Tokenize Statements where tokenize = imperative -- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted. data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 If where liftEq = genericLiftEq instance Ord1 If where liftCompare = genericLiftCompare instance Show1 If where liftShowsPrec = genericLiftShowsPrec instance Evaluatable If where - eval (If cond if' else') = do - bool <- subtermValue cond - Rval <$> ifthenelse bool (subtermValue if') (subtermValue else') + eval eval (If cond if' else') = do + bool <- eval cond >>= Abstract.value + Rval <$> ifthenelse bool (eval if' >>= address) (eval else' >>= address) instance Tokenize If where - tokenize If{..} = within' TIf $ do + tokenize If{..} = within' Scope.If $ do ifCondition - yield TThen + yield Token.Then ifThenBody - yield TElse + yield Token.Else ifElseBody -- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python. data Else a = Else { elseCondition :: !a, elseBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Else where liftEq = genericLiftEq instance Ord1 Else where liftCompare = genericLiftCompare @@ -73,7 +76,7 @@ instance Evaluatable Else -- | Goto statement (e.g. `goto a` in Go). newtype Goto a = Goto { gotoLocation :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Goto where liftEq = genericLiftEq instance Ord1 Goto where liftCompare = genericLiftCompare @@ -85,7 +88,7 @@ instance Evaluatable Goto -- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell. data Match a = Match { matchSubject :: !a, matchPatterns :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Match where liftEq = genericLiftEq instance Ord1 Match where liftCompare = genericLiftCompare @@ -97,7 +100,7 @@ instance Evaluatable Match -- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions. data Pattern a = Pattern { value :: !a, patternBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Pattern where liftEq = genericLiftEq instance Ord1 Pattern where liftCompare = genericLiftCompare @@ -109,26 +112,25 @@ instance Evaluatable Pattern -- | A let statement or local binding, like 'a as b' or 'let a = b'. data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Let where liftEq = genericLiftEq instance Ord1 Let where liftCompare = genericLiftCompare instance Show1 Let where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Let where - eval Let{..} = do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm letVariable)) - -- TODO: Fix me. - -- addr <- snd <$> letrec name (subtermValue letValue) - -- Rval <$> locally (bind name addr *> subtermAddress letBody) - rvalBox unit + eval eval Let{..} = do + undefined + -- name <- maybeM (throwEvalError NoNameError) (declaredName letVariable) + -- addr <- snd <$> letrec name (eval letValue >>= Abstract.value) + -- Rval <$> locally (bind name addr *> (eval letBody >>= address)) -- Assignment -- | Assignment to a variable or other lvalue. data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a } - deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Declarations1 Assignment where liftDeclaredName declaredName Assignment{..} = declaredName assignmentTarget @@ -138,15 +140,14 @@ instance Ord1 Assignment where liftCompare = genericLiftCompare instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Assignment where - eval Assignment{..} = do + eval eval Assignment{..} = do undefined - -- TODO: Fix me. - -- lhs <- subtermRef assignmentTarget - -- rhs <- subtermAddress assignmentValue + -- lhs <- eval assignmentTarget + -- rhs <- eval assignmentValue >>= address -- -- case lhs of -- LvalLocal name -> do - -- case declaredName (subterm assignmentValue) of + -- case declaredName assignmentValue of -- Just rhsName -> do -- assocScope <- associatedScope (Declaration rhsName) -- case assocScope of @@ -169,7 +170,7 @@ instance Evaluatable Assignment where -- | Post increment operator (e.g. 1++ in Go, or i++ in C). newtype PostIncrement a = PostIncrement { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 PostIncrement where liftEq = genericLiftEq instance Ord1 PostIncrement where liftCompare = genericLiftCompare @@ -181,7 +182,7 @@ instance Evaluatable PostIncrement -- | Post decrement operator (e.g. 1-- in Go, or i-- in C). newtype PostDecrement a = PostDecrement { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 PostDecrement where liftEq = genericLiftEq instance Ord1 PostDecrement where liftCompare = genericLiftCompare @@ -192,7 +193,7 @@ instance Evaluatable PostDecrement -- | Pre increment operator (e.g. ++1 in C or Java). newtype PreIncrement a = PreIncrement { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 PreIncrement where liftEq = genericLiftEq instance Ord1 PreIncrement where liftCompare = genericLiftCompare @@ -204,7 +205,7 @@ instance Evaluatable PreIncrement -- | Pre decrement operator (e.g. --1 in C or Java). newtype PreDecrement a = PreDecrement { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 PreDecrement where liftEq = genericLiftEq instance Ord1 PreDecrement where liftCompare = genericLiftCompare @@ -217,22 +218,20 @@ instance Evaluatable PreDecrement -- Returns newtype Return a = Return { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Return where liftEq = genericLiftEq instance Ord1 Return where liftCompare = genericLiftCompare instance Show1 Return where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Return where - eval (Return x) = undefined - -- TODO: Fix me. - -- Rval <$> (subtermAddress x >>= earlyReturn) + eval eval (Return x) = undefined -- Rval <$> (eval x >>= address >>= earlyReturn) instance Tokenize Return where - tokenize (Return x) = within' TReturn x + tokenize (Return x) = within' Scope.Return x newtype Yield a = Yield { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Yield where liftEq = genericLiftEq instance Ord1 Yield where liftCompare = genericLiftCompare @@ -243,31 +242,27 @@ instance Evaluatable Yield newtype Break a = Break { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Break where liftEq = genericLiftEq instance Ord1 Break where liftCompare = genericLiftCompare instance Show1 Break where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Break where - eval (Break x) = undefined - -- TODO: Fix me. - -- Rval <$> (subtermAddress x >>= throwBreak) + eval eval (Break x) = undefined -- Rval <$> (eval x >>= address >>= throwBreak) newtype Continue a = Continue { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Continue where liftEq = genericLiftEq instance Ord1 Continue where liftCompare = genericLiftCompare instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Continue where - eval (Continue x) = undefined - -- TODO: Fix me. - -- Rval <$> (subtermAddress x >>= throwContinue) + eval eval (Continue x) = undefined -- Rval <$> (eval x >>= address >>= throwContinue) newtype Retry a = Retry { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Retry where liftEq = genericLiftEq instance Ord1 Retry where liftCompare = genericLiftCompare @@ -278,30 +273,30 @@ instance Evaluatable Retry newtype NoOp a = NoOp { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 NoOp where liftEq = genericLiftEq instance Ord1 NoOp where liftCompare = genericLiftCompare instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NoOp where - eval _ = rvalBox unit + eval _ _ = rvalBox unit -- Loops data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 For where liftEq = genericLiftEq instance Ord1 For where liftCompare = genericLiftCompare instance Show1 For where liftShowsPrec = genericLiftShowsPrec instance Evaluatable For where - eval (fmap subtermValue -> For before cond step body) = rvalBox =<< forLoop before cond step body + eval eval (fmap (eval >=> Abstract.value) -> For before cond step body) = rvalBox =<< forLoop before cond step body data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ForEach where liftEq = genericLiftEq instance Ord1 ForEach where liftCompare = genericLiftCompare @@ -312,29 +307,29 @@ instance Evaluatable ForEach data While a = While { whileCondition :: !a, whileBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 While where liftEq = genericLiftEq instance Ord1 While where liftCompare = genericLiftCompare instance Show1 While where liftShowsPrec = genericLiftShowsPrec instance Evaluatable While where - eval While{..} = rvalBox =<< while (subtermValue whileCondition) (subtermValue whileBody) + eval eval While{..} = rvalBox =<< while (eval whileCondition >>= Abstract.value) (eval whileBody >>= Abstract.value) data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 DoWhile where liftEq = genericLiftEq instance Ord1 DoWhile where liftCompare = genericLiftCompare instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec instance Evaluatable DoWhile where - eval DoWhile{..} = rvalBox =<< doWhile (subtermValue doWhileBody) (subtermValue doWhileCondition) + eval eval DoWhile{..} = rvalBox =<< doWhile (eval doWhileBody >>= Abstract.value) (eval doWhileCondition >>= Abstract.value) -- Exception handling newtype Throw a = Throw { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Throw where liftEq = genericLiftEq instance Ord1 Throw where liftCompare = genericLiftCompare @@ -345,7 +340,7 @@ instance Evaluatable Throw data Try a = Try { tryBody :: !a, tryCatch :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Try where liftEq = genericLiftEq instance Ord1 Try where liftCompare = genericLiftCompare @@ -356,7 +351,7 @@ instance Evaluatable Try data Catch a = Catch { catchException :: !a, catchBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Catch where liftEq = genericLiftEq instance Ord1 Catch where liftCompare = genericLiftCompare @@ -367,7 +362,7 @@ instance Evaluatable Catch newtype Finally a = Finally { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Finally where liftEq = genericLiftEq instance Ord1 Finally where liftCompare = genericLiftCompare @@ -381,7 +376,7 @@ instance Evaluatable Finally -- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl). newtype ScopeEntry a = ScopeEntry { terms :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ScopeEntry where liftEq = genericLiftEq instance Ord1 ScopeEntry where liftCompare = genericLiftCompare @@ -393,7 +388,7 @@ instance Evaluatable ScopeEntry -- | ScopeExit (e.g. `END {}` block in Ruby or Perl). newtype ScopeExit a = ScopeExit { terms :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ScopeExit where liftEq = genericLiftEq instance Ord1 ScopeExit where liftCompare = genericLiftCompare diff --git a/src/Data/Syntax/Type.hs b/src/Data/Syntax/Type.hs index bf16a448d..14a31fc71 100644 --- a/src/Data/Syntax/Type.hs +++ b/src/Data/Syntax/Type.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Type where -import Data.Abstract.Evaluatable +import Data.Abstract.Evaluatable hiding (Void) import Data.JSON.Fields import Diffing.Algorithm import Prelude hiding (Bool, Float, Int, Double) @@ -11,7 +11,7 @@ import Proto3.Suite.Class import Reprinting.Tokenize data Array a = Array { arraySize :: !(Maybe a), arrayElementType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Message1, NFData1) instance Named1 Array where nameOf1 _ = "TypeArray" @@ -25,7 +25,7 @@ instance Evaluatable Array -- TODO: What about type variables? re: FreeVariables1 data Annotation a = Annotation { annotationSubject :: !a, annotationType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Annotation where liftEq = genericLiftEq instance Ord1 Annotation where liftCompare = genericLiftCompare @@ -33,7 +33,7 @@ instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec -- TODO: Specialize Evaluatable for Type to unify the inferred type of the subject with the specified type instance Evaluatable Annotation where - eval Annotation{annotationSubject = Subterm _ action} = action + eval eval Annotation{..} = eval annotationSubject instance Tokenize Annotation where -- FIXME: This ignores annotationType. @@ -42,7 +42,7 @@ instance Tokenize Annotation where data Function a = Function { functionParameters :: ![a], functionReturn :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Message1, NFData1) instance Named1 Function where nameOf1 _ = "TypeFunction" instance Eq1 Function where liftEq = genericLiftEq @@ -54,7 +54,7 @@ instance Evaluatable Function newtype Interface a = Interface { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Interface where liftEq = genericLiftEq instance Ord1 Interface where liftCompare = genericLiftCompare @@ -65,7 +65,7 @@ instance Evaluatable Interface data Map a = Map { mapKeyType :: !a, mapElementType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Map where liftEq = genericLiftEq instance Ord1 Map where liftCompare = genericLiftCompare @@ -76,7 +76,7 @@ instance Evaluatable Map newtype Parenthesized a = Parenthesized { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Parenthesized where liftEq = genericLiftEq instance Ord1 Parenthesized where liftCompare = genericLiftCompare @@ -87,7 +87,7 @@ instance Evaluatable Parenthesized newtype Pointer a = Pointer { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Message1, NFData1) instance Named1 Pointer where nameOf1 _ = "TypePointer" instance Eq1 Pointer where liftEq = genericLiftEq @@ -99,7 +99,7 @@ instance Evaluatable Pointer newtype Product a = Product { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Product where liftEq = genericLiftEq instance Ord1 Product where liftCompare = genericLiftCompare @@ -110,7 +110,7 @@ instance Evaluatable Product data Readonly a = Readonly - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Readonly where liftEq = genericLiftEq instance Ord1 Readonly where liftCompare = genericLiftCompare @@ -121,7 +121,7 @@ instance Evaluatable Readonly newtype Slice a = Slice { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Message1, NFData1) instance Named1 Slice where nameOf1 _ = "TypeSlice" instance Eq1 Slice where liftEq = genericLiftEq @@ -133,7 +133,7 @@ instance Evaluatable Slice newtype TypeParameters a = TypeParameters { terms :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 TypeParameters where liftEq = genericLiftEq instance Ord1 TypeParameters where liftCompare = genericLiftCompare @@ -144,7 +144,7 @@ instance Evaluatable TypeParameters -- data instead of newtype because no payload data Void a = Void - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Void where liftEq = genericLiftEq instance Ord1 Void where liftCompare = genericLiftCompare @@ -155,7 +155,7 @@ instance Evaluatable Void -- data instead of newtype because no payload data Int a = Int - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Int where liftEq = genericLiftEq instance Ord1 Int where liftCompare = genericLiftCompare @@ -165,7 +165,7 @@ instance Show1 Int where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Int data Float a = Float - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Message1, NFData1) instance Named1 Float where nameOf1 _ = "TypeFloat" @@ -177,7 +177,7 @@ instance Show1 Float where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Float data Double a = Double - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Double where liftEq = genericLiftEq instance Ord1 Double where liftCompare = genericLiftCompare @@ -187,7 +187,7 @@ instance Show1 Double where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Double data Bool a = Bool - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Bool where liftEq = genericLiftEq instance Ord1 Bool where liftCompare = genericLiftCompare diff --git a/src/Data/Term.hs b/src/Data/Term.hs index 22faabefb..e4fae2695 100644 --- a/src/Data/Term.hs +++ b/src/Data/Term.hs @@ -6,18 +6,17 @@ module Data.Term , termOut , injectTerm , projectTerm +, guardTerm , TermF(..) , termSize , hoistTerm , hoistTermF -, stripTerm , Annotated (..) ) where import Prologue import Data.Aeson import Data.JSON.Fields -import Data.Record import Text.Show import qualified Data.Sum as Sum import Proto3.Suite.Class @@ -37,6 +36,11 @@ termOut = termFOut . unTerm projectTerm :: forall f syntax ann . (f :< syntax) => Term (Sum syntax) ann -> Maybe (f (Term (Sum syntax) ann)) projectTerm = Sum.project . termOut +guardTerm :: forall m f syntax ann . (f :< syntax, Alternative m) + => Term (Sum syntax) ann + -> m (f (Term (Sum syntax) ann)) +guardTerm = Sum.projectGuard . termOut + data TermF syntax ann recur = In { termFAnnotation :: ann, termFOut :: syntax recur } deriving (Eq, Ord, Foldable, Functor, Show, Traversable) @@ -71,10 +75,6 @@ hoistTerm f = go where go (Term r) = Term (hoistTermF f (fmap go r)) hoistTermF :: (forall a. f a -> g a) -> TermF f a b -> TermF g a b hoistTermF f = go where go (In a r) = In a (f r) --- | Strips the head annotation off a term annotated with non-empty records. -stripTerm :: Functor f => Term f (Record (h ': t)) -> Term f (Record t) -stripTerm = fmap rtail - type instance Base (Term f a) = TermF f a @@ -113,6 +113,12 @@ instance Ord1 f => Ord1 (Term f) where instance (Ord1 f, Ord a) => Ord (Term f a) where compare = compare1 +instance NFData1 f => NFData1 (Term f) where + liftRnf rnf = go where go x = liftRnf2 rnf go (unTerm x) + +instance (NFData1 f, NFData a) => NFData (Term f a) where + rnf = liftRnf rnf + instance Functor f => Bifunctor (TermF f) where bimap f g (In a r) = In (f a) (fmap g r) @@ -127,6 +133,7 @@ instance Traversable f => Bitraversable (TermF f) where instance Eq1 f => Eq2 (TermF f) where liftEq2 eqA eqB (In a1 f1) (In a2 f2) = eqA a1 a2 && liftEq eqB f1 f2 + instance (Eq1 f, Eq a) => Eq1 (TermF f a) where liftEq = liftEq2 (==) @@ -142,6 +149,9 @@ instance Ord1 f => Ord2 (TermF f) where instance (Ord1 f, Ord a) => Ord1 (TermF f a) where liftCompare = liftCompare2 compare +instance NFData1 f => NFData2 (TermF f) where + liftRnf2 rnf1 rnf2 (In a1 f1) = rnf1 a1 `seq` liftRnf rnf2 f1 + instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Term f a) where toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index bf82e1d0c..4497567c0 100644 --- a/src/Diffing/Algorithm.hs +++ b/src/Diffing/Algorithm.hs @@ -18,6 +18,7 @@ import Control.Monad.Free.Freer import Data.Diff import Data.Sum import Data.Term +import GHC.Generics import Prologue -- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm. diff --git a/src/Diffing/Algorithm/RWS.hs b/src/Diffing/Algorithm/RWS.hs index 18b8f45db..ca6966cf8 100644 --- a/src/Diffing/Algorithm/RWS.hs +++ b/src/Diffing/Algorithm/RWS.hs @@ -18,7 +18,6 @@ import Control.Monad.State.Strict import Data.Diff (DiffF(..), deleting, inserting, merge, replacing) import qualified Data.KdMap.Static as KdMap import Data.List (sortOn) -import Data.Record import Data.Term as Term import Diffing.Algorithm import Diffing.Algorithm.RWS.FeatureVector @@ -31,11 +30,11 @@ import Prologue type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool rws :: (Foldable syntax, Functor syntax, Diffable syntax) - => ComparabilityRelation syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) - -> (Term syntax (Record (FeatureVector ': fields1)) -> Term syntax (Record (FeatureVector ': fields2)) -> Bool) - -> [Term syntax (Record (FeatureVector ': fields1))] - -> [Term syntax (Record (FeatureVector ': fields2))] - -> EditScript (Term syntax (Record (FeatureVector ': fields1))) (Term syntax (Record (FeatureVector ': fields2))) + => ComparabilityRelation syntax (FeatureVector, ann) (FeatureVector, ann) + -> (Term syntax (FeatureVector, ann) -> Term syntax (FeatureVector, ann) -> Bool) + -> [Term syntax (FeatureVector, ann)] + -> [Term syntax (FeatureVector, ann)] + -> EditScript (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) rws _ _ as [] = This <$> as rws _ _ [] bs = That <$> bs rws canCompare _ [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a] @@ -77,7 +76,7 @@ rws canCompare equivalent as bs -- -- cf Ā§4.2 of RWS-Diff mostSimilarMatching isEligible tree term = listToMaybe (sortOn (editDistanceUpTo optionsNodeComparisons term . snd) candidates) - where candidates = filter (uncurry isEligible) (snd <$> KdMap.kNearest tree optionsMaxSimilarTerms (rhead (termAnnotation term))) + where candidates = filter (uncurry isEligible) (snd <$> KdMap.kNearest tree optionsMaxSimilarTerms (fst (termAnnotation term))) data Options = Options { optionsLookaheadPlaces :: {-# UNPACK #-} !Int -- ^ How many places ahead should we look for similar terms? @@ -97,8 +96,8 @@ defaultP = 0 defaultQ = 3 -toKdMap :: [(Int, Term syntax (Record (FeatureVector ': fields)))] -> KdMap.KdMap Double FeatureVector (Int, Term syntax (Record (FeatureVector ': fields))) -toKdMap = KdMap.build unFV . fmap (rhead . termAnnotation . snd &&& id) +toKdMap :: [(Int, Term syntax (FeatureVector, ann))] -> KdMap.KdMap Double FeatureVector (Int, Term syntax (FeatureVector, ann)) +toKdMap = KdMap.build unFV . fmap (fst . termAnnotation . snd &&& id) -- | A `Gram` is a fixed-size view of some portion of a tree, consisting of a `stem` of _p_ labels for parent nodes, and a `base` of _q_ labels of sibling nodes. Collectively, the bag of `Gram`s for each node of a tree (e.g. as computed by `pqGrams`) form a summary of the tree. data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] } @@ -106,38 +105,38 @@ data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] } -- | Annotates a term with a feature vector at each node, using the default values for the p, q, and d parameters. defaultFeatureVectorDecorator :: (Hashable1 syntax, Traversable syntax) - => Term syntax (Record fields) - -> Term syntax (Record (FeatureVector ': fields)) + => Term syntax ann + -> Term syntax (FeatureVector, ann) defaultFeatureVectorDecorator = featureVectorDecorator . pqGramDecorator defaultP defaultQ -- | Annotates a term with a feature vector at each node, parameterized by stem length, base width, and feature vector dimensions. -featureVectorDecorator :: (Foldable syntax, Functor syntax, Hashable label) => Term syntax (Record (label ': fields)) -> Term syntax (Record (FeatureVector ': fields)) -featureVectorDecorator = cata (\ (In (label :. rest) functor) -> - termIn (foldl' addSubtermVector (unitVector (hash label)) functor :. rest) functor) - where addSubtermVector v term = addVectors v (rhead (termAnnotation term)) +featureVectorDecorator :: (Foldable syntax, Functor syntax, Hashable label) => Term syntax (Gram label, ann) -> Term syntax (FeatureVector, ann) +featureVectorDecorator = cata (\ (In (label, ann) functor) -> + termIn (foldl' addSubtermVector (unitVector (hash label)) functor, ann) functor) + where addSubtermVector v term = addVectors v (fst (termAnnotation term)) -- | Annotates a term with the corresponding p,q-gram at each node. pqGramDecorator :: Traversable syntax - => Int -- ^ 'p'; the desired stem length for the grams. - -> Int -- ^ 'q'; the desired base length for the grams. - -> Term syntax (Record fields) -- ^ The term to decorate. - -> Term syntax (Record (Gram (Label syntax) ': fields)) -- ^ The decorated term. + => Int -- ^ 'p'; the desired stem length for the grams. + -> Int -- ^ 'q'; the desired base length for the grams. + -> Term syntax ann -- ^ The term to decorate. + -> Term syntax (Gram (Label syntax), ann) -- ^ The decorated term. pqGramDecorator p q = cata algebra where algebra term = let label = Label (termFOut term) in - termIn (gram label :. termFAnnotation term) (assignParentAndSiblingLabels (termFOut term) label) + termIn (gram label, termFAnnotation term) (assignParentAndSiblingLabels (termFOut term) label) gram label = Gram (padToSize p []) (padToSize q (pure (Just label))) assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label)) assignLabels :: label - -> Term syntax (Record (Gram label ': fields)) - -> State [Maybe label] (Term syntax (Record (Gram label ': fields))) - assignLabels label (Term.Term (In (gram :. rest) functor)) = do + -> Term syntax (Gram label, ann) + -> State [Maybe label] (Term syntax (Gram label, ann)) + assignLabels label (Term.Term (In (gram, rest) functor)) = do labels <- get put (drop 1 labels) - pure $! termIn (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels } :. rest) functor - siblingLabels :: Traversable syntax => syntax (Term syntax (Record (Gram label ': fields))) -> [Maybe label] - siblingLabels = foldMap (base . rhead . termAnnotation) + pure $! termIn (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels }, rest) functor + siblingLabels :: Traversable syntax => syntax (Term syntax (Gram label, ann)) -> [Maybe label] + siblingLabels = foldMap (base . fst . termAnnotation) padToSize n list = take n (list <> repeat empty) -- | Test the comparability of two root 'Term's in O(1). diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index bf73c93a0..e071273a2 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -2,11 +2,11 @@ module Diffing.Interpreter ( diffTerms , diffTermPair +, stripDiff ) where import Control.Monad.Free.Freer import Data.Diff -import Data.Record import Data.Term import Diffing.Algorithm import Diffing.Algorithm.RWS @@ -14,24 +14,30 @@ import Prologue -- | Diff two Ć  la carte terms recursively. diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) - => Term syntax (Record fields1) - -> Term syntax (Record fields2) - -> Diff syntax (Record fields1) (Record fields2) + => Term syntax ann + -> Term syntax ann + -> Diff syntax ann ann diffTerms t1 t2 = stripDiff (fromMaybe (replacing t1' t2') (runAlgorithm (diff t1' t2'))) where (t1', t2') = ( defaultFeatureVectorDecorator t1 , defaultFeatureVectorDecorator t2) +-- | Strips the head annotation off a diff annotated with non-empty records. +stripDiff :: Functor syntax + => Diff syntax (FeatureVector, ann) (FeatureVector, ann) + -> Diff syntax ann ann +stripDiff = bimap snd snd + -- | Diff a 'These' of terms. -diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Diff syntax (Record fields1) (Record fields2) +diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Diff syntax ann ann diffTermPair = these deleting inserting diffTerms -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations. runAlgorithm :: (Diffable syntax, Eq1 syntax, Traversable syntax, Alternative m, Monad m) => Algorithm - (Term syntax (Record (FeatureVector ': fields1))) - (Term syntax (Record (FeatureVector ': fields2))) - (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) + (Term syntax (FeatureVector, ann)) + (Term syntax (FeatureVector, ann)) + (Diff syntax (FeatureVector, ann) (FeatureVector, ann)) result -> m result runAlgorithm = iterFreerA (\ yield step -> case step of diff --git a/src/Language/Go/Assignment.hs b/src/Language/Go/Assignment.hs index 1e51b7f7f..c28a828ca 100644 --- a/src/Language/Go/Assignment.hs +++ b/src/Language/Go/Assignment.hs @@ -12,7 +12,6 @@ import Prologue import Assigning.Assignment hiding (Assignment, Error) import qualified Assigning.Assignment as Assignment import Data.Abstract.Name (Name, name) -import Data.Record import Data.Syntax (contextualize, emptyTerm, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1, parseError) import qualified Data.Syntax as Syntax @@ -131,7 +130,7 @@ type Syntax = , Literal.EscapeSequence ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Assignment.Assignment [] Grammar -- For Protobuf serialization @@ -267,10 +266,10 @@ floatLiteral :: Assignment Term floatLiteral = makeTerm <$> symbol FloatLiteral <*> (Literal.Float <$> source) identifier :: Assignment Term -identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier') <*> (Syntax.Identifier . name <$> source) +identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') <*> (Syntax.Identifier . name <$> source) identifier' :: Assignment Name -identifier' = (symbol Identifier <|> symbol Identifier') *> (name <$> source) +identifier' = (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> (name <$> source) imaginaryLiteral :: Assignment Term imaginaryLiteral = makeTerm <$> symbol ImaginaryLiteral <*> (Literal.Complex <$> source) @@ -535,7 +534,7 @@ varDeclaration :: Assignment Term varDeclaration = (symbol ConstDeclaration <|> symbol VarDeclaration) *> children expressions variadicArgument :: Assignment Term -variadicArgument = makeTerm <$> symbol VariadicArgument <*> children (Go.Syntax.Variadic [] <$> expression) +variadicArgument = makeTerm <$> symbol VariadicArgument <*> children (Go.Syntax.Variadic [] <$> expressions) variadicParameterDeclaration :: Assignment Term variadicParameterDeclaration = makeTerm <$> symbol VariadicParameterDeclaration <*> children (flip Go.Syntax.Variadic <$> (expression <|> emptyTerm) <* token AnonDotDotDot <*> many expression) diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index bf5e059fe..aa74158fc 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -4,6 +4,7 @@ module Language.Go.Syntax where import Prologue +import Control.Abstract.ScopeGraph hiding (Import) import Data.Abstract.BaseError import Data.Abstract.Evaluatable import Data.Abstract.Module @@ -11,6 +12,9 @@ import qualified Data.Abstract.Package as Package import Data.Abstract.Path import Data.Aeson import Data.JSON.Fields +import qualified Data.Map as Map +import Data.Semigroup.App +import Data.Semigroup.Foldable import qualified Data.Text as T import Diffing.Algorithm import Proto3.Suite.Class @@ -22,7 +26,7 @@ import Control.Abstract.ScopeGraph import qualified Data.Abstract.ScopeGraph as ScopeGraph data IsRelative = Unknown | Relative | NonRelative - deriving (Bounded, Enum, Finite, Eq, Generic, Hashable, Ord, Show, ToJSON, Named, MessageField) + deriving (Bounded, Enum, Finite, Eq, Generic, Hashable, Ord, Show, ToJSON, Named, MessageField, NFData) instance Primitive IsRelative where primType _ = primType (Proxy @(Enumerated IsRelative)) @@ -35,7 +39,7 @@ instance HasDefault IsRelative where def = Unknown data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: IsRelative } - deriving (Eq, Generic, Hashable, Ord, Show, ToJSON, Named, Message) + deriving (Eq, Generic, Hashable, Ord, Show, ToJSON, Named, Message, NFData) instance MessageField ImportPath where encodeMessageField num = Encode.embedded num . encodeMessage (fieldNumber 1) @@ -54,15 +58,16 @@ importPath str = let path = stripQuotes str in ImportPath (T.unpack path) (pathT defaultAlias :: ImportPath -> Name defaultAlias = Data.Abstract.Evaluatable.name . T.pack . takeFileName . unPath -resolveGoImport :: ( Member (Modules address value) effects - , Member (Reader ModuleInfo) effects - , Member (Reader Package.PackageInfo) effects - , Member (Reader Span) effects - , Member (Resumable (BaseError ResolutionError)) effects - , Member Trace effects +resolveGoImport :: ( Member (Modules address value) sig + , Member (Reader ModuleInfo) sig + , Member (Reader Package.PackageInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Member Trace sig + , Carrier sig m ) => ImportPath - -> Evaluator address value effects [ModulePath] + -> Evaluator term address value m [ModulePath] resolveGoImport (ImportPath path Unknown) = throwResolutionError $ GoImportError path resolveGoImport (ImportPath path Relative) = do ModuleInfo{..} <- currentModule @@ -84,14 +89,14 @@ resolveGoImport (ImportPath path NonRelative) = do -- -- If the list of symbols is empty copy everything to the calling environment. data Import a = Import { importFrom :: ImportPath, importWildcardToken :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Import where liftEq = genericLiftEq instance Ord1 Import where liftCompare = genericLiftCompare instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where - eval (Language.Go.Syntax.Import importPath _) = do + eval _ (Language.Go.Syntax.Import importPath _) = do paths <- resolveGoImport importPath for_ paths $ \path -> do traceResolve (unPath importPath) path @@ -105,36 +110,34 @@ instance Evaluatable Import where -- -- If the list of symbols is empty copy and qualify everything to the calling environment. data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, qualifiedImportAlias :: !a} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 QualifiedImport where liftEq = genericLiftEq instance Ord1 QualifiedImport where liftCompare = genericLiftCompare instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedImport where - eval (QualifiedImport importPath aliasTerm) = do + eval _ (QualifiedImport importPath aliasTerm) = do paths <- resolveGoImport importPath - alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm)) - rvalBox unit - -- rvalBox . withChildFrame (Declaration alias) $ \addr -> do - -- -- TODO: Add edges to these importedScopeGraphs - -- for_ paths $ \p -> do + alias <- maybeM (throwEvalError NoNameError) (declaredName aliasTerm) + undefined + -- void . letrec' alias $ \addr -> do + -- makeNamespace alias addr Nothing . for_ paths $ \p -> do -- traceResolve (unPath importPath) p - -- importedScopeGraph <- fst <$> require p - -- bindAll importedScopeGraph - -- slot <- lookupDeclaration (Declaration alias) - -- makeNamespace alias slot Nothing + -- importedEnv <- fst . snd <$> require p + -- bindAll importedEnv + -- rvalBox unit -- | Side effect only imports (no symbols made available to the calling environment). data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 SideEffectImport where liftEq = genericLiftEq instance Ord1 SideEffectImport where liftCompare = genericLiftCompare instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable SideEffectImport where - eval (SideEffectImport importPath _) = do + eval _ (SideEffectImport importPath _) = do paths <- resolveGoImport importPath traceResolve (unPath importPath) paths for_ paths require @@ -142,7 +145,7 @@ instance Evaluatable SideEffectImport where -- A composite literal in Go data Composite a = Composite { compositeType :: !a, compositeElement :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Composite where liftEq = genericLiftEq instance Ord1 Composite where liftCompare = genericLiftCompare @@ -153,7 +156,7 @@ instance Evaluatable Composite -- | A default pattern in a Go select or switch statement (e.g. `switch { default: s() }`). newtype DefaultPattern a = DefaultPattern { defaultPatternBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 DefaultPattern where liftEq = genericLiftEq instance Ord1 DefaultPattern where liftCompare = genericLiftCompare @@ -164,7 +167,7 @@ instance Evaluatable DefaultPattern -- | A defer statement in Go (e.g. `defer x()`). newtype Defer a = Defer { deferBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Defer where liftEq = genericLiftEq instance Ord1 Defer where liftCompare = genericLiftCompare @@ -175,7 +178,7 @@ instance Evaluatable Defer -- | A go statement (i.e. go routine) in Go (e.g. `go x()`). newtype Go a = Go { goBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Go where liftEq = genericLiftEq instance Ord1 Go where liftCompare = genericLiftCompare @@ -186,7 +189,7 @@ instance Evaluatable Go -- | A label statement in Go (e.g. `label:continue`). data Label a = Label { labelName :: !a, labelStatement :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Label where liftEq = genericLiftEq instance Ord1 Label where liftCompare = genericLiftCompare @@ -197,7 +200,7 @@ instance Evaluatable Label -- | A rune literal in Go (e.g. `'āŒ˜'`). newtype Rune a = Rune { runeLiteral :: Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) -- TODO: Implement Eval instance for Rune instance Evaluatable Rune @@ -208,7 +211,7 @@ instance Show1 Rune where liftShowsPrec = genericLiftShowsPrec -- | A select statement in Go (e.g. `select { case x := <-c: x() }` where each case is a send or receive operation on channels). newtype Select a = Select { selectCases :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) -- TODO: Implement Eval instance for Select instance Evaluatable Select @@ -219,7 +222,7 @@ instance Show1 Select where liftShowsPrec = genericLiftShowsPrec -- | A send statement in Go (e.g. `channel <- value`). data Send a = Send { sendReceiver :: !a, sendValue :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Send where liftEq = genericLiftEq instance Ord1 Send where liftCompare = genericLiftCompare @@ -230,7 +233,7 @@ instance Evaluatable Send -- | A slice expression in Go (e.g. `a[1:4:3]` where a is a list, 1 is the low bound, 4 is the high bound, and 3 is the max capacity). data Slice a = Slice { sliceName :: !a, sliceLow :: !a, sliceHigh :: !a, sliceCapacity :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Slice where liftEq = genericLiftEq instance Ord1 Slice where liftCompare = genericLiftCompare @@ -241,7 +244,7 @@ instance Evaluatable Slice -- | A type switch statement in Go (e.g. `switch x.(type) { // cases }`). data TypeSwitch a = TypeSwitch { typeSwitchSubject :: !a, typeSwitchCases :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 TypeSwitch where liftEq = genericLiftEq instance Ord1 TypeSwitch where liftCompare = genericLiftCompare @@ -252,7 +255,7 @@ instance Evaluatable TypeSwitch -- | A type switch guard statement in a Go type switch statement (e.g. `switch i := x.(type) { // cases}`). newtype TypeSwitchGuard a = TypeSwitchGuard { typeSwitchGuardSubject :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 TypeSwitchGuard where liftEq = genericLiftEq instance Ord1 TypeSwitchGuard where liftCompare = genericLiftCompare @@ -263,7 +266,7 @@ instance Evaluatable TypeSwitchGuard -- | A receive statement in a Go select statement (e.g. `case value := <-channel` ) data Receive a = Receive { receiveSubject :: !a, receiveExpression :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Receive where liftEq = genericLiftEq instance Ord1 Receive where liftCompare = genericLiftCompare @@ -274,7 +277,7 @@ instance Evaluatable Receive -- | A receive operator unary expression in Go (e.g. `<-channel` ) newtype ReceiveOperator a = ReceiveOperator { value :: a} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 ReceiveOperator where liftEq = genericLiftEq instance Ord1 ReceiveOperator where liftCompare = genericLiftCompare @@ -285,7 +288,7 @@ instance Evaluatable ReceiveOperator -- | A field declaration in a Go struct type declaration. data Field a = Field { fieldContext :: ![a], fieldName :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Field where liftEq = genericLiftEq instance Ord1 Field where liftCompare = genericLiftCompare @@ -296,19 +299,23 @@ instance Evaluatable Field data Package a = Package { packageName :: !a, packageContents :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Package where liftEq = genericLiftEq instance Ord1 Package where liftCompare = genericLiftCompare instance Show1 Package where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Package where - eval (Package _ xs) = eval xs + eval eval (Package _ xs) = do + currentScope' <- currentScope + let edges = maybe mempty (Map.singleton Lexical . pure) currentScope' + scope <- newScope edges + withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . eval)) (nonEmpty xs) -- | A type assertion in Go (e.g. `x.(T)` where the value of `x` is not nil and is of type `T`). data TypeAssertion a = TypeAssertion { typeAssertionSubject :: !a, typeAssertionType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 TypeAssertion where liftEq = genericLiftEq instance Ord1 TypeAssertion where liftCompare = genericLiftCompare @@ -319,7 +326,7 @@ instance Evaluatable TypeAssertion -- | A type conversion expression in Go (e.g. `T(x)` where `T` is a type and `x` is an expression that can be converted to type `T`). data TypeConversion a = TypeConversion { typeConversionType :: !a, typeConversionSubject :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 TypeConversion where liftEq = genericLiftEq instance Ord1 TypeConversion where liftCompare = genericLiftCompare @@ -330,7 +337,7 @@ instance Evaluatable TypeConversion -- | Variadic arguments and parameters in Go (e.g. parameter: `param ...Type`, argument: `Type...`). data Variadic a = Variadic { variadicContext :: [a], variadicIdentifier :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Variadic where liftEq = genericLiftEq instance Ord1 Variadic where liftCompare = genericLiftCompare diff --git a/src/Language/Go/Type.hs b/src/Language/Go/Type.hs index 037a7a016..6be7ba041 100644 --- a/src/Language/Go/Type.hs +++ b/src/Language/Go/Type.hs @@ -11,7 +11,7 @@ import Proto3.Suite.Class -- | A Bidirectional channel in Go (e.g. `chan`). newtype BidirectionalChannel a = BidirectionalChannel { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 BidirectionalChannel where liftEq = genericLiftEq instance Ord1 BidirectionalChannel where liftCompare = genericLiftCompare @@ -22,7 +22,7 @@ instance Evaluatable BidirectionalChannel -- | A Receive channel in Go (e.g. `<-chan`). newtype ReceiveChannel a = ReceiveChannel { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 ReceiveChannel where liftEq = genericLiftEq instance Ord1 ReceiveChannel where liftCompare = genericLiftCompare @@ -33,7 +33,7 @@ instance Evaluatable ReceiveChannel -- | A Send channel in Go (e.g. `chan<-`). newtype SendChannel a = SendChannel { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 SendChannel where liftEq = genericLiftEq instance Ord1 SendChannel where liftCompare = genericLiftCompare diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 38dded6ca..809f6b6f8 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -14,7 +14,6 @@ import qualified Assigning.Assignment as Assignment import qualified Data.Abstract.Name as Name import Data.ByteString.Char8 (count) import qualified Data.List.NonEmpty as NonEmpty -import Data.Record import Data.Syntax (contextualize, emptyTerm, handleError, makeTerm, makeTerm', makeTerm'', makeTerm1, parseError, postContextualize) import qualified Data.Syntax as Syntax @@ -172,7 +171,7 @@ type Syntax = '[ , [] ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Assignment.Assignment [] Grammar -- For Protobuf serialization diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index 0659d090f..0401436b6 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -1,1126 +1,8 @@ -{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields #-} -{-# OPTIONS_GHC -Wno-missing-export-lists #-} -module Language.Haskell.Syntax where - -import Prelude -import Prologue - -import Data.Abstract.Evaluatable -import Data.JSON.Fields -import Diffing.Algorithm -import Proto3.Suite.Class - -data Module a = Module { moduleContext :: [a] - , moduleIdentifier :: a - , moduleExports :: [a] - , moduleStatements :: a - } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Module where liftEq = genericLiftEq -instance Ord1 Module where liftCompare = genericLiftCompare -instance Show1 Module where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Module - -newtype StrictPattern a = StrictPattern { value :: a} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 StrictPattern where liftEq = genericLiftEq -instance Ord1 StrictPattern where liftCompare = genericLiftCompare -instance Show1 StrictPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable StrictPattern - -data StrictType a = StrictType { strictTypeIdentifier :: a, strictTypeParameters :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 StrictType where liftEq = genericLiftEq -instance Ord1 StrictType where liftCompare = genericLiftCompare -instance Show1 StrictType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable StrictType - -newtype StrictTypeVariable a = StrictTypeVariable { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 StrictTypeVariable where liftEq = genericLiftEq -instance Ord1 StrictTypeVariable where liftCompare = genericLiftCompare -instance Show1 StrictTypeVariable where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable StrictTypeVariable - -data Type a = Type { typeIdentifier :: a, typeParameters :: a, typeKindSignature :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Type where liftEq = genericLiftEq -instance Ord1 Type where liftCompare = genericLiftCompare -instance Show1 Type where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Type - -data TypeSynonym a = TypeSynonym { typeSynonymLeft :: a, typeSynonymContext :: [a], typeSynonymRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeSynonym where liftEq = genericLiftEq -instance Ord1 TypeSynonym where liftCompare = genericLiftCompare -instance Show1 TypeSynonym where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeSynonym - -data UnitConstructor a = UnitConstructor - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 UnitConstructor where liftEq = genericLiftEq -instance Ord1 UnitConstructor where liftCompare = genericLiftCompare -instance Show1 UnitConstructor where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable UnitConstructor - -newtype TupleConstructor a = TupleConstructor { tupleConstructorArity :: Int } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TupleConstructor where liftEq = genericLiftEq -instance Ord1 TupleConstructor where liftCompare = genericLiftCompare -instance Show1 TupleConstructor where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TupleConstructor - -data ListConstructor a = ListConstructor - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ListConstructor where liftEq = genericLiftEq -instance Ord1 ListConstructor where liftCompare = genericLiftCompare -instance Show1 ListConstructor where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ListConstructor - -data FunctionConstructor a = FunctionConstructor - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 FunctionConstructor where liftEq = genericLiftEq -instance Ord1 FunctionConstructor where liftCompare = genericLiftCompare -instance Show1 FunctionConstructor where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FunctionConstructor - -data RecordDataConstructor a = RecordDataConstructor { recordDataConstructorContext :: [a], recordDataConstructorName :: !a, recordDataConstructorFields :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 RecordDataConstructor where liftEq = genericLiftEq -instance Ord1 RecordDataConstructor where liftCompare = genericLiftCompare -instance Show1 RecordDataConstructor where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable RecordDataConstructor - -data Field a = Field { fieldName :: !a, fieldBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Field where liftEq = genericLiftEq -instance Ord1 Field where liftCompare = genericLiftCompare -instance Show1 Field where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Field - -newtype Pragma a = Pragma { value :: Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Pragma where liftEq = genericLiftEq -instance Ord1 Pragma where liftCompare = genericLiftCompare -instance Show1 Pragma where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Pragma - -newtype Deriving a = Deriving { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Deriving where liftEq = genericLiftEq -instance Ord1 Deriving where liftCompare = genericLiftCompare -instance Show1 Deriving where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Deriving -newtype ContextAlt a = ContextAlt { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ContextAlt where liftEq = genericLiftEq -instance Ord1 ContextAlt where liftCompare = genericLiftCompare -instance Show1 ContextAlt where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ContextAlt - -newtype Class a = Class { classContent :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Class where liftEq = genericLiftEq -instance Ord1 Class where liftCompare = genericLiftCompare -instance Show1 Class where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Class - -data GADT a = GADT { gadtContext :: a, gadtName :: a, gadtConstructors :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 GADT where liftEq = genericLiftEq -instance Ord1 GADT where liftCompare = genericLiftCompare -instance Show1 GADT where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable GADT - -data GADTConstructor a = GADTConstructor { gadtConstructorContext :: a, gadtConstructorName :: a, gadtConstructorTypeSignature :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 GADTConstructor where liftEq = genericLiftEq -instance Ord1 GADTConstructor where liftCompare = genericLiftCompare -instance Show1 GADTConstructor where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable GADTConstructor - -data FunctionType a = FunctionType { functionTypeLeft :: a, functionTypeRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 FunctionType where liftEq = genericLiftEq -instance Ord1 FunctionType where liftCompare = genericLiftCompare -instance Show1 FunctionType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FunctionType - -data TypeSignature a = TypeSignature { typeSignatureName :: [a], typeSignatureContext :: [a], typeSignatureContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeSignature where liftEq = genericLiftEq -instance Ord1 TypeSignature where liftCompare = genericLiftCompare -instance Show1 TypeSignature where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeSignature - -data ExpressionTypeSignature a = ExpressionTypeSignature { expressionTypeSignatureName :: [a], expressionTypeSignatureContext :: [a], expressionTypeSignatureContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ExpressionTypeSignature where liftEq = genericLiftEq -instance Ord1 ExpressionTypeSignature where liftCompare = genericLiftCompare -instance Show1 ExpressionTypeSignature where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ExpressionTypeSignature - -newtype KindSignature a = KindSignature { kindSignatureContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 KindSignature where liftEq = genericLiftEq -instance Ord1 KindSignature where liftCompare = genericLiftCompare -instance Show1 KindSignature where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable KindSignature - -data KindFunctionType a = KindFunctionType { kindFunctionTypeLeft :: a, kindFunctionTypeRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 KindFunctionType where liftEq = genericLiftEq -instance Ord1 KindFunctionType where liftCompare = genericLiftCompare -instance Show1 KindFunctionType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable KindFunctionType - -newtype Kind a = Kind { kindKind :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Kind where liftEq = genericLiftEq -instance Ord1 Kind where liftCompare = genericLiftCompare -instance Show1 Kind where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Kind - -newtype KindListType a = KindListType { kindListTypeKind :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 KindListType where liftEq = genericLiftEq -instance Ord1 KindListType where liftCompare = genericLiftCompare -instance Show1 KindListType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable KindListType - -data Star a = Star - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Star where liftEq = genericLiftEq -instance Ord1 Star where liftCompare = genericLiftCompare -instance Show1 Star where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Star - -newtype QualifiedTypeClassIdentifier a = QualifiedTypeClassIdentifier { values :: NonEmpty a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QualifiedTypeClassIdentifier where liftEq = genericLiftEq -instance Ord1 QualifiedTypeClassIdentifier where liftCompare = genericLiftCompare -instance Show1 QualifiedTypeClassIdentifier where liftShowsPrec = genericLiftShowsPrec -instance Hashable1 QualifiedTypeClassIdentifier where liftHashWithSalt = foldl - -instance Evaluatable QualifiedTypeClassIdentifier - -newtype QualifiedTypeConstructorIdentifier a = QualifiedTypeConstructorIdentifier { values :: NonEmpty a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QualifiedTypeConstructorIdentifier where liftEq = genericLiftEq -instance Ord1 QualifiedTypeConstructorIdentifier where liftCompare = genericLiftCompare -instance Show1 QualifiedTypeConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec -instance Hashable1 QualifiedTypeConstructorIdentifier where liftHashWithSalt = foldl - -instance Evaluatable QualifiedTypeConstructorIdentifier - -newtype QualifiedConstructorIdentifier a = QualifiedConstructorIdentifier { values :: NonEmpty a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QualifiedConstructorIdentifier where liftEq = genericLiftEq -instance Ord1 QualifiedConstructorIdentifier where liftCompare = genericLiftCompare -instance Show1 QualifiedConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec -instance Hashable1 QualifiedConstructorIdentifier where liftHashWithSalt = foldl - -instance Evaluatable QualifiedConstructorIdentifier - -newtype QualifiedInfixVariableIdentifier a = QualifiedInfixVariableIdentifier { values :: NonEmpty a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QualifiedInfixVariableIdentifier where liftEq = genericLiftEq -instance Ord1 QualifiedInfixVariableIdentifier where liftCompare = genericLiftCompare -instance Show1 QualifiedInfixVariableIdentifier where liftShowsPrec = genericLiftShowsPrec -instance Hashable1 QualifiedInfixVariableIdentifier where liftHashWithSalt = foldl - -instance Evaluatable QualifiedInfixVariableIdentifier - -newtype QualifiedModuleIdentifier a = QualifiedModuleIdentifier { values :: NonEmpty a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QualifiedModuleIdentifier where liftEq = genericLiftEq -instance Ord1 QualifiedModuleIdentifier where liftCompare = genericLiftCompare -instance Show1 QualifiedModuleIdentifier where liftShowsPrec = genericLiftShowsPrec -instance Hashable1 QualifiedModuleIdentifier where liftHashWithSalt = foldl - -instance Evaluatable QualifiedModuleIdentifier - -newtype QualifiedVariableIdentifier a = QualifiedVariableIdentifier { values :: NonEmpty a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QualifiedVariableIdentifier where liftEq = genericLiftEq -instance Ord1 QualifiedVariableIdentifier where liftCompare = genericLiftCompare -instance Show1 QualifiedVariableIdentifier where liftShowsPrec = genericLiftShowsPrec -instance Hashable1 QualifiedVariableIdentifier where liftHashWithSalt = foldl - -instance Evaluatable QualifiedVariableIdentifier - -data AnnotatedTypeVariable a = AnnotatedTypeVariable { annotatedTypeVariableIdentifier :: a, annotatedTypeVariableannotation :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 AnnotatedTypeVariable where liftEq = genericLiftEq -instance Ord1 AnnotatedTypeVariable where liftCompare = genericLiftCompare -instance Show1 AnnotatedTypeVariable where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable AnnotatedTypeVariable - -newtype Export a = Export { exportContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Export where liftEq = genericLiftEq -instance Ord1 Export where liftCompare = genericLiftCompare -instance Show1 Export where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Export - -newtype ModuleExport a = ModuleExport { moduleExportContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ModuleExport where liftEq = genericLiftEq -instance Ord1 ModuleExport where liftCompare = genericLiftCompare -instance Show1 ModuleExport where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ModuleExport - -newtype TypeConstructorExport a = TypeConstructorExport { typeConstructorExportContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeConstructorExport where liftEq = genericLiftEq -instance Ord1 TypeConstructorExport where liftCompare = genericLiftCompare -instance Show1 TypeConstructorExport where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeConstructorExport - -data AllConstructors a = AllConstructors - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 AllConstructors where liftEq = genericLiftEq -instance Ord1 AllConstructors where liftCompare = genericLiftCompare -instance Show1 AllConstructors where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable AllConstructors - -data InfixOperatorPattern a = InfixOperatorPattern { infixOperatorPatternLeft :: a, infixOperatorPatternOperator :: a, infixOperatorPatternRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 InfixOperatorPattern where liftEq = genericLiftEq -instance Ord1 InfixOperatorPattern where liftCompare = genericLiftCompare -instance Show1 InfixOperatorPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable InfixOperatorPattern - -newtype QuotedName a = QuotedName { quotedNameContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QuotedName where liftEq = genericLiftEq -instance Ord1 QuotedName where liftCompare = genericLiftCompare -instance Show1 QuotedName where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QuotedName - -newtype TypePattern a = TypePattern { typePatternContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypePattern where liftEq = genericLiftEq -instance Ord1 TypePattern where liftCompare = genericLiftCompare -instance Show1 TypePattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypePattern - -newtype ScopedTypeVariables a = ScopedTypeVariables { scopedTypeVariablesContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ScopedTypeVariables where liftEq = genericLiftEq -instance Ord1 ScopedTypeVariables where liftCompare = genericLiftCompare -instance Show1 ScopedTypeVariables where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ScopedTypeVariables - -data NewType a = NewType { newTypeContext :: [a], newTypeLeft :: a, newTypeRight :: a, newTypeDeriving :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 NewType where liftEq = genericLiftEq -instance Ord1 NewType where liftCompare = genericLiftCompare -instance Show1 NewType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NewType - -newtype DefaultDeclaration a = DefaultDeclaration { defaultDeclarationContent :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 DefaultDeclaration where liftEq = genericLiftEq -instance Ord1 DefaultDeclaration where liftCompare = genericLiftCompare -instance Show1 DefaultDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable DefaultDeclaration - -data EqualityConstraint a = EqualityConstraint { equalityConstraintLeft :: a, equalityConstraintRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 EqualityConstraint where liftEq = genericLiftEq -instance Ord1 EqualityConstraint where liftCompare = genericLiftCompare -instance Show1 EqualityConstraint where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable EqualityConstraint - -newtype TypeVariableIdentifier a = TypeVariableIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeVariableIdentifier where liftEq = genericLiftEq -instance Ord1 TypeVariableIdentifier where liftCompare = genericLiftCompare -instance Show1 TypeVariableIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeVariableIdentifier - -newtype TypeConstructorIdentifier a = TypeConstructorIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeConstructorIdentifier where liftEq = genericLiftEq -instance Ord1 TypeConstructorIdentifier where liftCompare = genericLiftCompare -instance Show1 TypeConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeConstructorIdentifier - -newtype ModuleIdentifier a = ModuleIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ModuleIdentifier where liftEq = genericLiftEq -instance Ord1 ModuleIdentifier where liftCompare = genericLiftCompare -instance Show1 ModuleIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ModuleIdentifier - -newtype ConstructorIdentifier a = ConstructorIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ConstructorIdentifier where liftEq = genericLiftEq -instance Ord1 ConstructorIdentifier where liftCompare = genericLiftCompare -instance Show1 ConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ConstructorIdentifier - -newtype ImplicitParameterIdentifier a = ImplicitParameterIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ImplicitParameterIdentifier where liftEq = genericLiftEq -instance Ord1 ImplicitParameterIdentifier where liftCompare = genericLiftCompare -instance Show1 ImplicitParameterIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ImplicitParameterIdentifier - -newtype InfixConstructorIdentifier a = InfixConstructorIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 InfixConstructorIdentifier where liftEq = genericLiftEq -instance Ord1 InfixConstructorIdentifier where liftCompare = genericLiftCompare -instance Show1 InfixConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable InfixConstructorIdentifier - -newtype InfixVariableIdentifier a = InfixVariableIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 InfixVariableIdentifier where liftEq = genericLiftEq -instance Ord1 InfixVariableIdentifier where liftCompare = genericLiftCompare -instance Show1 InfixVariableIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable InfixVariableIdentifier - -newtype TypeClassIdentifier a = TypeClassIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeClassIdentifier where liftEq = genericLiftEq -instance Ord1 TypeClassIdentifier where liftCompare = genericLiftCompare -instance Show1 TypeClassIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeClassIdentifier - -newtype VariableIdentifier a = VariableIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 VariableIdentifier where liftEq = genericLiftEq -instance Ord1 VariableIdentifier where liftCompare = genericLiftCompare -instance Show1 VariableIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable VariableIdentifier - -newtype PrimitiveConstructorIdentifier a = PrimitiveConstructorIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 PrimitiveConstructorIdentifier where liftEq = genericLiftEq -instance Ord1 PrimitiveConstructorIdentifier where liftCompare = genericLiftCompare -instance Show1 PrimitiveConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable PrimitiveConstructorIdentifier - -newtype PrimitiveVariableIdentifier a = PrimitiveVariableIdentifier { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 PrimitiveVariableIdentifier where liftEq = genericLiftEq -instance Ord1 PrimitiveVariableIdentifier where liftCompare = genericLiftCompare -instance Show1 PrimitiveVariableIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable PrimitiveVariableIdentifier - -newtype VariableOperator a = VariableOperator { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 VariableOperator where liftEq = genericLiftEq -instance Ord1 VariableOperator where liftCompare = genericLiftCompare -instance Show1 VariableOperator where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable VariableOperator - -newtype ConstructorOperator a = ConstructorOperator { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ConstructorOperator where liftEq = genericLiftEq -instance Ord1 ConstructorOperator where liftCompare = genericLiftCompare -instance Show1 ConstructorOperator where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ConstructorOperator - -newtype TypeOperator a = TypeOperator { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeOperator where liftEq = genericLiftEq -instance Ord1 TypeOperator where liftCompare = genericLiftCompare -instance Show1 TypeOperator where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeOperator - -newtype PromotedTypeOperator a = PromotedTypeOperator { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 PromotedTypeOperator where liftEq = genericLiftEq -instance Ord1 PromotedTypeOperator where liftCompare = genericLiftCompare -instance Show1 PromotedTypeOperator where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable PromotedTypeOperator - -newtype ConstructorSymbol a = ConstructorSymbol { constructorSymbolName :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ConstructorSymbol where liftEq = genericLiftEq -instance Ord1 ConstructorSymbol where liftCompare = genericLiftCompare -instance Show1 ConstructorSymbol where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ConstructorSymbol - -newtype VariableSymbol a = VariableSymbol { variableSymbolName :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 VariableSymbol where liftEq = genericLiftEq -instance Ord1 VariableSymbol where liftCompare = genericLiftCompare -instance Show1 VariableSymbol where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable VariableSymbol - -data StandaloneDerivingInstance a = StandaloneDerivingInstance { standaloneDerivingInstanceContext :: [a], standaloneDerivingInstanceClass :: a, standaloneDerivingInstanceInstance :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 StandaloneDerivingInstance where liftEq = genericLiftEq -instance Ord1 StandaloneDerivingInstance where liftCompare = genericLiftCompare -instance Show1 StandaloneDerivingInstance where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable StandaloneDerivingInstance - -data ImportDeclaration a = ImportDeclaration { importPackageQualifiedContent :: a, importModule :: a, importSpec :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ImportDeclaration where liftEq = genericLiftEq -instance Ord1 ImportDeclaration where liftCompare = genericLiftCompare -instance Show1 ImportDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ImportDeclaration - -data QualifiedImportDeclaration a = QualifiedImportDeclaration { qualifiedImportPackageQualifiedContent :: a, qualifiedImportModule :: a, qualifiedImportSpec :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QualifiedImportDeclaration where liftEq = genericLiftEq -instance Ord1 QualifiedImportDeclaration where liftCompare = genericLiftCompare -instance Show1 QualifiedImportDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QualifiedImportDeclaration - -newtype Import a = Import { importContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Import where liftEq = genericLiftEq -instance Ord1 Import where liftCompare = genericLiftCompare -instance Show1 Import where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Import - -newtype HiddenImport a = HiddenImport { hiddenimportContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 HiddenImport where liftEq = genericLiftEq -instance Ord1 HiddenImport where liftCompare = genericLiftCompare -instance Show1 HiddenImport where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable HiddenImport - -data ImportAlias a = ImportAlias { importAliasSource :: a, importAliasName :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ImportAlias where liftEq = genericLiftEq -instance Ord1 ImportAlias where liftCompare = genericLiftCompare -instance Show1 ImportAlias where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ImportAlias - -data App a = App { appLeft :: a, appLeftTypeApp :: a, appRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 App where liftEq = genericLiftEq -instance Ord1 App where liftCompare = genericLiftCompare -instance Show1 App where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable App - -data InfixOperatorApp a = InfixOperatorApp { infixOperatorAppLeft :: a, infixOperatorAppLeftTypeApp :: a, infixOperatorAppOperator :: a, infixOperatorAppRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 InfixOperatorApp where liftEq = genericLiftEq -instance Ord1 InfixOperatorApp where liftCompare = genericLiftCompare -instance Show1 InfixOperatorApp where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable InfixOperatorApp - -newtype TypeApp a = TypeApp { typeAppType :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeApp where liftEq = genericLiftEq -instance Ord1 TypeApp where liftCompare = genericLiftCompare -instance Show1 TypeApp where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeApp - -data ListComprehension a = ListComprehension { comprehensionValue :: a, comprehensionSource :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ListComprehension where liftEq = genericLiftEq -instance Ord1 ListComprehension where liftCompare = genericLiftCompare -instance Show1 ListComprehension where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ListComprehension - -data Generator a = Generator { generatorValue :: a, generatorSource :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Generator where liftEq = genericLiftEq -instance Ord1 Generator where liftCompare = genericLiftCompare -instance Show1 Generator where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Generator - -newtype TupleExpression a = TupleExpression { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TupleExpression where liftEq = genericLiftEq -instance Ord1 TupleExpression where liftCompare = genericLiftCompare -instance Show1 TupleExpression where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TupleExpression - -newtype TuplePattern a = TuplePattern { value :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TuplePattern where liftEq = genericLiftEq -instance Ord1 TuplePattern where liftCompare = genericLiftCompare -instance Show1 TuplePattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TuplePattern - --- e.g. [1..], [1,2..], [1,2..10] -data ArithmeticSequence a = ArithmeticSequence { from :: a, next :: Maybe a, to :: Maybe a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ArithmeticSequence where liftEq = genericLiftEq -instance Ord1 ArithmeticSequence where liftCompare = genericLiftCompare -instance Show1 ArithmeticSequence where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ArithmeticSequence - -data RightOperatorSection a = RightOperatorSection { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 RightOperatorSection where liftEq = genericLiftEq -instance Ord1 RightOperatorSection where liftCompare = genericLiftCompare -instance Show1 RightOperatorSection where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable RightOperatorSection - -data LeftOperatorSection a = LeftOperatorSection { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 LeftOperatorSection where liftEq = genericLiftEq -instance Ord1 LeftOperatorSection where liftCompare = genericLiftCompare -instance Show1 LeftOperatorSection where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LeftOperatorSection - -newtype ConstructorPattern a = ConstructorPattern { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ConstructorPattern where liftEq = genericLiftEq -instance Ord1 ConstructorPattern where liftCompare = genericLiftCompare -instance Show1 ConstructorPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ConstructorPattern - --- e.g. `a <- b` in a Haskell do block. -data BindPattern a = BindPattern { bindPatternLeft :: [a], bindPatternRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 BindPattern where liftEq = genericLiftEq -instance Ord1 BindPattern where liftCompare = genericLiftCompare -instance Show1 BindPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable BindPattern - -newtype Do a = Do { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Do where liftEq = genericLiftEq -instance Ord1 Do where liftCompare = genericLiftCompare -instance Show1 Do where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Do - -data Lambda a = Lambda { lambdaHead :: a, lambdaBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Lambda where liftEq = genericLiftEq -instance Ord1 Lambda where liftCompare = genericLiftCompare -instance Show1 Lambda where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Lambda - --- e.g. -1 or (-a) as an expression and not `-` as a variable operator. -newtype PrefixNegation a = PrefixNegation { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 PrefixNegation where liftEq = genericLiftEq -instance Ord1 PrefixNegation where liftCompare = genericLiftCompare -instance Show1 PrefixNegation where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable PrefixNegation - -newtype CPPDirective a = CPPDirective { value :: Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 CPPDirective where liftEq = genericLiftEq -instance Ord1 CPPDirective where liftCompare = genericLiftCompare -instance Show1 CPPDirective where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable CPPDirective - -data QuasiQuotation a = QuasiQuotation { quasiQuotationHead :: a, quasiQuotationBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QuasiQuotation where liftEq = genericLiftEq -instance Ord1 QuasiQuotation where liftCompare = genericLiftCompare -instance Show1 QuasiQuotation where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QuasiQuotation - -newtype QuasiQuotationExpressionBody a = QuasiQuotationExpressionBody { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QuasiQuotationExpressionBody where liftEq = genericLiftEq -instance Ord1 QuasiQuotationExpressionBody where liftCompare = genericLiftCompare -instance Show1 QuasiQuotationExpressionBody where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QuasiQuotationExpressionBody - -data QuasiQuotationPattern a = QuasiQuotationPattern - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QuasiQuotationPattern where liftEq = genericLiftEq -instance Ord1 QuasiQuotationPattern where liftCompare = genericLiftCompare -instance Show1 QuasiQuotationPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QuasiQuotationPattern - -data QuasiQuotationType a = QuasiQuotationType - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QuasiQuotationType where liftEq = genericLiftEq -instance Ord1 QuasiQuotationType where liftCompare = genericLiftCompare -instance Show1 QuasiQuotationType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QuasiQuotationType - -data QuasiQuotationDeclaration a = QuasiQuotationDeclaration - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QuasiQuotationDeclaration where liftEq = genericLiftEq -instance Ord1 QuasiQuotationDeclaration where liftCompare = genericLiftCompare -instance Show1 QuasiQuotationDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QuasiQuotationDeclaration - -newtype QuasiQuotationQuoter a = QuasiQuotationQuoter { name :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QuasiQuotationQuoter where liftEq = genericLiftEq -instance Ord1 QuasiQuotationQuoter where liftCompare = genericLiftCompare -instance Show1 QuasiQuotationQuoter where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QuasiQuotationQuoter - -data QuasiQuotationExpression a = QuasiQuotationExpression - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 QuasiQuotationExpression where liftEq = genericLiftEq -instance Ord1 QuasiQuotationExpression where liftCompare = genericLiftCompare -instance Show1 QuasiQuotationExpression where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QuasiQuotationExpression - -newtype Splice a = Splice { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Splice where liftEq = genericLiftEq -instance Ord1 Splice where liftCompare = genericLiftCompare -instance Show1 Splice where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Splice - -data TypeClass a = TypeClass { typeClassContext :: a, typeClassIdentifier :: a, typeClassParameters :: [a], typeClassBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeClass where liftEq = genericLiftEq -instance Ord1 TypeClass where liftCompare = genericLiftCompare -instance Show1 TypeClass where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeClass - -data FixityAlt a = FixityAlt { fixityPrecedence :: a, fixityIdentifier :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 FixityAlt where liftEq = genericLiftEq -instance Ord1 FixityAlt where liftCompare = genericLiftCompare -instance Show1 FixityAlt where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FixityAlt - --- The default signature of a type class. The default signature has the same shape as a TypeSignature Assignment. -data DefaultSignature a = DefaultSignature { defaultSignatureName :: [a], defaultSignatureContext :: [a], defaultSignatureContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 DefaultSignature where liftEq = genericLiftEq -instance Ord1 DefaultSignature where liftCompare = genericLiftCompare -instance Show1 DefaultSignature where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable DefaultSignature - -data TypeFamily a = TypeFamily { typeFamilyIdentifier :: a, typeFamilyParameters :: [a], typeFamilySignature :: a, typeFamilyBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeFamily where liftEq = genericLiftEq -instance Ord1 TypeFamily where liftCompare = genericLiftCompare -instance Show1 TypeFamily where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeFamily - -newtype FunctionalDependency a = FunctionalDependency { functionalDependencyContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 FunctionalDependency where liftEq = genericLiftEq -instance Ord1 FunctionalDependency where liftCompare = genericLiftCompare -instance Show1 FunctionalDependency where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FunctionalDependency - -data TypeClassInstance a = TypeClassInstance { typeClassInstanceContext :: [a], typeClassInstanceIdentifier :: a, typeClassInstanceInstance :: a, typeClassInstanceBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeClassInstance where liftEq = genericLiftEq -instance Ord1 TypeClassInstance where liftCompare = genericLiftCompare -instance Show1 TypeClassInstance where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeClassInstance - -newtype Instance a = Instance { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Instance where liftEq = genericLiftEq -instance Ord1 Instance where liftCompare = genericLiftCompare -instance Show1 Instance where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Instance - --- e.g. The `Bar{..}` in `foo Bar{..} = baz`. -newtype LabeledPattern a = LabeledPattern { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 LabeledPattern where liftEq = genericLiftEq -instance Ord1 LabeledPattern where liftCompare = genericLiftCompare -instance Show1 LabeledPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LabeledPattern - --- e.g. The `{..}` in `foo Bar{..} = baz` -data RecordWildCards a = RecordWildCards - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 RecordWildCards where liftEq = genericLiftEq -instance Ord1 RecordWildCards where liftCompare = genericLiftCompare -instance Show1 RecordWildCards where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable RecordWildCards - --- e.g. `type instance F [Int] = Int` where `F` is an open type family. -data TypeInstance a = TypeInstance { typeInstanceType :: a, typeInstanceBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 TypeInstance where liftEq = genericLiftEq -instance Ord1 TypeInstance where liftCompare = genericLiftCompare -instance Show1 TypeInstance where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeInstance - -newtype KindParenthesizedConstructor a = KindParenthesizedConstructor { kindParenthesizedConstructorContent :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 KindParenthesizedConstructor where liftEq = genericLiftEq -instance Ord1 KindParenthesizedConstructor where liftCompare = genericLiftCompare -instance Show1 KindParenthesizedConstructor where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable KindParenthesizedConstructor - -newtype KindTupleType a = KindTupleType { kindTupleType :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 KindTupleType where liftEq = genericLiftEq -instance Ord1 KindTupleType where liftCompare = genericLiftCompare -instance Show1 KindTupleType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable KindTupleType - -data Wildcard a = Wildcard - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Wildcard where liftEq = genericLiftEq -instance Ord1 Wildcard where liftCompare = genericLiftCompare -instance Show1 Wildcard where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Wildcard - -data Let a = Let { letStatements :: [a], letInClause :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Let where liftEq = genericLiftEq -instance Ord1 Let where liftCompare = genericLiftCompare -instance Show1 Let where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Let - -newtype ListPattern a = ListPattern { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ListPattern where liftEq = genericLiftEq -instance Ord1 ListPattern where liftCompare = genericLiftCompare -instance Show1 ListPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ListPattern - --- e.g. The `n@num1` in `f n@num1 x@num2 = x` -data AsPattern a = AsPattern { asPatternLeft :: a, asPatternRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 AsPattern where liftEq = genericLiftEq -instance Ord1 AsPattern where liftCompare = genericLiftCompare -instance Show1 AsPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable AsPattern - --- e.g. The `a = 1` in `foo Bar{ a = 1 } = baz`. -data FieldPattern a = FieldPattern { fieldPatternLeft :: a, fieldPatternRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 FieldPattern where liftEq = genericLiftEq -instance Ord1 FieldPattern where liftCompare = genericLiftCompare -instance Show1 FieldPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FieldPattern - --- e.g. The `start` or `end` in `f Blob{start, end} = [start, end]`. -newtype NamedFieldPun a = NamedFieldPun { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 NamedFieldPun where liftEq = genericLiftEq -instance Ord1 NamedFieldPun where liftCompare = genericLiftCompare -instance Show1 NamedFieldPun where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NamedFieldPun - --- e.g. The `-(1)` in `f (-(1)) = 1`. -newtype NegativeLiteral a = NegativeLiteral { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 NegativeLiteral where liftEq = genericLiftEq -instance Ord1 NegativeLiteral where liftCompare = genericLiftCompare -instance Show1 NegativeLiteral where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NegativeLiteral - --- e.g. The `~a` in `f ~a = 1` -newtype IrrefutablePattern a = IrrefutablePattern { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 IrrefutablePattern where liftEq = genericLiftEq -instance Ord1 IrrefutablePattern where liftCompare = genericLiftCompare -instance Show1 IrrefutablePattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable IrrefutablePattern - --- For handling guards in case alternative expressions. -newtype CaseGuardPattern a = CaseGuardPattern { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 CaseGuardPattern where liftEq = genericLiftEq -instance Ord1 CaseGuardPattern where liftCompare = genericLiftCompare -instance Show1 CaseGuardPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable CaseGuardPattern - -newtype Guard a = Guard { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 Guard where liftEq = genericLiftEq -instance Ord1 Guard where liftCompare = genericLiftCompare -instance Show1 Guard where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Guard - -newtype LambdaCase a = LambdaCase { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 LambdaCase where liftEq = genericLiftEq -instance Ord1 LambdaCase where liftCompare = genericLiftCompare -instance Show1 LambdaCase where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LambdaCase - --- For handling guards in function declarations. -newtype FunctionGuardPattern a = FunctionGuardPattern { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 FunctionGuardPattern where liftEq = genericLiftEq -instance Ord1 FunctionGuardPattern where liftCompare = genericLiftCompare -instance Show1 FunctionGuardPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FunctionGuardPattern - --- The `y { a = 1, b = 2} in `f y@Example = y { a = 1, b = 2 }`. -newtype LabeledUpdate a = LabeledUpdate { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 LabeledUpdate where liftEq = genericLiftEq -instance Ord1 LabeledUpdate where liftCompare = genericLiftCompare -instance Show1 LabeledUpdate where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LabeledUpdate - --- The `a = 1` in `f y@Example = y { a = 1, b = 2 }`. -data FieldBind a = FieldBind { fieldBindLeft :: a, fieldBindRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 FieldBind where liftEq = genericLiftEq -instance Ord1 FieldBind where liftCompare = genericLiftCompare -instance Show1 FieldBind where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FieldBind - -data ViewPattern a = ViewPattern { viewPatternLeft :: a, viewPatternRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 ViewPattern where liftEq = genericLiftEq -instance Ord1 ViewPattern where liftCompare = genericLiftCompare -instance Show1 ViewPattern where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ViewPattern - --- The `a <- b` in `f a | a <- b = c` of a function declaration. -data PatternGuard a = PatternGuard { patternGuardPattern :: a, patternGuardExpression :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 PatternGuard where liftEq = genericLiftEq -instance Ord1 PatternGuard where liftCompare = genericLiftCompare -instance Show1 PatternGuard where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable PatternGuard - -data LabeledConstruction a = LabeledConstruction { labeledConstructionConstructor :: a, labeledConstructionFields :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 LabeledConstruction where liftEq = genericLiftEq -instance Ord1 LabeledConstruction where liftCompare = genericLiftCompare -instance Show1 LabeledConstruction where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LabeledConstruction - -data InfixDataConstructor a = InfixDataConstructor { infixDataConstructorContext :: [a], infixDataConstructorLeft :: a, infixDataConstructorOperator :: a, infixDataConstructorRight :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) - -instance Eq1 InfixDataConstructor where liftEq = genericLiftEq -instance Ord1 InfixDataConstructor where liftCompare = genericLiftCompare -instance Show1 InfixDataConstructor where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable InfixDataConstructor +module Language.Haskell.Syntax (module X) where + +import Language.Haskell.Syntax.Constructor as X +import Language.Haskell.Syntax.Haskell as X +import Language.Haskell.Syntax.Identifier as X +import Language.Haskell.Syntax.Pattern as X +import Language.Haskell.Syntax.QuasiQuote as X +import Language.Haskell.Syntax.Type as X diff --git a/src/Language/Haskell/Syntax/Constructor.hs b/src/Language/Haskell/Syntax/Constructor.hs new file mode 100644 index 000000000..975bc89ec --- /dev/null +++ b/src/Language/Haskell/Syntax/Constructor.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +module Language.Haskell.Syntax.Constructor where + +import Prologue + +import Data.Abstract.Evaluatable +import Data.JSON.Fields +import Diffing.Algorithm +import Proto3.Suite.Class + +data UnitConstructor a = UnitConstructor + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 UnitConstructor where liftEq = genericLiftEq +instance Ord1 UnitConstructor where liftCompare = genericLiftCompare +instance Show1 UnitConstructor where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable UnitConstructor + +newtype TupleConstructor a = TupleConstructor { tupleConstructorArity :: Int } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TupleConstructor where liftEq = genericLiftEq +instance Ord1 TupleConstructor where liftCompare = genericLiftCompare +instance Show1 TupleConstructor where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TupleConstructor + +data ListConstructor a = ListConstructor + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ListConstructor where liftEq = genericLiftEq +instance Ord1 ListConstructor where liftCompare = genericLiftCompare +instance Show1 ListConstructor where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ListConstructor + +data FunctionConstructor a = FunctionConstructor + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 FunctionConstructor where liftEq = genericLiftEq +instance Ord1 FunctionConstructor where liftCompare = genericLiftCompare +instance Show1 FunctionConstructor where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable FunctionConstructor + +data RecordDataConstructor a = RecordDataConstructor { recordDataConstructorContext :: [a], recordDataConstructorName :: !a, recordDataConstructorFields :: !a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 RecordDataConstructor where liftEq = genericLiftEq +instance Ord1 RecordDataConstructor where liftCompare = genericLiftCompare +instance Show1 RecordDataConstructor where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable RecordDataConstructor + +newtype TypeConstructorExport a = TypeConstructorExport { typeConstructorExportContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeConstructorExport where liftEq = genericLiftEq +instance Ord1 TypeConstructorExport where liftCompare = genericLiftCompare +instance Show1 TypeConstructorExport where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeConstructorExport + +data AllConstructors a = AllConstructors + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 AllConstructors where liftEq = genericLiftEq +instance Ord1 AllConstructors where liftCompare = genericLiftCompare +instance Show1 AllConstructors where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable AllConstructors +newtype KindParenthesizedConstructor a = KindParenthesizedConstructor { kindParenthesizedConstructorContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 KindParenthesizedConstructor where liftEq = genericLiftEq +instance Ord1 KindParenthesizedConstructor where liftCompare = genericLiftCompare +instance Show1 KindParenthesizedConstructor where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable KindParenthesizedConstructor + +data GADTConstructor a = GADTConstructor { gadtConstructorContext :: a, gadtConstructorName :: a, gadtConstructorTypeSignature :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 GADTConstructor where liftEq = genericLiftEq +instance Ord1 GADTConstructor where liftCompare = genericLiftCompare +instance Show1 GADTConstructor where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable GADTConstructor + +newtype ConstructorSymbol a = ConstructorSymbol { constructorSymbolName :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ConstructorSymbol where liftEq = genericLiftEq +instance Ord1 ConstructorSymbol where liftCompare = genericLiftCompare +instance Show1 ConstructorSymbol where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ConstructorSymbol + +data LabeledConstruction a = LabeledConstruction { labeledConstructionConstructor :: a, labeledConstructionFields :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 LabeledConstruction where liftEq = genericLiftEq +instance Ord1 LabeledConstruction where liftCompare = genericLiftCompare +instance Show1 LabeledConstruction where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable LabeledConstruction + +data InfixDataConstructor a = InfixDataConstructor { infixDataConstructorContext :: [a], infixDataConstructorLeft :: a, infixDataConstructorOperator :: a, infixDataConstructorRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 InfixDataConstructor where liftEq = genericLiftEq +instance Ord1 InfixDataConstructor where liftCompare = genericLiftCompare +instance Show1 InfixDataConstructor where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable InfixDataConstructor diff --git a/src/Language/Haskell/Syntax/Haskell.hs b/src/Language/Haskell/Syntax/Haskell.hs new file mode 100644 index 000000000..938f3bfb5 --- /dev/null +++ b/src/Language/Haskell/Syntax/Haskell.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +module Language.Haskell.Syntax.Haskell where + +import Prologue + +import Data.Abstract.Evaluatable +import Data.JSON.Fields +import Diffing.Algorithm +import Proto3.Suite.Class + +data Module a = Module { moduleContext :: [a] + , moduleIdentifier :: a + , moduleExports :: [a] + , moduleStatements :: a + } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Module where liftEq = genericLiftEq +instance Ord1 Module where liftCompare = genericLiftCompare +instance Show1 Module where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Module + +data Field a = Field { fieldName :: !a, fieldBody :: !a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Field where liftEq = genericLiftEq +instance Ord1 Field where liftCompare = genericLiftCompare +instance Show1 Field where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Field + +newtype Pragma a = Pragma { value :: Text } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Pragma where liftEq = genericLiftEq +instance Ord1 Pragma where liftCompare = genericLiftCompare +instance Show1 Pragma where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Pragma + +newtype Deriving a = Deriving { values :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Deriving where liftEq = genericLiftEq +instance Ord1 Deriving where liftCompare = genericLiftCompare +instance Show1 Deriving where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Deriving + +newtype ContextAlt a = ContextAlt { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ContextAlt where liftEq = genericLiftEq +instance Ord1 ContextAlt where liftCompare = genericLiftCompare +instance Show1 ContextAlt where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ContextAlt + +newtype Class a = Class { classContent :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Class where liftEq = genericLiftEq +instance Ord1 Class where liftCompare = genericLiftCompare +instance Show1 Class where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Class + +data GADT a = GADT { gadtContext :: a, gadtName :: a, gadtConstructors :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 GADT where liftEq = genericLiftEq +instance Ord1 GADT where liftCompare = genericLiftCompare +instance Show1 GADT where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable GADT + +newtype Export a = Export { exportContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Export where liftEq = genericLiftEq +instance Ord1 Export where liftCompare = genericLiftCompare +instance Show1 Export where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Export + +newtype ModuleExport a = ModuleExport { moduleExportContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ModuleExport where liftEq = genericLiftEq +instance Ord1 ModuleExport where liftCompare = genericLiftCompare +instance Show1 ModuleExport where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ModuleExport + +data InfixOperatorPattern a = InfixOperatorPattern { infixOperatorPatternLeft :: a, infixOperatorPatternOperator :: a, infixOperatorPatternRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 InfixOperatorPattern where liftEq = genericLiftEq +instance Ord1 InfixOperatorPattern where liftCompare = genericLiftCompare +instance Show1 InfixOperatorPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable InfixOperatorPattern + +newtype QuotedName a = QuotedName { quotedNameContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QuotedName where liftEq = genericLiftEq +instance Ord1 QuotedName where liftCompare = genericLiftCompare +instance Show1 QuotedName where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable QuotedName + +newtype ScopedTypeVariables a = ScopedTypeVariables { scopedTypeVariablesContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ScopedTypeVariables where liftEq = genericLiftEq +instance Ord1 ScopedTypeVariables where liftCompare = genericLiftCompare +instance Show1 ScopedTypeVariables where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ScopedTypeVariables + +data NewType a = NewType { newTypeContext :: [a], newTypeLeft :: a, newTypeRight :: a, newTypeDeriving :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 NewType where liftEq = genericLiftEq +instance Ord1 NewType where liftCompare = genericLiftCompare +instance Show1 NewType where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable NewType + +newtype DefaultDeclaration a = DefaultDeclaration { defaultDeclarationContent :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 DefaultDeclaration where liftEq = genericLiftEq +instance Ord1 DefaultDeclaration where liftCompare = genericLiftCompare +instance Show1 DefaultDeclaration where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable DefaultDeclaration + + +newtype VariableOperator a = VariableOperator { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 VariableOperator where liftEq = genericLiftEq +instance Ord1 VariableOperator where liftCompare = genericLiftCompare +instance Show1 VariableOperator where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable VariableOperator + +newtype ConstructorOperator a = ConstructorOperator { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ConstructorOperator where liftEq = genericLiftEq +instance Ord1 ConstructorOperator where liftCompare = genericLiftCompare +instance Show1 ConstructorOperator where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ConstructorOperator + +newtype TypeOperator a = TypeOperator { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeOperator where liftEq = genericLiftEq +instance Ord1 TypeOperator where liftCompare = genericLiftCompare +instance Show1 TypeOperator where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeOperator + +newtype PromotedTypeOperator a = PromotedTypeOperator { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 PromotedTypeOperator where liftEq = genericLiftEq +instance Ord1 PromotedTypeOperator where liftCompare = genericLiftCompare +instance Show1 PromotedTypeOperator where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable PromotedTypeOperator + +newtype VariableSymbol a = VariableSymbol { variableSymbolName :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 VariableSymbol where liftEq = genericLiftEq +instance Ord1 VariableSymbol where liftCompare = genericLiftCompare +instance Show1 VariableSymbol where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable VariableSymbol + +data ImportDeclaration a = ImportDeclaration { importPackageQualifiedContent :: a, importModule :: a, importSpec :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ImportDeclaration where liftEq = genericLiftEq +instance Ord1 ImportDeclaration where liftCompare = genericLiftCompare +instance Show1 ImportDeclaration where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ImportDeclaration + +data QualifiedImportDeclaration a = QualifiedImportDeclaration { qualifiedImportPackageQualifiedContent :: a, qualifiedImportModule :: a, qualifiedImportSpec :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QualifiedImportDeclaration where liftEq = genericLiftEq +instance Ord1 QualifiedImportDeclaration where liftCompare = genericLiftCompare +instance Show1 QualifiedImportDeclaration where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable QualifiedImportDeclaration + +newtype Import a = Import { importContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Import where liftEq = genericLiftEq +instance Ord1 Import where liftCompare = genericLiftCompare +instance Show1 Import where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Import + +newtype HiddenImport a = HiddenImport { hiddenimportContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 HiddenImport where liftEq = genericLiftEq +instance Ord1 HiddenImport where liftCompare = genericLiftCompare +instance Show1 HiddenImport where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable HiddenImport + +data ImportAlias a = ImportAlias { importAliasSource :: a, importAliasName :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ImportAlias where liftEq = genericLiftEq +instance Ord1 ImportAlias where liftCompare = genericLiftCompare +instance Show1 ImportAlias where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ImportAlias + +data App a = App { appLeft :: a, appLeftTypeApp :: a, appRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 App where liftEq = genericLiftEq +instance Ord1 App where liftCompare = genericLiftCompare +instance Show1 App where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable App + +data InfixOperatorApp a = InfixOperatorApp { infixOperatorAppLeft :: a, infixOperatorAppLeftTypeApp :: a, infixOperatorAppOperator :: a, infixOperatorAppRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 InfixOperatorApp where liftEq = genericLiftEq +instance Ord1 InfixOperatorApp where liftCompare = genericLiftCompare +instance Show1 InfixOperatorApp where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable InfixOperatorApp + +newtype TypeApp a = TypeApp { typeAppType :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeApp where liftEq = genericLiftEq +instance Ord1 TypeApp where liftCompare = genericLiftCompare +instance Show1 TypeApp where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeApp + +data ListComprehension a = ListComprehension { comprehensionValue :: a, comprehensionSource :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ListComprehension where liftEq = genericLiftEq +instance Ord1 ListComprehension where liftCompare = genericLiftCompare +instance Show1 ListComprehension where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ListComprehension + +data Generator a = Generator { generatorValue :: a, generatorSource :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Generator where liftEq = genericLiftEq +instance Ord1 Generator where liftCompare = genericLiftCompare +instance Show1 Generator where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Generator + +newtype TupleExpression a = TupleExpression { values :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TupleExpression where liftEq = genericLiftEq +instance Ord1 TupleExpression where liftCompare = genericLiftCompare +instance Show1 TupleExpression where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TupleExpression + +newtype TuplePattern a = TuplePattern { value :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TuplePattern where liftEq = genericLiftEq +instance Ord1 TuplePattern where liftCompare = genericLiftCompare +instance Show1 TuplePattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TuplePattern + +-- e.g. [1..], [1,2..], [1,2..10] +data ArithmeticSequence a = ArithmeticSequence { from :: a, next :: Maybe a, to :: Maybe a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ArithmeticSequence where liftEq = genericLiftEq +instance Ord1 ArithmeticSequence where liftCompare = genericLiftCompare +instance Show1 ArithmeticSequence where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ArithmeticSequence + +data RightOperatorSection a = RightOperatorSection { lhs :: a, rhs :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 RightOperatorSection where liftEq = genericLiftEq +instance Ord1 RightOperatorSection where liftCompare = genericLiftCompare +instance Show1 RightOperatorSection where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable RightOperatorSection + +data LeftOperatorSection a = LeftOperatorSection { lhs :: a, rhs :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 LeftOperatorSection where liftEq = genericLiftEq +instance Ord1 LeftOperatorSection where liftCompare = genericLiftCompare +instance Show1 LeftOperatorSection where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable LeftOperatorSection + +newtype ConstructorPattern a = ConstructorPattern { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ConstructorPattern where liftEq = genericLiftEq +instance Ord1 ConstructorPattern where liftCompare = genericLiftCompare +instance Show1 ConstructorPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ConstructorPattern + +-- e.g. `a <- b` in a Haskell do block. +data BindPattern a = BindPattern { bindPatternLeft :: [a], bindPatternRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 BindPattern where liftEq = genericLiftEq +instance Ord1 BindPattern where liftCompare = genericLiftCompare +instance Show1 BindPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable BindPattern + +newtype Do a = Do { values :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Do where liftEq = genericLiftEq +instance Ord1 Do where liftCompare = genericLiftCompare +instance Show1 Do where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Do + +data Lambda a = Lambda { lambdaHead :: a, lambdaBody :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Lambda where liftEq = genericLiftEq +instance Ord1 Lambda where liftCompare = genericLiftCompare +instance Show1 Lambda where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Lambda + +-- e.g. -1 or (-a) as an expression and not `-` as a variable operator. +newtype PrefixNegation a = PrefixNegation { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 PrefixNegation where liftEq = genericLiftEq +instance Ord1 PrefixNegation where liftCompare = genericLiftCompare +instance Show1 PrefixNegation where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable PrefixNegation + +newtype CPPDirective a = CPPDirective { value :: Text } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 CPPDirective where liftEq = genericLiftEq +instance Ord1 CPPDirective where liftCompare = genericLiftCompare +instance Show1 CPPDirective where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable CPPDirective + +data FixityAlt a = FixityAlt { fixityPrecedence :: a, fixityIdentifier :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 FixityAlt where liftEq = genericLiftEq +instance Ord1 FixityAlt where liftCompare = genericLiftCompare +instance Show1 FixityAlt where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable FixityAlt + +-- e.g. The `{..}` in `foo Bar{..} = baz` +data RecordWildCards a = RecordWildCards + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 RecordWildCards where liftEq = genericLiftEq +instance Ord1 RecordWildCards where liftCompare = genericLiftCompare +instance Show1 RecordWildCards where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable RecordWildCards + +data Wildcard a = Wildcard + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Wildcard where liftEq = genericLiftEq +instance Ord1 Wildcard where liftCompare = genericLiftCompare +instance Show1 Wildcard where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Wildcard + +data Let a = Let { letStatements :: [a], letInClause :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Let where liftEq = genericLiftEq +instance Ord1 Let where liftCompare = genericLiftCompare +instance Show1 Let where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Let + +-- e.g. The `start` or `end` in `f Blob{start, end} = [start, end]`. +newtype NamedFieldPun a = NamedFieldPun { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 NamedFieldPun where liftEq = genericLiftEq +instance Ord1 NamedFieldPun where liftCompare = genericLiftCompare +instance Show1 NamedFieldPun where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable NamedFieldPun + +-- e.g. The `-(1)` in `f (-(1)) = 1`. +newtype NegativeLiteral a = NegativeLiteral { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 NegativeLiteral where liftEq = genericLiftEq +instance Ord1 NegativeLiteral where liftCompare = genericLiftCompare +instance Show1 NegativeLiteral where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable NegativeLiteral + +newtype LambdaCase a = LambdaCase { values :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 LambdaCase where liftEq = genericLiftEq +instance Ord1 LambdaCase where liftCompare = genericLiftCompare +instance Show1 LambdaCase where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable LambdaCase + +-- The `y { a = 1, b = 2} in `f y@Example = y { a = 1, b = 2 }`. +newtype LabeledUpdate a = LabeledUpdate { values :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 LabeledUpdate where liftEq = genericLiftEq +instance Ord1 LabeledUpdate where liftCompare = genericLiftCompare +instance Show1 LabeledUpdate where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable LabeledUpdate + +-- The `a = 1` in `f y@Example = y { a = 1, b = 2 }`. +data FieldBind a = FieldBind { fieldBindLeft :: a, fieldBindRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 FieldBind where liftEq = genericLiftEq +instance Ord1 FieldBind where liftCompare = genericLiftCompare +instance Show1 FieldBind where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable FieldBind diff --git a/src/Language/Haskell/Syntax/Identifier.hs b/src/Language/Haskell/Syntax/Identifier.hs new file mode 100644 index 000000000..08219000d --- /dev/null +++ b/src/Language/Haskell/Syntax/Identifier.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +module Language.Haskell.Syntax.Identifier where + +import Prologue + +import Data.Abstract.Evaluatable +import Data.JSON.Fields +import Diffing.Algorithm +import Proto3.Suite.Class + +newtype QualifiedTypeClassIdentifier a = QualifiedTypeClassIdentifier { values :: NonEmpty a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QualifiedTypeClassIdentifier where liftEq = genericLiftEq +instance Ord1 QualifiedTypeClassIdentifier where liftCompare = genericLiftCompare +instance Show1 QualifiedTypeClassIdentifier where liftShowsPrec = genericLiftShowsPrec +instance Hashable1 QualifiedTypeClassIdentifier where liftHashWithSalt = foldl + +instance Evaluatable QualifiedTypeClassIdentifier + +newtype QualifiedTypeConstructorIdentifier a = QualifiedTypeConstructorIdentifier { values :: NonEmpty a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QualifiedTypeConstructorIdentifier where liftEq = genericLiftEq +instance Ord1 QualifiedTypeConstructorIdentifier where liftCompare = genericLiftCompare +instance Show1 QualifiedTypeConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec +instance Hashable1 QualifiedTypeConstructorIdentifier where liftHashWithSalt = foldl + +instance Evaluatable QualifiedTypeConstructorIdentifier + +newtype QualifiedConstructorIdentifier a = QualifiedConstructorIdentifier { values :: NonEmpty a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QualifiedConstructorIdentifier where liftEq = genericLiftEq +instance Ord1 QualifiedConstructorIdentifier where liftCompare = genericLiftCompare +instance Show1 QualifiedConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec +instance Hashable1 QualifiedConstructorIdentifier where liftHashWithSalt = foldl + +instance Evaluatable QualifiedConstructorIdentifier + +newtype QualifiedInfixVariableIdentifier a = QualifiedInfixVariableIdentifier { values :: NonEmpty a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QualifiedInfixVariableIdentifier where liftEq = genericLiftEq +instance Ord1 QualifiedInfixVariableIdentifier where liftCompare = genericLiftCompare +instance Show1 QualifiedInfixVariableIdentifier where liftShowsPrec = genericLiftShowsPrec +instance Hashable1 QualifiedInfixVariableIdentifier where liftHashWithSalt = foldl + +instance Evaluatable QualifiedInfixVariableIdentifier + +newtype QualifiedModuleIdentifier a = QualifiedModuleIdentifier { values :: NonEmpty a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QualifiedModuleIdentifier where liftEq = genericLiftEq +instance Ord1 QualifiedModuleIdentifier where liftCompare = genericLiftCompare +instance Show1 QualifiedModuleIdentifier where liftShowsPrec = genericLiftShowsPrec +instance Hashable1 QualifiedModuleIdentifier where liftHashWithSalt = foldl + +instance Evaluatable QualifiedModuleIdentifier + +newtype QualifiedVariableIdentifier a = QualifiedVariableIdentifier { values :: NonEmpty a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QualifiedVariableIdentifier where liftEq = genericLiftEq +instance Ord1 QualifiedVariableIdentifier where liftCompare = genericLiftCompare +instance Show1 QualifiedVariableIdentifier where liftShowsPrec = genericLiftShowsPrec +instance Hashable1 QualifiedVariableIdentifier where liftHashWithSalt = foldl + +instance Evaluatable QualifiedVariableIdentifier + +newtype TypeVariableIdentifier a = TypeVariableIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeVariableIdentifier where liftEq = genericLiftEq +instance Ord1 TypeVariableIdentifier where liftCompare = genericLiftCompare +instance Show1 TypeVariableIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeVariableIdentifier + +newtype TypeConstructorIdentifier a = TypeConstructorIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeConstructorIdentifier where liftEq = genericLiftEq +instance Ord1 TypeConstructorIdentifier where liftCompare = genericLiftCompare +instance Show1 TypeConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeConstructorIdentifier + +newtype ModuleIdentifier a = ModuleIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ModuleIdentifier where liftEq = genericLiftEq +instance Ord1 ModuleIdentifier where liftCompare = genericLiftCompare +instance Show1 ModuleIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ModuleIdentifier + +newtype ConstructorIdentifier a = ConstructorIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ConstructorIdentifier where liftEq = genericLiftEq +instance Ord1 ConstructorIdentifier where liftCompare = genericLiftCompare +instance Show1 ConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ConstructorIdentifier + +newtype ImplicitParameterIdentifier a = ImplicitParameterIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ImplicitParameterIdentifier where liftEq = genericLiftEq +instance Ord1 ImplicitParameterIdentifier where liftCompare = genericLiftCompare +instance Show1 ImplicitParameterIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ImplicitParameterIdentifier + +newtype InfixConstructorIdentifier a = InfixConstructorIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 InfixConstructorIdentifier where liftEq = genericLiftEq +instance Ord1 InfixConstructorIdentifier where liftCompare = genericLiftCompare +instance Show1 InfixConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable InfixConstructorIdentifier + +newtype InfixVariableIdentifier a = InfixVariableIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 InfixVariableIdentifier where liftEq = genericLiftEq +instance Ord1 InfixVariableIdentifier where liftCompare = genericLiftCompare +instance Show1 InfixVariableIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable InfixVariableIdentifier + +newtype TypeClassIdentifier a = TypeClassIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeClassIdentifier where liftEq = genericLiftEq +instance Ord1 TypeClassIdentifier where liftCompare = genericLiftCompare +instance Show1 TypeClassIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeClassIdentifier + +newtype VariableIdentifier a = VariableIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 VariableIdentifier where liftEq = genericLiftEq +instance Ord1 VariableIdentifier where liftCompare = genericLiftCompare +instance Show1 VariableIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable VariableIdentifier + +newtype PrimitiveConstructorIdentifier a = PrimitiveConstructorIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 PrimitiveConstructorIdentifier where liftEq = genericLiftEq +instance Ord1 PrimitiveConstructorIdentifier where liftCompare = genericLiftCompare +instance Show1 PrimitiveConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable PrimitiveConstructorIdentifier + +newtype PrimitiveVariableIdentifier a = PrimitiveVariableIdentifier { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 PrimitiveVariableIdentifier where liftEq = genericLiftEq +instance Ord1 PrimitiveVariableIdentifier where liftCompare = genericLiftCompare +instance Show1 PrimitiveVariableIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable PrimitiveVariableIdentifier diff --git a/src/Language/Haskell/Syntax/Pattern.hs b/src/Language/Haskell/Syntax/Pattern.hs new file mode 100644 index 000000000..f51cb10ce --- /dev/null +++ b/src/Language/Haskell/Syntax/Pattern.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +module Language.Haskell.Syntax.Pattern where + +import Prologue + +import Data.Abstract.Evaluatable +import Data.JSON.Fields +import Diffing.Algorithm +import Proto3.Suite.Class + +newtype StrictPattern a = StrictPattern { value :: a} + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 StrictPattern where liftEq = genericLiftEq +instance Ord1 StrictPattern where liftCompare = genericLiftCompare +instance Show1 StrictPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable StrictPattern + +newtype ListPattern a = ListPattern { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ListPattern where liftEq = genericLiftEq +instance Ord1 ListPattern where liftCompare = genericLiftCompare +instance Show1 ListPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ListPattern + +-- e.g. The `n@num1` in `f n@num1 x@num2 = x` +data AsPattern a = AsPattern { asPatternLeft :: a, asPatternRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 AsPattern where liftEq = genericLiftEq +instance Ord1 AsPattern where liftCompare = genericLiftCompare +instance Show1 AsPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable AsPattern + +newtype TypePattern a = TypePattern { typePatternContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypePattern where liftEq = genericLiftEq +instance Ord1 TypePattern where liftCompare = genericLiftCompare +instance Show1 TypePattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypePattern + +-- e.g. The `a = 1` in `foo Bar{ a = 1 } = baz`. +data FieldPattern a = FieldPattern { fieldPatternLeft :: a, fieldPatternRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 FieldPattern where liftEq = genericLiftEq +instance Ord1 FieldPattern where liftCompare = genericLiftCompare +instance Show1 FieldPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable FieldPattern + +-- e.g. The `~a` in `f ~a = 1` +newtype IrrefutablePattern a = IrrefutablePattern { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 IrrefutablePattern where liftEq = genericLiftEq +instance Ord1 IrrefutablePattern where liftCompare = genericLiftCompare +instance Show1 IrrefutablePattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable IrrefutablePattern + +-- For handling guards in case alternative expressions. +newtype CaseGuardPattern a = CaseGuardPattern { values :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 CaseGuardPattern where liftEq = genericLiftEq +instance Ord1 CaseGuardPattern where liftCompare = genericLiftCompare +instance Show1 CaseGuardPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable CaseGuardPattern + +-- For handling guards in function declarations. +newtype FunctionGuardPattern a = FunctionGuardPattern { values :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 FunctionGuardPattern where liftEq = genericLiftEq +instance Ord1 FunctionGuardPattern where liftCompare = genericLiftCompare +instance Show1 FunctionGuardPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable FunctionGuardPattern + +data ViewPattern a = ViewPattern { viewPatternLeft :: a, viewPatternRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ViewPattern where liftEq = genericLiftEq +instance Ord1 ViewPattern where liftCompare = genericLiftCompare +instance Show1 ViewPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ViewPattern + +-- e.g. The `Bar{..}` in `foo Bar{..} = baz`. +newtype LabeledPattern a = LabeledPattern { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 LabeledPattern where liftEq = genericLiftEq +instance Ord1 LabeledPattern where liftCompare = genericLiftCompare +instance Show1 LabeledPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable LabeledPattern + +-- The `a <- b` in `f a | a <- b = c` of a function declaration. +data PatternGuard a = PatternGuard { patternGuardPattern :: a, patternGuardExpression :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 PatternGuard where liftEq = genericLiftEq +instance Ord1 PatternGuard where liftCompare = genericLiftCompare +instance Show1 PatternGuard where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable PatternGuard + +newtype Guard a = Guard { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Guard where liftEq = genericLiftEq +instance Ord1 Guard where liftCompare = genericLiftCompare +instance Show1 Guard where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Guard diff --git a/src/Language/Haskell/Syntax/QuasiQuote.hs b/src/Language/Haskell/Syntax/QuasiQuote.hs new file mode 100644 index 000000000..cf113f74f --- /dev/null +++ b/src/Language/Haskell/Syntax/QuasiQuote.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +module Language.Haskell.Syntax.QuasiQuote where + +import Prologue + +import Data.Abstract.Evaluatable +import Data.JSON.Fields +import Diffing.Algorithm +import Proto3.Suite.Class + +data QuasiQuotation a = QuasiQuotation { quasiQuotationHead :: a, quasiQuotationBody :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QuasiQuotation where liftEq = genericLiftEq +instance Ord1 QuasiQuotation where liftCompare = genericLiftCompare +instance Show1 QuasiQuotation where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable QuasiQuotation + +newtype QuasiQuotationExpressionBody a = QuasiQuotationExpressionBody { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QuasiQuotationExpressionBody where liftEq = genericLiftEq +instance Ord1 QuasiQuotationExpressionBody where liftCompare = genericLiftCompare +instance Show1 QuasiQuotationExpressionBody where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable QuasiQuotationExpressionBody + +data QuasiQuotationPattern a = QuasiQuotationPattern + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QuasiQuotationPattern where liftEq = genericLiftEq +instance Ord1 QuasiQuotationPattern where liftCompare = genericLiftCompare +instance Show1 QuasiQuotationPattern where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable QuasiQuotationPattern + +data QuasiQuotationType a = QuasiQuotationType + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QuasiQuotationType where liftEq = genericLiftEq +instance Ord1 QuasiQuotationType where liftCompare = genericLiftCompare +instance Show1 QuasiQuotationType where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable QuasiQuotationType + +data QuasiQuotationDeclaration a = QuasiQuotationDeclaration + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QuasiQuotationDeclaration where liftEq = genericLiftEq +instance Ord1 QuasiQuotationDeclaration where liftCompare = genericLiftCompare +instance Show1 QuasiQuotationDeclaration where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable QuasiQuotationDeclaration + +newtype QuasiQuotationQuoter a = QuasiQuotationQuoter { name :: Name } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QuasiQuotationQuoter where liftEq = genericLiftEq +instance Ord1 QuasiQuotationQuoter where liftCompare = genericLiftCompare +instance Show1 QuasiQuotationQuoter where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable QuasiQuotationQuoter + +data QuasiQuotationExpression a = QuasiQuotationExpression + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 QuasiQuotationExpression where liftEq = genericLiftEq +instance Ord1 QuasiQuotationExpression where liftCompare = genericLiftCompare +instance Show1 QuasiQuotationExpression where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable QuasiQuotationExpression + +newtype Splice a = Splice { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Splice where liftEq = genericLiftEq +instance Ord1 Splice where liftCompare = genericLiftCompare +instance Show1 Splice where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Splice diff --git a/src/Language/Haskell/Syntax/Type.hs b/src/Language/Haskell/Syntax/Type.hs new file mode 100644 index 000000000..607c8722e --- /dev/null +++ b/src/Language/Haskell/Syntax/Type.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +module Language.Haskell.Syntax.Type where + +import Prologue + +import Data.Abstract.Evaluatable +import Data.JSON.Fields +import Diffing.Algorithm +import Proto3.Suite.Class + +data StrictType a = StrictType { strictTypeIdentifier :: a, strictTypeParameters :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 StrictType where liftEq = genericLiftEq +instance Ord1 StrictType where liftCompare = genericLiftCompare +instance Show1 StrictType where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable StrictType + +newtype StrictTypeVariable a = StrictTypeVariable { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 StrictTypeVariable where liftEq = genericLiftEq +instance Ord1 StrictTypeVariable where liftCompare = genericLiftCompare +instance Show1 StrictTypeVariable where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable StrictTypeVariable + +data Type a = Type { typeIdentifier :: a, typeParameters :: a, typeKindSignature :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Type where liftEq = genericLiftEq +instance Ord1 Type where liftCompare = genericLiftCompare +instance Show1 Type where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Type + +data TypeSynonym a = TypeSynonym { typeSynonymLeft :: a, typeSynonymContext :: [a], typeSynonymRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeSynonym where liftEq = genericLiftEq +instance Ord1 TypeSynonym where liftCompare = genericLiftCompare +instance Show1 TypeSynonym where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeSynonym + +data AnnotatedTypeVariable a = AnnotatedTypeVariable { annotatedTypeVariableIdentifier :: a, annotatedTypeVariableannotation :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 AnnotatedTypeVariable where liftEq = genericLiftEq +instance Ord1 AnnotatedTypeVariable where liftCompare = genericLiftCompare +instance Show1 AnnotatedTypeVariable where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable AnnotatedTypeVariable + +data StandaloneDerivingInstance a = StandaloneDerivingInstance { standaloneDerivingInstanceContext :: [a], standaloneDerivingInstanceClass :: a, standaloneDerivingInstanceInstance :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 StandaloneDerivingInstance where liftEq = genericLiftEq +instance Ord1 StandaloneDerivingInstance where liftCompare = genericLiftCompare +instance Show1 StandaloneDerivingInstance where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable StandaloneDerivingInstance + +data FunctionType a = FunctionType { functionTypeLeft :: a, functionTypeRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 FunctionType where liftEq = genericLiftEq +instance Ord1 FunctionType where liftCompare = genericLiftCompare +instance Show1 FunctionType where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable FunctionType + +data TypeSignature a = TypeSignature { typeSignatureName :: [a], typeSignatureContext :: [a], typeSignatureContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeSignature where liftEq = genericLiftEq +instance Ord1 TypeSignature where liftCompare = genericLiftCompare +instance Show1 TypeSignature where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeSignature + +data ExpressionTypeSignature a = ExpressionTypeSignature { expressionTypeSignatureName :: [a], expressionTypeSignatureContext :: [a], expressionTypeSignatureContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 ExpressionTypeSignature where liftEq = genericLiftEq +instance Ord1 ExpressionTypeSignature where liftCompare = genericLiftCompare +instance Show1 ExpressionTypeSignature where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable ExpressionTypeSignature + +newtype KindSignature a = KindSignature { kindSignatureContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 KindSignature where liftEq = genericLiftEq +instance Ord1 KindSignature where liftCompare = genericLiftCompare +instance Show1 KindSignature where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable KindSignature + +data KindFunctionType a = KindFunctionType { kindFunctionTypeLeft :: a, kindFunctionTypeRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 KindFunctionType where liftEq = genericLiftEq +instance Ord1 KindFunctionType where liftCompare = genericLiftCompare +instance Show1 KindFunctionType where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable KindFunctionType + +newtype Kind a = Kind { kindKind :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Kind where liftEq = genericLiftEq +instance Ord1 Kind where liftCompare = genericLiftCompare +instance Show1 Kind where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Kind + +newtype KindListType a = KindListType { kindListTypeKind :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 KindListType where liftEq = genericLiftEq +instance Ord1 KindListType where liftCompare = genericLiftCompare +instance Show1 KindListType where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable KindListType + +data Star a = Star + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Star where liftEq = genericLiftEq +instance Ord1 Star where liftCompare = genericLiftCompare +instance Show1 Star where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Star + +data EqualityConstraint a = EqualityConstraint { equalityConstraintLeft :: a, equalityConstraintRight :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 EqualityConstraint where liftEq = genericLiftEq +instance Ord1 EqualityConstraint where liftCompare = genericLiftCompare +instance Show1 EqualityConstraint where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable EqualityConstraint + +-- e.g. `type instance F [Int] = Int` where `F` is an open type family. +data TypeInstance a = TypeInstance { typeInstanceType :: a, typeInstanceBody :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeInstance where liftEq = genericLiftEq +instance Ord1 TypeInstance where liftCompare = genericLiftCompare +instance Show1 TypeInstance where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeInstance + +data TypeClassInstance a = TypeClassInstance { typeClassInstanceContext :: [a], typeClassInstanceIdentifier :: a, typeClassInstanceInstance :: a, typeClassInstanceBody :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeClassInstance where liftEq = genericLiftEq +instance Ord1 TypeClassInstance where liftCompare = genericLiftCompare +instance Show1 TypeClassInstance where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeClassInstance + +newtype Instance a = Instance { value :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 Instance where liftEq = genericLiftEq +instance Ord1 Instance where liftCompare = genericLiftCompare +instance Show1 Instance where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Instance + +newtype KindTupleType a = KindTupleType { kindTupleType :: [a] } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 KindTupleType where liftEq = genericLiftEq +instance Ord1 KindTupleType where liftCompare = genericLiftCompare +instance Show1 KindTupleType where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable KindTupleType + +data TypeClass a = TypeClass { typeClassContext :: a, typeClassIdentifier :: a, typeClassParameters :: [a], typeClassBody :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeClass where liftEq = genericLiftEq +instance Ord1 TypeClass where liftCompare = genericLiftCompare +instance Show1 TypeClass where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeClass + +-- The default signature of a type class. The default signature has the same shape as a TypeSignature Assignment. +data DefaultSignature a = DefaultSignature { defaultSignatureName :: [a], defaultSignatureContext :: [a], defaultSignatureContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 DefaultSignature where liftEq = genericLiftEq +instance Ord1 DefaultSignature where liftCompare = genericLiftCompare +instance Show1 DefaultSignature where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable DefaultSignature + +data TypeFamily a = TypeFamily { typeFamilyIdentifier :: a, typeFamilyParameters :: [a], typeFamilySignature :: a, typeFamilyBody :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 TypeFamily where liftEq = genericLiftEq +instance Ord1 TypeFamily where liftCompare = genericLiftCompare +instance Show1 TypeFamily where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable TypeFamily + +newtype FunctionalDependency a = FunctionalDependency { functionalDependencyContent :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) + +instance Eq1 FunctionalDependency where liftEq = genericLiftEq +instance Ord1 FunctionalDependency where liftCompare = genericLiftCompare +instance Show1 FunctionalDependency where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable FunctionalDependency diff --git a/src/Language/JSON/Assignment.hs b/src/Language/JSON/Assignment.hs index 244cb36a8..4298240cd 100644 --- a/src/Language/JSON/Assignment.hs +++ b/src/Language/JSON/Assignment.hs @@ -8,9 +8,8 @@ where import Assigning.Assignment.Deterministic hiding (Assignment) import qualified Assigning.Assignment.Deterministic as Deterministic -import Data.AST -import Data.Record import Data.Sum +import Data.Location import qualified Data.Syntax as Syntax import qualified Data.Syntax.Literal as Literal import qualified Data.Term as Term @@ -31,7 +30,7 @@ type Syntax = , Syntax.Error ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Deterministic.Assignment Grammar instance Named1 (Sum Syntax) where diff --git a/src/Language/JSON/PrettyPrint.hs b/src/Language/JSON/PrettyPrint.hs index 91526af49..b34349f48 100644 --- a/src/Language/JSON/PrettyPrint.hs +++ b/src/Language/JSON/PrettyPrint.hs @@ -6,20 +6,21 @@ module Language.JSON.PrettyPrint , minimizingJSON ) where -import Prologue hiding (throwError) +import Prologue -import Control.Monad.Effect -import Control.Monad.Effect.Exception (Exc, throwError) +import Control.Effect +import Control.Effect.Error import Control.Monad.Trans (lift) import Data.Machine import Data.Reprinting.Errors import Data.Reprinting.Splice import Data.Reprinting.Token +import Data.Reprinting.Scope -- | Default printing pipeline for JSON. -defaultJSONPipeline :: (Member (Exc TranslationError) effs) - => ProcessT (Eff effs) Fragment Splice +defaultJSONPipeline :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) + => ProcessT m Fragment Splice defaultJSONPipeline = printingJSON ~> beautifyingJSON defaultBeautyOpts @@ -34,14 +35,14 @@ printingJSON = repeatedly (await >>= step) where (Truth False, _) -> ins "false" (Nullity, _) -> ins "null" - (TOpen, Just TList) -> ins "[" - (TClose, Just TList) -> ins "]" - (TOpen, Just THash) -> ins "{" - (TClose, Just THash) -> ins "}" + (Open, Just List) -> ins "[" + (Close, Just List) -> ins "]" + (Open, Just Hash) -> ins "{" + (Close, Just Hash) -> ins "}" - (TSep, Just TList) -> ins "," - (TSep, Just TPair) -> ins ":" - (TSep, Just THash) -> ins "," + (Sep, Just List) -> ins "," + (Sep, Just Pair) -> ins ":" + (Sep, Just Hash) -> ins "," _ -> yield s step x = yield x @@ -55,23 +56,26 @@ defaultBeautyOpts :: JSONBeautyOpts defaultBeautyOpts = JSONBeautyOpts 2 False -- | Produce JSON with configurable whitespace and layout. -beautifyingJSON :: (Member (Exc TranslationError) effs) - => JSONBeautyOpts -> ProcessT (Eff effs) Fragment Splice +beautifyingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) + => JSONBeautyOpts -> ProcessT m Fragment Splice beautifyingJSON _ = repeatedly (await >>= step) where step (Defer el cs) = lift (throwError (NoTranslation el cs)) step (Verbatim txt) = emit txt - step (New el cs txt) = case (el, listToMaybe cs) of - (TOpen, Just THash) -> emit txt *> layouts [HardWrap, Indent 2 Spaces] - (TClose, Just THash) -> layout HardWrap *> emit txt - (TSep, Just TList) -> emit txt *> space - (TSep, Just TPair) -> emit txt *> space - (TSep, Just THash) -> emit txt *> layouts [HardWrap, Indent 2 Spaces] + step (New el cs txt) = case (el, cs) of + (Open, Hash:_) -> emit txt *> layout HardWrap *> indent 2 (hashDepth cs) + (Close, Hash:rest) -> layout HardWrap *> indent 2 (hashDepth rest) *> emit txt + (Sep, List:_) -> emit txt *> space + (Sep, Pair:_) -> emit txt *> space + (Sep, Hash:_) -> emit txt *> layout HardWrap *> indent 2 (hashDepth cs) _ -> emit txt -- | Produce whitespace minimal JSON. -minimizingJSON :: (Member (Exc TranslationError) effs) - => ProcessT (Eff effs) Fragment Splice +minimizingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) + => ProcessT m Fragment Splice minimizingJSON = repeatedly (await >>= step) where step (Defer el cs) = lift (throwError (NoTranslation el cs)) step (Verbatim txt) = emit txt step (New _ _ txt) = emit txt + +hashDepth :: [Scope] -> Int +hashDepth = length . filter (== Hash) diff --git a/src/Language/Java/Assignment.hs b/src/Language/Java/Assignment.hs index 4a611f390..6e272ddf8 100644 --- a/src/Language/Java/Assignment.hs +++ b/src/Language/Java/Assignment.hs @@ -15,7 +15,6 @@ import qualified Assigning.Assignment as Assignment import Data.Abstract.Name import Data.Functor (($>)) import Data.List.NonEmpty (some1) -import Data.Record import Data.Syntax ( contextualize , emptyTerm @@ -153,7 +152,7 @@ type Syntax = , [] ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Assignment.Assignment [] Grammar -- For Protobuf serialization diff --git a/src/Language/Java/Syntax.hs b/src/Language/Java/Syntax.hs index 7e6570458..67b2af317 100644 --- a/src/Language/Java/Syntax.hs +++ b/src/Language/Java/Syntax.hs @@ -5,11 +5,11 @@ module Language.Java.Syntax where import Data.Abstract.Evaluatable import Data.JSON.Fields import Diffing.Algorithm -import Prologue hiding (Constructor) +import Prologue import Proto3.Suite.Class newtype Import a = Import { imports :: [a]} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Import where liftEq = genericLiftEq @@ -20,7 +20,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Module where liftEq = genericLiftEq @@ -30,7 +30,7 @@ instance Show1 Module where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Module newtype Package a = Package { packages :: [a]} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Package where liftEq = genericLiftEq @@ -41,7 +41,7 @@ instance Show1 Package where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Package data EnumDeclaration a = EnumDeclaration { enumDeclarationModifier :: ![a], enumDeclarationIdentifier :: !a, enumDeclarationSuperInterfaces :: ![a], enumDeclarationConstant :: ![a], enumDeclarationBody :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 EnumDeclaration where liftEq = genericLiftEq instance Ord1 EnumDeclaration where liftCompare = genericLiftCompare @@ -50,7 +50,7 @@ instance Evaluatable EnumDeclaration data Variable a = Variable { variableModifiers :: ![a], variableType :: !a, variableName :: !a} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Variable where liftEq = genericLiftEq instance Ord1 Variable where liftCompare = genericLiftCompare @@ -60,7 +60,7 @@ instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Variable data Synchronized a = Synchronized { synchronizedSubject :: !a, synchronizedBody :: !a} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Synchronized where liftEq = genericLiftEq instance Ord1 Synchronized where liftCompare = genericLiftCompare @@ -70,7 +70,7 @@ instance Show1 Synchronized where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Synchronized data New a = New { newType :: !a, newArgs :: ![a], newClassBody :: Maybe a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 New where liftEq = genericLiftEq instance Ord1 New where liftCompare = genericLiftCompare @@ -80,7 +80,7 @@ instance Show1 New where liftShowsPrec = genericLiftShowsPrec instance Evaluatable New data Asterisk a = Asterisk - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Asterisk where liftEq = genericLiftEq instance Ord1 Asterisk where liftCompare = genericLiftCompare @@ -91,7 +91,7 @@ instance Evaluatable Asterisk data Constructor a = Constructor { constructorModifiers :: ![a], constructorTypeParams :: ![a], constructorIdentifier :: !a, constructorParams :: ![a], constructorThrows :: ![a], constructorBody :: a} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Constructor where liftEq = genericLiftEq instance Ord1 Constructor where liftCompare = genericLiftCompare @@ -101,7 +101,7 @@ instance Show1 Constructor where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Constructor data TypeParameter a = TypeParameter { typeParamAnnotation :: ![a], typeParamIdentifier :: !a, typeParamTypeBound :: ![a]} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 TypeParameter where liftEq = genericLiftEq instance Ord1 TypeParameter where liftCompare = genericLiftCompare @@ -111,7 +111,7 @@ instance Show1 TypeParameter where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeParameter data Annotation a = Annotation { annotationName :: !a, annotationField :: [a]} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Message1, NFData1, Traversable) instance Named1 Annotation where nameOf1 _ = "JavaAnnotation" instance Eq1 Annotation where liftEq = genericLiftEq @@ -122,7 +122,7 @@ instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Annotation data AnnotationField a = AnnotationField { annotationFieldName :: a, annotationFieldValue :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 AnnotationField where liftEq = genericLiftEq instance Ord1 AnnotationField where liftCompare = genericLiftCompare @@ -132,7 +132,7 @@ instance Show1 AnnotationField where liftShowsPrec = genericLiftShowsPrec instance Evaluatable AnnotationField data GenericType a = GenericType { genericTypeIdentifier :: a, genericTypeArguments :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 GenericType where liftEq = genericLiftEq instance Ord1 GenericType where liftCompare = genericLiftCompare @@ -142,7 +142,7 @@ instance Show1 GenericType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable GenericType data AnnotatedType a = AnnotatedType { annotationes :: [a], annotatedType :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 AnnotatedType where liftEq = genericLiftEq instance Ord1 AnnotatedType where liftCompare = genericLiftCompare @@ -152,7 +152,7 @@ instance Show1 AnnotatedType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable AnnotatedType newtype CatchType a = CatchType { types :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 CatchType where liftEq = genericLiftEq instance Ord1 CatchType where liftCompare = genericLiftCompare @@ -162,7 +162,7 @@ instance Show1 CatchType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable CatchType data TypeWithModifiers a = TypeWithModifiers { types :: [a], modifier :: a} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 TypeWithModifiers where liftEq = genericLiftEq instance Ord1 TypeWithModifiers where liftCompare = genericLiftCompare @@ -172,7 +172,7 @@ instance Show1 TypeWithModifiers where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeWithModifiers data Wildcard a = Wildcard { wildcardAnnotation :: [a], wildcardBounds :: Maybe a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Wildcard where liftEq = genericLiftEq instance Ord1 Wildcard where liftCompare = genericLiftCompare @@ -182,7 +182,7 @@ instance Show1 Wildcard where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Wildcard data WildcardBounds a = WildcardBoundExtends { wildcardBoundExtendsType :: a} | WildcardBoundSuper { wildcardBoundSuperType :: a} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 WildcardBounds where liftEq = genericLiftEq instance Ord1 WildcardBounds where liftCompare = genericLiftCompare @@ -192,7 +192,7 @@ instance Show1 WildcardBounds where liftShowsPrec = genericLiftShowsPrec instance Evaluatable WildcardBounds newtype SpreadParameter a = SpreadParameter { spreadParameterVariableDeclarator :: a} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 SpreadParameter where liftEq = genericLiftEq instance Ord1 SpreadParameter where liftCompare = genericLiftCompare @@ -202,7 +202,7 @@ instance Show1 SpreadParameter where liftShowsPrec = genericLiftShowsPrec instance Evaluatable SpreadParameter newtype StaticInitializer a = StaticInitializer { staticInitializerBlock :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 StaticInitializer where liftEq = genericLiftEq @@ -212,7 +212,7 @@ instance Show1 StaticInitializer where liftShowsPrec = genericLiftShowsPrec instance Evaluatable StaticInitializer data MethodReference a = MethodReference { methodReferenceType :: !a, methodReferenceTypeArgs :: ![a], methodReferenceIdentifier :: !a} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 MethodReference where liftEq = genericLiftEq instance Ord1 MethodReference where liftCompare = genericLiftCompare @@ -222,7 +222,7 @@ instance Show1 MethodReference where liftShowsPrec = genericLiftShowsPrec instance Evaluatable MethodReference data NewKeyword a = NewKeyword - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 NewKeyword where liftEq = genericLiftEq instance Ord1 NewKeyword where liftCompare = genericLiftCompare @@ -232,7 +232,7 @@ instance Show1 NewKeyword where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NewKeyword data Lambda a = Lambda { lambdaParams :: ![a], lambdaBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 Lambda where liftEq = genericLiftEq instance Ord1 Lambda where liftCompare = genericLiftCompare @@ -241,7 +241,7 @@ instance Show1 Lambda where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Lambda newtype LambdaBody a = LambdaBody { lambdaBodyExpression :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 LambdaBody where liftEq = genericLiftEq instance Ord1 LambdaBody where liftCompare = genericLiftCompare @@ -250,7 +250,7 @@ instance Show1 LambdaBody where liftShowsPrec = genericLiftShowsPrec instance Evaluatable LambdaBody data ArrayCreationExpression a = ArrayCreationExpression { arrayCreationExpressionType :: !a, arrayCreationExpressionDims :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 ArrayCreationExpression where liftEq = genericLiftEq instance Ord1 ArrayCreationExpression where liftCompare = genericLiftCompare @@ -259,7 +259,7 @@ instance Show1 ArrayCreationExpression where liftShowsPrec = genericLiftShowsPre instance Evaluatable ArrayCreationExpression data DimsExpr a = DimsExpr { dimsExprAnnotation :: ![a], dimsExprExpression :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 DimsExpr where liftEq = genericLiftEq instance Ord1 DimsExpr where liftCompare = genericLiftCompare @@ -268,7 +268,7 @@ instance Show1 DimsExpr where liftShowsPrec = genericLiftShowsPrec instance Evaluatable DimsExpr newtype ClassBody a = ClassBody { classBodyExpression :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 ClassBody where liftEq = genericLiftEq instance Ord1 ClassBody where liftCompare = genericLiftCompare @@ -277,7 +277,7 @@ instance Show1 ClassBody where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ClassBody newtype ClassLiteral a = ClassLiteral { classLiteralType :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 ClassLiteral where liftEq = genericLiftEq instance Ord1 ClassLiteral where liftCompare = genericLiftCompare @@ -286,7 +286,7 @@ instance Show1 ClassLiteral where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ClassLiteral data TryWithResources a = TryWithResources { tryResources :: ![a], tryBody :: !a, tryCatch :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 TryWithResources where liftEq = genericLiftEq instance Ord1 TryWithResources where liftCompare = genericLiftCompare @@ -296,7 +296,7 @@ instance Show1 TryWithResources where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TryWithResources data AssertStatement a = AssertStatement { assertLHS :: !a, assertRHS :: !(Maybe a) } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 AssertStatement where liftEq = genericLiftEq instance Ord1 AssertStatement where liftCompare = genericLiftCompare @@ -306,7 +306,7 @@ instance Show1 AssertStatement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable AssertStatement newtype DefaultValue a = DefaultValue { defaultValueElement :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 DefaultValue where liftEq = genericLiftEq instance Ord1 DefaultValue where liftCompare = genericLiftCompare @@ -315,7 +315,7 @@ instance Show1 DefaultValue where liftShowsPrec = genericLiftShowsPrec instance Evaluatable DefaultValue data AnnotationTypeElement a = AnnotationTypeElement { modifiers :: ![a], annotationType :: a, identifier :: !a, dims :: ![a], defaultValue :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Named1, Message1, NFData1, Traversable) instance Eq1 AnnotationTypeElement where liftEq = genericLiftEq instance Ord1 AnnotationTypeElement where liftCompare = genericLiftCompare diff --git a/src/Language/Markdown/Assignment.hs b/src/Language/Markdown/Assignment.hs index 306bdc954..d7aec3df6 100644 --- a/src/Language/Markdown/Assignment.hs +++ b/src/Language/Markdown/Assignment.hs @@ -12,7 +12,6 @@ import Prologue import Assigning.Assignment hiding (Assignment, Error) import qualified Assigning.Assignment as Assignment import qualified CMarkGFM -import Data.Record import Data.Syntax (makeTerm) import qualified Data.Syntax as Syntax import qualified Data.Term as Term @@ -49,7 +48,7 @@ type Syntax = , [] ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Assignment.Assignment (Term.TermF [] CMarkGFM.NodeType) Grammar -- For Protobuf serialization diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index 2bcb68403..471d45a2c 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -10,7 +10,7 @@ import Proto3.Suite import qualified Proto3.Suite as PB newtype Document a = Document { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Document where liftEq = genericLiftEq instance Ord1 Document where liftCompare = genericLiftCompare @@ -20,70 +20,70 @@ instance Show1 Document where liftShowsPrec = genericLiftShowsPrec -- Block elements newtype Paragraph a = Paragraph { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Paragraph where liftEq = genericLiftEq instance Ord1 Paragraph where liftCompare = genericLiftCompare instance Show1 Paragraph where liftShowsPrec = genericLiftShowsPrec data Heading a = Heading { headingLevel :: Int, headingContent :: [a], sectionContent :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Heading where liftEq = genericLiftEq instance Ord1 Heading where liftCompare = genericLiftCompare instance Show1 Heading where liftShowsPrec = genericLiftShowsPrec newtype UnorderedList a = UnorderedList { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 UnorderedList where liftEq = genericLiftEq instance Ord1 UnorderedList where liftCompare = genericLiftCompare instance Show1 UnorderedList where liftShowsPrec = genericLiftShowsPrec newtype OrderedList a = OrderedList { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 OrderedList where liftEq = genericLiftEq instance Ord1 OrderedList where liftCompare = genericLiftCompare instance Show1 OrderedList where liftShowsPrec = genericLiftShowsPrec newtype BlockQuote a = BlockQuote { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 BlockQuote where liftEq = genericLiftEq instance Ord1 BlockQuote where liftCompare = genericLiftCompare instance Show1 BlockQuote where liftShowsPrec = genericLiftShowsPrec data ThematicBreak a = ThematicBreak - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 ThematicBreak where liftEq = genericLiftEq instance Ord1 ThematicBreak where liftCompare = genericLiftCompare instance Show1 ThematicBreak where liftShowsPrec = genericLiftShowsPrec newtype HTMLBlock a = HTMLBlock { value :: T.Text } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 HTMLBlock where liftEq = genericLiftEq instance Ord1 HTMLBlock where liftCompare = genericLiftCompare instance Show1 HTMLBlock where liftShowsPrec = genericLiftShowsPrec newtype Table a = Table { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Table where liftEq = genericLiftEq instance Ord1 Table where liftCompare = genericLiftCompare instance Show1 Table where liftShowsPrec = genericLiftShowsPrec newtype TableRow a = TableRow { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 TableRow where liftEq = genericLiftEq instance Ord1 TableRow where liftCompare = genericLiftCompare instance Show1 TableRow where liftShowsPrec = genericLiftShowsPrec newtype TableCell a = TableCell { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 TableCell where liftEq = genericLiftEq instance Ord1 TableCell where liftCompare = genericLiftCompare @@ -93,28 +93,28 @@ instance Show1 TableCell where liftShowsPrec = genericLiftShowsPrec -- Inline elements newtype Strong a = Strong { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Strong where liftEq = genericLiftEq instance Ord1 Strong where liftCompare = genericLiftCompare instance Show1 Strong where liftShowsPrec = genericLiftShowsPrec newtype Emphasis a = Emphasis { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Emphasis where liftEq = genericLiftEq instance Ord1 Emphasis where liftCompare = genericLiftCompare instance Show1 Emphasis where liftShowsPrec = genericLiftShowsPrec newtype Text a = Text { value :: T.Text} - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Text where liftEq = genericLiftEq instance Ord1 Text where liftCompare = genericLiftCompare instance Show1 Text where liftShowsPrec = genericLiftShowsPrec data Link a = Link { linkURL :: T.Text, linkTitle :: Maybe T.Text } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, NFData1) instance Message1 Link where liftEncodeMessage _ _ Link{..} = encodeMessageField 1 linkURL <> maybe mempty (encodeMessageField 2) linkTitle @@ -129,7 +129,7 @@ instance Ord1 Link where liftCompare = genericLiftCompare instance Show1 Link where liftShowsPrec = genericLiftShowsPrec data Image a = Image { imageURL :: T.Text, imageTitle :: Maybe T.Text } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, NFData1) instance Message1 Image where liftEncodeMessage _ _ Image{..} = encodeMessageField 1 imageURL <> maybe mempty (encodeMessageField 2) imageTitle @@ -144,7 +144,7 @@ instance Ord1 Image where liftCompare = genericLiftCompare instance Show1 Image where liftShowsPrec = genericLiftShowsPrec data Code a = Code { codeLanguage :: Maybe T.Text, codeContent :: T.Text } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, NFData1) instance Message1 Code where liftEncodeMessage _ _ Code{..} = maybe mempty (encodeMessageField 1) codeLanguage <> encodeMessageField 2 codeContent @@ -160,14 +160,14 @@ instance Ord1 Code where liftCompare = genericLiftCompare instance Show1 Code where liftShowsPrec = genericLiftShowsPrec data LineBreak a = LineBreak - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 LineBreak where liftEq = genericLiftEq instance Ord1 LineBreak where liftCompare = genericLiftCompare instance Show1 LineBreak where liftShowsPrec = genericLiftShowsPrec newtype Strikethrough a = Strikethrough { values :: [a] } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, ToJSONFields1, Named1, Message1, NFData1) instance Eq1 Strikethrough where liftEq = genericLiftEq instance Ord1 Strikethrough where liftCompare = genericLiftCompare diff --git a/src/Language/MiniPython/Assignment.hs b/src/Language/MiniPython/Assignment.hs index 8bdb820f3..5e430d9f9 100644 --- a/src/Language/MiniPython/Assignment.hs +++ b/src/Language/MiniPython/Assignment.hs @@ -12,7 +12,6 @@ module Language.MiniPython.Assignment import Assigning.Assignment hiding (Assignment, Error) import qualified Assigning.Assignment as Assignment import Data.Abstract.Name (name) -import Data.Record import Data.Sum import Data.Syntax ( contextualize @@ -59,7 +58,7 @@ type Syntax = , [] ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Assignment.Assignment [] Grammar -- | Assignment from AST in Python's grammar onto a program in Python's syntax. diff --git a/src/Language/MiniRuby/Assignment.hs b/src/Language/MiniRuby/Assignment.hs index 820010b2b..c718e5ae9 100644 --- a/src/Language/MiniRuby/Assignment.hs +++ b/src/Language/MiniRuby/Assignment.hs @@ -12,7 +12,6 @@ import Assigning.Assignment hiding (Assignment, Error) import qualified Assigning.Assignment as Assignment import Data.Abstract.Name (name) import Data.List (elem) -import Data.Record import Data.Sum import Data.Syntax ( contextualize @@ -55,7 +54,7 @@ type Syntax = , [] ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Assignment.Assignment [] Grammar assignment :: Assignment Term @@ -210,7 +209,7 @@ withNewScope inner = withExtendedScope $ do putLocals [] inner -identWithLocals :: Assignment (Record Location, Text, [Text]) +identWithLocals :: Assignment (Location, Text, [Text]) identWithLocals = do loc <- symbol Identifier -- source advances, so it's important we call getLocals first diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index 164f9a538..8de76da7a 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -14,7 +14,6 @@ import qualified Assigning.Assignment as Assignment import qualified Data.Abstract.Name as Name import qualified Data.Diff as Diff import qualified Data.List.NonEmpty as NonEmpty -import Data.Record import Data.Syntax ( contextualize , emptyTerm @@ -162,7 +161,7 @@ type Syntax = '[ , Type.Annotation , [] ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Assignment.Assignment [] Grammar -- For Protobuf serialization diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 379da0a76..6523edc0b 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -3,7 +3,7 @@ module Language.PHP.Syntax where import Data.Abstract.BaseError -import Data.Abstract.Evaluatable +import Data.Abstract.Evaluatable as Abstract import Data.Abstract.Module import Data.Abstract.Path import Data.JSON.Fields @@ -17,7 +17,7 @@ import qualified Data.Abstract.ScopeGraph as ScopeGraph import qualified Data.Map.Strict as Map newtype Text a = Text { value :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Text where liftEq = genericLiftEq instance Ord1 Text where liftCompare = genericLiftCompare @@ -26,7 +26,7 @@ instance Evaluatable Text newtype VariableName a = VariableName { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 VariableName where liftEq = genericLiftEq instance Ord1 VariableName where liftCompare = genericLiftCompare @@ -41,37 +41,40 @@ instance Evaluatable VariableName -- file, the complete contents of the included file are treated as though it -- were defined inside that function. -resolvePHPName :: ( Member (Modules address value) effects - , Member (Reader ModuleInfo) effects - , Member (Reader Span) effects - , Member (Resumable (BaseError ResolutionError)) effects +resolvePHPName :: ( Member (Modules address value) sig + , Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Carrier sig m ) => T.Text - -> Evaluator address value effects ModulePath + -> Evaluator term address value m ModulePath resolvePHPName n = do modulePath <- resolve [name] maybeM (throwResolutionError $ NotFoundError name [name] Language.PHP) modulePath where name = toName n toName = T.unpack . dropRelativePrefix . stripQuotes -include :: ( AbstractValue address value effects - , Member (Deref value) effects - , Member (Modules address value) effects - , Member (Reader ModuleInfo) effects - , Member (Reader Span) effects - , Member (Resumable (BaseError (AddressError address value))) effects +include :: ( AbstractValue term address value m + , Carrier sig m + , Member (Deref value) sig + , Member (Modules address) sig + , Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (AddressError address value))) sig , Member (Resumable (BaseError (ScopeError address))) effects , Member (State (ScopeGraph address)) effects - , Member (Resumable (BaseError ResolutionError)) effects - , Member (State (Heap address address value)) effects - , Member Trace effects + , Member (Resumable (BaseError ResolutionError)) sig + , Member (State (Heap address address value)) sig + , Member Trace sig , Ord address ) - => Subterm term (Evaluator address value effects (ValueRef address value)) - -> (ModulePath -> Evaluator address value effects (ModuleResult address value)) - -> Evaluator address value effects (ValueRef address value) -include pathTerm f = do - name <- subtermValue pathTerm >>= asString + => (term -> Evaluator term address value m (ValueRef address)) + -> term + -> (ModulePath -> Evaluator term address value m (ModuleResult address)) + -> Evaluator term address value m (ValueRef address) +include eval pathTerm f = do + name <- eval pathTerm >>= Abstract.value >>= asString path <- resolvePHPName name traceResolve name path (scopeGraph, v) <- f path @@ -80,51 +83,51 @@ include pathTerm f = do pure (Rval v) newtype Require a = Require { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Require where liftEq = genericLiftEq instance Ord1 Require where liftCompare = genericLiftCompare instance Show1 Require where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Require where - eval (Require path) = include path load + eval eval (Require path) = include eval path load newtype RequireOnce a = RequireOnce { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 RequireOnce where liftEq = genericLiftEq instance Ord1 RequireOnce where liftCompare = genericLiftCompare instance Show1 RequireOnce where liftShowsPrec = genericLiftShowsPrec instance Evaluatable RequireOnce where - eval (RequireOnce path) = include path require + eval eval (RequireOnce path) = include eval path require newtype Include a = Include { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Include where liftEq = genericLiftEq instance Ord1 Include where liftCompare = genericLiftCompare instance Show1 Include where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Include where - eval (Include path) = include path load + eval eval (Include path) = include eval path load newtype IncludeOnce a = IncludeOnce { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 IncludeOnce where liftEq = genericLiftEq instance Ord1 IncludeOnce where liftCompare = genericLiftCompare instance Show1 IncludeOnce where liftShowsPrec = genericLiftShowsPrec instance Evaluatable IncludeOnce where - eval (IncludeOnce path) = include path require + eval eval (IncludeOnce path) = include eval path require newtype ArrayElement a = ArrayElement { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ArrayElement where liftEq = genericLiftEq instance Ord1 ArrayElement where liftCompare = genericLiftCompare @@ -132,7 +135,7 @@ instance Show1 ArrayElement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ArrayElement newtype GlobalDeclaration a = GlobalDeclaration { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 GlobalDeclaration where liftEq = genericLiftEq instance Ord1 GlobalDeclaration where liftCompare = genericLiftCompare @@ -140,7 +143,7 @@ instance Show1 GlobalDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable GlobalDeclaration newtype SimpleVariable a = SimpleVariable { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 SimpleVariable where liftEq = genericLiftEq instance Ord1 SimpleVariable where liftCompare = genericLiftCompare @@ -150,7 +153,7 @@ instance Evaluatable SimpleVariable -- | TODO: Unify with TypeScript's PredefinedType newtype CastType a = CastType { _castType :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 CastType where liftEq = genericLiftEq instance Ord1 CastType where liftCompare = genericLiftCompare @@ -158,7 +161,7 @@ instance Show1 CastType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable CastType newtype ErrorControl a = ErrorControl { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ErrorControl where liftEq = genericLiftEq instance Ord1 ErrorControl where liftCompare = genericLiftCompare @@ -166,7 +169,7 @@ instance Show1 ErrorControl where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ErrorControl newtype Clone a = Clone { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Clone where liftEq = genericLiftEq instance Ord1 Clone where liftCompare = genericLiftCompare @@ -174,7 +177,7 @@ instance Show1 Clone where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Clone newtype ShellCommand a = ShellCommand { value :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ShellCommand where liftEq = genericLiftEq instance Ord1 ShellCommand where liftCompare = genericLiftCompare @@ -183,7 +186,7 @@ instance Evaluatable ShellCommand -- | TODO: Combine with TypeScript update expression. newtype Update a = Update { _updateSubject :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Update where liftEq = genericLiftEq instance Ord1 Update where liftCompare = genericLiftCompare @@ -191,7 +194,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Update newtype NewVariable a = NewVariable { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 NewVariable where liftEq = genericLiftEq instance Ord1 NewVariable where liftCompare = genericLiftCompare @@ -199,7 +202,7 @@ instance Show1 NewVariable where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NewVariable newtype RelativeScope a = RelativeScope { value :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 RelativeScope where liftEq = genericLiftEq instance Ord1 RelativeScope where liftCompare = genericLiftCompare @@ -207,19 +210,19 @@ instance Show1 RelativeScope where liftShowsPrec = genericLiftShowsPrec instance Evaluatable RelativeScope data QualifiedName a = QualifiedName { name :: a, identifier :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 QualifiedName where liftEq = genericLiftEq instance Ord1 QualifiedName where liftCompare = genericLiftCompare instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedName where - eval (QualifiedName obj iden) = do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm obj)) + eval eval (QualifiedName obj iden) = do + name <- maybeM (throwEvalError NoNameError) (declaredName obj) reference (Reference name) (Declaration name) childScope <- associatedScope (Declaration name) - propName <- maybeM (throwEvalError NoNameError) (declaredName (subterm iden)) + propName <- maybeM (throwEvalError NoNameError) (declaredName iden) case childScope of Just childScope -> do currentScopeAddress <- currentScope @@ -234,7 +237,7 @@ instance Evaluatable QualifiedName where rvalBox unit newtype NamespaceName a = NamespaceName { names :: NonEmpty a } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Hashable1 NamespaceName where liftHashWithSalt = foldl instance Eq1 NamespaceName where liftEq = genericLiftEq @@ -242,12 +245,11 @@ instance Ord1 NamespaceName where liftCompare = genericLiftCompare instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NamespaceName where - eval (NamespaceName xs) = rvalBox unit - -- Rval <$> foldl1 f (fmap subtermAddress xs) + eval eval (NamespaceName xs) = undefined -- Rval <$> foldl1 f (fmap (eval >=> address) xs) -- where f ns id = ns >>= flip evaluateInScopedEnv id newtype ConstDeclaration a = ConstDeclaration { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ConstDeclaration where liftEq = genericLiftEq instance Ord1 ConstDeclaration where liftCompare = genericLiftCompare @@ -255,7 +257,7 @@ instance Show1 ConstDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ConstDeclaration data ClassConstDeclaration a = ClassConstDeclaration { visibility :: a, elements :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ClassConstDeclaration where liftEq = genericLiftEq instance Ord1 ClassConstDeclaration where liftCompare = genericLiftCompare @@ -263,7 +265,7 @@ instance Show1 ClassConstDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ClassConstDeclaration newtype ClassInterfaceClause a = ClassInterfaceClause { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ClassInterfaceClause where liftEq = genericLiftEq instance Ord1 ClassInterfaceClause where liftCompare = genericLiftCompare @@ -271,7 +273,7 @@ instance Show1 ClassInterfaceClause where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ClassInterfaceClause newtype ClassBaseClause a = ClassBaseClause { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ClassBaseClause where liftEq = genericLiftEq instance Ord1 ClassBaseClause where liftCompare = genericLiftCompare @@ -280,7 +282,7 @@ instance Evaluatable ClassBaseClause newtype UseClause a = UseClause { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 UseClause where liftEq = genericLiftEq instance Ord1 UseClause where liftCompare = genericLiftCompare @@ -288,7 +290,7 @@ instance Show1 UseClause where liftShowsPrec = genericLiftShowsPrec instance Evaluatable UseClause newtype ReturnType a = ReturnType { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ReturnType where liftEq = genericLiftEq instance Ord1 ReturnType where liftCompare = genericLiftCompare @@ -296,7 +298,7 @@ instance Show1 ReturnType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ReturnType newtype TypeDeclaration a = TypeDeclaration { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 TypeDeclaration where liftEq = genericLiftEq instance Ord1 TypeDeclaration where liftCompare = genericLiftCompare @@ -304,7 +306,7 @@ instance Show1 TypeDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeDeclaration newtype BaseTypeDeclaration a = BaseTypeDeclaration { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 BaseTypeDeclaration where liftEq = genericLiftEq instance Ord1 BaseTypeDeclaration where liftCompare = genericLiftCompare @@ -312,7 +314,7 @@ instance Show1 BaseTypeDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable BaseTypeDeclaration newtype ScalarType a = ScalarType { value :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ScalarType where liftEq = genericLiftEq instance Ord1 ScalarType where liftCompare = genericLiftCompare @@ -320,7 +322,7 @@ instance Show1 ScalarType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ScalarType newtype EmptyIntrinsic a = EmptyIntrinsic { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 EmptyIntrinsic where liftEq = genericLiftEq instance Ord1 EmptyIntrinsic where liftCompare = genericLiftCompare @@ -328,7 +330,7 @@ instance Show1 EmptyIntrinsic where liftShowsPrec = genericLiftShowsPrec instance Evaluatable EmptyIntrinsic newtype ExitIntrinsic a = ExitIntrinsic { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ExitIntrinsic where liftEq = genericLiftEq instance Ord1 ExitIntrinsic where liftCompare = genericLiftCompare @@ -336,7 +338,7 @@ instance Show1 ExitIntrinsic where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ExitIntrinsic newtype IssetIntrinsic a = IssetIntrinsic { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 IssetIntrinsic where liftEq = genericLiftEq instance Ord1 IssetIntrinsic where liftCompare = genericLiftCompare @@ -344,7 +346,7 @@ instance Show1 IssetIntrinsic where liftShowsPrec = genericLiftShowsPrec instance Evaluatable IssetIntrinsic newtype EvalIntrinsic a = EvalIntrinsic { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 EvalIntrinsic where liftEq = genericLiftEq instance Ord1 EvalIntrinsic where liftCompare = genericLiftCompare @@ -352,7 +354,7 @@ instance Show1 EvalIntrinsic where liftShowsPrec = genericLiftShowsPrec instance Evaluatable EvalIntrinsic newtype PrintIntrinsic a = PrintIntrinsic { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 PrintIntrinsic where liftEq = genericLiftEq instance Ord1 PrintIntrinsic where liftCompare = genericLiftCompare @@ -360,7 +362,7 @@ instance Show1 PrintIntrinsic where liftShowsPrec = genericLiftShowsPrec instance Evaluatable PrintIntrinsic newtype NamespaceAliasingClause a = NamespaceAliasingClause { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 NamespaceAliasingClause where liftEq = genericLiftEq instance Ord1 NamespaceAliasingClause where liftCompare = genericLiftCompare @@ -368,7 +370,7 @@ instance Show1 NamespaceAliasingClause where liftShowsPrec = genericLiftShowsPre instance Evaluatable NamespaceAliasingClause newtype NamespaceUseDeclaration a = NamespaceUseDeclaration { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 NamespaceUseDeclaration where liftEq = genericLiftEq instance Ord1 NamespaceUseDeclaration where liftCompare = genericLiftCompare @@ -376,7 +378,7 @@ instance Show1 NamespaceUseDeclaration where liftShowsPrec = genericLiftShowsPre instance Evaluatable NamespaceUseDeclaration newtype NamespaceUseClause a = NamespaceUseClause { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 NamespaceUseClause where liftEq = genericLiftEq instance Ord1 NamespaceUseClause where liftCompare = genericLiftCompare @@ -384,7 +386,7 @@ instance Show1 NamespaceUseClause where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NamespaceUseClause newtype NamespaceUseGroupClause a = NamespaceUseGroupClause { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 NamespaceUseGroupClause where liftEq = genericLiftEq instance Ord1 NamespaceUseGroupClause where liftCompare = genericLiftCompare @@ -392,31 +394,30 @@ instance Show1 NamespaceUseGroupClause where liftShowsPrec = genericLiftShowsPre instance Evaluatable NamespaceUseGroupClause data Namespace a = Namespace { namespaceName :: [a], namespaceBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Namespace where liftEq = genericLiftEq instance Ord1 Namespace where liftCompare = genericLiftCompare instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Namespace where - eval Namespace{..} = rvalBox unit - -- Rval <$> go (declaredName . subterm <$> namespaceName) - where - -- Each namespace name creates a closure over the subsequent namespace closures - -- go (n:x:xs) = do - -- name <- maybeM (throwEvalError NoNameError) n - -- letrec' name $ \addr -> - -- box =<< makeNamespace name addr Nothing (void $ go (x:xs)) - -- -- The last name creates a closure over the namespace body. - -- go [n] = do - -- name <- maybeM (throwEvalError NoNameError) n - -- letrec' name $ \addr -> - -- box =<< makeNamespace name addr Nothing (void $ subtermAddress namespaceBody) - -- -- The absence of names implies global scope, cf http://php.net/manual/en/language.namespaces.definitionmultiple.php - -- go [] = subtermAddress namespaceBody + eval eval Namespace{..} = undefined -- Rval <$> go (declaredName <$> namespaceName) + -- where + -- -- Each namespace name creates a closure over the subsequent namespace closures + -- go (n:x:xs) = do + -- name <- maybeM (throwEvalError NoNameError) n + -- letrec' name $ \addr -> + -- box =<< makeNamespace name addr Nothing (void $ go (x:xs)) + -- -- The last name creates a closure over the namespace body. + -- go [n] = do + -- name <- maybeM (throwEvalError NoNameError) n + -- letrec' name $ \addr -> + -- box =<< makeNamespace name addr Nothing (void $ eval namespaceBody) + -- -- The absence of names implies global scope, cf http://php.net/manual/en/language.namespaces.definitionmultiple.php + -- go [] = eval namespaceBody >>= address data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 TraitDeclaration where liftEq = genericLiftEq instance Ord1 TraitDeclaration where liftCompare = genericLiftCompare @@ -424,7 +425,7 @@ instance Show1 TraitDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TraitDeclaration data AliasAs a = AliasAs { aliasAsName :: a, aliasAsModifier :: a, aliasAsClause :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 AliasAs where liftEq = genericLiftEq instance Ord1 AliasAs where liftCompare = genericLiftCompare @@ -432,7 +433,7 @@ instance Show1 AliasAs where liftShowsPrec = genericLiftShowsPrec instance Evaluatable AliasAs data InsteadOf a = InsteadOf { left :: a, right :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 InsteadOf where liftEq = genericLiftEq instance Ord1 InsteadOf where liftCompare = genericLiftCompare @@ -440,7 +441,7 @@ instance Show1 InsteadOf where liftShowsPrec = genericLiftShowsPrec instance Evaluatable InsteadOf newtype TraitUseSpecification a = TraitUseSpecification { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 TraitUseSpecification where liftEq = genericLiftEq instance Ord1 TraitUseSpecification where liftCompare = genericLiftCompare @@ -448,7 +449,7 @@ instance Show1 TraitUseSpecification where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TraitUseSpecification data TraitUseClause a = TraitUseClause { namespace :: [a], alias :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 TraitUseClause where liftEq = genericLiftEq instance Ord1 TraitUseClause where liftCompare = genericLiftCompare @@ -456,7 +457,7 @@ instance Show1 TraitUseClause where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TraitUseClause data DestructorDeclaration a = DestructorDeclaration { body:: [a], name :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 DestructorDeclaration where liftEq = genericLiftEq instance Ord1 DestructorDeclaration where liftCompare = genericLiftCompare @@ -464,7 +465,7 @@ instance Show1 DestructorDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable DestructorDeclaration newtype Static a = Static { value :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Static where liftEq = genericLiftEq instance Ord1 Static where liftCompare = genericLiftCompare @@ -472,7 +473,7 @@ instance Show1 Static where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Static newtype ClassModifier a = ClassModifier { value :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ClassModifier where liftEq = genericLiftEq instance Ord1 ClassModifier where liftCompare = genericLiftCompare @@ -480,7 +481,7 @@ instance Show1 ClassModifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ClassModifier data ConstructorDeclaration a = ConstructorDeclaration { modifiers :: [a], parameters :: [a], body :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 ConstructorDeclaration where liftEq = genericLiftEq instance Ord1 ConstructorDeclaration where liftCompare = genericLiftCompare @@ -488,7 +489,7 @@ instance Show1 ConstructorDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ConstructorDeclaration data PropertyDeclaration a = PropertyDeclaration { modifier :: a, elements :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 PropertyDeclaration where liftEq = genericLiftEq instance Ord1 PropertyDeclaration where liftCompare = genericLiftCompare @@ -496,7 +497,7 @@ instance Show1 PropertyDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable PropertyDeclaration data PropertyModifier a = PropertyModifier { visibility :: a , static :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 PropertyModifier where liftEq = genericLiftEq instance Ord1 PropertyModifier where liftCompare = genericLiftCompare @@ -504,7 +505,7 @@ instance Show1 PropertyModifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable PropertyModifier data InterfaceDeclaration a = InterfaceDeclaration { name :: a, base :: a, declarations :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare @@ -512,7 +513,7 @@ instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable InterfaceDeclaration newtype InterfaceBaseClause a = InterfaceBaseClause { values :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 InterfaceBaseClause where liftEq = genericLiftEq instance Ord1 InterfaceBaseClause where liftCompare = genericLiftCompare @@ -520,7 +521,7 @@ instance Show1 InterfaceBaseClause where liftShowsPrec = genericLiftShowsPrec instance Evaluatable InterfaceBaseClause newtype Echo a = Echo { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Echo where liftEq = genericLiftEq instance Ord1 Echo where liftCompare = genericLiftCompare @@ -528,7 +529,7 @@ instance Show1 Echo where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Echo newtype Unset a = Unset { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Unset where liftEq = genericLiftEq instance Ord1 Unset where liftCompare = genericLiftCompare @@ -536,7 +537,7 @@ instance Show1 Unset where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Unset data Declare a = Declare { left :: a, right :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Declare where liftEq = genericLiftEq instance Ord1 Declare where liftCompare = genericLiftCompare @@ -544,7 +545,7 @@ instance Show1 Declare where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Declare newtype DeclareDirective a = DeclareDirective { value :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 DeclareDirective where liftEq = genericLiftEq instance Ord1 DeclareDirective where liftCompare = genericLiftCompare @@ -552,7 +553,7 @@ instance Show1 DeclareDirective where liftShowsPrec = genericLiftShowsPrec instance Evaluatable DeclareDirective newtype LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 LabeledStatement where liftEq = genericLiftEq instance Ord1 LabeledStatement where liftCompare = genericLiftCompare diff --git a/src/Language/Python/Assignment.hs b/src/Language/Python/Assignment.hs index 0ac8563b5..e5c773bf8 100644 --- a/src/Language/Python/Assignment.hs +++ b/src/Language/Python/Assignment.hs @@ -12,7 +12,6 @@ import qualified Assigning.Assignment as Assignment import Data.Abstract.Name (Name, name) import qualified Data.Diff as Diff import qualified Data.List.NonEmpty as NonEmpty -import Data.Record import Data.Sum import Data.Syntax ( contextualize @@ -120,7 +119,7 @@ type Syntax = , [] ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Assignment.Assignment [] Grammar instance Named1 (Sum Syntax) where @@ -465,9 +464,13 @@ raiseStatement :: Assignment Term raiseStatement = makeTerm <$> symbol RaiseStatement <*> children (Statement.Throw <$> expressions) ifStatement :: Assignment Term -ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> term expression <*> term (makeTerm <$> location <*> manyTermsTill expression (void (symbol ElseClause) <|> void (symbol ElifClause) <|> eof)) <*> (flip (foldr makeElif) <$> many elifClause <*> (symbol ElseClause *> children expressions <|> emptyTerm))) - where elifClause = (,) <$> symbol ElifClause <*> children (Statement.If <$> term expression <*> expressions) - makeElif (loc, makeIf) rest = makeTerm loc (makeIf rest) +ifStatement = makeTerm <$> symbol IfStatement <*> children if' + where + if' = Statement.If <$> term expression <*> thenClause <*> (elseClause <|> emptyTerm) + thenClause = makeTerm <$> location <*> manyTermsTill expression (void (symbol ElseClause) <|> void (symbol ElifClause) <|> eof) + elseClause = makeTerm <$> location <*> many (comment <|> elif <|> else') + elif = makeTerm <$> symbol ElifClause <*> children if' + else' = symbol ElseClause *> children expressions execStatement :: Assignment Term execStatement = makeTerm <$> symbol ExecStatement <*> children (Expression.Call [] <$> term (makeTerm <$> location <*> (Syntax.Identifier . name <$> source)) <*> manyTerm (string <|> expression) <*> emptyTerm) diff --git a/src/Language/Python/PrettyPrint.hs b/src/Language/Python/PrettyPrint.hs index 0de3631dc..b0bca195d 100644 --- a/src/Language/Python/PrettyPrint.hs +++ b/src/Language/Python/PrettyPrint.hs @@ -2,63 +2,66 @@ module Language.Python.PrettyPrint ( printingPython ) where -import Control.Monad.Effect -import Control.Monad.Effect.Exception (Exc, throwError) +import Control.Effect +import Control.Effect.Error import Control.Monad.Trans (lift) import Data.Machine + import Data.Reprinting.Errors import Data.Reprinting.Splice import Data.Reprinting.Token as Token +import Data.Reprinting.Scope +import Data.Reprinting.Operator -- | Print Python syntax. -printingPython :: (Member (Exc TranslationError) effs) => ProcessT (Eff effs) Fragment Splice +printingPython :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => ProcessT m Fragment Splice printingPython = repeatedly (await >>= step) -step :: (Member (Exc TranslationError) effs) => Fragment -> PlanT k Splice (Eff effs) () +step :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => Fragment -> PlanT k Splice m () step (Verbatim txt) = emit txt step (New _ _ txt) = emit txt step (Defer el cs) = case (el, cs) of -- Function declarations - (TOpen, TFunction:_) -> emit "def" *> space - (TOpen, TParams:TFunction:_) -> emit "(" - (TClose, TParams:TFunction:_) -> emit "):" - (TClose, TFunction:xs) -> endContext (imperativeDepth xs) + (Open, Function:_) -> emit "def" *> space + (Open, Params:Function:_) -> emit "(" + (Close, Params:Function:_) -> emit "):" + (Close, Function:xs) -> endContext (imperativeDepth xs) -- Return statements - (TOpen, TReturn:_) -> emit "return" *> space - (TClose, TReturn:_) -> pure () - (TOpen, Imperative:TReturn:_) -> pure () - (TSep, Imperative:TReturn:_) -> emit "," *> space - (TClose, Imperative:TReturn:_) -> pure () -- Don't hardwarp or indent for return statements + (Open, Return:_) -> emit "return" *> space + (Close, Return:_) -> pure () + (Open, Imperative:Return:_) -> pure () + (Sep, Imperative:Return:_) -> emit "," *> space + (Close, Imperative:Return:_) -> pure () -- Don't hardwarp or indent for return statements -- If statements - (TOpen, TIf:_) -> emit "if" *> space - (TThen, TIf:_) -> emit ":" - (TElse, TIf:xs) -> endContext (imperativeDepth xs) *> emit "else:" - (TClose, TIf:_) -> pure () + (Open, If:_) -> emit "if" *> space + (Then, If:_) -> emit ":" + (Else, If:xs) -> endContext (imperativeDepth xs) *> emit "else:" + (Close, If:_) -> pure () -- Booleans (Truth True, _) -> emit "True" (Truth False, _) -> emit "False" -- Infix binary operators - (TOpen, TInfixL _ p:xs) -> emitIf (p < precedenceOf xs) "(" - (TSym, TInfixL Add _:_) -> space *> emit "+" *> space - (TSym, TInfixL Multiply _:_) -> space *> emit "*" *> space - (TSym, TInfixL Subtract _:_) -> space *> emit "-" *> space - (TClose, TInfixL _ p:xs) -> emitIf (p < precedenceOf xs) ")" + (Open, InfixL _ p:xs) -> emitIf (p < precedenceOf xs) "(" + (Sym, InfixL Add _:_) -> space *> emit "+" *> space + (Sym, InfixL Multiply _:_) -> space *> emit "*" *> space + (Sym, InfixL Subtract _:_) -> space *> emit "-" *> space + (Close, InfixL _ p:xs) -> emitIf (p < precedenceOf xs) ")" -- General params handling - (TOpen, TParams:_) -> emit "(" - (TSep, TParams:_) -> emit "," *> space - (TClose, TParams:_) -> emit ")" + (Open, Params:_) -> emit "(" + (Sep, Params:_) -> emit "," *> space + (Close, Params:_) -> emit ")" -- Imperative context and whitespace handling - (TOpen, [Imperative]) -> pure () -- Don't indent at the top-level imperative context... - (TClose, [Imperative]) -> layout HardWrap -- but end the program with a newline. - (TOpen, Imperative:xs) -> layout HardWrap *> indent 4 (imperativeDepth xs) - (TSep, Imperative:xs) -> layout HardWrap *> indent 4 (imperativeDepth xs) - (TClose, Imperative:_) -> pure () + (Open, [Imperative]) -> pure () -- Don't indent at the top-level imperative context... + (Close, [Imperative]) -> layout HardWrap -- but end the program with a newline. + (Open, Imperative:xs) -> layout HardWrap *> indent 4 (imperativeDepth xs) + (Sep, Imperative:xs) -> layout HardWrap *> indent 4 (imperativeDepth xs) + (Close, Imperative:_) -> pure () _ -> lift (throwError (NoTranslation el cs)) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index a36640cf0..d2389f42d 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -27,7 +27,7 @@ import qualified Data.Abstract.ScopeGraph as ScopeGraph data QualifiedName = QualifiedName { paths :: NonEmpty FilePath } | RelativeQualifiedName { path :: FilePath, maybeQualifiedName :: Maybe QualifiedName } - deriving (Eq, Generic, Hashable, Ord, Show, ToJSON, Named, Message) + deriving (Eq, Generic, Hashable, Ord, Show, ToJSON, Named, Message, NFData) instance MessageField QualifiedName where encodeMessageField num QualifiedName{..} = Encode.embedded num (encodeMessageField 1 paths) @@ -67,14 +67,15 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (T.unpack prefix) (Ju -- Subsequent imports of `parent.two` or `parent.three` will execute -- `parent/two/__init__.py` and -- `parent/three/__init__.py` respectively. -resolvePythonModules :: ( Member (Modules address value) effects - , Member (Reader ModuleInfo) effects - , Member (Reader Span) effects - , Member (Resumable (BaseError ResolutionError)) effects - , Member Trace effects +resolvePythonModules :: ( Member (Modules address value) sig + , Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Member Trace sig + , Carrier sig m ) => QualifiedName - -> Evaluator address value effects (NonEmpty ModulePath) + -> Evaluator term address value m (NonEmpty ModulePath) resolvePythonModules q = do relRootDir <- rootDir q <$> currentModule for (moduleNames q) $ \name -> do @@ -105,14 +106,14 @@ resolvePythonModules q = do -- -- If the list of symbols is empty copy everything to the calling environment. data Import a = Import { importFrom :: QualifiedName, importSymbols :: ![Alias] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable, NFData1) instance Eq1 Import where liftEq = genericLiftEq instance Ord1 Import where liftCompare = genericLiftCompare instance Show1 Import where liftShowsPrec = genericLiftShowsPrec newtype FutureImport a = FutureImport { futureImportSymbols :: [Alias] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable, NFData1) instance Eq1 FutureImport where liftEq = genericLiftEq instance Ord1 FutureImport where liftCompare = genericLiftCompare @@ -121,7 +122,7 @@ instance Show1 FutureImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable FutureImport where data Alias = Alias { aliasValue :: Name, aliasName :: Name } - deriving (Eq, Generic, Hashable, Ord, Show, Message, Named, ToJSON) + deriving (Eq, Generic, Hashable, Ord, Show, Message, Named, ToJSON, NFData) toTuple :: Alias -> (Name, Name) toTuple Alias{..} = (aliasValue, aliasName) @@ -131,7 +132,7 @@ toTuple Alias{..} = (aliasValue, aliasName) instance Evaluatable Import where -- from . import moduleY -- This is a bit of a special case in the syntax as this actually behaves like a qualified relative import. - eval (Import (RelativeQualifiedName n Nothing) [Alias{..}]) = do + eval _ (Import (RelativeQualifiedName n Nothing) [Alias{..}]) = do path <- NonEmpty.last <$> resolvePythonModules (RelativeQualifiedName n (Just (qualifiedName (formatName aliasValue :| [])))) scopeGraph <- fst <$> require path bindAll scopeGraph @@ -143,7 +144,7 @@ instance Evaluatable Import where -- from a import b as c -- from a import * -- from .moduleY import b - eval (Import name xs) = do + eval _ (Import name xs) = do modulePaths <- resolvePythonModules name -- Eval parent modules first @@ -162,10 +163,27 @@ instance Evaluatable Import where pure () rvalBox unit + -- where + -- select importedBinds + -- | Prologue.null xs = importedBinds + -- | otherwise = Env.aliasBindings (toTuple <$> xs) importedBinds +-- Evaluate a qualified import +evalQualifiedImport :: ( AbstractValue term address value m + , Carrier sig m + , Member (Allocator address) sig + , Member (Deref value) sig + , Member (Modules address value) sig + , Member (State (Heap address address value)) sig + , Ord address + ) + => Name -> ModulePath -> Evaluator term address value m value +evalQualifiedImport name path = letrec' name $ \addr -> do + unit <$ makeNamespace name addr Nothing (bindAll . fst . snd =<< require path) + newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: NonEmpty FilePath } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Named1, Ord, Show, ToJSONFields1, Traversable, NFData1) instance Message1 QualifiedImport where liftEncodeMessage _ _ QualifiedImport{..} = encodeMessageField 1 qualifiedImportFrom @@ -185,7 +203,7 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec -- import a.b.c instance Evaluatable QualifiedImport where - eval (QualifiedImport qualifiedName) = do + eval _ (QualifiedImport qualifiedName) = do modulePaths <- resolvePythonModules (QualifiedName qualifiedName) -- rvalBox =<< go (NonEmpty.zip (Data.Abstract.Evaluatable.name . T.pack <$> qualifiedName) modulePaths) rvalBox unit @@ -198,7 +216,7 @@ instance Evaluatable QualifiedImport where -- makeNamespace name addr Nothing (void (require path >> go (NonEmpty.fromList xs))) data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportFrom :: QualifiedName, qualifiedAliasedImportAlias :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable, NFData1) instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare @@ -206,22 +224,22 @@ instance Show1 QualifiedAliasedImport where liftShowsPrec = genericLiftShowsPrec -- import a.b.c as e instance Evaluatable QualifiedAliasedImport where - eval (QualifiedAliasedImport name aliasTerm) = do + eval _ (QualifiedAliasedImport name aliasTerm) = do modulePaths <- resolvePythonModules name -- Evaluate each parent module for_ (NonEmpty.init modulePaths) require -- Evaluate and import the last module, aliasing and updating the environment - alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm)) - rvalBox unit + alias <- maybeM (throwEvalError NoNameError) (declaredName aliasTerm) -- rvalBox =<< letrec' alias (\addr -> do -- let path = NonEmpty.last modulePaths -- unit <$ makeNamespace alias addr Nothing (void (bindAll . fst . snd =<< require path))) + undefined -- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell) data Ellipsis a = Ellipsis - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable, NFData1) instance Eq1 Ellipsis where liftEq = genericLiftEq instance Ord1 Ellipsis where liftCompare = genericLiftCompare @@ -232,7 +250,7 @@ instance Evaluatable Ellipsis data Redirect a = Redirect { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable, NFData1) instance Eq1 Redirect where liftEq = genericLiftEq instance Ord1 Redirect where liftCompare = genericLiftCompare diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index 6617a2b5f..773a2876d 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/src/Language/Ruby/Assignment.hs @@ -14,7 +14,6 @@ import qualified Assigning.Assignment as Assignment import Data.Abstract.Name (name) import Data.List (elem) import qualified Data.List.NonEmpty as NonEmpty -import Data.Record import Data.Syntax ( contextualize , emptyTerm @@ -130,7 +129,7 @@ type Syntax = '[ , [] ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Assignment.Assignment [] Grammar -- For Protobuf serialization @@ -163,6 +162,7 @@ expressionChoices = , heredoc , identifier , if' + , then' , lambda , literal , method @@ -270,7 +270,7 @@ literal = (children (inject . Literal.String <$> some (interpolation <|> escapeSequence)) <|> inject . Literal.TextElement <$> source) symbol' :: Assignment Term - symbol' = makeTerm' <$> (symbol Symbol <|> symbol Symbol' <|> symbol BareSymbol) <*> + symbol' = makeTerm' <$> (symbol Symbol <|> symbol Symbol' <|> symbol Symbol'' <|> symbol BareSymbol) <*> (children (inject . Literal.Symbol <$> some interpolation) <|> inject . Literal.SymbolElement <$> source) interpolation :: Assignment Term @@ -363,14 +363,17 @@ undef = makeTerm <$> symbol Undef <*> children (Expression.Call [] <$> name' <*> where name' = makeTerm <$> location <*> (Syntax.Identifier . name <$> source) if' :: Assignment Term -if' = ifElsif If +if' = ifElsif If <|> makeTerm <$> symbol IfModifier <*> children (flip Statement.If <$> expression <*> expression <*> emptyTerm) where ifElsif s = makeTerm <$> symbol s <*> children (Statement.If <$> expression <*> expressions' <*> (elsif' <|> else' <|> emptyTerm)) - expressions' = makeTerm <$> location <*> manyTermsTill expression (void (symbol Else) <|> void (symbol Elsif) <|> eof) elsif' = postContextualize comment (ifElsif Elsif) + expressions' = makeTerm <$> location <*> manyTermsTill expression (void (symbol Else) <|> void (symbol Elsif) <|> eof) else' = postContextualize comment (symbol Else *> children expressions) +then' :: Assignment Term +then' = postContextualize comment (symbol Then *> children expressions) + unless :: Assignment Term unless = makeTerm <$> symbol Unless <*> children (Statement.If <$> invert expression <*> expressions' <*> (else' <|> emptyTerm)) <|> makeTerm <$> symbol UnlessModifier <*> children (flip Statement.If <$> expression <*> invert expression <*> emptyTerm) @@ -485,7 +488,7 @@ assignment' = makeTerm <$> symbol Assignment <*> children (Statement.As <|> lhsIdent <|> expression -identWithLocals :: Assignment (Record Location, Text, [Text]) +identWithLocals :: Assignment (Location, Text, [Text]) identWithLocals = do loc <- symbol Identifier -- source advances, so it's important we call getLocals first @@ -505,17 +508,17 @@ unary = symbol Unary >>= \ location -> <|> makeTerm location . Expression.Not <$> children ( symbol AnonBang *> expression ) <|> makeTerm location . Expression.Not <$> children ( symbol AnonNot *> expression ) <|> makeTerm location <$> children (Expression.Call [] <$> (makeTerm <$> symbol AnonDefinedQuestion <*> (Syntax.Identifier . name <$> source)) <*> some expression <*> emptyTerm) - <|> makeTerm location . Expression.Negate <$> children ( symbol AnonMinus' *> expression ) + <|> makeTerm location . Expression.Negate <$> children ( (symbol AnonMinus <|> symbol AnonMinus' <|> symbol AnonMinus'') *> expression ) <|> children ( symbol AnonPlus *> expression ) -- TODO: Distinguish `===` from `==` ? binary :: Assignment Term binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expression [ (inject .) . Expression.Plus <$ symbol AnonPlus - , (inject .) . Expression.Minus <$ symbol AnonMinus' - , (inject .) . Expression.Times <$ symbol AnonStar' + , (inject .) . Expression.Minus <$ (symbol AnonMinus <|> symbol AnonMinus' <|> symbol AnonMinus'') + , (inject .) . Expression.Times <$ (symbol AnonStar <|> symbol AnonStar') , (inject .) . Expression.Power <$ symbol AnonStarStar - , (inject .) . Expression.DividedBy <$ symbol AnonSlash + , (inject .) . Expression.DividedBy <$ (symbol AnonSlash <|> symbol AnonSlash' <|> symbol AnonSlash'') , (inject .) . Expression.Modulo <$ symbol AnonPercent , (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand , (inject .) . Ruby.Syntax.LowPrecedenceAnd <$ symbol AnonAnd @@ -530,7 +533,7 @@ binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expressi -- for this situation. , (inject .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual) , (inject .) . invert Expression.Equal <$ symbol AnonBangEqual - , (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle + , (inject .) . Expression.LShift <$ (symbol AnonLAngleLAngle <|> symbol AnonLAngleLAngle') , (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle , (inject .) . Expression.Comparison <$ symbol AnonLAngleEqualRAngle , (inject .) . Expression.LessThan <$ symbol AnonLAngle diff --git a/src/Language/Ruby/PrettyPrint.hs b/src/Language/Ruby/PrettyPrint.hs index b77600004..1f943f5e3 100644 --- a/src/Language/Ruby/PrettyPrint.hs +++ b/src/Language/Ruby/PrettyPrint.hs @@ -2,49 +2,52 @@ module Language.Ruby.PrettyPrint ( printingRuby ) where -import Control.Monad.Effect -import Control.Monad.Effect.Exception (Exc, throwError) +import Control.Effect +import Control.Effect.Error import Control.Monad.Trans (lift) import Data.Machine + +import Data.Reprinting.Scope import Data.Reprinting.Errors +import Data.Reprinting.Operator import Data.Reprinting.Splice import Data.Reprinting.Token as Token -- | Print Ruby syntax. -printingRuby :: (Member (Exc TranslationError) effs) => ProcessT (Eff effs) Fragment Splice +printingRuby :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => ProcessT m Fragment Splice printingRuby = repeatedly (await >>= step) -step :: (Member (Exc TranslationError) effs) => Fragment -> PlanT k Splice (Eff effs) () +step :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => Fragment -> PlanT k Splice m () step (Verbatim txt) = emit txt step (New _ _ txt) = emit txt step (Defer el cs) = case (el, cs) of - (TOpen, TMethod:_) -> emit "def" *> space - (TClose, TMethod:xs) -> endContext (imperativeDepth xs) *> emit "end" + (Open, Method:_) -> emit "def" *> space + (Close, Method:xs) -> endContext (imperativeDepth xs) *> emit "end" - -- TODO: do..end vs {..} should be configurable. - (TOpen, TFunction:_) -> space *> emit "do" *> space - (TOpen, TParams:TFunction:_) -> emit "|" - (TClose, TParams:TFunction:_) -> emit "|" - (TClose, TFunction:xs) -> endContext (imperativeDepth xs) *> emit "end" + -- ODO: do..end vs {..} should be configurable. + (Open, Function:_) -> space *> emit "do" *> space + (Open, Params:Function:_) -> emit "|" + (Close, Params:Function:_) -> emit "|" + (Close, Function:xs) -> endContext (imperativeDepth xs) *> emit "end" - -- TODO: Parens for calls are a style choice, make configurable. - (TOpen, TParams:_) -> emit "(" - (TSep, TParams:_) -> emit "," *> space - (TClose, TParams:_) -> emit ")" + -- ODO: Parens for calls are a style choice, make configurable. + (Open, Params:_) -> emit "(" + (Sep, Params:_) -> emit "," *> space + (Close, Params:_) -> emit ")" - (TOpen, TInfixL _ p:xs) -> emitIf (p < precedenceOf xs) "(" - (TSym, TInfixL Add _:_) -> space *> emit "+" *> space - (TSym, TInfixL Multiply _:_) -> space *> emit "*" *> space - (TSym, TInfixL Subtract _:_) -> space *> emit "-" *> space - (TClose, TInfixL _ p:xs) -> emitIf (p < precedenceOf xs) ")" + (Open, InfixL _ p:xs) -> emitIf (p < precedenceOf xs) "(" + (Sym, InfixL Add _:_) -> space *> emit "+" *> space + (Sym, InfixL Multiply _:_) -> space *> emit "*" *> space + (Sym, InfixL Subtract _:_) -> space *> emit "-" *> space + (Close, InfixL _ p:xs) -> emitIf (p < precedenceOf xs) ")" - (TOpen, [Imperative]) -> pure () - (TOpen, Imperative:xs) -> layout HardWrap *> indent 2 (imperativeDepth xs) - (TSep, Imperative:xs) -> layout HardWrap *> indent 2 (imperativeDepth xs) - (TClose, [Imperative]) -> layout HardWrap - (TClose, Imperative:xs) -> indent 2 (pred (imperativeDepth xs)) + (Open, [Imperative]) -> pure () + (Open, Imperative:xs) -> layout HardWrap *> indent 2 (imperativeDepth xs) + (Sep, Imperative:xs) -> layout HardWrap *> indent 2 (imperativeDepth xs) + (Close, [Imperative]) -> layout HardWrap + (Close, Imperative:xs) -> indent 2 (pred (imperativeDepth xs)) - (TSep, TCall:_) -> emit "." + (Sep, Call:_) -> emit "." _ -> lift (throwError (NoTranslation el cs)) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index e54603dd4..633126fc3 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -2,34 +2,37 @@ {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Ruby.Syntax where -import Control.Abstract.Value (Boolean) import Control.Monad (unless) +import qualified Data.Text as T +import Prologue +import System.FilePath.Posix + +import Control.Abstract.Value (Boolean) import Data.Abstract.BaseError import Data.Abstract.Evaluatable import qualified Data.Abstract.Module as M import Data.Abstract.Path +import qualified Data.Reprinting.Scope as Scope import Data.JSON.Fields import qualified Data.Language as Language -import qualified Data.Text as T import Diffing.Algorithm -import Prologue import Proto3.Suite.Class import Reprinting.Tokenize import System.FilePath.Posix import qualified Data.Abstract.ScopeGraph as ScopeGraph import Control.Abstract.ScopeGraph (bindAll, insertImportEdge, ScopeError) - -- TODO: Fully sort out ruby require/load mechanics -- -- require "json" -resolveRubyName :: ( Member (Modules address value) effects - , Member (Reader ModuleInfo) effects - , Member (Reader Span) effects - , Member (Resumable (BaseError ResolutionError)) effects +resolveRubyName :: ( Member (Modules address value) sig + , Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Carrier sig m ) => Text - -> Evaluator address value effects M.ModulePath + -> Evaluator term address value m M.ModulePath resolveRubyName name = do let name' = cleanNameOrPath name let paths = [name' <.> "rb"] @@ -37,13 +40,14 @@ resolveRubyName name = do maybeM (throwResolutionError $ NotFoundError name' paths Language.Ruby) modulePath -- load "/root/src/file.rb" -resolveRubyPath :: ( Member (Modules address value) effects - , Member (Reader ModuleInfo) effects - , Member (Reader Span) effects - , Member (Resumable (BaseError ResolutionError)) effects +resolveRubyPath :: ( Member (Modules address value) sig + , Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Carrier sig m ) => Text - -> Evaluator address value effects M.ModulePath + -> Evaluator term address value m M.ModulePath resolveRubyPath path = do let name' = cleanNameOrPath path modulePath <- resolve [name'] @@ -53,40 +57,39 @@ cleanNameOrPath :: Text -> String cleanNameOrPath = T.unpack . dropRelativePrefix . stripQuotes data Send a = Send { sendReceiver :: Maybe a, sendSelector :: Maybe a, sendArgs :: [a], sendBlock :: Maybe a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Send where liftEq = genericLiftEq instance Ord1 Send where liftCompare = genericLiftCompare instance Show1 Send where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Send where - eval Send{..} = do - undefined + eval eval Send{..} = undefined -- do -- let sel = case sendSelector of - -- Just sel -> subtermAddress sel + -- Just sel -> eval sel >>= address -- Nothing -> variable (name "call") - -- recv <- maybe (self >>= maybeM (box unit)) subtermAddress sendReceiver + -- recv <- maybe (self >>= maybeM (box unit)) (eval >=> address) sendReceiver -- func <- deref =<< evaluateInScopedEnv recv sel - -- args <- traverse subtermValue sendArgs + -- args <- traverse (eval >=> address) sendArgs -- Rval <$> call func recv args -- TODO pass through sendBlock instance Tokenize Send where - tokenize Send{..} = within TCall $ do - maybe (pure ()) (\r -> r *> yield TSep) sendReceiver + tokenize Send{..} = within Scope.Call $ do + maybe (pure ()) (\r -> r *> yield Sep) sendReceiver fromMaybe (pure ()) sendSelector - within' TParams $ sequenceA_ (sep sendArgs) + within' Scope.Params $ sequenceA_ (sep sendArgs) fromMaybe (pure ()) sendBlock data Require a = Require { requireRelative :: Bool, requirePath :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Require where liftEq = genericLiftEq instance Ord1 Require where liftCompare = genericLiftCompare instance Show1 Require where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Require where - eval (Require _ x) = do - name <- subtermValue x >>= asString + eval eval (Require _ x) = do + name <- eval x >>= value >>= asString path <- resolveRubyName name traceResolve name path (scopeGraph, v) <- doRequire path @@ -94,11 +97,12 @@ instance Evaluatable Require where maybe (pure ()) insertImportEdge (ScopeGraph.currentScope scopeGraph) rvalBox v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require -doRequire :: ( Member (Boolean value) effects - , Member (Modules address value) effects +doRequire :: ( Member (Boolean value) sig + , Member (Modules address value) sig + , Carrier sig m ) => M.ModulePath - -> Evaluator address value effects (ScopeGraph.ScopeGraph address, value) + -> Evaluator term address value m (Bindings address, value) doRequire path = do result <- lookupModule path case result of @@ -107,34 +111,35 @@ doRequire path = do data Load a = Load { loadPath :: a, loadWrap :: Maybe a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Load where liftEq = genericLiftEq instance Ord1 Load where liftCompare = genericLiftCompare instance Show1 Load where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Load where - eval (Load x Nothing) = do - path <- subtermValue x >>= asString + eval eval (Load x Nothing) = do + path <- eval x >>= value >>= asString rvalBox =<< doLoad path False - eval (Load x (Just wrap)) = do - path <- subtermValue x >>= asString - shouldWrap <- subtermValue wrap >>= asBool + eval eval (Load x (Just wrap)) = do + path <- eval x >>= value >>= asString + shouldWrap <- eval wrap >>= value >>= asBool rvalBox =<< doLoad path shouldWrap -doLoad :: ( Member (Boolean value) effects - , Member (Modules address value) effects - , Member (Reader ModuleInfo) effects - , Member (Reader Span) effects - , Member (Resumable (BaseError ResolutionError)) effects - , Member Trace effects +doLoad :: ( Member (Boolean value) sig + , Member (Modules address value) sig + , Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Member (Resumable (BaseError (ScopeError address))) sig + , Member (State (ScopeGraph.ScopeGraph address)) sig + , Member Trace sig , Ord address - , Member (Resumable (BaseError (ScopeError address))) effects - , Member (State (ScopeGraph.ScopeGraph address)) effects + , Carrier sig m ) => Text -> Bool - -> Evaluator address value effects value + -> Evaluator term address value m value doLoad path shouldWrap = do path' <- resolveRubyPath path traceResolve path path' @@ -147,7 +152,7 @@ doLoad path shouldWrap = do -- TODO: autoload data Class a = Class { classIdentifier :: !a, classSuperClass :: !(Maybe a), classBody :: !a } - deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1) + deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1) instance Diffable Class where equivalentBySubterm = Just . classIdentifier @@ -157,35 +162,31 @@ instance Ord1 Class where liftCompare = genericLiftCompare instance Show1 Class where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Class where - eval Class{..} = do - -- TODO: Reimplement this - undefined - -- super <- traverse subtermAddress classSuperClass - -- name <- maybeM (throwEvalError NoNameError) (declaredName (subterm classIdentifier)) + eval eval Class{..} = undefined -- do + -- super <- traverse (eval >=> address) classSuperClass + -- name <- maybeM (throwEvalError NoNameError) (declaredName classIdentifier) -- rvalBox =<< letrec' name (\addr -> - -- makeNamespace name addr super (void (subtermAddress classBody))) + -- makeNamespace name addr super (void (eval classBody))) data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Eq1 Module where liftEq = genericLiftEq instance Ord1 Module where liftCompare = genericLiftCompare instance Show1 Module where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Module where - eval (Module iden xs) = do - -- TODO: Implement this - undefined - -- name <- maybeM (throwEvalError NoNameError) (declaredName (subterm iden)) + eval eval (Module iden xs) = undefined -- do + -- name <- maybeM (throwEvalError NoNameError) (declaredName iden) -- rvalBox =<< letrec' name (\addr -> - -- makeNamespace name addr Nothing (void (eval xs))) + -- makeNamespace name addr Nothing (traverse_ eval xs)) data LowPrecedenceAnd a = LowPrecedenceAnd { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Evaluatable LowPrecedenceAnd where -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands - eval t = rvalBox =<< go (fmap subtermValue t) where + eval eval t = rvalBox =<< go (fmap (eval >=> value) t) where go (LowPrecedenceAnd a b) = do cond <- a ifthenelse cond b (pure cond) @@ -195,11 +196,11 @@ instance Ord1 LowPrecedenceAnd where liftCompare = genericLiftCompare instance Show1 LowPrecedenceAnd where liftShowsPrec = genericLiftShowsPrec data LowPrecedenceOr a = LowPrecedenceOr { lhs :: a, rhs :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1) instance Evaluatable LowPrecedenceOr where -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands - eval t = rvalBox =<< go (fmap subtermValue t) where + eval eval t = rvalBox =<< go (fmap (eval >=> value) t) where go (LowPrecedenceOr a b) = do cond <- a ifthenelse cond (pure cond) b diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index 177d72fd3..30bfb4170 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -10,7 +10,6 @@ module Language.TypeScript.Assignment import Assigning.Assignment hiding (Assignment, Error) import Data.Abstract.Name (Name, name) import qualified Assigning.Assignment as Assignment -import Data.Record import Data.Sum import Data.Syntax ( contextualize @@ -207,7 +206,7 @@ type Syntax = '[ , [] ] -type Term = Term.Term (Sum Syntax) (Record Location) +type Term = Term.Term (Sum Syntax) Location type Assignment = Assignment.Assignment [] Grammar instance Named1 (Sum Syntax) where @@ -382,7 +381,7 @@ false :: Assignment Term false = makeTerm <$> symbol Grammar.False <*> (Literal.false <$ rawSource) identifier :: Assignment Term -identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier') <*> (Syntax.Identifier . name <$> source) +identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') <*> (Syntax.Identifier . name <$> source) class' :: Assignment Term class' = makeClass <$> symbol Class <*> children ((,,,,) <$> manyTerm decorator <*> term typeIdentifier <*> (symbol TypeParameters *> children (manyTerm typeParameter') <|> pure []) <*> (classHeritage' <|> pure []) <*> classBodyStatements) @@ -515,7 +514,7 @@ typeAnnotation' :: Assignment Term typeAnnotation' = makeTerm <$> symbol TypeAnnotation <*> children (TypeScript.Syntax.Annotation <$> term ty) typeParameter' :: Assignment Term -typeParameter' = makeTerm <$> symbol Grammar.TypeParameter <*> children (TypeScript.Syntax.TypeParameter <$> term identifier <*> term (constraint <|> emptyTerm) <*> term (defaultType <|> emptyTerm)) +typeParameter' = makeTerm <$> symbol Grammar.TypeParameter <*> children (TypeScript.Syntax.TypeParameter <$> term typeIdentifier <*> term (constraint <|> emptyTerm) <*> term (defaultType <|> emptyTerm)) defaultType :: Assignment Term defaultType = makeTerm <$> symbol Grammar.DefaultType <*> children (TypeScript.Syntax.DefaultType <$> term ty) @@ -593,7 +592,7 @@ typeQuery :: Assignment Term typeQuery = makeTerm <$> symbol Grammar.TypeQuery <*> children (TypeScript.Syntax.TypeQuery <$> term (identifier <|> nestedIdentifier)) indexTypeQuery :: Assignment Term -indexTypeQuery = makeTerm <$> symbol Grammar.IndexTypeQuery <*> children (TypeScript.Syntax.IndexTypeQuery <$> term (typeIdentifier <|> nestedIdentifier)) +indexTypeQuery = makeTerm <$> symbol Grammar.IndexTypeQuery <*> children (TypeScript.Syntax.IndexTypeQuery <$> term (typeIdentifier <|> nestedTypeIdentifier)) thisType :: Assignment Term thisType = makeTerm <$> symbol Grammar.ThisType <*> (TypeScript.Syntax.ThisType <$> source) @@ -725,7 +724,7 @@ importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> childr makeImportTerm loc ([x], from) = makeImportTerm1 loc from x makeImportTerm loc (xs, from) = makeTerm loc $ fmap (makeImportTerm1 loc from) xs importSymbol = symbol Grammar.ImportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> ((Just <$> rawIdentifier) <|> pure Nothing)) - rawIdentifier = (symbol Identifier <|> symbol Identifier') *> (name <$> source) + rawIdentifier = (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> (name <$> source) makeNameAliasPair from (Just alias) = (from, alias) makeNameAliasPair from Nothing = (from, from) @@ -784,7 +783,7 @@ exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip <|> symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> pure Nothing) makeNameAliasPair from (Just alias) = TypeScript.Syntax.Alias from alias makeNameAliasPair from Nothing = TypeScript.Syntax.Alias from from - rawIdentifier = (symbol Identifier <|> symbol Identifier') *> (name <$> source) + rawIdentifier = (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> (name <$> source) -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term. fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source) @@ -860,7 +859,7 @@ variableDeclarator = where makeVarDecl loc (subject, annotations, value) = makeTerm loc (Statement.Assignment [annotations] subject value) - requireCall = symbol CallExpression *> children ((symbol Identifier <|> symbol Identifier') *> do + requireCall = symbol CallExpression *> children ((symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> do s <- source guard (s == "require") symbol Arguments *> children (symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source)) diff --git a/src/Language/TypeScript/Resolution.hs b/src/Language/TypeScript/Resolution.hs index 280f12dda..5498e831a 100644 --- a/src/Language/TypeScript/Resolution.hs +++ b/src/Language/TypeScript/Resolution.hs @@ -31,7 +31,7 @@ import Data.Abstract.Path import qualified Data.Language as Language data IsRelative = Unknown | Relative | NonRelative - deriving (Bounded, Enum, Finite, MessageField, Named, Eq, Generic, Hashable, Ord, Show, ToJSON) + deriving (Bounded, Enum, Finite, MessageField, Named, Eq, Generic, Hashable, Ord, Show, ToJSON, NFData) instance Primitive IsRelative where encodePrimitive = Encode.enum @@ -42,7 +42,7 @@ instance HasDefault IsRelative where def = Unknown data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: IsRelative } - deriving (Eq, Generic, Hashable, Message, Named, Ord, Show, ToJSON) + deriving (Eq, Generic, Hashable, Message, Named, Ord, Show, ToJSON, NFData) instance MessageField ImportPath where encodeMessageField num = Encode.embedded num . encodeMessage (fieldNumber 1) @@ -66,16 +66,17 @@ toName = name . T.pack . unPath -- -- NB: TypeScript has a couple of different strategies, but the main one (and the -- only one we support) mimics Node.js. -resolveWithNodejsStrategy :: ( Member (Modules address value) effects - , Member (Reader M.ModuleInfo) effects - , Member (Reader PackageInfo) effects - , Member (Reader Span) effects - , Member (Resumable (BaseError ResolutionError)) effects - , Member Trace effects +resolveWithNodejsStrategy :: ( Member (Modules address value) sig + , Member (Reader M.ModuleInfo) sig + , Member (Reader PackageInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Member Trace sig + , Carrier sig m ) => ImportPath -> [String] - -> Evaluator address value effects M.ModulePath + -> Evaluator term address value m M.ModulePath resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath path exts resolveWithNodejsStrategy (ImportPath path _) exts = resolveRelativePath path exts @@ -86,16 +87,17 @@ resolveWithNodejsStrategy (ImportPath path _) exts = resolveRelativePa -- /root/src/moduleB.ts -- /root/src/moduleB/package.json (if it specifies a "types" property) -- /root/src/moduleB/index.ts -resolveRelativePath :: ( Member (Modules address value) effects - , Member (Reader M.ModuleInfo) effects - , Member (Reader PackageInfo) effects - , Member (Reader Span) effects - , Member (Resumable (BaseError ResolutionError)) effects - , Member Trace effects +resolveRelativePath :: ( Member (Modules address value) sig + , Member (Reader M.ModuleInfo) sig + , Member (Reader PackageInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Member Trace sig + , Carrier sig m ) => FilePath -> [String] - -> Evaluator address value effects M.ModulePath + -> Evaluator term address value m M.ModulePath resolveRelativePath relImportPath exts = do M.ModuleInfo{..} <- currentModule let relRootDir = takeDirectory modulePath @@ -115,16 +117,17 @@ resolveRelativePath relImportPath exts = do -- -- /root/node_modules/moduleB.ts, etc -- /node_modules/moduleB.ts, etc -resolveNonRelativePath :: ( Member (Modules address value) effects - , Member (Reader M.ModuleInfo) effects - , Member (Reader PackageInfo) effects - , Member (Reader Span) effects - , Member (Resumable (BaseError ResolutionError)) effects - , Member Trace effects +resolveNonRelativePath :: ( Member (Modules address value) sig + , Member (Reader M.ModuleInfo) sig + , Member (Reader PackageInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Member Trace sig + , Carrier sig m ) => FilePath -> [String] - -> Evaluator address value effects M.ModulePath + -> Evaluator term address value m M.ModulePath resolveNonRelativePath name exts = do M.ModuleInfo{..} <- currentModule go "." modulePath mempty @@ -141,13 +144,14 @@ resolveNonRelativePath name exts = do notFound xs = throwResolutionError $ NotFoundError name xs Language.TypeScript -- | Resolve a module name to a ModulePath. -resolveModule :: ( Member (Modules address value) effects - , Member (Reader PackageInfo) effects - , Member Trace effects +resolveModule :: ( Member (Modules address value) sig + , Member (Reader PackageInfo) sig + , Member Trace sig + , Carrier sig m ) => FilePath -- ^ Module path used as directory to search in -> [String] -- ^ File extensions to look for - -> Evaluator address value effects (Either [FilePath] M.ModulePath) + -> Evaluator term address value m (Either [FilePath] M.ModulePath) resolveModule path' exts = do let path = makeRelative "." path' PackageInfo{..} <- currentPackage @@ -164,15 +168,17 @@ typescriptExtensions = ["ts", "tsx", "d.ts"] javascriptExtensions :: [String] javascriptExtensions = ["js"] --- evalRequire :: ( AbstractValue address value effects --- , Member (Allocator address) effects --- , Member (Deref value) effects --- , Member (Modules address value) effects --- , Member (State (Heap address address value)) effects +-- evalRequire :: ( AbstractValue term address value m +-- , Member (Allocator address) sig +-- , Member (Deref value) sig +-- , Member (Env address) sig +-- , Member (Modules address value) sig +-- , Member (State (Heap address address value)) sig -- , Ord address +-- , Carrier sig m -- ) -- => M.ModulePath -- -> Name --- -> Evaluator address value effects value +-- -> Evaluator term address value m value -- evalRequire modulePath alias = letrec' alias $ \addr -> -- unit <$ makeNamespace alias addr Nothing (bindAll . fst . snd =<< require modulePath) diff --git a/src/Language/TypeScript/Syntax/JSX.hs b/src/Language/TypeScript/Syntax/JSX.hs index 3d7bbc855..395fb5f0a 100644 --- a/src/Language/TypeScript/Syntax/JSX.hs +++ b/src/Language/TypeScript/Syntax/JSX.hs @@ -12,7 +12,7 @@ import Data.JSON.Fields import Diffing.Algorithm data JsxElement a = JsxElement { jsxOpeningElement :: !a, jsxElements :: ![a], jsxClosingElement :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 JsxElement where liftEq = genericLiftEq instance Ord1 JsxElement where liftCompare = genericLiftCompare @@ -20,7 +20,7 @@ instance Show1 JsxElement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JsxElement newtype JsxText a = JsxText { contents :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 JsxText where liftEq = genericLiftEq instance Ord1 JsxText where liftCompare = genericLiftCompare @@ -28,7 +28,7 @@ instance Show1 JsxText where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JsxText newtype JsxExpression a = JsxExpression { jsxExpression :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 JsxExpression where liftEq = genericLiftEq instance Ord1 JsxExpression where liftCompare = genericLiftCompare @@ -36,7 +36,7 @@ instance Show1 JsxExpression where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JsxExpression data JsxOpeningElement a = JsxOpeningElement { jsxOpeningElementIdentifier :: !a, jsxAttributes :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 JsxOpeningElement where liftEq = genericLiftEq instance Ord1 JsxOpeningElement where liftCompare = genericLiftCompare @@ -44,7 +44,7 @@ instance Show1 JsxOpeningElement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JsxOpeningElement newtype JsxClosingElement a = JsxClosingElement { jsxClosingElementIdentifier :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 JsxClosingElement where liftEq = genericLiftEq instance Ord1 JsxClosingElement where liftCompare = genericLiftCompare @@ -52,7 +52,7 @@ instance Show1 JsxClosingElement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JsxClosingElement data JsxSelfClosingElement a = JsxSelfClosingElement { jsxSelfClosingElementIdentifier :: !a, jsxSelfClosingElementAttributes :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 JsxSelfClosingElement where liftEq = genericLiftEq instance Ord1 JsxSelfClosingElement where liftCompare = genericLiftCompare @@ -60,7 +60,7 @@ instance Show1 JsxSelfClosingElement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JsxSelfClosingElement data JsxAttribute a = JsxAttribute { jsxAttributeTarget :: !a, jsxAttributeValue :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 JsxAttribute where liftEq = genericLiftEq instance Ord1 JsxAttribute where liftCompare = genericLiftCompare @@ -68,7 +68,7 @@ instance Show1 JsxAttribute where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JsxAttribute newtype ImplementsClause a = ImplementsClause { implementsClauseTypes :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ImplementsClause where liftEq = genericLiftEq instance Ord1 ImplementsClause where liftCompare = genericLiftCompare @@ -76,7 +76,7 @@ instance Show1 ImplementsClause where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ImplementsClause data OptionalParameter a = OptionalParameter { optionalParameterContext :: ![a], optionalParameterSubject :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 OptionalParameter where liftEq = genericLiftEq instance Ord1 OptionalParameter where liftCompare = genericLiftCompare @@ -84,7 +84,7 @@ instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec instance Evaluatable OptionalParameter data RequiredParameter a = RequiredParameter { requiredParameterContext :: ![a], requiredParameterSubject :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 RequiredParameter where liftEq = genericLiftEq instance Ord1 RequiredParameter where liftCompare = genericLiftCompare @@ -92,7 +92,7 @@ instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec instance Evaluatable RequiredParameter data RestParameter a = RestParameter { restParameterContext :: ![a], restParameterSubject :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 RestParameter where liftEq = genericLiftEq instance Ord1 RestParameter where liftCompare = genericLiftCompare @@ -100,7 +100,7 @@ instance Show1 RestParameter where liftShowsPrec = genericLiftShowsPrec instance Evaluatable RestParameter newtype JsxFragment a = JsxFragment { terms :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 JsxFragment where liftEq = genericLiftEq instance Ord1 JsxFragment where liftCompare = genericLiftCompare @@ -108,7 +108,7 @@ instance Show1 JsxFragment where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JsxFragment data JsxNamespaceName a = JsxNamespaceName { left :: a, right :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 JsxNamespaceName where liftEq = genericLiftEq instance Ord1 JsxNamespaceName where liftCompare = genericLiftCompare diff --git a/src/Language/TypeScript/Syntax/JavaScript.hs b/src/Language/TypeScript/Syntax/JavaScript.hs index 8e6aba2dc..a6259b1fb 100644 --- a/src/Language/TypeScript/Syntax/JavaScript.hs +++ b/src/Language/TypeScript/Syntax/JavaScript.hs @@ -15,17 +15,19 @@ import qualified Data.Abstract.ScopeGraph as ScopeGraph import qualified Data.Map.Strict as Map data JavaScriptRequire a = JavaScriptRequire { javascriptRequireIden :: !a, javascriptRequireFrom :: ImportPath } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 JavaScriptRequire where liftEq = genericLiftEq instance Ord1 JavaScriptRequire where liftCompare = genericLiftCompare instance Show1 JavaScriptRequire where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JavaScriptRequire where - eval (JavaScriptRequire aliasTerm importPath) = do + eval _ (JavaScriptRequire aliasTerm importPath) = do modulePath <- resolveWithNodejsStrategy importPath javascriptExtensions (scopeGraph, value) <- require modulePath bindAll scopeGraph + -- alias <- maybeM (throwEvalError NoNameError) (declaredName aliasTerm) + -- rvalBox =<< evalRequire modulePath alias case declaredName (subterm aliasTerm) of Just alias -> do span <- get @Span @@ -37,7 +39,7 @@ instance Evaluatable JavaScriptRequire where rvalBox unit data Debugger a = Debugger - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Debugger where liftEq = genericLiftEq instance Ord1 Debugger where liftCompare = genericLiftCompare @@ -45,7 +47,7 @@ instance Show1 Debugger where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Debugger data Super a = Super - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Super where liftEq = genericLiftEq instance Ord1 Super where liftCompare = genericLiftCompare @@ -53,7 +55,7 @@ instance Show1 Super where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Super data Undefined a = Undefined - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Undefined where liftEq = genericLiftEq instance Ord1 Undefined where liftCompare = genericLiftCompare @@ -61,7 +63,7 @@ instance Show1 Undefined where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Undefined data With a = With { withExpression :: !a, withBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 With where liftEq = genericLiftEq instance Ord1 With where liftCompare = genericLiftCompare diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index 813687161..c0be282c3 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields, TupleSections #-} +{-# LANGUAGE DeriveAnyClass, DerivingStrategies, DuplicateRecordFields, TupleSections #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.TypeScript.Syntax.TypeScript where @@ -19,7 +19,7 @@ import Data.Semigroup.App import Data.Semigroup.Foldable (foldMap1) data Import a = Import { importSymbols :: ![Alias], importFrom :: ImportPath } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Import where liftEq = genericLiftEq instance Ord1 Import where liftCompare = genericLiftCompare @@ -27,7 +27,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec -- http://www.typescriptlang.org/docs/handbook/module-resolution.html instance Evaluatable Import where - eval (Import symbols importPath) = do + eval _ (Import symbols importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions (scopeGraph, value) <- require modulePath bindAll scopeGraph @@ -42,15 +42,17 @@ instance Evaluatable Import where rvalBox unit data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare instance Show1 QualifiedAliasedImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedAliasedImport where - eval (QualifiedAliasedImport aliasTerm importPath) = do + eval _ (QualifiedAliasedImport aliasTerm importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions + -- alias <- maybeM (throwEvalError NoNameError) (declaredName aliasTerm) + -- rvalBox =<< evalRequire modulePath alias alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm)) span <- get @Span (scopeGraph, value) <- require modulePath @@ -59,14 +61,14 @@ instance Evaluatable QualifiedAliasedImport where rvalBox unit newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 SideEffectImport where liftEq = genericLiftEq instance Ord1 SideEffectImport where liftCompare = genericLiftCompare instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable SideEffectImport where - eval (SideEffectImport importPath) = do + eval _ (SideEffectImport importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions void $ require modulePath rvalBox unit @@ -74,13 +76,17 @@ instance Evaluatable SideEffectImport where -- | Qualified Export declarations newtype QualifiedExport a = QualifiedExport { qualifiedExportSymbols :: [Alias] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 QualifiedExport where liftEq = genericLiftEq instance Ord1 QualifiedExport where liftCompare = genericLiftCompare instance Show1 QualifiedExport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedExport where + -- eval _ (QualifiedExport exportSymbols) = do + -- -- Insert the aliases with no addresses. + -- for_ exportSymbols $ \Alias{..} -> + -- export aliasValue aliasName Nothing eval (QualifiedExport exportSymbols) = do -- Create a Lexical edge from the qualifed export's scope to the current scope. currentScopeAddress <- currentScope @@ -102,21 +108,21 @@ instance Evaluatable QualifiedExport where rvalBox unit data Alias = Alias { aliasValue :: Name, aliasName :: Name } - deriving (Eq, Generic, Hashable, Ord, Show, Message, Named, ToJSON) + deriving (Eq, Generic, Hashable, Ord, Show, Message, Named, ToJSON, NFData) toTuple :: Alias -> (Name, Name) toTuple Alias{..} = (aliasValue, aliasName) -- | Qualified Export declarations that export from another module. data QualifiedExportFrom a = QualifiedExportFrom { qualifiedExportFrom :: ImportPath, qualifiedExportFromSymbols :: ![Alias]} - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 QualifiedExportFrom where liftEq = genericLiftEq instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedExportFrom where - eval (QualifiedExportFrom importPath exportSymbols) = do + eval _ (QualifiedExportFrom importPath exportSymbols) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions scopeGraph <- fst <$> require modulePath -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. @@ -129,17 +135,17 @@ instance Evaluatable QualifiedExportFrom where rvalBox unit newtype DefaultExport a = DefaultExport { defaultExport :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 DefaultExport where liftEq = genericLiftEq instance Ord1 DefaultExport where liftCompare = genericLiftCompare instance Show1 DefaultExport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable DefaultExport where - eval (DefaultExport term) = do + eval eval (DefaultExport term) = do case declaredName term of - Just name -> pure () - -- addr <- subtermAddress term + Just name -> undefined -- do + -- addr <- eval term >>= address -- export name name Nothing -- bind name addr Nothing -> throwEvalError DefaultExportError @@ -148,7 +154,7 @@ instance Evaluatable DefaultExport where -- | Lookup type for a type-level key in a typescript map. data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 LookupType where liftEq = genericLiftEq instance Ord1 LookupType where liftCompare = genericLiftCompare @@ -157,7 +163,7 @@ instance Evaluatable LookupType -- | ShorthandPropertyIdentifier used in object patterns such as var baz = { foo } to mean var baz = { foo: foo } newtype ShorthandPropertyIdentifier a = ShorthandPropertyIdentifier { contents :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ShorthandPropertyIdentifier where liftEq = genericLiftEq instance Ord1 ShorthandPropertyIdentifier where liftCompare = genericLiftCompare @@ -165,7 +171,7 @@ instance Show1 ShorthandPropertyIdentifier where liftShowsPrec = genericLiftShow instance Evaluatable ShorthandPropertyIdentifier data Union a = Union { unionLeft :: !a, unionRight :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Language.TypeScript.Syntax.TypeScript.Union where liftEq = genericLiftEq instance Ord1 Language.TypeScript.Syntax.TypeScript.Union where liftCompare = genericLiftCompare @@ -173,7 +179,7 @@ instance Show1 Language.TypeScript.Syntax.TypeScript.Union where liftShowsPrec = instance Evaluatable Language.TypeScript.Syntax.TypeScript.Union data Intersection a = Intersection { intersectionLeft :: !a, intersectionRight :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Intersection where liftEq = genericLiftEq instance Ord1 Intersection where liftCompare = genericLiftCompare @@ -181,7 +187,7 @@ instance Show1 Intersection where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Intersection data FunctionType a = FunctionType { functionTypeParameters :: !a, functionFormalParameters :: ![a], functionType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 FunctionType where liftEq = genericLiftEq instance Ord1 FunctionType where liftCompare = genericLiftCompare @@ -189,7 +195,7 @@ instance Show1 FunctionType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable FunctionType data AmbientFunction a = AmbientFunction { ambientFunctionContext :: ![a], ambientFunctionIdentifier :: !a, ambientFunctionParameters :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 AmbientFunction where liftEq = genericLiftEq instance Ord1 AmbientFunction where liftCompare = genericLiftCompare @@ -197,7 +203,7 @@ instance Show1 AmbientFunction where liftShowsPrec = genericLiftShowsPrec instance Evaluatable AmbientFunction data ImportRequireClause a = ImportRequireClause { importRequireIdentifier :: !a, importRequireSubject :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ImportRequireClause where liftEq = genericLiftEq instance Ord1 ImportRequireClause where liftCompare = genericLiftCompare @@ -205,7 +211,7 @@ instance Show1 ImportRequireClause where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ImportRequireClause newtype ImportClause a = ImportClause { importClauseElements :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ImportClause where liftEq = genericLiftEq instance Ord1 ImportClause where liftCompare = genericLiftCompare @@ -213,7 +219,7 @@ instance Show1 ImportClause where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ImportClause newtype Tuple a = Tuple { tupleElements :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Tuple where liftEq = genericLiftEq instance Ord1 Tuple where liftCompare = genericLiftCompare @@ -223,7 +229,7 @@ instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Tuple data Constructor a = Constructor { constructorTypeParameters :: !a, constructorFormalParameters :: ![a], constructorType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Language.TypeScript.Syntax.TypeScript.Constructor where liftEq = genericLiftEq instance Ord1 Language.TypeScript.Syntax.TypeScript.Constructor where liftCompare = genericLiftCompare @@ -231,7 +237,7 @@ instance Show1 Language.TypeScript.Syntax.TypeScript.Constructor where liftShows instance Evaluatable Language.TypeScript.Syntax.TypeScript.Constructor data TypeParameter a = TypeParameter { typeParameter :: !a, typeParameterConstraint :: !a, typeParameterDefaultType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 TypeParameter where liftEq = genericLiftEq instance Ord1 TypeParameter where liftCompare = genericLiftCompare @@ -239,7 +245,7 @@ instance Show1 TypeParameter where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeParameter data TypeAssertion a = TypeAssertion { typeAssertionParameters :: !a, typeAssertionExpression :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 TypeAssertion where liftEq = genericLiftEq instance Ord1 TypeAssertion where liftCompare = genericLiftCompare @@ -247,7 +253,7 @@ instance Show1 TypeAssertion where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeAssertion newtype Annotation a = Annotation { annotationType :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Annotation where liftEq = genericLiftEq instance Ord1 Annotation where liftCompare = genericLiftCompare @@ -255,7 +261,7 @@ instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Annotation newtype Decorator a = Decorator { decoratorTerm :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Decorator where liftEq = genericLiftEq instance Ord1 Decorator where liftCompare = genericLiftCompare @@ -263,7 +269,7 @@ instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Decorator newtype ComputedPropertyName a = ComputedPropertyName { propertyName :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ComputedPropertyName where liftEq = genericLiftEq instance Ord1 ComputedPropertyName where liftCompare = genericLiftCompare @@ -271,7 +277,7 @@ instance Show1 ComputedPropertyName where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ComputedPropertyName newtype Constraint a = Constraint { constraintType :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Constraint where liftEq = genericLiftEq instance Ord1 Constraint where liftCompare = genericLiftCompare @@ -279,7 +285,7 @@ instance Show1 Constraint where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Constraint newtype DefaultType a = DefaultType { defaultType :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 DefaultType where liftEq = genericLiftEq instance Ord1 DefaultType where liftCompare = genericLiftCompare @@ -287,7 +293,7 @@ instance Show1 DefaultType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable DefaultType newtype ParenthesizedType a = ParenthesizedType { parenthesizedType :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ParenthesizedType where liftEq = genericLiftEq instance Ord1 ParenthesizedType where liftCompare = genericLiftCompare @@ -295,7 +301,7 @@ instance Show1 ParenthesizedType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ParenthesizedType newtype PredefinedType a = PredefinedType { predefinedType :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 PredefinedType where liftEq = genericLiftEq instance Ord1 PredefinedType where liftCompare = genericLiftCompare @@ -304,7 +310,7 @@ instance Show1 PredefinedType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable PredefinedType newtype TypeIdentifier a = TypeIdentifier { contents :: T.Text } - deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Declarations1 TypeIdentifier where liftDeclaredName _ (TypeIdentifier identifier) = Just (Evaluatable.name identifier) @@ -314,13 +320,13 @@ instance Ord1 TypeIdentifier where liftCompare = genericLiftCompare instance Show1 TypeIdentifier where liftShowsPrec = genericLiftShowsPrec -- TODO: TypeIdentifier shouldn't evaluate to an address in the heap? instance Evaluatable TypeIdentifier where - eval TypeIdentifier{..} = do + eval _ TypeIdentifier{..} = do -- Add a reference to the type identifier in the current scope. reference (Reference (Evaluatable.name contents)) (Declaration (Evaluatable.name contents)) rvalBox unit data NestedIdentifier a = NestedIdentifier { left :: !a, right :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 NestedIdentifier where liftEq = genericLiftEq instance Ord1 NestedIdentifier where liftCompare = genericLiftCompare @@ -328,7 +334,7 @@ instance Show1 NestedIdentifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NestedIdentifier data NestedTypeIdentifier a = NestedTypeIdentifier { left :: !a, right :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 NestedTypeIdentifier where liftEq = genericLiftEq instance Ord1 NestedTypeIdentifier where liftCompare = genericLiftCompare @@ -336,7 +342,7 @@ instance Show1 NestedTypeIdentifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NestedTypeIdentifier data GenericType a = GenericType { genericTypeIdentifier :: !a, genericTypeArguments :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 GenericType where liftEq = genericLiftEq instance Ord1 GenericType where liftCompare = genericLiftCompare @@ -344,7 +350,7 @@ instance Show1 GenericType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable GenericType data TypePredicate a = TypePredicate { typePredicateIdentifier :: !a, typePredicateType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 TypePredicate where liftEq = genericLiftEq instance Ord1 TypePredicate where liftCompare = genericLiftCompare @@ -352,7 +358,7 @@ instance Show1 TypePredicate where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypePredicate newtype ObjectType a = ObjectType { objectTypeElements :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ObjectType where liftEq = genericLiftEq instance Ord1 ObjectType where liftCompare = genericLiftCompare @@ -360,17 +366,17 @@ instance Show1 ObjectType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ObjectType newtype AmbientDeclaration a = AmbientDeclaration { ambientDeclarationBody :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 AmbientDeclaration where liftEq = genericLiftEq instance Ord1 AmbientDeclaration where liftCompare = genericLiftCompare instance Show1 AmbientDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable AmbientDeclaration where - eval (AmbientDeclaration body) = subtermRef body + eval eval (AmbientDeclaration body) = eval body data EnumDeclaration a = EnumDeclaration { enumDeclarationIdentifier :: !a, enumDeclarationBody :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 EnumDeclaration where liftEq = genericLiftEq instance Ord1 EnumDeclaration where liftCompare = genericLiftCompare @@ -381,7 +387,7 @@ instance Declarations a => Declarations (EnumDeclaration a) where declaredName EnumDeclaration{..} = declaredName enumDeclarationIdentifier newtype ExtendsClause a = ExtendsClause { extendsClauses :: [a] } - deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Declarations1 ExtendsClause where liftDeclaredName _ (ExtendsClause []) = Nothing @@ -392,13 +398,13 @@ instance Ord1 ExtendsClause where liftCompare = genericLiftCompare instance Show1 ExtendsClause where liftShowsPrec = genericLiftShowsPrec -- TODO: ExtendsClause shouldn't evaluate to an address in the heap? instance Evaluatable ExtendsClause where - eval ExtendsClause{..} = do + eval eval ExtendsClause{..} = do -- Evaluate subterms - traverse_ subtermRef extendsClauses + traverse_ eval extendsClauses rvalBox unit newtype ArrayType a = ArrayType { arrayType :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ArrayType where liftEq = genericLiftEq instance Ord1 ArrayType where liftCompare = genericLiftCompare @@ -406,7 +412,7 @@ instance Show1 ArrayType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ArrayType newtype FlowMaybeType a = FlowMaybeType { flowMaybeType :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 FlowMaybeType where liftEq = genericLiftEq instance Ord1 FlowMaybeType where liftCompare = genericLiftCompare @@ -414,7 +420,7 @@ instance Show1 FlowMaybeType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable FlowMaybeType newtype TypeQuery a = TypeQuery { typeQuerySubject :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 TypeQuery where liftEq = genericLiftEq instance Ord1 TypeQuery where liftCompare = genericLiftCompare @@ -422,7 +428,7 @@ instance Show1 TypeQuery where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeQuery newtype IndexTypeQuery a = IndexTypeQuery { indexTypeQuerySubject :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 IndexTypeQuery where liftEq = genericLiftEq instance Ord1 IndexTypeQuery where liftCompare = genericLiftCompare @@ -430,7 +436,7 @@ instance Show1 IndexTypeQuery where liftShowsPrec = genericLiftShowsPrec instance Evaluatable IndexTypeQuery newtype TypeArguments a = TypeArguments { typeArguments :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 TypeArguments where liftEq = genericLiftEq instance Ord1 TypeArguments where liftCompare = genericLiftCompare @@ -438,7 +444,7 @@ instance Show1 TypeArguments where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeArguments newtype ThisType a = ThisType { contents :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ThisType where liftEq = genericLiftEq instance Ord1 ThisType where liftCompare = genericLiftCompare @@ -446,7 +452,7 @@ instance Show1 ThisType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ThisType newtype ExistentialType a = ExistentialType { contents :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ExistentialType where liftEq = genericLiftEq instance Ord1 ExistentialType where liftCompare = genericLiftCompare @@ -454,7 +460,7 @@ instance Show1 ExistentialType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ExistentialType newtype LiteralType a = LiteralType { literalTypeSubject :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 LiteralType where liftEq = genericLiftEq instance Ord1 LiteralType where liftCompare = genericLiftCompare @@ -462,7 +468,7 @@ instance Show1 LiteralType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable LiteralType data PropertySignature a = PropertySignature { modifiers :: ![a], propertySignaturePropertyName :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 PropertySignature where liftEq = genericLiftEq instance Ord1 PropertySignature where liftCompare = genericLiftCompare @@ -470,7 +476,7 @@ instance Show1 PropertySignature where liftShowsPrec = genericLiftShowsPrec instance Evaluatable PropertySignature data CallSignature a = CallSignature { callSignatureTypeParameters :: !a, callSignatureParameters :: ![a], callSignatureType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 CallSignature where liftEq = genericLiftEq instance Ord1 CallSignature where liftCompare = genericLiftCompare @@ -479,7 +485,7 @@ instance Evaluatable CallSignature -- | Todo: Move type params and type to context data ConstructSignature a = ConstructSignature { constructSignatureTypeParameters :: !a, constructSignatureParameters :: ![a], constructSignatureType :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ConstructSignature where liftEq = genericLiftEq instance Ord1 ConstructSignature where liftCompare = genericLiftCompare @@ -487,7 +493,7 @@ instance Show1 ConstructSignature where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ConstructSignature data IndexSignature a = IndexSignature { indexSignatureSubject :: a, indexSignatureType :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 IndexSignature where liftEq = genericLiftEq instance Ord1 IndexSignature where liftCompare = genericLiftCompare @@ -495,7 +501,7 @@ instance Show1 IndexSignature where liftShowsPrec = genericLiftShowsPrec instance Evaluatable IndexSignature data AbstractMethodSignature a = AbstractMethodSignature { abstractMethodSignatureContext :: ![a], abstractMethodSignatureName :: !a, abstractMethodSignatureParameters :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 AbstractMethodSignature where liftEq = genericLiftEq instance Ord1 AbstractMethodSignature where liftCompare = genericLiftCompare @@ -503,7 +509,7 @@ instance Show1 AbstractMethodSignature where liftShowsPrec = genericLiftShowsPre instance Evaluatable AbstractMethodSignature data ForOf a = ForOf { forOfBinding :: !a, forOfSubject :: !a, forOfBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ForOf where liftEq = genericLiftEq instance Ord1 ForOf where liftCompare = genericLiftCompare @@ -511,7 +517,7 @@ instance Show1 ForOf where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ForOf data LabeledStatement a = LabeledStatement { labeledStatementIdentifier :: !a, labeledStatementSubject :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 LabeledStatement where liftEq = genericLiftEq instance Ord1 LabeledStatement where liftCompare = genericLiftCompare @@ -519,7 +525,7 @@ instance Show1 LabeledStatement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable LabeledStatement newtype Update a = Update { updateSubject :: a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Update where liftEq = genericLiftEq instance Ord1 Update where liftCompare = genericLiftCompare @@ -527,40 +533,38 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Update data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 Module where liftEq = genericLiftEq instance Ord1 Module where liftCompare = genericLiftCompare instance Show1 Module where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Module where - eval (Module iden xs) = do - currentScopeAddress <- currentScope - let edges = Map.singleton Lexical [ currentScopeAddress ] - scope <- newScope edges - withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs) + eval eval (Module iden xs) = undefined -- do + -- name <- maybeM (throwEvalError NoNameError) (declaredName iden) + -- rvalBox =<< letrec' name (\addr -> + -- makeNamespace name addr Nothing (traverse_ eval xs)) data InternalModule a = InternalModule { internalModuleIdentifier :: !a, internalModuleStatements :: ![a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 InternalModule where liftEq = genericLiftEq instance Ord1 InternalModule where liftCompare = genericLiftCompare instance Show1 InternalModule where liftShowsPrec = genericLiftShowsPrec instance Evaluatable InternalModule where - eval (InternalModule iden xs) = do - currentScopeAddress <- currentScope - let edges = Map.singleton Lexical [ currentScopeAddress ] - scope <- newScope edges - withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs) + eval eval (InternalModule iden xs) = undefined -- do + -- name <- maybeM (throwEvalError NoNameError) (declaredName iden) + -- rvalBox =<< letrec' name (\addr -> + -- makeNamespace name addr Nothing (traverse_ eval xs)) instance Declarations a => Declarations (InternalModule a) where declaredName InternalModule{..} = declaredName internalModuleIdentifier data ImportAlias a = ImportAlias { importAliasSubject :: !a, importAlias :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ImportAlias where liftEq = genericLiftEq instance Ord1 ImportAlias where liftCompare = genericLiftCompare @@ -568,7 +572,7 @@ instance Show1 ImportAlias where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ImportAlias data ClassHeritage a = ClassHeritage { classHeritageExtendsClause :: !a, implementsClause :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 ClassHeritage where liftEq = genericLiftEq instance Ord1 ClassHeritage where liftCompare = genericLiftCompare @@ -576,7 +580,7 @@ instance Show1 ClassHeritage where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ClassHeritage data AbstractClass a = AbstractClass { abstractClassIdentifier :: !a, abstractClassTypeParameters :: !a, classHeritage :: ![a], classBody :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, NFData1, Named1, Ord, Show, ToJSONFields1, Traversable) instance Eq1 AbstractClass where liftEq = genericLiftEq instance Ord1 AbstractClass where liftCompare = genericLiftCompare @@ -585,26 +589,36 @@ instance Declarations a => Declarations (AbstractClass a) where declaredName AbstractClass{..} = declaredName abstractClassIdentifier instance Evaluatable AbstractClass where - eval AbstractClass{..} = do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm abstractClassIdentifier)) - span <- ask @Span - -- Run the action within the class's scope. - currentScopeAddress <- currentScope + eval eval AbstractClass{..} = undefined -- do + -- name <- maybeM (throwEvalError NoNameError) (declaredName abstractClassIdentifier) + -- supers <- traverse (eval >=> address) classHeritage + -- (v, addr) <- letrec name $ do + -- void $ eval classBody + -- classBinds <- Env.head <$> getEnv + -- klass name supers classBinds + -- rvalBox =<< (v <$ bind name addr) - supers <- for classHeritage $ \superclass -> do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm superclass)) - scope <- associatedScope (Declaration name) - (scope,) <$> subtermValue superclass - - let imports = (ScopeGraph.Import, ) <$> (pure . catMaybes $ fst <$> supers) - current = pure (Lexical, [ currentScopeAddress ]) - edges = Map.fromList (imports <> current) - childScope <- newScope edges - declare (Declaration name) span (Just childScope) - - frame <- newFrame childScope mempty -- TODO: Instantiate frames for superclasses - withScopeAndFrame frame $ do - void $ subtermValue classBody - klass (Declaration name) (snd <$> supers) frame - - rvalBox unit + -- Previous ScopeGraph approach: + -- eval AbstractClass{..} = do + -- name <- maybeM (throwEvalError NoNameError) (declaredName (subterm abstractClassIdentifier)) + -- span <- ask @Span + -- -- Run the action within the class's scope. + -- currentScopeAddress <- currentScope + -- + -- supers <- for classHeritage $ \superclass -> do + -- name <- maybeM (throwEvalError NoNameError) (declaredName (subterm superclass)) + -- scope <- associatedScope (Declaration name) + -- (scope,) <$> subtermValue superclass + -- + -- let imports = (ScopeGraph.Import, ) <$> (pure . catMaybes $ fst <$> supers) + -- current = pure (Lexical, [ currentScopeAddress ]) + -- edges = Map.fromList (imports <> current) + -- childScope <- newScope edges + -- declare (Declaration name) span (Just childScope) + -- + -- frame <- newFrame childScope mempty -- TODO: Instantiate frames for superclasses + -- withScopeAndFrame frame $ do + -- void $ subtermValue classBody + -- klass (Declaration name) (snd <$> supers) frame + -- + -- rvalBox unit diff --git a/src/Matching/Core.hs b/src/Matching/Core.hs index c0b08e747..8fb5b31af 100644 --- a/src/Matching/Core.hs +++ b/src/Matching/Core.hs @@ -8,7 +8,7 @@ module Matching.Core import Prologue -import Control.Abstract.Matching +import Control.Matching import qualified Data.Syntax.Literal as Literal import Data.Term diff --git a/src/Parsing/CMark.hs b/src/Parsing/CMark.hs index 58b40f530..cac437028 100644 --- a/src/Parsing/CMark.hs +++ b/src/Parsing/CMark.hs @@ -9,6 +9,7 @@ import CMarkGFM import qualified Data.AST as A import Data.Ix import Data.Range +import Data.Location import Data.Span import Data.Source import Data.Term @@ -55,7 +56,7 @@ cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkT toTerm within withinSpan (Node position t children) = let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position span = maybe withinSpan toSpan position - in termIn (A.Node (toGrammar t) range span) (In t (toTerm range span <$> children)) + in termIn (A.Node (toGrammar t) (Location range span)) (In t (toTerm range span <$> children)) toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn))) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index b394971f8..4c93043c8 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -31,12 +31,11 @@ module Parsing.Parser import Assigning.Assignment import qualified Assigning.Assignment.Deterministic as Deterministic import qualified CMarkGFM -import Data.Abstract.Evaluatable (HasPostlude, HasPrelude) +import Data.Abstract.Evaluatable (HasPrelude) import Data.AST import Data.Graph.ControlFlowVertex (VertexDeclaration') import Data.Kind import Data.Language -import Data.Record import Data.Sum import qualified Data.Syntax as Syntax import Data.Term @@ -74,7 +73,6 @@ data SomeAnalysisParser typeclasses ann where , Apply (VertexDeclaration' (Sum fs)) fs , Element Syntax.Identifier fs , HasPrelude lang - , HasPostlude lang ) => Parser (Term (Sum fs) ann) -> Proxy lang @@ -89,9 +87,9 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax , ApplyAll' typeclasses TypeScript.Syntax , ApplyAll' typeclasses Haskell.Syntax ) - => proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. - -> Language -- ^ The 'Language' to select. - -> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced. + => proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. + -> Language -- ^ The 'Language' to select. + -> SomeAnalysisParser typeclasses Location -- ^ A 'SomeAnalysisParser' abstracting the syntax type to be produced. someAnalysisParser _ Go = SomeAnalysisParser goParser (Proxy :: Proxy 'Go) someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser (Proxy :: Proxy 'Haskell) someAnalysisParser _ Java = SomeAnalysisParser javaParser (Proxy :: Proxy 'Java) @@ -109,13 +107,13 @@ data Parser term where ASTParser :: (Bounded grammar, Enum grammar, Show grammar) => Ptr TS.Language -> Parser (AST [] grammar) -- | A parser producing an Ć  la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. AssignmentParser :: (Enum grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq1 ast, Apply Foldable fs, Apply Functor fs, Foldable ast, Functor ast) - => Parser (Term ast (Node grammar)) -- ^ A parser producing AST. - -> Assignment ast grammar (Term (Sum fs) (Record Location)) -- ^ An assignment from AST onto 'Term's. - -> Parser (Term (Sum fs) (Record Location)) -- ^ A parser producing 'Term's. + => Parser (Term ast (Node grammar)) -- ^ A parser producing AST. + -> Assignment ast grammar (Term (Sum fs) Location) -- ^ An assignment from AST onto 'Term's. + -> Parser (Term (Sum fs) Location) -- ^ A parser producing 'Term's. DeterministicParser :: (Enum grammar, Ord grammar, Show grammar, Element Syntax.Error syntaxes, Apply Foldable syntaxes, Apply Functor syntaxes) => Parser (AST [] grammar) - -> Deterministic.Assignment grammar (Term (Sum syntaxes) (Record Location)) - -> Parser (Term (Sum syntaxes) (Record Location)) + -> Deterministic.Assignment grammar (Term (Sum syntaxes) Location) + -> Parser (Term (Sum syntaxes) Location) -- | A parser for 'Markdown' using cmark. MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar)) -- | An abstraction over parsers when we donā€™t know the details of the term type. @@ -141,8 +139,8 @@ someParser :: ( ApplyAll typeclasses (Sum Go.Syntax) , ApplyAll typeclasses (Sum TypeScript.Syntax) , ApplyAll typeclasses (Sum PHP.Syntax) ) - => Language -- ^ The 'Language' to select. - -> Maybe (Parser (SomeTerm typeclasses (Record Location))) -- ^ A 'SomeParser' abstracting the syntax type to be produced. + => Language -- ^ The 'Language' to select. + -> Maybe (Parser (SomeTerm typeclasses Location)) -- ^ A 'SomeParser' abstracting the syntax type to be produced. someParser Go = Just (SomeParser goParser) someParser Java = Just (SomeParser javaParser) someParser JavaScript = Just (SomeParser typescriptParser) diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index db842afb2..256b91b83 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -8,10 +8,9 @@ import Prologue hiding (bracket) import Control.Concurrent.Async import qualified Control.Exception as Exc (bracket) -import Control.Monad.Effect -import Control.Monad.Effect.Exception -import Control.Monad.Effect.Trace -import Control.Monad.IO.Class +import Control.Effect +import Control.Effect.Resource +import Control.Effect.Trace import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Foreign import Foreign.C.Types (CBool (..)) @@ -20,7 +19,7 @@ import Foreign.Marshal.Array (allocaArray) import Data.AST (AST, Node (Node)) import Data.Blob import Data.Duration -import Data.Range +import Data.Location import Data.Source import Data.Span import Data.Term @@ -57,8 +56,19 @@ runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ -- | Parse 'Source' with the given 'TS.Language' and return its AST. -- Returns Nothing if the operation timed out. -parseToAST :: (Bounded grammar, Enum grammar, Member (Lift IO) effects, Member Timeout effects, Member Trace effects, PureEffects effects) => Duration -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar)) -parseToAST parseTimeout language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do +parseToAST :: ( Bounded grammar + , Carrier sig m + , Enum grammar + , Member Resource sig + , Member Timeout sig + , Member Trace sig + , MonadIO m + ) + => Duration + -> Ptr TS.Language + -> Blob + -> m (Maybe (AST [] grammar)) +parseToAST parseTimeout language Blob{..} = bracket (liftIO TS.ts_parser_new) (liftIO . TS.ts_parser_delete) $ \ parser -> do liftIO $ do TS.ts_parser_halt_on_error parser (CBool 1) TS.ts_parser_set_language parser language @@ -82,9 +92,9 @@ toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base toAST node@TS.Node{..} = do let count = fromIntegral nodeChildCount children <- allocaArray count $ \ childNodesPtr -> do - _ <- with nodeTSNode (\ nodePtr -> TS.ts_node_copy_child_nodes nodePtr childNodesPtr (fromIntegral count)) + _ <- with nodeTSNode (`TS.ts_node_copy_child_nodes` childNodesPtr) peekArray count childNodesPtr - pure $! In (Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (nodeRange node) (nodeSpan node)) children + pure $! In (Node (toEnum (min (fromIntegral nodeSymbol) (fromEnum (maxBound :: grammar)))) (Location (nodeRange node) (nodeSpan node))) children anaM :: (Corecursive t, Monad m, Traversable (Base t)) => (a -> m (Base t a)) -> a -> m t anaM g = a where a = pure . embed <=< traverse a <=< g diff --git a/src/Prologue.hs b/src/Prologue.hs index ef0092310..4f37a9185 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -8,6 +8,7 @@ module Prologue ) where +import Control.DeepSeq as X import Data.Bifunctor.Join as X import Data.Bits as X import Data.ByteString as X (ByteString) @@ -25,7 +26,6 @@ import Data.Set as X (Set) import Data.Sum as X (Sum, Element, Elements, (:<), (:<:), Apply (..), inject) import Data.Text as X (Text) import Data.These as X -import Data.Union as X import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, throwIO, throwTo) @@ -33,8 +33,8 @@ import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, thr import Control.Applicative as X import Control.Arrow as X ((&&&), (***)) import Control.Monad as X hiding (fail, return) -import Control.Monad.Except as X (MonadError (..)) import Control.Monad.Fail as X (MonadFail (..)) +import Control.Monad.IO.Class as X (MonadIO (..)) import Data.Algebra as X import Data.Bifoldable as X import Data.Bifunctor as X (Bifunctor (..)) @@ -54,7 +54,7 @@ import Data.Traversable as X import Data.Typeable as X (Typeable) -- Generics -import GHC.Generics as X hiding (moduleName) +import GHC.Generics as X (Generic, Generic1) import GHC.Stack as X -- | Fold a collection by mapping each element onto an 'Alternative' action. diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 1b835ab60..7a3c696fc 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -8,16 +8,14 @@ module Rendering.Graph import Algebra.Graph.Export.Dot import Analysis.ConstructorName -import Control.Monad.Effect -import Control.Monad.Effect.Fresh -import Control.Monad.Effect.Reader +import Control.Effect +import Control.Effect.Fresh +import Control.Effect.Reader import Data.Diff import Data.Graph import Data.Graph.TermVertex import Data.Graph.DiffVertex -import Data.Range -import Data.Span -import Data.Record +import Data.Location import Data.Patch import Data.String (IsString(..)) import Data.Term @@ -27,8 +25,11 @@ import Prologue renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex renderTreeGraph = simplify . runGraph . cata toTreeGraph -runGraph :: Eff '[Reader (Graph vertex), Fresh] (Graph vertex) -> Graph vertex -runGraph = run . runFresh 0 . runReader mempty +runGraph :: Eff (ReaderC (Graph vertex) + (Eff (FreshC + (Eff VoidC)))) (Graph vertex) + -> Graph vertex +runGraph = run . runFresh . runReader mempty -- | GraphViz styling for terms termStyle :: (IsString string, Monoid string) => String -> Style TermVertex string @@ -50,30 +51,30 @@ diffStyle name = (defaultStyle (fromString . show . diffVertexId)) vertexAttributes (DiffVertex _ (Merged MergedTerm{..})) = [ "label" := fromString mergedTermName ] class ToTreeGraph vertex t | t -> vertex where - toTreeGraph :: (Member Fresh effs, Member (Reader (Graph vertex)) effs) => t (Eff effs (Graph vertex)) -> Eff effs (Graph vertex) + toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m, Monad m) => t (m (Graph vertex)) -> m (Graph vertex) -instance (ConstructorName syntax, Foldable syntax, HasField fields Range, HasField fields Span) => - ToTreeGraph TermVertex (TermF syntax (Record fields)) where +instance (ConstructorName syntax, Foldable syntax) => + ToTreeGraph TermVertex (TermF syntax Location) where toTreeGraph = termAlgebra where termAlgebra :: ( ConstructorName syntax - , HasField fields Range - , HasField fields Span , Foldable syntax - , Member Fresh effs - , Member (Reader (Graph TermVertex)) effs + , Member Fresh sig + , Member (Reader (Graph TermVertex)) sig + , Carrier sig m + , Monad m ) - => TermF syntax (Record fields) (Eff effs (Graph TermVertex)) - -> Eff effs (Graph TermVertex) + => TermF syntax Location (m (Graph TermVertex)) + -> m (Graph TermVertex) termAlgebra (In ann syntax) = do i <- fresh parent <- ask - let root = vertex (TermVertex i (constructorName syntax) (TermAnnotation (getField ann) (getField ann))) + let root = vertex (TermVertex i (constructorName syntax) (TermAnnotation (locationByteRange ann) (locationSpan ann))) subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax pure (parent `connect` root `overlay` subGraph) -instance (ConstructorName syntax, Foldable syntax, HasField fields1 Range, HasField fields1 Span, HasField fields2 Range, HasField fields2 Span) => - ToTreeGraph DiffVertex (DiffF syntax (Record fields1) (Record fields2)) where +instance (ConstructorName syntax, Foldable syntax) => + ToTreeGraph DiffVertex (DiffF syntax Location Location) where toTreeGraph d = case d of Merge t@(In (a1, a2) syntax) -> diffAlgebra t (Merged (MergedTerm (constructorName syntax) (ann a1) (ann a2))) Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted (DeletedTerm (constructorName syntax) (ann a1))) @@ -87,12 +88,14 @@ instance (ConstructorName syntax, Foldable syntax, HasField fields1 Range, HasFi graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted a) <*> diffAlgebra t2 (Inserted b)) pure (parent `connect` replace `overlay` graph) where - ann a = TermAnnotation (getField a) (getField a) + ann a = TermAnnotation (locationByteRange a) (locationSpan a) diffAlgebra :: ( Foldable f - , Member Fresh effs - , Member (Reader (Graph DiffVertex)) effs - ) => f (Eff effs (Graph DiffVertex)) -> DiffVertexTerm -> Eff effs (Graph DiffVertex) + , Member Fresh sig + , Member (Reader (Graph DiffVertex)) sig + , Carrier sig m + , Monad m + ) => f (m (Graph DiffVertex)) -> DiffVertexTerm -> m (Graph DiffVertex) diffAlgebra syntax a = do i <- fresh parent <- ask diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index c564a302a..b8b34f474 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -61,6 +61,8 @@ data TermRenderer output where DOTTermRenderer :: TermRenderer (Graph TermVertex) -- | Render to a 'ByteString' formatted using the 'Show' instance. ShowTermRenderer :: TermRenderer Builder + -- | Render just to tracking timing metrics + QuietTermRenderer :: TermRenderer Builder deriving instance Eq (TermRenderer output) deriving instance Show (TermRenderer output) diff --git a/src/Rendering/Symbol.hs b/src/Rendering/Symbol.hs index b2668c55e..3406d8ce6 100644 --- a/src/Rendering/Symbol.hs +++ b/src/Rendering/Symbol.hs @@ -11,8 +11,7 @@ import Analysis.Declaration import Data.Aeson import Data.Blob import Data.Language (ensureLanguage) -import Data.Record -import Data.Span +import Data.Location import Data.List.Split (splitWhen) import Data.Term import qualified Data.Text as T @@ -20,25 +19,24 @@ import Rendering.TOC -- | Render a 'Term' to a list of symbols (See 'Symbol'). -renderToSymbols :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => SymbolFields -> Blob -> Term f (Record fields) -> [Value] +renderToSymbols :: (Foldable f, Functor f) => SymbolFields -> Blob -> Term f (Maybe Declaration) -> [Value] renderToSymbols fields Blob{..} term = [toJSON (termToC fields blobPath term)] where - termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => SymbolFields -> FilePath -> Term f (Record fields) -> File + termToC :: (Foldable f, Functor f) => SymbolFields -> FilePath -> Term f (Maybe Declaration) -> File termToC fields path = File (T.pack path) (T.pack (show blobLanguage)) . mapMaybe (symbolSummary fields path "unchanged") . termTableOfContentsBy declaration -- | Construct a 'Symbol' from a node annotation and a change type label. -symbolSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => SymbolFields -> FilePath -> T.Text -> Record fields -> Maybe Symbol -symbolSummary SymbolFields{..} path _ record = case getDeclaration record of - Just ErrorDeclaration{} -> Nothing - Just declaration -> Just Symbol +symbolSummary :: SymbolFields -> FilePath -> T.Text -> Declaration -> Maybe Symbol +symbolSummary SymbolFields{..} path _ record = case record of + ErrorDeclaration{} -> Nothing + declaration -> Just Symbol { symbolName = when symbolFieldsName (declarationIdentifier declaration) , symbolPath = when symbolFieldsPath (T.pack path) , symbolLang = join (when symbolFieldsLang (T.pack . show <$> ensureLanguage (declarationLanguage declaration))) , symbolKind = when symbolFieldsKind (toCategoryName declaration) , symbolLine = when symbolFieldsLine (declarationText declaration) - , symbolSpan = when symbolFieldsSpan (getField record) + , symbolSpan = when symbolFieldsSpan (declarationSpan declaration) } - _ -> Nothing data File = File { filePath :: T.Text diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 9cebc0f56..8c1314467 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -7,7 +7,6 @@ module Rendering.TOC , Summaries(..) , TOCSummary(..) , isValidSummary -, getDeclaration , declaration , Entry(..) , tableOfContentsBy @@ -19,8 +18,8 @@ module Rendering.TOC import Prologue import Analysis.Declaration -import Data.Aeson import Data.Align (bicrosswalk) +import Data.Aeson import Data.Blob import Data.Diff import Data.Language as Language @@ -28,8 +27,7 @@ import Data.List (sortOn) import qualified Data.List as List import qualified Data.Map as Map import Data.Patch -import Data.Record -import Data.Span +import Data.Location import Data.Term import qualified Data.Text as T @@ -65,13 +63,9 @@ isValidSummary :: TOCSummary -> Bool isValidSummary ErrorSummary{} = False isValidSummary _ = True - -getDeclaration :: HasField fields (Maybe Declaration) => Record fields -> Maybe Declaration -getDeclaration = getField - -- | Produce the annotations of nodes representing declarations. -declaration :: HasField fields (Maybe Declaration) => TermF f (Record fields) a -> Maybe (Record fields) -declaration (In annotation _) = annotation <$ getDeclaration annotation +declaration :: TermF f (Maybe Declaration) a -> Maybe Declaration +declaration (In annotation _) = annotation -- | An entry in a table of contents. @@ -93,8 +87,7 @@ tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of (Just a, Just entries) -> Just (Changed a : entries) (_ , entries) -> entries) - - where patchEntry = patch Deleted Inserted (const Replaced) + where patchEntry = patch Deleted Inserted (const Replaced) termTableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f annotation b -> Maybe a) @@ -104,8 +97,7 @@ termTableOfContentsBy selector = cata termAlgebra where termAlgebra r | Just a <- selector r = a : fold r | otherwise = fold r - -newtype DedupeKey = DedupeKey (Maybe T.Text, Maybe T.Text) deriving (Eq, Ord) +newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord) -- Dedupe entries in a final pass. This catches two specific scenarios with -- different behaviors: @@ -114,12 +106,12 @@ newtype DedupeKey = DedupeKey (Maybe T.Text, Maybe T.Text) deriving (Eq, Ord) -- 2. Two similar entries (defined by a case insensitive comparision of their -- identifiers) are in the list. -- Action: Combine them into a single Replaced entry. -dedupe :: forall fields. HasField fields (Maybe Declaration) => [Entry (Record fields)] -> [Entry (Record fields)] +dedupe :: [Entry Declaration] -> [Entry Declaration] dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in (fmap . fmap) snd tuples where - go :: (Int, Map.Map DedupeKey (Int, Entry (Record fields))) - -> Entry (Record fields) - -> (Int, Map.Map DedupeKey (Int, Entry (Record fields))) + go :: (Int, Map.Map DedupeKey (Int, Entry Declaration)) + -> Entry Declaration + -> (Int, Map.Map DedupeKey (Int, Entry Declaration)) go (index, m) x | Just (_, similar) <- Map.lookup (dedupeKey x) m = if exactMatch similar x then (succ index, m) @@ -128,11 +120,11 @@ dedupe = let tuples = sortOn fst . Map.elems . snd . foldl' go (0, Map.empty) in in (succ index, Map.insert (dedupeKey replacement) (index, replacement) m) | otherwise = (succ index, Map.insert (dedupeKey x) (index, x) m) - dedupeKey entry = DedupeKey ((fmap toCategoryName . getDeclaration . entryPayload) entry, (fmap (T.toLower . declarationIdentifier) . getDeclaration . entryPayload) entry) - exactMatch = (==) `on` (getDeclaration . entryPayload) + dedupeKey entry = DedupeKey (toCategoryName (entryPayload entry), T.toLower (declarationIdentifier (entryPayload entry))) + exactMatch = (==) `on` entryPayload -- | Construct a 'TOCSummary' from an 'Entry'. -entrySummary :: (HasField fields (Maybe Declaration), HasField fields Span) => Entry (Record fields) -> Maybe TOCSummary +entrySummary :: Entry Declaration -> TOCSummary entrySummary entry = case entry of Changed a -> recordSummary "modified" a Deleted a -> recordSummary "removed" a @@ -140,50 +132,48 @@ entrySummary entry = case entry of Replaced a -> recordSummary "modified" a -- | Construct a 'TOCSummary' from a node annotation and a change type label. -recordSummary :: (HasField fields (Maybe Declaration), HasField fields Span) => T.Text -> Record fields -> Maybe TOCSummary -recordSummary changeText record = case getDeclaration record of - Just (ErrorDeclaration text _ language) -> Just $ ErrorSummary text (getField record) language - Just declaration -> Just $ TOCSummary (toCategoryName declaration) (formatIdentifier declaration) (getField record) changeText - Nothing -> Nothing +recordSummary :: T.Text -> Declaration -> TOCSummary +recordSummary changeText record = case record of + (ErrorDeclaration text _ srcSpan language) -> ErrorSummary text srcSpan language + decl-> TOCSummary (toCategoryName decl) (formatIdentifier decl) (declarationSpan decl) changeText where - formatIdentifier (MethodDeclaration identifier _ Language.Go (Just receiver)) = "(" <> receiver <> ") " <> identifier - formatIdentifier (MethodDeclaration identifier _ _ (Just receiver)) = receiver <> "." <> identifier - formatIdentifier declaration = declarationIdentifier declaration + formatIdentifier (MethodDeclaration identifier _ _ Language.Go (Just receiver)) = "(" <> receiver <> ") " <> identifier + formatIdentifier (MethodDeclaration identifier _ _ _ (Just receiver)) = receiver <> "." <> identifier + formatIdentifier decl = declarationIdentifier decl -renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => BlobPair -> Diff f (Record fields) (Record fields) -> Summaries +renderToCDiff :: (Foldable f, Functor f) => BlobPair -> Diff f (Maybe Declaration) (Maybe Declaration) -> Summaries renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC where toMap [] = mempty toMap as = Map.singleton summaryKey (toJSON <$> as) summaryKey = T.pack $ pathKeyForBlobPair blobs -renderRPCToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => BlobPair -> Diff f (Record fields) (Record fields) -> ([TOCSummary], [TOCSummary]) +renderRPCToCDiff :: (Foldable f, Functor f) => BlobPair -> Diff f (Maybe Declaration) (Maybe Declaration) -> ([TOCSummary], [TOCSummary]) renderRPCToCDiff _ = List.partition isValidSummary . diffTOC -diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Diff f (Record fields) (Record fields) -> [TOCSummary] -diffTOC = mapMaybe entrySummary . dedupe . filter extraDeclarations . tableOfContentsBy declaration +diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [TOCSummary] +diffTOC = fmap entrySummary . dedupe . filter extraDeclarations . tableOfContentsBy declaration where - extraDeclarations :: HasField fields (Maybe Declaration) => Entry (Record fields) -> Bool - extraDeclarations entry = case getDeclaration (entryPayload entry) of - Just ImportDeclaration{..} -> False - Just CallReference{..} -> False + extraDeclarations :: Entry Declaration -> Bool + extraDeclarations entry = case entryPayload entry of + ClassDeclaration{..} -> False + ModuleDeclaration{..} -> False _ -> True -renderToCTerm :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Blob -> Term f (Record fields) -> Summaries +renderToCTerm :: (Foldable f, Functor f) => Blob -> Term f (Maybe Declaration) -> Summaries renderToCTerm Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC where toMap [] = mempty toMap as = Map.singleton (T.pack blobPath) (toJSON <$> as) - termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Term f (Record fields) -> [TOCSummary] - termToC = mapMaybe (recordSummary "unchanged") . termTableOfContentsBy declaration + termToC :: (Foldable f, Functor f) => Term f (Maybe Declaration) -> [TOCSummary] + termToC = fmap (recordSummary "unchanged") . termTableOfContentsBy declaration -- The user-facing category name toCategoryName :: Declaration -> T.Text toCategoryName declaration = case declaration of ClassDeclaration{} -> "Class" - ImportDeclaration{} -> "Import" + ModuleDeclaration{} -> "Module" FunctionDeclaration{} -> "Function" MethodDeclaration{} -> "Method" - CallReference{} -> "Call" - HeadingDeclaration _ _ _ l -> "Heading " <> T.pack (show l) + HeadingDeclaration _ _ _ _ l -> "Heading " <> T.pack (show l) ErrorDeclaration{} -> "ParseError" diff --git a/src/Reprinting/Pipeline.hs b/src/Reprinting/Pipeline.hs index 3cfa49155..b28127b89 100644 --- a/src/Reprinting/Pipeline.hs +++ b/src/Reprinting/Pipeline.hs @@ -103,19 +103,20 @@ module Reprinting.Pipeline , runTranslating ) where -import Control.Monad.Effect as Effect -import qualified Control.Monad.Effect.Exception as Exc -import Control.Monad.Effect.State +import Control.Effect as Effect +import Control.Effect.Error as Effect +import Control.Effect.State as Effect import Data.Machine hiding (Source) import Data.Machine.Runner -import Data.Record +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Text + import Data.Reprinting.Errors +import Data.Reprinting.Scope import Data.Reprinting.Splice import Data.Reprinting.Token import qualified Data.Source as Source import Data.Term -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.Text import Reprinting.Tokenize import Reprinting.Translate import Reprinting.Typeset @@ -123,21 +124,17 @@ import Reprinting.Typeset -- | Run the reprinting pipeline given the original 'Source', a language -- specific machine (`ProcessT`) and the provided 'Term'. -runReprinter :: - ( Show (Record fields) - , Tokenize a - , HasField fields History - ) +runReprinter :: Tokenize a => Source.Source -> ProcessT Translator Fragment Splice - -> Term a (Record fields) + -> Term a History -> Either TranslationError Source.Source runReprinter src translating tree = fmap go . Effect.run - . Exc.runError + . Effect.runError . fmap snd - . runState (mempty :: [Context]) + . runState (mempty :: [Scope]) . foldT $ source (tokenizing src tree) ~> contextualizing ~> translating @@ -145,48 +142,36 @@ runReprinter src translating tree where go = Source.fromText . renderStrict . layoutPretty defaultLayoutOptions -- | Run the reprinting pipeline up to tokenizing. -runTokenizing :: - ( Show (Record fields) - , Tokenize a - , HasField fields History - ) +runTokenizing :: Tokenize a => Source.Source - -> Term a (Record fields) + -> Term a History -> [Token] runTokenizing src tree = Data.Machine.run $ source (tokenizing src tree) -- | Run the reprinting pipeline up to contextualizing. -runContextualizing :: - ( Show (Record fields) - , Tokenize a - , HasField fields History - ) +runContextualizing :: Tokenize a => Source.Source - -> Term a (Record fields) + -> Term a History -> Either TranslationError [Fragment] runContextualizing src tree = Effect.run - . Exc.runError + . Effect.runError . fmap snd - . runState (mempty :: [Context]) + . runState (mempty :: [Scope]) . runT $ source (tokenizing src tree) ~> contextualizing -runTranslating :: - ( Show (Record fields) - , Tokenize a - , HasField fields History - ) +runTranslating :: Tokenize a => Source.Source -> ProcessT Translator Fragment Splice - -> Term a (Record fields) + -> Term a History -> Either TranslationError [Splice] runTranslating src translating tree = Effect.run - . Exc.runError + . Effect.runError . fmap snd - . runState (mempty :: [Context]) + . runState (mempty :: [Scope]) . runT $ source (tokenizing src tree) ~> contextualizing ~> translating diff --git a/src/Reprinting/Tokenize.hs b/src/Reprinting/Tokenize.hs index 11a93992b..5905ff99e 100644 --- a/src/Reprinting/Tokenize.hs +++ b/src/Reprinting/Tokenize.hs @@ -1,7 +1,9 @@ {-# LANGUAGE GADTs, LambdaCase, RankNTypes, UndecidableInstances #-} module Reprinting.Tokenize - ( module Data.Reprinting.Token + ( module Token + , module Scope + , module Operator , History (..) , mark , remark @@ -32,8 +34,10 @@ import Data.History import Data.List (intersperse) import qualified Data.Machine as Machine import Data.Range -import Data.Record -import Data.Reprinting.Token +import Data.Reprinting.Scope (Scope) +import qualified Data.Reprinting.Scope as Scope +import Data.Reprinting.Token as Token +import Data.Reprinting.Operator as Operator import Data.Source import Data.Term @@ -95,11 +99,11 @@ data State = State yield :: Element -> Tokenizer () yield e = do on <- filter <$> Get - when (on == AllowAll) . Tell . TElement $ e + when (on == AllowAll) . Tell . Element $ e -- | Yield a 'Control' token. control :: Control -> Tokenizer () -control = Tell . TControl +control = Tell . Control -- | Yield a 'Chunk' of some 'Source'. chunk :: Source -> Tokenizer () @@ -128,13 +132,13 @@ forbidData = modify (\x -> x { filter = ForbidData }) move :: Int -> Tokenizer () move c = modify (\x -> x { cursor = c }) -withHistory :: (Annotated t (Record fields), HasField fields History) +withHistory :: Annotated t History => t -> Tokenizer a -> Tokenizer a withHistory t act = do old <- asks history - modify (\x -> x { history = getField (annotation t)}) + modify (\x -> x { history = annotation t }) act <* modify (\x -> x { history = old }) withStrategy :: Strategy -> Tokenizer a -> Tokenizer a @@ -149,7 +153,7 @@ withStrategy s act = do -- The reprinting algorithm. -- | A subterm algebra inspired by the /Scrap Your Reprinter/ algorithm. -descend :: (Tokenize constr, HasField fields History) => SubtermAlgebra constr (Term a (Record fields)) (Tokenizer ()) +descend :: Tokenize constr => SubtermAlgebra constr (Term a History) (Tokenizer ()) descend t = do (State src hist strat crs _) <- asks id let into s = withHistory (subterm s) (subtermRef s) @@ -179,39 +183,40 @@ log = control . Log -- | Emit an Enter for the given context, then run the provided -- action, then emit a corresponding Exit. -within :: Context -> Tokenizer () -> Tokenizer () +within :: Scope -> Tokenizer () -> Tokenizer () within c r = control (Enter c) *> r <* control (Exit c) --- | Like 'within', but adds 'TOpen' and 'TClose' elements around the action. -within' :: Context -> Tokenizer () -> Tokenizer () -within' c x = within c $ yield TOpen *> x <* yield TClose +-- | Like 'within', but adds 'Open' and 'Close' elements around the action. +within' :: Scope -> Tokenizer () -> Tokenizer () +within' c x = within c $ yield Token.Open *> x <* yield Token.Close --- | Emit a sequence of tokens interspersed with 'TSep'. +-- | Emit a sequence of tokens interspersed with 'Sep'. sep :: Foldable t => t (Tokenizer ()) -> [Tokenizer ()] -sep = intersperse (yield TSep) . toList +sep = intersperse (yield Token.Sep) . toList --- | Emit a sequence of tokens each with trailing 'TSep'. +-- | Emit a sequence of tokens each with trailing 'Sep'. sepTrailing :: Foldable t => t (Tokenizer ()) -> [Tokenizer ()] -sepTrailing = foldr (\x acc -> x : yield TSep : acc) mempty +sepTrailing = foldr (\x acc -> x : yield Token.Sep : acc) mempty --- | Emit a sequence of tokens within a 'TList' Context with appropriate 'TOpen', +-- | Emit a sequence of tokens within a 'List' Scope with appropriate 'Open', -- 'TClose' tokens surrounding. list :: Foldable t => t (Tokenizer ()) -> Tokenizer () -list = within' TList . sequenceA_ . sep +list = within' Scope.List . sequenceA_ . sep --- | Emit a sequence of tokens within a 'THash' Context with appropriate --- 'TOpen', 'TClose' tokens surrounding and interspersing 'TSep'. +-- | Emit a sequence of tokens within a 'Hash' Scope with appropriate +-- 'Open', 'TClose' tokens surrounding and interspersing 'Sep'. hash :: Foldable t => t (Tokenizer ()) -> Tokenizer () -hash = within' THash . sequenceA_ . sep +hash = within' Scope.Hash . sequenceA_ . sep --- | Emit key value tokens with a 'TSep' within an TPair Context +-- | Emit key value tokens with a 'Sep' within a scoped 'Pair'. pair :: Tokenizer () -> Tokenizer () -> Tokenizer () -pair k v = within TPair $ k *> yield TSep <* v +pair k v = within Scope.Pair $ k *> yield Token.Sep <* v --- | Emit a sequence of tokens within an Imperative Context with appropriate --- 'TOpen', 'TClose' tokens surrounding and interspersing 'TSep'. +-- | Emit a sequence of tokens within an 'Imperative' scope with +-- appropriate 'Open', 'Close' tokens surrounding and interspersing +-- 'Sep'. imperative :: Foldable t => t (Tokenizer ()) -> Tokenizer () -imperative = within' Imperative . sequenceA_ . sep +imperative = within' Scope.Imperative . sequenceA_ . sep -- | Shortcut for @const (pure ())@, useful for when no action -- should be taken. @@ -224,13 +229,13 @@ class (Show1 constr, Traversable constr) => Tokenize constr where -- | Should emit control and data tokens. tokenize :: FAlgebra constr (Tokenizer ()) -tokenizing :: (Show (Record fields), Tokenize a, HasField fields History) +tokenizing :: Tokenize a => Source - -> Term a (Record fields) + -> Term a History -> Machine.Source Token tokenizing src term = pipe where pipe = Machine.construct . fmap snd $ compile state go - state = State src (getField (termAnnotation term)) Reprinting 0 ForbidData + state = State src (termAnnotation term) Reprinting 0 ForbidData go = forbidData *> foldSubterms descend term <* finish -- | Sums of reprintable terms are reprintable. @@ -238,7 +243,7 @@ instance (Apply Show1 fs, Apply Functor fs, Apply Foldable fs, Apply Traversable tokenize = apply @Tokenize tokenize -- | Annotated terms are reprintable and operate in a context derived from the annotation. -instance (HasField fields History, Show (Record fields), Tokenize a) => Tokenize (TermF a (Record fields)) where +instance Tokenize a => Tokenize (TermF a History) where tokenize t = withHistory t (tokenize (termFOut t)) instance Tokenize [] where diff --git a/src/Reprinting/Translate.hs b/src/Reprinting/Translate.hs index 72723ffa7..9e9ff0c7c 100644 --- a/src/Reprinting/Translate.hs +++ b/src/Reprinting/Translate.hs @@ -6,35 +6,38 @@ module Reprinting.Translate ) where import Control.Monad -import Control.Monad.Effect -import Control.Monad.Effect.Exception (Exc) -import qualified Control.Monad.Effect.Exception as Exc -import Control.Monad.Effect.State +import Control.Effect +import Control.Effect.Error +import Control.Effect.State import Control.Monad.Trans import Data.Machine import Data.Reprinting.Errors import Data.Reprinting.Splice import Data.Reprinting.Token +import Data.Reprinting.Scope import qualified Data.Source as Source -type Translator = Eff '[State [Context], Exc TranslationError] +type Translator + = Eff (StateC [Scope] + ( Eff (ErrorC TranslationError + ( Eff VoidC)))) contextualizing :: ProcessT Translator Token Fragment contextualizing = repeatedly $ await >>= \case Chunk source -> yield . Verbatim . Source.toText $ source - TElement t -> case t of + Element t -> case t of Run f -> lift get >>= \c -> yield (New t c f) _ -> lift get >>= yield . Defer t - TControl ctl -> case ctl of - Enter c -> enterContext c - Exit c -> exitContext c + Control ctl -> case ctl of + Enter c -> enterScope c + Exit c -> exitScope c _ -> pure () -enterContext, exitContext :: Context -> PlanT k Fragment Translator () +enterScope, exitScope :: Scope -> PlanT k Fragment Translator () -enterContext c = lift (modify' (c :)) +enterScope c = lift (modify (c :)) -exitContext c = lift get >>= \case - (x:xs) -> when (x == c) (lift (modify' (const xs))) - cs -> lift (Exc.throwError (UnbalancedPair c cs)) +exitScope c = lift get >>= \case + (x:xs) -> when (x == c) (lift (modify (const xs))) + cs -> lift (throwError (UnbalancedPair c cs)) diff --git a/src/Reprinting/Typeset.hs b/src/Reprinting/Typeset.hs index 2da1d797c..09ef1554e 100644 --- a/src/Reprinting/Typeset.hs +++ b/src/Reprinting/Typeset.hs @@ -1,6 +1,5 @@ module Reprinting.Typeset - ( typeset - , typesetting + ( typesetting , typesettingWithVisualWhitespace ) where @@ -10,9 +9,6 @@ import Data.Machine import Data.Reprinting.Splice hiding (space) import Data.Text.Prettyprint.Doc -typeset :: Seq Splice -> Doc a -typeset = foldMap step - typesetting :: Monad m => ProcessT m Splice (Doc a) typesetting = auto step diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs index 6fddfd4e5..3e710349c 100644 --- a/src/Semantic/AST.hs +++ b/src/Semantic/AST.hs @@ -7,12 +7,13 @@ module Semantic.AST , runASTParse ) where +import Control.Effect +import Control.Monad import Data.AST import Data.Blob import Parsing.Parser -import Prologue hiding (MonadError(..)) +import Prologue import Rendering.JSON (renderJSONAST) -import Semantic.IO (noLanguageForBlob) import Semantic.Task import qualified Serializing.Format as F @@ -22,7 +23,7 @@ data SomeAST where withSomeAST :: (forall grammar . Show grammar => AST [] grammar -> a) -> SomeAST -> a withSomeAST f (SomeAST ast) = f ast -astParseBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs SomeAST +astParseBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Functor m) => Blob -> m SomeAST astParseBlob blob@Blob{..} | Just (SomeASTParser parser) <- someASTParser blobLanguage = SomeAST <$> parse parser blob | otherwise = noLanguageForBlob blobPath @@ -31,7 +32,7 @@ astParseBlob blob@Blob{..} data ASTFormat = SExpression | JSON | Show deriving (Show) -runASTParse :: (Member Distribute effects, Member (Exc SomeException) effects, Member Task effects) => ASTFormat -> [Blob] -> Eff effects F.Builder +runASTParse :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => ASTFormat -> [Blob] -> m F.Builder runASTParse SExpression = distributeFoldMap (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow))) runASTParse Show = distributeFoldMap (astParseBlob >=> withSomeAST (serialize F.Show . fmap nodeSymbol)) runASTParse JSON = distributeFoldMap (\ blob -> astParseBlob blob >>= withSomeAST (render (renderJSONAST blob))) >=> serialize F.JSON diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs new file mode 100644 index 000000000..b52943f45 --- /dev/null +++ b/src/Semantic/Analysis.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE TypeFamilies, TypeOperators #-} +module Semantic.Analysis +( evaluate +, evalTerm +) where + +import Control.Abstract +import Control.Effect.Interpose +import Data.Abstract.Environment as Env +import Data.Abstract.Evaluatable +import Data.Abstract.Module +import Data.Abstract.ModuleTable as ModuleTable +import Data.Function +import Prologue + +type ModuleC address value m + = ErrorC (LoopControl address) (Eff + ( ErrorC (Return address) (Eff + ( EnvC address (Eff + ( ScopeEnvC address (Eff + (Ā DerefC address value (Eff + ( AllocatorC address (Eff + ( ReaderC ModuleInfo (Eff + m))))))))))))) + +type ValueC term address value m + = FunctionC term address value (Eff + ( WhileC value (Eff + ( BooleanC value (Eff + ( InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff + m))))))) + +-- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module. +evaluate :: ( AbstractValue term address value (ValueC term address value inner) + , Carrier innerSig inner + , Carrier outerSig outer + , derefSig ~ (Deref value :+: allocatorSig) + , derefC ~ (DerefC address value (Eff allocatorC)) + , Carrier derefSig derefC + , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig) + , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff outer)))) + , Carrier allocatorSig allocatorC + , booleanC ~ BooleanC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError value))) (Eff inner))) + , booleanSig ~ (Boolean value :+: Interpose (Resumable (BaseError (UnspecializedError value))) :+: innerSig) + , Carrier booleanSig booleanC + , whileC ~ WhileC value (Eff booleanC) + , whileSig ~ (While value :+: booleanSig) + , Carrier whileSig whileC + , functionC ~ FunctionC term address value (Eff whileC) + , functionSig ~ (Function term address value :+: whileSig) + , Carrier functionSig functionC + , Effect outerSig + , HasPrelude lang + , Member Fresh outerSig + , Member (Allocator address) innerSig + , Member (Deref value) innerSig + , Member (Env address) innerSig + , Member Fresh innerSig + , Member (Reader ModuleInfo) innerSig + , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) outerSig + , Member (Reader Span) innerSig + , Member (Resumable (BaseError (AddressError address value))) innerSig + , Member (Resumable (BaseError (EnvironmentError address))) innerSig + , Member (Resumable (BaseError (UnspecializedError value))) innerSig + , Member (State (Heap address value)) innerSig + , Member Trace innerSig + , Ord address + ) + => proxy lang + -> ( (Module (Either (proxy lang) term) -> Evaluator term address value inner address) + -> (Module (Either (proxy lang) term) -> Evaluator term address value (ModuleC address value outer) address)) + -> (term -> Evaluator term address value (ValueC term address value inner) address) + -> [Module term] + -> Evaluator term address value outer (ModuleTable (NonEmpty (Module (ModuleResult address value)))) +evaluate lang perModule runTerm modules = do + let prelude = Module moduleInfoFromCallStack (Left lang) + (_, (preludeBinds, _)) <- evalModule lowerBound prelude + foldr (run preludeBinds . fmap Right) ask modules + where run prelude m rest = do + evaluated <- evalModule prelude m + -- 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 + + evalModule prelude m = runInModule (perModule (runValueEffects . moduleBody) m) + where runInModule + = raiseHandler (runReader (moduleInfo m)) + . runAllocator + . runDeref + . runScopeEnv + . runEnv (EvalContext Nothing (Env.push (newEnv prelude))) + . runReturn + . runLoopControl + + runValueEffects = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((*> box unit) . definePrelude) runTerm + +-- | Evaluate a term recursively, applying the passed function at every recursive position. +-- +-- This calls out to the 'Evaluatable' instances, will be passed to 'runValueEffects', and can have other functions composed after it to e.g. intercept effects arising in the evaluation of the term. +evalTerm :: ( Carrier sig m + , Declarations term + , Evaluatable (Base term) + , FreeVariables term + , AbstractValue term address value m + , Member (Allocator address) sig + , Member (Boolean value) sig + , Member (Deref value) sig + , Member (Env address) sig + , Member (Error (LoopControl address)) sig + , Member (Error (Return address)) sig + , Member Fresh sig + , Member (Function term address value) sig + , Member (Modules address) sig + , Member (Reader ModuleInfo) sig + , Member (Reader PackageInfo) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (AddressError address value))) sig + , Member (Resumable (BaseError (EnvironmentError address))) sig + , Member (Resumable (BaseError EvalError)) sig + , Member (Resumable (BaseError ResolutionError)) sig + , Member (Resumable (BaseError (UnspecializedError value))) sig + , Member (ScopeEnv address) sig + , Member (State (Heap address value)) sig + , Member (State Span) sig + , Member Trace sig + , Member (While value) sig + , Ord address + , Recursive term + ) + => Open (Open (term -> Evaluator term address value m (ValueRef address))) + -> term -> Evaluator term address value m address +evalTerm perTerm = fix (perTerm (\ ev -> eval ev . project)) >=> address diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index bd7f57107..b82e1f600 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -6,10 +6,12 @@ module Semantic.CLI , Parse.runParse ) where -import Control.Monad.IO.Class -import Data.Language (ensureLanguage) +import Control.Exception as Exc (displayException) +import Data.File +import Data.Language (ensureLanguage, languageForFilePath) import Data.List (intercalate, uncons) import Data.List.Split (splitWhen) +import Data.Handle import Data.Project import Options.Applicative hiding (style) import Prologue @@ -18,17 +20,22 @@ import qualified Semantic.AST as AST import Semantic.Config import qualified Semantic.Diff as Diff import qualified Semantic.Graph as Graph -import Semantic.IO as IO import qualified Semantic.Parse as Parse import qualified Semantic.Task as Task +import Semantic.Task.Files import qualified Semantic.Telemetry.Log as Log import Semantic.Version +import System.Exit (die) import System.FilePath import Serializing.Format hiding (Options) import Text.Read main :: IO () -main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions +main = do + (options, task) <- customExecParser (prefs showHelpOnEmpty) arguments + res <- Task.withOptions options $ \ config logger statter -> + Task.runTaskWithConfig config { configSHA = Just buildSHA } logger statter task + either (die . displayException) pure res -- | A parser for the application's command-line arguments. -- @@ -46,7 +53,8 @@ optionsParser = do (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id") failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.") - pure $ Options logLevel requestId failOnWarning + failOnParseError <- switch (long "fail-on-parse-error" <> help "Fail on tree-sitter parse errors.") + pure $ Options logLevel requestId failOnWarning failOnParseError argumentsParser :: Parser (Task.TaskEff ()) argumentsParser = do @@ -60,7 +68,7 @@ diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute change diffArgumentsParser = do renderer <- flag (Diff.runDiff SExpressionDiffRenderer) (Diff.runDiff SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)") <|> flag' (Diff.runDiff JSONDiffRenderer) (long "json" <> help "Output JSON diff trees") - <|> flag' (Diff.runDiff JSONGraphDiffRenderer) (long "json-graph" <> help "Output JSON diff trees") + <|> flag' (Diff.runDiff JSONGraphDiffRenderer) (long "json-graph" <> help "Output JSON diff trees") <|> flag' (Diff.runDiff ToCDiffRenderer) (long "toc" <> help "Output JSON table of contents diff summary") <|> flag' (Diff.runDiff DOTDiffRenderer) (long "dot" <> help "Output the diff as a DOT graph") <|> flag' (Diff.runDiff ShowDiffRenderer) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)") @@ -73,7 +81,7 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa parseArgumentsParser = do renderer <- flag (Parse.runParse SExpressionTermRenderer) (Parse.runParse SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)") <|> flag' (Parse.runParse JSONTermRenderer) (long "json" <> help "Output JSON parse trees") - <|> flag' (Parse.runParse JSONGraphTermRenderer) (long "json-graph" <> help "Output JSON adjacency list") + <|> flag' (Parse.runParse JSONGraphTermRenderer) (long "json-graph" <> help "Output JSON adjacency list") <|> flag' (Parse.runParse . SymbolsTermRenderer) (long "symbols" <> help "Output JSON symbol list") <*> (option symbolFieldsReader ( long "fields" <> help "Comma delimited list of specific fields to return (symbols output only)." @@ -81,6 +89,7 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa <|> pure defaultSymbolFields) <|> flag' (Parse.runParse DOTTermRenderer) (long "dot" <> help "Output DOT graph parse trees") <|> flag' (Parse.runParse ShowTermRenderer) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)") + <|> flag' (Parse.runParse QuietTermRenderer) (long "quiet" <> help "Don't produce output, but show timing stats") filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) pure $ Task.readBlobs filesOrStdin >>= renderer @@ -116,7 +125,7 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g <|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin.")) makeReadProjectFromPathsTask language maybePaths = do paths <- maybeM (liftIO (many getLine)) maybePaths - blobs <- traverse IO.readBlob (flip File language <$> paths) + blobs <- traverse readBlobFromFile' (flip File language <$> paths) pure $! Project (takeDirectory (maybe "/" fst (uncons paths))) blobs language [] readProjectRecursively = makeReadProjectRecursivelyTask <$> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 0581ad9ed..f0a3add28 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -23,9 +23,8 @@ import Semantic.Env import Semantic.Telemetry import qualified Semantic.Telemetry.Haystack as Haystack import qualified Semantic.Telemetry.Stat as Stat -import Semantic.Version import System.Environment -import System.IO (hIsTerminalDevice, stderr) +import System.IO (hIsTerminalDevice, stdout) import System.Posix.Process import System.Posix.Types @@ -43,6 +42,7 @@ data Config , configIsTerminal :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime). , configLogPrintSource :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime). , configLogFormatter :: LogFormatter -- ^ Log formatter to use (set automaticaly at runtime). + , configSHA :: Maybe String -- ^ Optional SHA to include in log messages. , configOptions :: Options -- ^ Options configurable via command line arguments. } @@ -50,22 +50,23 @@ data Config -- Options configurable via command line arguments. data Options = Options - { optionsLogLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. - , optionsRequestID :: Maybe String -- ^ Optional request id for tracing across systems. - , optionsFailOnWarning :: Bool -- ^ Should semantic fail fast on assignment warnings (for testing) + { optionsLogLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disables logging. + , optionsRequestID :: Maybe String -- ^ Optional request id for tracing across systems. + , optionsFailOnWarning :: Bool -- ^ Should semantic fail fast on assignment warnings (for testing) + , optionsFailOnParseError :: Bool -- ^ Should semantic fail fast on tree-sitter parser errors (for testing) } defaultOptions :: Options -defaultOptions = Options (Just Warning) Nothing False +defaultOptions = Options (Just Warning) Nothing False False debugOptions :: Options -debugOptions = Options (Just Debug) Nothing False +debugOptions = Options (Just Debug) Nothing False False defaultConfig :: Options -> IO Config defaultConfig options@Options{..} = do pid <- getProcessID hostName <- getHostName - isTerminal <- hIsTerminalDevice stderr + isTerminal <- hIsTerminalDevice stdout haystackURL <- lookupEnv "HAYSTACK_URL" (statsHost, statsPort) <- lookupStatsAddr size <- envLookupNum 1000 "MAX_TELEMETRY_QUEUE_SIZE" @@ -83,6 +84,7 @@ defaultConfig options@Options{..} = do , configIsTerminal = isTerminal , configLogPrintSource = isTerminal , configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter + , configSHA = Nothing , configOptions = options } @@ -104,8 +106,9 @@ logOptionsFromConfig Config{..} = LogOptions False -> [ ("app", configAppName) , ("pid", show configProcessID) , ("hostname", configHostName) - , ("sha", buildSHA) - ] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ] + , ("sha", fromMaybe "development" configSHA) + ] + <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ] _ -> [] diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 77100bc6c..99bb75528 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -6,29 +6,30 @@ module Semantic.Diff import Analysis.ConstructorName (ConstructorName) import Analysis.Declaration (HasDeclaration, declarationAlgebra) -import Data.AST +import Control.Effect +import Control.Monad.IO.Class import Data.Blob import Data.Diff import Data.JSON.Fields -import Data.Record +import Data.Location import Data.Term import Data.Graph.DiffVertex import Diffing.Algorithm (Diffable) import Parsing.Parser -import Prologue hiding (MonadError(..)) +import Prologue import Rendering.Graph import Rendering.Renderer -import Semantic.IO (noLanguageForBlob) import Semantic.Telemetry as Stat import Semantic.Task as Task import Serializing.Format import Rendering.JSON (SomeJSON (..)) import qualified Rendering.JSON as JSON -runDiff :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => DiffRenderer output -> [BlobPair] -> Eff effs Builder +-- | Using the specified renderer, diff a list of 'BlobPair's to produce a 'Builder' output. +runDiff :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Carrier sig m) => DiffRenderer output -> [BlobPair] -> m Builder runDiff ToCDiffRenderer = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON runDiff JSONDiffRenderer = withParsedBlobPairs (const pure) (render . renderJSONDiff) >=> serialize JSON -runDiff JSONGraphDiffRenderer = withParsedBlobPairs (const pure) (render . renderAdjGraph) >=> serialize JSON +runDiff JSONGraphDiffRenderer = withParsedBlobPairs (const pure) (render . renderAdjGraph) >=> serialize JSON where renderAdjGraph :: (Recursive t, ToTreeGraph DiffVertex (Base t)) => BlobPair -> t -> JSON.JSON "diffs" SomeJSON renderAdjGraph blob diff = renderJSONAdjDiff blob (renderTreeGraph diff) runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName))) @@ -41,27 +42,28 @@ data SomeTermPair typeclasses ann where withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a withSomeTermPair with (SomeTermPair terms) = with terms -diffBlobTOCPairs :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => [BlobPair] -> Eff effs ([TOCSummary], [TOCSummary]) +diffBlobTOCPairs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Carrier sig m) => [BlobPair] -> m ([TOCSummary], [TOCSummary]) diffBlobTOCPairs = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderRPCToCDiff) type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) +type Decorate m a b = forall syntax . CanDiff syntax => Blob -> Term syntax a -> m (Term syntax b) -withParsedBlobPairs :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs, Monoid output) - => (forall syntax . CanDiff syntax => Blob -> Term syntax (Record Location) -> Eff effs (Term syntax (Record fields))) - -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax (Record fields) (Record fields) -> Eff effs output) +withParsedBlobPairs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Member Telemetry sig, MonadIO m, Monoid output, Carrier sig m) + => Decorate m Location ann + -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output) -> [BlobPair] - -> Eff effs output + -> m output withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)) - where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields)) + where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Member Telemetry sig, Carrier sig m, MonadIO m) => BlobPair -> Join These (Term syntax ann) -> m (Diff syntax ann ann) diffTerms blobs terms = time "diff" languageTag $ do diff <- diff (runJoin terms) diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) where languageTag = languageTagForBlobPair blobs -withParsedBlobPair :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) - => (forall syntax . (CanDiff syntax) => Blob -> Term syntax (Record Location) -> Eff effs (Term syntax (Record fields))) +withParsedBlobPair :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) + => Decorate m Location ann -> BlobPair - -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (Record fields)) + -> m (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] ann) withParsedBlobPair decorate blobs | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (languageForBlobPair blobs) = SomeTermPair <$> distributeFor blobs (\ blob -> parse parser blob >>= decorate blob) diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index cb79e8af7..34c789a41 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -1,45 +1,60 @@ -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ExistentialQuantification, TypeOperators, UndecidableInstances #-} module Semantic.Distribute ( distribute , distributeFor , distributeFoldMap , Distribute , runDistribute +, DistributeC(..) ) where import qualified Control.Concurrent.Async as Async +import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Sum import Control.Parallel.Strategies -import Control.Monad.Effect -import Control.Monad.IO.Class -import Prologue hiding (MonadError (..)) +import Prologue -- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results. -- -- This is a concurrent analogue of 'sequenceA'. -distribute :: (Member Distribute effs, Traversable t) => t (Eff effs output) -> Eff effs (t output) -distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . Distribute) +distribute :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t (m output) -> m (t output) +distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute ret) -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results. -- -- This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped). -distributeFor :: (Member Distribute effs, Traversable t) => t a -> (a -> Eff effs output) -> Eff effs (t output) +distributeFor :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t a -> (a -> m output) -> m (t output) distributeFor inputs toTask = distribute (fmap toTask inputs) -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), combining the results 'Monoid'ally into a final value. -- -- This is a concurrent analogue of 'foldMap'. -distributeFoldMap :: (Member Distribute effs, Monoid output, Traversable t) => (a -> Eff effs output) -> t a -> Eff effs output +distributeFoldMap :: (Member Distribute sig, Monoid output, Traversable t, Carrier sig m, Applicative m) => (a -> m output) -> t a -> m output distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) -- | Distribute effects run tasks concurrently. -newtype Distribute task output = Distribute (task output) +data Distribute m k + = forall a . Distribute (m a) (a -> k) + +deriving instance Functor (Distribute m) + +instance HFunctor Distribute where + hmap f (Distribute m k) = Distribute (f m) k -instance PureEffect Distribute instance Effect Distribute where - handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c))) (dist . fmap k) + handle state handler (Distribute task k) = Distribute (handler (task <$ state)) (handler . fmap k) -- | Evaluate a 'Distribute' effect concurrently. -runDistribute :: Eff '[Distribute, Lift IO] a -> Eff '[Lift IO] a -runDistribute = interpret (\ (Distribute task) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistribute task))))) +runDistribute :: Eff (DistributeC (Eff (LiftC IO))) a -> Eff (LiftC IO) a +runDistribute = runDistributeC . interpret + +newtype DistributeC m a = DistributeC { runDistributeC :: m a } + +instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where + ret = DistributeC . ret + eff = DistributeC . handleSum + (eff . handleCoercible) + (\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) diff --git a/src/Semantic/Env.hs b/src/Semantic/Env.hs index 4bf717e7b..8243d6fb4 100644 --- a/src/Semantic/Env.hs +++ b/src/Semantic/Env.hs @@ -4,7 +4,6 @@ module Semantic.Env , envLookupString ) where -import Control.Monad.IO.Class import Prologue import System.Environment import Text.Read (readMaybe) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 958e81016..81981c2bb 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -8,8 +8,9 @@ module Semantic.Graph , GraphType(..) , Graph , ControlFlowVertex -, ConcreteEff(..) , style +, runHeap +, runModuleTable , parsePackage , parsePythonPackage , withTermSpans @@ -26,7 +27,7 @@ module Semantic.Graph import Prelude hiding (readFile) -import Analysis.Abstract.Caching +import Analysis.Abstract.Caching.FlowInsensitive import Analysis.Abstract.Collecting import Analysis.Abstract.Graph as Graph import Control.Abstract @@ -41,25 +42,25 @@ import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package -import qualified Data.Abstract.ScopeGraph as ScopeGraph import Data.Abstract.Value.Abstract as Abstract import Data.Abstract.Value.Concrete as Concrete - (Value, ValueError (..), runBoolean, runFunction, runValueErrorWith) + (Value, ValueError (..), runValueErrorWith) import Data.Abstract.Value.Type as Type import Data.Blob -import Data.Coerce +import Data.File import Data.Graph import Data.Graph.ControlFlowVertex (VertexDeclarationStrategy, VertexDeclarationWithStrategy) import Data.Language as Language import Data.List (isPrefixOf, isSuffixOf) import Data.Project -import Data.Record +import Data.Location import Data.Term import Data.Text (pack, unpack) import Language.Haskell.HsColour import Language.Haskell.HsColour.Colourise import Parsing.Parser -import Prologue hiding (MonadError (..), TypeError (..)) +import Prologue hiding (TypeError (..)) +import Semantic.Analysis import Semantic.Task as Task import System.FilePath.Posix (takeDirectory, ()) import Text.Show.Pretty (ppShow) @@ -68,17 +69,18 @@ data GraphType = ImportGraph | CallGraph type AnalysisClasses = '[ Declarations1, Eq1, Evaluatable, FreeVariables1, Foldable, Functor, Ord1, Show1 ] -runGraph :: forall effs. ( Member Distribute effs - , Member (Exc SomeException) effs - , Member Resolution effs - , Member Task effs - , Member Trace effs - , Effects effs - ) +runGraph :: ( Member Distribute sig + , Member (Error SomeException) sig + , Member Resolution sig + , Member Task sig + , Member Trace sig + , Carrier sig m + , Effect sig + ) => GraphType -> Bool -> Project - -> Eff effs (Graph ControlFlowVertex) + -> Eff m (Graph ControlFlowVertex) runGraph ImportGraph _ project | SomeAnalysisParser parser (lang' :: Proxy lang) <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do let parse = if projectLanguage project == Language.Python then parsePythonPackage parser else fmap (fmap snd) . parsePackage parser @@ -91,70 +93,72 @@ runGraph CallGraph includePackages project modules <- topologicalSort <$> runImportGraphToModules lang package runCallGraph lang includePackages modules package -runCallGraph :: forall fields syntax term lang effs. ( HasField fields Span +runCallGraph :: ( HasField fields Span , Show (Record fields) , Ord (Record fields) - , (VertexDeclarationWithStrategy (VertexDeclarationStrategy syntax) syntax syntax) + , VertexDeclarationWithStrategy (VertexDeclarationStrategy syntax) syntax syntax , Declarations1 syntax , Ord1 syntax , Functor syntax , Evaluatable syntax - , term ~ Term syntax (Record fields) - , FreeVariables term - , Recursive term + , term ~ Term syntax Location + , FreeVariables1 syntax , HasPrelude lang - , HasPostlude lang - , Member Trace effs - , Effects effs + , Member Trace sig + , Carrier sig m + , Effect sig ) => Proxy lang -> Bool -> [Module term] -> Package term - -> Eff effs (Graph ControlFlowVertex) -runCallGraph lang includePackages modules package = do - let analyzeTerm = withTermSpans . graphingTerms . cachingTerms - analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules - extractGraph (graph, _) = simplify graph - runGraphAnalysis - = runTermEvaluator @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract - . graphing @_ @_ @(Maybe Name) @Monovariant - . caching - . runState (lowerBound @(ScopeGraph (Hole (Maybe Name) (Located Monovariant)))) - . runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) (Hole (Maybe Name) (Located Monovariant)) Abstract)) - . runFresh 0 - . resumingLoadError - . resumingUnspecialized - -- . resumingEnvironmentError -- TODO: Fix me. Replace with resumingScopeGraphError? - . resumingScopeError - . resumingHeapError - . resumingEvalError - . resumingResolutionError - . resumingAddressError - . runReader (packageInfo package) - . runReader (lowerBound @Span) - . runState (lowerBound @Span) - . runReader (lowerBound @ControlFlowVertex) - . providingLiveSet - . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) (Located Monovariant)) Abstract))))) - . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) - runAddressEffects - = Hole.runAllocator (Located.handleAllocator Monovariant.handleAllocator) - . Hole.runDeref (Located.handleDeref Monovariant.handleDeref) - extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm runAddressEffects (Abstract.runBoolean . Abstract.runFunction) modules)) + -> Eff m (Graph ControlFlowVertex) +runCallGraph lang includePackages modules package + = fmap (simplify . fst) + . runEvaluator + . graphing @_ @_ @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract + . runHeap + . caching + . runState (lowerBound @(ScopeGraph (Hole (Maybe Name) (Located Monovariant)))) + . runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) (Hole (Maybe Name) (Located Monovariant)) Abstract)) + . raiseHandler runFresh + . resumingLoadError + . resumingUnspecialized + . resumingScopeError + . resumingHeapError + . resumingEvalError + . resumingResolutionError + . resumingAddressError + . raiseHandler (runReader (packageInfo package)) + . raiseHandler (runReader (lowerBound @Span)) + . raiseHandler (runState (lowerBound @Span)) + . raiseHandler (runReader (lowerBound @ControlFlowVertex)) + . providingLiveSet + . runModuleTable + . runModules (ModuleTable.modulePaths (packageModules package)) + $ evaluate lang perModule perTerm modules + where perTerm = evalTerm (withTermSpans . graphingTerms . cachingTerms) + perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules + + +runModuleTable :: Carrier sig m + => Evaluator term address value (ReaderC (ModuleTable (NonEmpty (Module (ModuleResult address)))) (Eff m)) a + -> Evaluator term address value m a +runModuleTable = raiseHandler $ runReader lowerBound runImportGraphToModuleInfos :: ( Declarations term , Evaluatable (Base term) , FreeVariables term , HasPrelude lang - , HasPostlude lang - , Member Trace effs + , Member Trace sig , Recursive term - , Effects effs + , Carrier sig m + , Show term + , Effect sig ) => Proxy lang -> Package term - -> Eff effs (Graph ControlFlowVertex) + -> Eff m (Graph ControlFlowVertex) runImportGraphToModuleInfos lang (package :: Package term) = runImportGraph lang package allModuleInfos where allModuleInfos info = maybe (vertex (unknownModuleVertex info)) (foldMap (vertex . moduleVertex . moduleInfo)) (ModuleTable.lookup (modulePath info) (packageModules package)) @@ -162,14 +166,15 @@ runImportGraphToModules :: ( Declarations term , Evaluatable (Base term) , FreeVariables term , HasPrelude lang - , HasPostlude lang - , Member Trace effs + , Member Trace sig , Recursive term - , Effects effs + , Carrier sig m + , Show term + , Effect sig ) => Proxy lang -> Package term - -> Eff effs (Graph (Module term)) + -> Eff m (Graph (Module term)) runImportGraphToModules lang (package :: Package term) = runImportGraph lang package resolveOrLowerBound where resolveOrLowerBound info = maybe lowerBound (foldMap vertex) (ModuleTable.lookup (modulePath info) (packageModules package)) @@ -177,72 +182,45 @@ runImportGraph :: ( Declarations term , Evaluatable (Base term) , FreeVariables term , HasPrelude lang - , HasPostlude lang - , Member Trace effs + , Member Trace sig , Recursive term - , Effects effs + , Carrier sig m + , Show term + , Effect sig ) => Proxy lang -> Package term -> (ModuleInfo -> Graph vertex) - -> Eff effs (Graph vertex) -runImportGraph lang (package :: Package term) f = - let analyzeModule = graphingModuleInfo - extractGraph (graph, _) = graph >>= f - runImportGraphAnalysis - = runState lowerBound - . runState lowerBound - . runFresh 0 - . resumingLoadError - . resumingUnspecialized - -- . resumingEnvironmentError -- TODO: Fix me. Replace with `resumingScopeGraphError`? - . resumingScopeError - . resumingHeapError - . resumingEvalError - . resumingResolutionError - . resumingAddressError - . resumingValueError - . runReader lowerBound - . runModules (ModuleTable.modulePaths (packageModules package)) - . runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _)) - . runReader (packageInfo package) - . runState lowerBound - . runReader lowerBound - runAddressEffects - = Hole.runAllocator Precise.handleAllocator - . Hole.runDeref Precise.handleDeref - in extractGraph <$> runEvaluator (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (Concrete.runBoolean . Concrete.runFunction coerce coerce) (ModuleTable.toPairs (packageModules package) >>= toList . snd))) - -type ConcreteEffects address rest - = Reader Span - ': State Span - ': Reader PackageInfo - ': Modules address (Value address (ConcreteEff address rest)) - ': Reader (ModuleTable (NonEmpty (Module (ModuleResult address (Value address (ConcreteEff address rest)))))) - ': Resumable (BaseError (ValueError address (ConcreteEff address rest))) - ': Resumable (BaseError (AddressError address (Value address (ConcreteEff address rest)))) - ': Resumable (BaseError ResolutionError) - ': Resumable (BaseError EvalError) - ': Resumable (BaseError (HeapError address)) - ': Resumable (BaseError (ScopeError address)) - ': Resumable (BaseError (UnspecializedError (Value address (ConcreteEff address rest)))) - ': Resumable (BaseError (LoadError address (Value address (ConcreteEff address rest)))) - ': Fresh - ': State (Heap address address (Value address (ConcreteEff address rest))) - ': rest - -newtype ConcreteEff address outerEffects a = ConcreteEff - { runConcreteEff :: Eff (ValueEffects address (Value address (ConcreteEff address outerEffects)) - (ModuleEffects address (Value address (ConcreteEff address outerEffects)) - (ConcreteEffects address outerEffects))) a - } + -> Eff m (Graph vertex) +runImportGraph lang (package :: Package term) f + = fmap (fst >=> f) + . runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) + . raiseHandler (runState lowerBound) + . runHeap + . raiseHandler runFresh + . resumingLoadError + . resumingUnspecialized + . resumingEvalError + . resumingResolutionError + . resumingAddressError + . resumingValueError + . runModuleTable + . runModules (ModuleTable.modulePaths (packageModules package)) + . raiseHandler (runReader (packageInfo package)) + . raiseHandler (runState (lowerBound @Span)) + . raiseHandler (runReader (lowerBound @Span)) + $ evaluate lang graphingModuleInfo (evalTerm id) (ModuleTable.toPairs (packageModules package) >>= toList . snd) +runHeap :: (Carrier sig m, Effect sig) + => Evaluator term address value (StateC (Heap address address value) (Eff m)) a + -> Evaluator term address value m (Heap address address value, a) +runHeap = raiseHandler (runState lowerBound) -- | Parse a list of files into a 'Package'. -parsePackage :: (Member Distribute effs, Member (Exc SomeException) effs, Member Resolution effs, Member Task effs, Member Trace effs) +parsePackage :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Task sig, Member Trace sig, Carrier sig m, Monad m) => Parser term -- ^ A parser. -> Project -- ^ Project to parse into a package. - -> Eff effs (Package (Blob, term)) + -> m (Package (Blob, term)) parsePackage parser project = do p <- parseModules parser project resMap <- Task.resolutionMap project @@ -253,32 +231,33 @@ parsePackage parser project = do n = Data.Abstract.Evaluatable.name (projectName project) -- TODO: Confirm this is the right `name`. -- | Parse all files in a project into 'Module's. -parseModules :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) => Parser term -> Project -> Eff effs [Module (Blob, term)] +parseModules :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Parser term -> Project -> m [Module (Blob, term)] parseModules parser p@Project{..} = distributeFor (projectFiles p) (parseModule p parser) -- | Parse a list of packages from a python project. -parsePythonPackage :: forall syntax fields effs term. +parsePythonPackage :: forall syntax sig m term. ( Declarations1 syntax , Evaluatable syntax , FreeVariables1 syntax , Functor syntax - , term ~ Term syntax (Record fields) - , Member (Exc SomeException) effs - , Member Distribute effs - , Member Resolution effs - , Member Trace effs - , Member Task effs - , (Show (Record fields)) - , Effects effs) - => Parser term -- ^ A parser. - -> Project -- ^ Project to parse into a package. - -> Eff effs (Package term) + , term ~ Term syntax Location + , Member (Error SomeException) sig + , Member Distribute sig + , Member Resolution sig + , Member Trace sig + , Member Task sig + , Carrier sig m + , Effect sig + ) + => Parser term -- ^ A parser. + -> Project -- ^ Project to parse into a package. + -> Eff m (Package term) parsePythonPackage parser project = do - let runAnalysis = runEvaluator - . runState PythonPackage.Unknown - . runState lowerBound - . runFresh 0 + let runAnalysis = runEvaluator @_ @_ @(Value term (Hole (Maybe Name) Precise)) + . raiseHandler (runState PythonPackage.Unknown) + . raiseHandler (runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Value term (Hole (Maybe Name) Precise))))) + . raiseHandler runFresh . resumingLoadError . resumingUnspecialized -- . resumingEnvironmentError -- TODO: Fix me. Replace with `resumineScopeGraphError`? @@ -288,20 +267,16 @@ parsePythonPackage parser project = do . resumingResolutionError . resumingAddressError . resumingValueError - . runReader lowerBound + . runModuleTable . runModules lowerBound - . runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _)) - . runReader (PackageInfo (Data.Abstract.Evaluatable.name "setup") lowerBound) -- TODO: Confirm this is the right `name`. - . runState lowerBound - . runReader lowerBound - runAddressEffects - = Hole.runAllocator Precise.handleAllocator - . Hole.runDeref Precise.handleDeref + . raiseHandler (runReader (PackageInfo (Data.Abstract.Evaluatable.name "setup") lowerBound)) + . raiseHandler (runState (lowerBound @Span)) + . raiseHandler (runReader (lowerBound @Span)) strat <- case find ((== (projectRootDir project "setup.py")) . filePath) (projectFiles project) of Just setupFile -> do setupModule <- fmap snd <$> parseModule project parser setupFile - fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id id runAddressEffects (Concrete.runBoolean . Concrete.runFunction coerce coerce . runPythonPackaging) [ setupModule ]) + fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id (runPythonPackaging . evalTerm id) [ setupModule ]) Nothing -> pure PythonPackage.Unknown case strat of PythonPackage.Unknown -> do @@ -329,58 +304,56 @@ parsePythonPackage parser project = do resMap <- Task.resolutionMap p pure (Package.fromModules (Data.Abstract.Evaluatable.name $ projectName p) modules resMap) -- TODO: Confirm this is the right `name`. -parseModule :: (Member (Exc SomeException) effs, Member Task effs) +parseModule :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Project -> Parser term -> File - -> Eff effs (Module (Blob, term)) + -> m (Module (Blob, term)) parseModule proj parser file = do mBlob <- readFile proj file case mBlob of Just blob -> moduleForBlob (Just (projectRootDir proj)) blob . (,) blob <$> parse parser blob Nothing -> throwError (SomeException (FileNotFound (filePath file))) -withTermSpans :: ( HasField fields Span - , Member (Reader Span) effects - , Member (State Span) effects -- last evaluated child's span +withTermSpans :: ( Member (Reader Span) sig + , Member (State Span) sig -- last evaluated child's span + , Recursive term + , Carrier sig m + , Base term ~ TermF syntax Location ) - => SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a) - -> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a) -withTermSpans recur term = let - updatedSpanAlg = withCurrentSpan (getField (termFAnnotation term)) (recur term) - in modifyChildSpan (getField (termFAnnotation term)) updatedSpanAlg + => Open (Open (term -> Evaluator term address value m a)) +withTermSpans recur0 recur term = let + span = locationSpan (termFAnnotation (project term)) + updatedSpanAlg = withCurrentSpan span (recur0 recur term) + in modifyChildSpan span updatedSpanAlg -resumingResolutionError :: ( Applicative (m effects) - , Effectful m - , Member Trace effects - , Effects effects +resumingResolutionError :: ( Member Trace sig + , Carrier sig m ) - => m (Resumable (BaseError ResolutionError) ': effects) a - -> m effects a + => Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff + m)) a + -> Evaluator term address value m a resumingResolutionError = runResolutionErrorWith (\ baseError -> traceError "ResolutionError" baseError *> case baseErrorException baseError of NotFoundError nameToResolve _ _ -> pure nameToResolve GoImportError pathToResolve -> pure [pathToResolve]) -resumingLoadError :: forall m address value effects a. ( Applicative (m address value effects) - , AbstractHole value - , Effectful (m address value) - , Effects effects - , Member Trace effects +resumingLoadError :: ( AbstractHole value + , Carrier sig m + , Member Trace sig , Ord address ) - => m address value (Resumable (BaseError (LoadError address value)) ': effects) a - -> m address value effects a + => Evaluator term address value (ResumableWithC (BaseError (LoadError address)) (Eff m)) a + -> Evaluator term address value m a resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of - ModuleNotFoundError _ -> pure (lowerBound @(ScopeGraph.ScopeGraph address), hole :: value)) -- TODO: Confirm `lowerBound @ScopeGraph.ScopeGraph` is what we want. + ModuleNotFoundError _ -> pure (lowerBound, hole)) -resumingEvalError :: ( Applicative (m effects) - , Effectful m - , Effects effects - , Member Fresh effects - , Member Trace effects +resumingEvalError :: ( Carrier sig m + , Member Fresh sig + , Member Trace sig ) - => m (Resumable (BaseError EvalError) ': effects) a - -> m effects a + => Evaluator term address value (ResumableWithC (BaseError EvalError) (Eff + m)) a + -> Evaluator term address value m a resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of DefaultExportError{} -> pure () ExportError{} -> pure () @@ -389,37 +362,36 @@ resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" base RationalFormatError{} -> pure 0 NoNameError -> gensym) -resumingUnspecialized :: ( Applicative (m value effects) - , AbstractHole value - , Effectful (m value) - , Effects effects - , Member Trace effects) - => m value (Resumable (BaseError (UnspecializedError value)) ': effects) a - -> m value effects a +resumingUnspecialized :: ( AbstractHole value + , Carrier sig m + , Member Trace sig + ) + => Evaluator term address value (ResumableWithC (BaseError (UnspecializedError value)) (Eff + m)) a + -> Evaluator term address value m a resumingUnspecialized = runUnspecializedWith (\ baseError -> traceError "UnspecializedError" baseError *> case baseErrorException baseError of UnspecializedError _ -> pure hole) resumingAddressError :: ( AbstractHole value - , Applicative (m address value effects) - , Effectful (m address value) - , Effects effects - , Member Trace effects + , Carrier sig m + , Member Trace sig , Show address ) - => m address value (Resumable (BaseError (AddressError address value)) ': effects) a - -> m address value effects a + => Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff + m)) a + -> Evaluator term address value m a resumingAddressError = runAddressErrorWith $ \ baseError -> traceError "AddressError" baseError *> case baseErrorException baseError of UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole -resumingValueError :: ( Applicative (m address (Value address body) effects) - , Effectful (m address (Value address body)) - , Effects effects - , Member Trace effects +resumingValueError :: ( Carrier sig m + , Member Trace sig , Show address + , Show term ) - => m address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a - -> m address (Value address body) effects a + => Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff + m)) a + -> Evaluator term address (Value term address) m a resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of CallError val -> pure val StringError val -> pure (pack (prettyShow val)) @@ -466,24 +438,15 @@ resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" b -- LookupPathError :: Path address -> HeapError address address --- TODO: Fix me. --- Replace this with ScopeGraphError? --- resumingEnvironmentError :: ( Monad (m (Hole (Maybe Name) address) value effects) --- , Effectful (m (Hole (Maybe Name) address) value) --- , Effects effects --- , Member Trace effects --- ) --- => m (Hole (Maybe Name) address) value (Resumable (BaseError (EnvironmentError (Hole (Maybe Name) address))) ': effects) a --- -> m (Hole (Maybe Name) address) value effects a --- resumingEnvironmentError = runResumableWith (\ baseError -> traceError "EnvironmentError" baseError >> (\ (FreeVariable name) -> pure (Partial (Just name))) (baseErrorException baseError)) - -resumingTypeError :: ( Alternative (m address Type (State TypeMap ': effects)) - , Effects effects - , Effectful (m address Type) - , Member Trace effects +resumingTypeError :: ( Carrier sig m + , Member NonDet sig + , Member Trace sig + , Effect sig ) - => m address Type (Resumable (BaseError TypeError) ': State TypeMap ': effects) a - -> m address Type effects a + => Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff + (StateC TypeMap (Eff + m)))) a + -> Evaluator term address Type m a resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseError *> case baseErrorException baseError of UnificationError l r -> pure l <|> pure r InfiniteType _ r -> pure r) @@ -491,5 +454,5 @@ resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseErro prettyShow :: Show a => a -> String prettyShow = hscolour TTY defaultColourPrefs False False "" False . ppShow -traceError :: (Member Trace effects, Effectful m, Show (exc resume)) => String -> BaseError exc resume -> m effects () +traceError :: (Member Trace sig, Show (exc resume), Carrier sig m) => String -> BaseError exc resume -> Evaluator term address value m () traceError prefix baseError = trace $ prefix <> ": " <> prettyShow baseError diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 17d3b850f..7495f48b8 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -1,119 +1,22 @@ -{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.IO -( Destination(..) -, Files -, Handle(..) -, IO.IOMode(..) -, NoLanguageForBlob(..) -, Source(..) -, findFiles -, findFilesInDir -, getHandle -, isDirectory -, languageForFilePath -, noLanguageForBlob -, openFileForReading -, readBlob -, readBlobFromPath -, readBlobPairs -, readBlobPairsFromHandle -, readBlobs -, readBlobsFromDir -, readBlobsFromHandle -, decodeBlobPairs -, decodeBlobs -, readFile -, readFilePair -, readProject -, readProjectFromPaths -, rethrowing -, runFiles -, stderr -, stdin -, stdout -, write -) where + ( isDirectory + , findFilesInDir + ) where + +import Prelude hiding (readFile) +import Prologue -import Control.Monad.Effect -import Control.Monad.Effect.Exception -import Control.Monad.IO.Class -import Data.Aeson -import Data.Blob -import Data.Bool -import Data.Project hiding (readFile) -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Lazy as BL -import Data.Language -import Data.Source (fromUTF8) -import Prelude hiding (readFile) -import Prologue hiding (MonadError (..), fail) import System.Directory (doesDirectoryExist) +import System.Directory.Tree (AnchoredDirTree (..)) import qualified System.Directory.Tree as Tree -import System.Directory.Tree (AnchoredDirTree(..)) -import System.Exit import System.FilePath -import System.FilePath.Glob -import qualified System.IO as IO - --- | Read a utf8-encoded file to a 'Blob'. -readFile :: forall m. MonadIO m => File -> m (Maybe Blob) -readFile (File "/dev/null" _) = pure Nothing -readFile (File path language) = do - raw <- liftIO $ B.readFile path - pure . Just . sourceBlob path language . fromUTF8 $ raw - -readFilePair :: forall m. MonadIO m => File -> File -> m BlobPair -readFilePair a b = Join <$> join (maybeThese <$> readFile a <*> readFile b) - -maybeThese :: Monad 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) - _ -> fail "expected file pair with content on at least one side" - -newtype Blobs a = Blobs { blobs :: [a] } - deriving (Generic, FromJSON) isDirectory :: MonadIO m => FilePath -> m Bool isDirectory path = liftIO (doesDirectoryExist path) -decodeBlobPairs :: BL.ByteString -> Either String [BlobPair] -decodeBlobPairs = fmap blobs <$> eitherDecode - --- | Read JSON encoded blob pairs from a handle. -readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair] -readBlobPairsFromHandle = fmap blobs <$> readFromHandle - -decodeBlobs :: BL.ByteString -> Either String [Blob] -decodeBlobs = fmap blobs <$> eitherDecode - --- | Read JSON encoded blobs from a handle. -readBlobsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob] -readBlobsFromHandle = fmap blobs <$> readFromHandle - -readBlobFromPath :: MonadIO m => File -> m Blob -readBlobFromPath file = do - maybeFile <- readFile file - maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile - -readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project -readProjectFromPaths maybeRoot path lang excludeDirs = do - isDir <- isDirectory path - let rootDir = if isDir - then fromMaybe path maybeRoot - else fromMaybe (takeDirectory path) maybeRoot - - paths <- liftIO $ findFilesInDir rootDir exts excludeDirs - blobs <- liftIO $ traverse (readBlobFromPath . toFile) paths - pure $ Project rootDir blobs lang excludeDirs - where - toFile path = File path lang - exts = extensionsForLanguage lang - -- Recursively find files in a directory. -findFilesInDir :: forall m. MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath] +findFilesInDir :: MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath] findFilesInDir path exts excludeDirs = do _:/dir <- liftIO $ Tree.build path pure $ (onlyFiles . Tree.filterDir (withExtensions exts) . Tree.filterDir (notIn excludeDirs)) dir @@ -135,106 +38,3 @@ findFilesInDir path exts excludeDirs = do | n `elem` dirs = False | otherwise = True notIn _ _ = True - -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 readFile paths' - pure (catMaybes blobs) - -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 - - --- | 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 (Exc SomeException) effs => FilePath -> Eff effs a -noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath)) - - -readBlob :: Member Files effs => File -> Eff effs Blob -readBlob = send . Read . FromPath - --- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. -readBlobs :: Member Files effs => Either (Handle 'IO.ReadMode) [File] -> Eff effs [Blob] -readBlobs (Left handle) = send (Read (FromHandle handle)) -readBlobs (Right paths) = traverse (send . Read . FromPath) paths - --- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's. -readBlobPairs :: Member Files effs => Either (Handle 'IO.ReadMode) [Both File] -> Eff effs [BlobPair] -readBlobPairs (Left handle) = send (Read (FromPairHandle handle)) -readBlobPairs (Right paths) = traverse (send . Read . FromPathPair) paths - -readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project -readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs - -findFiles :: Member Files effs => FilePath -> [String] -> [FilePath] -> Eff effs [FilePath] -findFiles dir exts = send . FindFiles dir exts - --- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'. -write :: Member Files effs => Destination -> B.Builder -> Eff effs () -write dest = send . Write dest - -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 - -data Source blob where - FromPath :: File -> Source Blob - FromHandle :: Handle 'IO.ReadMode -> Source [Blob] - FromPathPair :: Both File -> Source BlobPair - FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair] - -data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode) - --- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's. -data Files (m :: * -> *) out where - Read :: Source out -> Files m out - ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files m Project - FindFiles :: FilePath -> [String] -> [FilePath] -> Files m [FilePath] - Write :: Destination -> B.Builder -> Files m () - -instance PureEffect Files -instance Effect Files where - handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k) - handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k) - handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k) - handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k) - --- | Run a 'Files' effect in 'IO'. -runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, PureEffects effs) => Eff (Files ': effs) a -> Eff effs a -runFiles = interpret $ \ files -> case files of - Read (FromPath path) -> rethrowing (readBlobFromPath path) - Read (FromHandle handle) -> rethrowing (readBlobsFromHandle handle) - Read (FromPathPair paths) -> rethrowing (runBothWith readFilePair paths) - Read (FromPairHandle handle) -> rethrowing (readBlobPairsFromHandle handle) - ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs) - FindFiles dir exts excludeDirs -> rethrowing (findFilesInDir dir exts excludeDirs) - Write (ToPath path) builder -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) - Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder) diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index d32a0236c..bdced8a0b 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -1,59 +1,73 @@ {-# LANGUAGE GADTs, RankNTypes #-} -module Semantic.Parse ( runParse ) where +module Semantic.Parse ( runParse, runParse', parseSomeBlob ) where import Analysis.ConstructorName (ConstructorName) import Analysis.Declaration (HasDeclaration, declarationAlgebra) import Analysis.PackageDef (HasPackageDef) -import Control.Monad.Effect.Exception -import Data.AST +import Control.Effect +import Control.Effect.Error +import Control.Monad.IO.Class import Data.Blob +import Data.Either +import Data.ByteString.Builder (stringUtf8) import Data.Graph.TermVertex import Data.JSON.Fields import Data.Quieterm -import Data.Record +import Data.Location import Data.Term import Parsing.Parser -import Prologue hiding (MonadError (..)) +import Prologue import Rendering.Graph import Rendering.JSON (SomeJSON (..)) import qualified Rendering.JSON as JSON import Rendering.Renderer -import Semantic.IO (noLanguageForBlob) import Semantic.Task import Serializing.Format -runParse :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) => TermRendererĀ output -> [Blob] -> Eff effs Builder -runParse JSONTermRenderer = withParsedBlobs renderJSONError (render . renderJSONTerm) >=> serialize JSON -runParse JSONGraphTermRenderer = withParsedBlobs renderJSONError (render . renderAdjGraph) >=> serialize JSON +-- | Using the specified renderer, parse a list of 'Blob's to produce a 'Builder' output. +runParse :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, MonadIO m) => TermRendererĀ output -> [Blob] -> m Builder +runParse JSONTermRenderer = withParsedBlobs' renderJSONError (render . renderJSONTerm) >=> serialize JSON +runParse JSONGraphTermRenderer = withParsedBlobs' renderJSONError (render . renderAdjGraph) >=> serialize JSON where renderAdjGraph :: (Recursive t, ToTreeGraph TermVertex (Base t)) => Blob -> t -> JSON.JSON "trees" SomeJSON renderAdjGraph blob term = renderJSONAdjTerm blob (renderTreeGraph term) -runParse SExpressionTermRenderer = withParsedBlobs (\_ _ -> mempty) (const (serialize (SExpression ByConstructorName))) -runParse ShowTermRenderer = withParsedBlobs (\_ _ -> mempty) (const (serialize Show . quieterm)) -runParse (SymbolsTermRenderer fields) = withParsedBlobs (\_ _ -> mempty) (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON -runParse DOTTermRenderer = withParsedBlobs (\_ _ -> mempty) (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms")) +runParse SExpressionTermRenderer = withParsedBlobs (const (serialize (SExpression ByConstructorName))) +runParse ShowTermRenderer = withParsedBlobs (const (serialize Show . quieterm)) +runParse (SymbolsTermRenderer fields) = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON +runParse DOTTermRenderer = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms")) +runParse QuietTermRenderer = distributeFoldMap $ \blob -> + showTiming blob <$> time' ((parseSomeBlob blob >>= withSomeTerm (fmap (const (Right ())) . serialize Show . quieterm)) `catchError` \(SomeException e) -> pure (Left (show e))) + where + showTiming Blob{..} (res, duration) = + let status = if isLeft res then "ERR" else "OK" + in stringUtf8 (status <> "\t" <> show blobLanguage <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n") -withParsedBlobs :: - ( Member Distribute effs - , Member (Exc SomeException) effs - , Member Task effs - , Monoid output - ) - => (Blob -> String -> output) - -> ( forall syntax . - ( ConstructorName syntax - , Foldable syntax - , Functor syntax - , HasDeclaration syntax - , HasPackageDef syntax - , Show1 syntax - , ToJSONFields1 syntax - ) => Blob -> Term syntax (Record Location) -> Eff effs output - ) - -> [Blob] - -> Eff effs output -withParsedBlobs onError render = distributeFoldMap $ \blob -> +-- | For testing and running parse-examples. +runParse' :: (Member (Error SomeException) sig, Member Task sig, Monad m, Carrier sig m) => Blob -> m Builder +runParse' blob = parseSomeBlob blob >>= withSomeTerm (serialize Show . quieterm) + +type Render m output + = forall syntax + . ( ConstructorName syntax + , HasDeclaration syntax + , HasPackageDef syntax + , Foldable syntax + , Functor syntax + , Show1 syntax + , ToJSONFields1 syntax + ) + => Blob + -> Term syntax Location + -> m output + +withParsedBlobs :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Monad m, Monoid output, Carrier sig m) + => Render m output -> [Blob] -> m output +withParsedBlobs render = distributeFoldMap $ \blob -> parseSomeBlob blob >>= withSomeTerm (render blob) + +withParsedBlobs' :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Monad m, Monoid output, Carrier sig m) + => (Blob -> String -> output) -> Render m output -> [Blob] -> m output +withParsedBlobs' onError render = distributeFoldMap $ \blob -> (parseSomeBlob blob >>= withSomeTerm (render blob)) `catchError` \(SomeException e) -> pure (onError blob (show e)) -parseSomeBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] (Record Location)) +parseSomeBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] Location) parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (`parse` blob) (someParser blobLanguage) diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 6d20e9505..dd0aa6dad 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, KindSignatures, LambdaCase, TypeOperators #-} +{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Semantic.REPL ( rubyREPL @@ -7,7 +7,10 @@ module Semantic.REPL import Control.Abstract hiding (Continue, List, string) import Control.Abstract.ScopeGraph (runScopeError) import Control.Abstract.Heap (runHeapError) -import Control.Monad.IO.Class +import Control.Effect.Carrier +import Control.Effect.Resource +import Control.Effect.Sum +import Control.Effect.REPL import Data.Abstract.Address.Precise as Precise import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable hiding (string) @@ -16,25 +19,27 @@ import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package import Data.Abstract.Value.Concrete as Concrete import Data.Blob (Blob(..)) -import Data.Coerce import Data.Error (showExcerpt) +import Data.File (File (..), readBlobFromFile) import Data.Graph (topologicalSort) import Data.Language as Language import Data.List (uncons) import Data.Project import Data.Quieterm import Data.Span +import qualified Data.Text as T import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) import qualified Data.Time.LocalTime as LocalTime import Numeric (readDec) import Parsing.Parser (rubyParser) -import Prologue hiding (throwError) +import Prologue +import Semantic.Analysis import Semantic.Config (logOptionsFromConfig) import Semantic.Distribute import Semantic.Graph -import Semantic.IO as IO import Semantic.Resolution import Semantic.Task hiding (Error) +import qualified Semantic.Task.Files as Files import Semantic.Telemetry import Semantic.Timeout import Semantic.Telemetry.Log (LogOptions, Message(..), writeLogMessage) @@ -43,38 +48,15 @@ import System.Console.Haskeline import System.Directory (createDirectoryIfMissing, getHomeDirectory) import System.FilePath -data REPL (m :: * -> *) result where - Prompt :: REPL m (Maybe String) - Output :: String -> REPL m () - -prompt :: (Effectful m, Member REPL effects) => m effects (Maybe String) -prompt = send Prompt - -output :: (Effectful m, Member REPL effects) => String -> m effects () -output s = send (Output s) - - data Quit = Quit deriving Show instance Exception Quit - -instance PureEffect REPL -instance Effect REPL where - handleState state handler (Request Prompt k) = Request Prompt (handler . (<$ state) . k) - handleState state handler (Request (Output s) k) = Request (Output s) (handler . (<$ state) . k) - - -runREPL :: (Effectful m, MonadIO (m effects), PureEffects effects) => Prefs -> Settings IO -> m (REPL ': effects) a -> m effects a -runREPL prefs settings = interpret $ \case - Prompt -> liftIO (runInputTWithPrefs prefs settings (getInputLine (cyan <> "repl: " <> plain))) - Output s -> liftIO (runInputTWithPrefs prefs settings (outputStrLn s)) - rubyREPL = repl (Proxy @'Language.Ruby) rubyParser -repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runTimeout (runM . runDistribute) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . IO.runFiles . runResolution . runTaskF $ do - blobs <- catMaybes <$> traverse IO.readFile (flip File (Language.reflect proxy) <$> paths) +repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . Files.runFiles . runResolution . runTaskF $ do + blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths) package <- fmap (fmap quieterm) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) []) modules <- topologicalSort <$> runImportGraphToModules proxy (snd <$> package) homeDir <- liftIO getHomeDirectory @@ -91,10 +73,11 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD . fmap snd . runState ([] @Breakpoint) . runReader Step - . runTermEvaluator @_ @_ @(Value Precise (ConcreteEff Precise _)) - . runPrintingTrace - . runState lowerBound - . runFresh 0 + . runEvaluator + . id @(Evaluator _ Precise (Value _ Precise) _ _) + . raiseHandler runTraceByPrinting + . runHeap + . raiseHandler runFresh . fmap reassociate . runLoadError . runUnspecialized @@ -104,46 +87,54 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD . runResolutionError . runAddressError . runValueError - . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise (Value Precise (ConcreteEff Precise _))))))) - . raiseHandler (runModules (ModuleTable.modulePaths (packageModules (snd <$> package)))) - . runReader (packageInfo package) - . runState (lowerBound @Span) - . runReader (lowerBound @Span) - $ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules + . runModuleTable + . runModules (ModuleTable.modulePaths (packageModules (snd <$> package))) + . raiseHandler (runReader (packageInfo package)) + . raiseHandler (runState (lowerBound @Span)) + . raiseHandler (runReader (lowerBound @Span)) + $ evaluate proxy id (evalTerm (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package))))) modules -- TODO: REPL for typechecking/abstract semantics -- TODO: drive the flow from within the REPL instead of from without -runTelemetryIgnoringStat :: (Effectful m, MonadIO (m effects), PureEffects effects) => LogOptions -> m (Telemetry : effects) a -> m effects a -runTelemetryIgnoringStat logOptions = interpret $ \case - WriteStat{} -> pure () - WriteLog level message pairs -> do - time <- liftIO Time.getCurrentTime - zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time) - writeLogMessage logOptions (Message level message pairs zonedTime) -step :: ( Member (Exc SomeException) effects - , Member REPL effects - , Member (Reader ModuleInfo) effects - , Member (Reader Span) effects - , Member (Reader Step) effects - , Member (State [Breakpoint]) effects +runTelemetryIgnoringStat :: (Carrier sig m, MonadIO m) => LogOptions -> Eff (TelemetryIgnoringStatC m) a -> m a +runTelemetryIgnoringStat logOptions = flip runTelemetryIgnoringStatC logOptions . interpret + +newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: LogOptions -> m a } + +instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryIgnoringStatC m) where + ret = TelemetryIgnoringStatC . const . ret + eff op = TelemetryIgnoringStatC (\ logOptions -> handleSum (eff . handleReader logOptions runTelemetryIgnoringStatC) (\case + WriteStat _ k -> runTelemetryIgnoringStatC k logOptions + WriteLog level message pairs k -> do + time <- liftIO Time.getCurrentTime + zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time) + writeLogMessage logOptions (Message level message pairs zonedTime) + runTelemetryIgnoringStatC k logOptions) op) + +step :: ( Member (Error SomeException) sig + , Member REPL sig + , Member (Reader ModuleInfo) sig + , Member (Reader Span) sig + , Member (Reader Step) sig + , Member (State [Breakpoint]) sig , Show address + , Carrier sig m ) => [(ModulePath, Blob)] - -> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a) - -> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a) -step blobs recur term = do + -> Open (Open (term -> Evaluator term address value m a)) +step blobs recur0 recur term = do break <- shouldBreak if break then do list - runCommands (recur term) + runCommands (recur0 recur term) else - recur term + recur0 recur term where list = do path <- asks modulePath span <- ask - maybe (pure ()) (\ blob -> output (showExcerpt True span blob "")) (Prelude.lookup path blobs) + maybe (pure ()) (\ blob -> output (T.pack (showExcerpt True span blob ""))) (Prelude.lookup path blobs) help = do output "Commands available from the prompt:" output "" @@ -153,10 +144,15 @@ step blobs recur term = do output " :continue continue evaluation until the next breakpoint" output " :show bindings show the current bindings" output " :quit, :q, :abandon abandon the current evaluation and exit the repl" + -- TODO: showScopeGraph option for REPL. + -- showBindings = do + -- bindings <- Env.head <$> getEnv + -- output . T.pack $ unlines (uncurry showBinding <$> Env.pairs bindings) + -- showBinding name addr = show name <> " = " <> show addr runCommand run [":step"] = local (const Step) run runCommand run [":continue"] = local (const Continue) run runCommand run [":break", s] - | [(i, "")] <- readDec s = modify' (OnLine i :) >> runCommands run + | [(i, "")] <- readDec (T.unpack s) = modify (OnLine i :) >> runCommands run -- TODO: :show breakpoints -- TODO: :delete breakpoints runCommand run [":list"] = list >> runCommands run @@ -168,10 +164,10 @@ step blobs recur term = do runCommand run [":help"] = help >> runCommands run runCommand run [":?"] = help >> runCommands run runCommand run [] = runCommands run - runCommand run other = output ("unknown command '" <> unwords other <> "'") >> output "use :? for help" >> runCommands run + runCommand run other = output ("unknown command '" <> T.unwords other <> "'") >> output "use :? for help" >> runCommands run runCommands run = do - str <- prompt - maybe (runCommands run) (runCommand run . words) str + str <- prompt "repl: " + maybe (runCommands run) (runCommand run . T.words) str newtype Breakpoint @@ -189,7 +185,7 @@ data Step -- TODO: StepLocal/StepModule -shouldBreak :: (Member (State [Breakpoint]) effects, Member (Reader Span) effects, Member (Reader Step) effects) => TermEvaluator term address value effects Bool +shouldBreak :: (Member (State [Breakpoint]) sig, Member (Reader Span) sig, Member (Reader Step) sig, Carrier sig m) => Evaluator term address value m Bool shouldBreak = do step <- ask case step of @@ -202,10 +198,3 @@ shouldBreak = do | n >= posLine spanStart , n <= posLine spanEnd = True | otherwise = False - - -cyan :: String -cyan = "\ESC[1;36m\STX" - -plain :: String -plain = "\ESC[0m\STX" diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index cdb3766ab..ce8bfda59 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -1,25 +1,30 @@ -{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.Resolution ( Resolution (..) , nodeJSResolutionMap , resolutionMap , runResolution + , ResolutionC(..) ) where -import Control.Monad.Effect +import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Sum import Data.Aeson import Data.Aeson.Types (parseMaybe) import Data.Blob +import Data.Coerce +import Data.File import Data.Project import qualified Data.Map as Map import Data.Source import Data.Language import Prologue -import Semantic.IO +import Semantic.Task.Files import System.FilePath.Posix -nodeJSResolutionMap :: Member Files effs => FilePath -> Text -> [FilePath] -> Eff effs (Map FilePath FilePath) +nodeJSResolutionMap :: (Member Files sig, Carrier sig m, Monad m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath) nodeJSResolutionMap rootDir prop excludeDirs = do files <- findFiles rootDir [".json"] excludeDirs let packageFiles = file <$> filter ((==) "package.json" . takeFileName) files @@ -34,22 +39,31 @@ nodeJSResolutionMap rootDir prop excludeDirs = do where relPkgDotJSONPath = makeRelative rootDir path relEntryPath x = takeDirectory relPkgDotJSONPath x -resolutionMap :: Member Resolution effs => Project -> Eff effs (Map FilePath FilePath) +resolutionMap :: (Member Resolution sig, Carrier sig m) => Project -> m (Map FilePath FilePath) resolutionMap Project{..} = case projectLanguage of - TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs) - JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs) - _ -> send NoResolution + TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs ret) + JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs ret) + _ -> send (NoResolution ret) -data Resolution (m :: * -> *) output where - NodeJSResolution :: FilePath -> Text -> [FilePath] -> Resolution m (Map FilePath FilePath) - NoResolution :: Resolution m (Map FilePath FilePath) +data Resolution (m :: * -> *) k + = NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k) + | NoResolution (Map FilePath FilePath -> k) + deriving (Functor) + +instance HFunctor Resolution where + hmap _ = coerce -instance PureEffect Resolution instance Effect Resolution where - handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (dist . (<$ c) . k) - handleState c dist (Request NoResolution k) = Request NoResolution (dist . (<$ c) . k) + handle state handler (NodeJSResolution path key paths k) = NodeJSResolution path key paths (handler . (<$ state) . k) + handle state handler (NoResolution k) = NoResolution (handler . (<$ state) . k) -runResolution :: (Member Files effs, PureEffects effs) => Eff (Resolution ': effs) a -> Eff effs a -runResolution = interpret $ \ res -> case res of - NodeJSResolution dir prop excludeDirs -> nodeJSResolutionMap dir prop excludeDirs - NoResolution -> pure Map.empty +runResolution :: (Member Files sig, Carrier sig m, Monad m) => Eff (ResolutionC m) a -> m a +runResolution = runResolutionC . interpret + +newtype ResolutionC m a = ResolutionC { runResolutionC :: m a } + +instance (Member Files sig, Carrier sig m, Monad m) => Carrier (Resolution :+: sig) (ResolutionC m) where + ret = ResolutionC . ret + eff = ResolutionC . handleSum (eff . handleCoercible) (\case + NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k + NoResolution k -> runResolutionC (k Map.empty)) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index b09aae667..96f8b26a8 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Semantic.Task ( Task , TaskEff , Level(..) , RAlgebra -- * I/O -, IO.readBlob -, IO.readBlobs -, IO.readBlobPairs -, IO.readProject -, IO.findFiles -, IO.write +, Files.readBlob +, Files.readBlobs +, Files.readBlobPairs +, Files.readProject +, Files.findFiles +, Files.write -- * Module Resolution , resolutionMap , Resolution @@ -18,6 +18,7 @@ module Semantic.Task , writeLog , writeStat , time +, time' -- * High-level flow , parse , analyze @@ -41,13 +42,15 @@ module Semantic.Task , runTaskWithConfig , runTraceInTelemetry , runTaskF +-- * Exceptions +, ParserCancelled(..) -- * Re-exports , Distribute , Eff -, Exc +, Error , Lift , throwError -, SomeException +, SomeException(..) , Telemetry ) where @@ -55,19 +58,24 @@ import Analysis.Decorator (decoratorWithAlgebra) import qualified Assigning.Assignment as Assignment import qualified Assigning.Assignment.Deterministic as Deterministic import qualified Control.Abstract as Analysis +import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Error +import Control.Effect.Reader +import Control.Effect.Resource +import Control.Effect.Sum +import Control.Effect.Trace import Control.Monad -import Control.Monad.Effect -import Control.Monad.Effect.Exception -import Control.Monad.Effect.Reader -import Control.Monad.Effect.Trace +import Control.Monad.IO.Class import Data.Blob import Data.Bool import Data.ByteString.Builder +import Data.Coerce import Data.Diff import Data.Duration import qualified Data.Error as Error import Data.Language (Language) -import Data.Record +import Data.Location import Data.Source (Source) import Data.Sum import qualified Data.Syntax as Syntax @@ -77,127 +85,192 @@ import Diffing.Interpreter import Parsing.CMark import Parsing.Parser import Parsing.TreeSitter -import Prologue hiding (MonadError (..), project) +import Prologue hiding (project) import Semantic.Config import Semantic.Distribute +import qualified Semantic.Task.Files as Files import Semantic.Timeout -import qualified Semantic.IO as IO import Semantic.Resolution import Semantic.Telemetry import Serializing.Format hiding (Options) import System.Exit (die) -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap' -type TaskEff = Eff '[ Task - , Resolution - , IO.Files - , Reader Config - , Trace - , Telemetry - , Exc SomeException - , Timeout - , Distribute - , Lift IO - ] +type TaskEff + = Eff (TaskC + ( Eff (ResolutionC + ( Eff (Files.FilesC + ( Eff (ReaderC Config + ( Eff (TraceInTelemetryC + ( Eff (TelemetryC + ( Eff (ErrorC SomeException + ( Eff (TimeoutC + ( Eff (ResourceC + ( Eff (DistributeC + ( Eff (LiftC IO))))))))))))))))))))) -- | A function to render terms or diffs. type Renderer i o = i -> o -- | A task which parses a 'Blob' with the given 'Parser'. -parse :: Member Task effs => Parser term -> Blob -> Eff effs term -parse parser = send . Parse parser +parse :: (Member Task sig, Carrier sig m) + => Parser term + -> Blob + -> m term +parse parser blob = send (Parse parser blob ret) --- | A task running some 'Analysis.TermEvaluator' to completion. -analyze :: Member Task effs => (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator term address value effects a -> Eff effs result -analyze interpret analysis = send (Analyze interpret analysis) +-- | A task running some 'Analysis.Evaluator' to completion. +analyze :: (Member Task sig, Carrier sig m) + => (Analysis.Evaluator term address value m a -> result) + -> Analysis.Evaluator term address value m a + -> m result +analyze interpret analysis = send (Analyze interpret analysis ret) -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function. -decorate :: (Functor f, Member Task effs) => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Eff effs (Term f (Record (field ': fields))) -decorate algebra = send . Decorate algebra +decorate :: (Functor f, Member Task sig, Carrier sig m) + => RAlgebra (TermF f Location) (Term f Location) field + -> Term f Location + -> m (Term f field) +decorate algebra term = send (Decorate algebra term ret) -- | A task which diffs a pair of terms using the supplied 'Differ' function. -diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task effs) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Eff effs (Diff syntax (Record fields1) (Record fields2)) -diff terms = send (Semantic.Task.Diff terms) +diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Carrier sig m) + => These (Term syntax ann) (Term syntax ann) + -> m (Diff syntax ann ann) +diff terms = send (Semantic.Task.Diff terms ret) -- | A task which renders some input using the supplied 'Renderer' function. -render :: Member Task effs => Renderer input output -> input -> Eff effs output -render renderer = send . Render renderer +render :: (Member Task sig, Carrier sig m) + => Renderer input output + -> input + -> m output +render renderer input = send (Render renderer input ret) -serialize :: Member Task effs => Format input -> input -> Eff effs Builder -serialize format = send . Serialize format +serialize :: (Member Task sig, Carrier sig m) + => Format input + -> input + -> m Builder +serialize format input = send (Serialize format input ret) -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'. -- -- > runTask = runTaskWithOptions defaultOptions -runTask :: TaskEff a -> IO a +runTask :: TaskEff a + -> IO a runTask = runTaskWithOptions defaultOptions -- | Execute a 'TaskEff' with the passed 'Options', yielding its result value in 'IO'. -runTaskWithOptions :: Options -> TaskEff a -> IO a +runTaskWithOptions :: Options + -> TaskEff a + -> IO a runTaskWithOptions opts task = withOptions opts (\ config logger statter -> runTaskWithConfig config logger statter task) >>= either (die . displayException) pure -withOptions :: Options -> (Config -> LogQueue -> StatQueue -> IO a) -> IO a +withOptions :: Options + -> (Config -> LogQueue -> StatQueue -> IO a) + -> IO a withOptions options with = do config <- defaultConfig options withTelemetry config (\ (TelemetryQueues logger statter _) -> with config logger statter) -- | Execute a 'TaskEff' yielding its result value in 'IO'. -runTaskWithConfig :: Config -> LogQueue -> StatQueue -> TaskEff a -> IO (Either SomeException a) +runTaskWithConfig :: Config + -> LogQueue + -> StatQueue + -> TaskEff a + -> IO (Either SomeException a) runTaskWithConfig options logger statter task = do (result, stat) <- withTiming "run" [] $ do let run :: TaskEff a -> IO (Either SomeException a) run = runM . runDistribute - . runTimeout (runM . runDistribute) + . runResource (runM . runDistribute) + . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError . runTelemetry logger statter . runTraceInTelemetry . runReader options - . IO.runFiles + . Files.runFiles . runResolution . runTaskF run task queueStat statter stat pure result -runTraceInTelemetry :: (Member Telemetry effects, PureEffects effects) => Eff (Trace ': effects) a -> Eff effects a -runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str []) +runTraceInTelemetry :: (Member Telemetry sig, Carrier sig m, Monad m) + => Eff (TraceInTelemetryC m) a + -> m a +runTraceInTelemetry = runTraceInTelemetryC . interpret + +newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a } + +instance (Member Telemetry sig, Carrier sig m, Monad m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where + ret = TraceInTelemetryC . ret + eff = TraceInTelemetryC . handleSum + (eff . handleCoercible) + (\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) -- | An effect describing high-level tasks to be performed. -data Task (m :: * -> *) output where - Parse :: Parser term -> Blob -> Task m term - Analyze :: (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator term address value effects a -> Task m result - Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task m (Term f (Record (field ': fields))) - Diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task m (Diff syntax (Record fields1) (Record fields2)) - Render :: Renderer input output -> input -> Task m output - Serialize :: Format input -> input -> Task m Builder +data Task (m :: * -> *) k + = forall term . Parse (Parser term) Blob (term -> k) + | forall term address value m a result . Analyze (Analysis.Evaluator term address value m a -> result) (Analysis.Evaluator term address value m a) (result -> k) + | forall f field . Functor f => Decorate (RAlgebra (TermF f Location) (Term f Location) field) (Term f Location) (Term f field -> k) + | forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> k) + | forall input output . Render (Renderer input output) input (output -> k) + | forall input . Serialize (Format input) input (Builder -> k) + +deriving instance Functor (Task m) + +instance HFunctor Task where + hmap _ = coerce -instance PureEffect Task instance Effect Task where - handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (dist . (<$ c) . k) - handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (dist . (<$ c) . k) - handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (dist . (<$ c) . k) - handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (dist . (<$ c) . k) - handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (dist . (<$ c) . k) - handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k) + handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k) + handle state handler (Analyze run analysis k) = Analyze run analysis (handler . (<$ state) . k) + handle state handler (Decorate decorator term k) = Decorate decorator term (handler . (<$ state) . k) + handle state handler (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (handler . (<$ state) . k) + handle state handler (Render renderer input k) = Render renderer input (handler . (<$ state) . k) + handle state handler (Serialize format input k) = Serialize format input (handler . (<$ state) . k) -- | Run a 'Task' effect by performing the actions in 'IO'. -runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Eff (Task ': effs) a -> Eff effs a -runTaskF = interpret $ \ task -> case task of - Parse parser blob -> runParser blob parser - Analyze interpret analysis -> pure (interpret analysis) - Decorate algebra term -> pure (decoratorWithAlgebra algebra term) - Semantic.Task.Diff terms -> pure (diffTermPair terms) - Render renderer input -> pure (renderer input) - Serialize format input -> do - formatStyle <- asks (bool Plain Colourful . configIsTerminal) - pure (runSerialize formatStyle format input) +runTaskF :: ( Member (Error SomeException) sig + , Member (Lift IO) sig + , Member (Reader Config) sig + , Member Resource sig + , Member Telemetry sig + , Member Timeout sig + , Member Trace sig + , Carrier sig m + , MonadIO m + ) + => Eff (TaskC m) a + -> m a +runTaskF = runTaskC . interpret + +newtype TaskC m a = TaskC { runTaskC :: m a } + +instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Config) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) => Carrier (Task :+: sig) (TaskC m) where + ret = TaskC . ret + eff = TaskC . handleSum (eff . handleCoercible) (\case + Parse parser blob k -> runParser blob parser >>= runTaskC . k + Analyze interpret analysis k -> runTaskC (k (interpret analysis)) + Decorate algebra term k -> runTaskC (k (decoratorWithAlgebra algebra term)) + Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms)) + Render renderer input k -> runTaskC (k (renderer input)) + Serialize format input k -> do + formatStyle <- asks (bool Plain Colourful . configIsTerminal) + runTaskC (k (runSerialize formatStyle format input))) -- | Log an 'Error.Error' at the specified 'Level'. -logError :: Member Telemetry effs => Config -> Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs () +logError :: (Member Telemetry sig, Carrier sig m) + => Config + -> Level + -> Blob + -> Error.Error String + -> [(String, String)] + -> m () logError Config{..} level blob err = writeLog level (Error.formatError configLogPrintSource configIsTerminal blob err) data ParserCancelled = ParserTimedOut FilePath Language | AssignmentTimedOut FilePath Language @@ -206,7 +279,10 @@ data ParserCancelled = ParserTimedOut FilePath Language | AssignmentTimedOut Fil instance Exception ParserCancelled -- | Parse a 'Blob' in 'IO'. -runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Blob -> Parser term -> Eff effs term +runParser :: (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Config) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) + => Blob + -> Parser term + -> m term runParser blob@Blob{..} parser = case parser of ASTParser language -> time "parse.tree_sitter_ast_parse" languageTag $ do @@ -223,25 +299,27 @@ runParser blob@Blob{..} parser = case parser of in length term `seq` pure term SomeParser parser -> SomeTerm <$> runParser blob parser where languageTag = pure . (,) ("language" :: String) . show $ blobLanguage - errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) (Record Assignment.Location) -> [Error.Error String] - errors = cata $ \ (In a syntax) -> case syntax of - _ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError (getField a) err] + errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) Assignment.Location -> [Error.Error String] + errors = cata $ \ (In Assignment.Location{..} syntax) -> case syntax of + _ | Just err@Syntax.Error{} <- project syntax -> [Syntax.unError locationSpan err] _ -> fold syntax runAssignment :: ( Apply Foldable syntaxes , Apply Functor syntaxes , Element Syntax.Error syntaxes - , Member (Exc SomeException) effs - , Member (Lift IO) effs - , Member (Reader Config) effs - , Member Telemetry effs - , Member Timeout effs - , Member Trace effs - , PureEffects effs + , Member (Error SomeException) sig + , Member (Lift IO) sig + , Member (Reader Config) sig + , Member Resource sig + , Member Telemetry sig + , Member Timeout sig + , Member Trace sig + , Carrier sig m + , MonadIO m ) - => (Source -> assignment (Term (Sum syntaxes) (Record Assignment.Location)) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) (Record Assignment.Location))) + => (Source -> assignment (Term (Sum syntaxes) Assignment.Location) -> ast -> Either (Error.Error String) (Term (Sum syntaxes) Assignment.Location)) -> Parser ast - -> assignment (Term (Sum syntaxes) (Record Assignment.Location)) - -> Eff effs (Term (Sum syntaxes) (Record Assignment.Location)) + -> assignment (Term (Sum syntaxes) Assignment.Location) + -> m (Term (Sum syntaxes) Assignment.Location) runAssignment assign parser assignment = do config <- ask let blobFields = ("path", if configLogPrintSource config then blobPath else "") : languageTag @@ -262,6 +340,7 @@ runParser blob@Blob{..} parser = case parser of Just "ParseError" -> do writeStat (increment "parse.parse_errors" languageTag) logError config Warning blob err (("task", "parse") : blobFields) + when (optionsFailOnParseError (configOptions config)) $ throwError (toException err) _ -> do writeStat (increment "parse.assign_warnings" languageTag) logError config Warning blob err (("task", "assign") : blobFields) diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs new file mode 100644 index 000000000..a2e6e9a42 --- /dev/null +++ b/src/Semantic/Task/Files.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE ExistentialQuantification, GADTs, LambdaCase, KindSignatures, TypeOperators, UndecidableInstances #-} + +module Semantic.Task.Files + ( Files + , Destination (..) + , Source (..) + , runFiles + , readBlob + , readBlobs + , readBlobPairs + , readProject + , findFiles + , write + , Handle (..) + , FilesC(..) + ) where + +import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Error +import Control.Effect.Sum +import Control.Exception as Exc +import qualified Data.ByteString.Builder as B +import Data.Blob +import Data.Coerce +import Data.File +import Data.Handle +import Data.Language +import Data.Project hiding (readFile) +import Prelude hiding (readFile) +import Prologue +import Semantic.IO +import qualified System.IO as IO + +data Source blob where + FromPath :: File -> Source Blob + FromHandle :: Handle 'IO.ReadMode -> Source [Blob] + FromPathPair :: Both File -> Source BlobPair + FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair] + +data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode) + +-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's. +data Files (m :: * -> *) k + = forall a . Read (Source a) (a -> k) + | ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> k) + | FindFiles FilePath [String] [FilePath] ([FilePath] -> k) + | Write Destination B.Builder k + +deriving instance Functor (Files m) + +instance HFunctor Files where + hmap _ = coerce + +instance Effect Files where + handle state handler (Read source k) = Read source (handler . (<$ state) . k) + handle state handler (ReadProject rootDir dir language excludeDirs k) = ReadProject rootDir dir language excludeDirs (handler . (<$ state) . k) + handle state handler (FindFiles dir exts paths k) = FindFiles dir exts paths (handler . (<$ state) . k) + handle state handler (Write destination builder k) = Write destination builder (handler (k <$ state)) + +-- | Run a 'Files' effect in 'IO'. +runFiles :: (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Eff (FilesC m) a -> m a +runFiles = runFilesC . interpret + +newtype FilesC m a = FilesC { runFilesC :: m a } + +instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where + ret = FilesC . ret + eff = FilesC . handleSum (eff . handleCoercible) (\case + Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + Read (FromHandle handle) k -> (readBlobsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> runFilesC k + Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> runFilesC k) + + +readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob +readBlob file = send (Read (FromPath file) ret) + +-- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. +readBlobs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob] +readBlobs (Left handle) = send (Read (FromHandle handle) ret) +readBlobs (Right paths) = traverse (send . flip Read ret . FromPath) paths + +-- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's. +readBlobPairs :: (Member Files sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair] +readBlobPairs (Left handle) = send (Read (FromPairHandle handle) ret) +readBlobPairs (Right paths) = traverse (send . flip Read ret . FromPathPair) paths + +readProject :: (Member Files sig, Carrier sig m) => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project +readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs ret) + +findFiles :: (Member Files sig, Carrier sig m) => FilePath -> [String] -> [FilePath] -> m [FilePath] +findFiles dir exts paths = send (FindFiles dir exts paths ret) + +-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'. +write :: (Member Files sig, Carrier sig m) => Destination -> B.Builder -> m () +write dest builder = send (Write dest builder (ret ())) + + +-- | Generalize 'Exc.catch' to other 'MonadIO' contexts for the handler and result. +catchIO :: ( Exc.Exception exc + , MonadIO m + ) + => IO a + -> (exc -> m a) + -> m a +catchIO m handler = liftIO (Exc.try m) >>= either handler pure diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index f112eeb8d..c4515beb7 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-} module Semantic.Telemetry ( -- Async telemetry interface @@ -42,14 +42,20 @@ module Semantic.Telemetry , writeLog , writeStat , time +, time' , Telemetry(..) , runTelemetry +, TelemetryC(..) , ignoreTelemetry +, IgnoreTelemetryC(..) ) where +import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Sum import Control.Exception -import Control.Monad.Effect import Control.Monad.IO.Class +import Data.Coerce import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) import qualified Data.Time.LocalTime as LocalTime import Network.HTTP.Client @@ -114,38 +120,57 @@ queueStat q = liftIO . writeAsyncQueue q -- Eff interface -- | A task which logs a message at a specific log level to stderr. -writeLog :: Member Telemetry effs => Level -> String -> [(String, String)] -> Eff effs () -writeLog level message pairs = send (WriteLog level message pairs) +writeLog :: (Member Telemetry sig, Carrier sig m) => Level -> String -> [(String, String)] -> m () +writeLog level message pairs = send (WriteLog level message pairs (ret ())) -- | A task which writes a stat. -writeStat :: Member Telemetry effs => Stat -> Eff effs () -writeStat stat = send (WriteStat stat) +writeStat :: (Member Telemetry sig, Carrier sig m) => Stat -> m () +writeStat stat = send (WriteStat stat (ret ())) -- | A task which measures and stats the timing of another task. -time :: (Member (Lift IO) effs, Member Telemetry effs) => String -> [(String, String)] -> Eff effs output -> Eff effs output +time :: (Member Telemetry sig, Carrier sig m, MonadIO m) => String -> [(String, String)] -> m output -> m output time statName tags task = do (a, stat) <- withTiming statName tags task a <$ writeStat stat +-- | A task which measures and returns the timing of another task. +time' :: MonadIO m => m output -> m (output, Double) +time' = withTiming' -- | Statting and logging effects. -data Telemetry (m :: * -> *) output where - WriteStat :: Stat -> Telemetry m () - WriteLog :: Level -> String -> [(String, String)] -> Telemetry m () +data Telemetry (m :: * -> *) k + = WriteStat Stat k + | WriteLog Level String [(String, String)] k + deriving (Functor) + +instance HFunctor Telemetry where + hmap _ = coerce -instance PureEffect Telemetry instance Effect Telemetry where - handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (dist . (<$ c) . k) - handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (dist . (<$ c) . k) + handle state handler (WriteStat stat k) = WriteStat stat (handler (k <$ state)) + handle state handler (WriteLog level message pairs k) = WriteLog level message pairs (handler (k <$ state)) -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to. -runTelemetry :: (Member (Lift IO) effects, PureEffects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a -runTelemetry logger statter = interpret (\ t -> case t of - WriteStat stat -> queueStat statter stat - WriteLog level message pairs -> queueLogMessage logger level message pairs) +runTelemetry :: (Carrier sig m, MonadIO m) => LogQueue -> StatQueue -> Eff (TelemetryC m) a -> m a +runTelemetry logger statter = flip runTelemetryC (logger, statter) . interpret + +newtype TelemetryC m a = TelemetryC { runTelemetryC :: (LogQueue, StatQueue) -> m a } + +instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where + ret = TelemetryC . const . ret + eff op = TelemetryC (\ queues -> handleSum (eff . handleReader queues runTelemetryC) (\case + WriteStat stat k -> queueStat (snd queues) stat *> runTelemetryC k queues + WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues) op) + -- | Run a 'Telemetry' effect by ignoring statting/logging. -ignoreTelemetry :: PureEffects effs => Eff (Telemetry ': effs) a -> Eff effs a -ignoreTelemetry = interpret (\ t -> case t of - WriteStat{} -> pure () - WriteLog{} -> pure ()) +ignoreTelemetry :: Carrier sig m => Eff (IgnoreTelemetryC m) a -> m a +ignoreTelemetry = runIgnoreTelemetryC . interpret + +newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a } + +instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where + ret = IgnoreTelemetryC . ret + eff = handleSum (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) (\case + WriteStat _ k -> k + WriteLog _ _ _ k -> k) diff --git a/src/Semantic/Telemetry/Log.hs b/src/Semantic/Telemetry/Log.hs index ce826266d..9553c0a8c 100644 --- a/src/Semantic/Telemetry/Log.hs +++ b/src/Semantic/Telemetry/Log.hs @@ -8,7 +8,6 @@ module Semantic.Telemetry.Log , writeLogMessage ) where -import Control.Monad.IO.Class import Data.Error (withSGRCode) import Data.List (intersperse) import qualified Data.Time.Format as Time diff --git a/src/Semantic/Telemetry/Stat.hs b/src/Semantic/Telemetry/Stat.hs index 1bb313a14..d969e8302 100644 --- a/src/Semantic/Telemetry/Stat.hs +++ b/src/Semantic/Telemetry/Stat.hs @@ -7,6 +7,7 @@ module Semantic.Telemetry.Stat , gauge , timing , withTiming +, withTiming' , histogram , set , Stat @@ -26,7 +27,6 @@ module Semantic.Telemetry.Stat ) where -import Control.Monad.IO.Class import qualified Data.ByteString.Char8 as B import Data.List (intercalate) import Data.List.Split (splitOneOf) @@ -80,14 +80,20 @@ gauge n v = Stat n (Gauge v) timing :: String -> Double -> Tags -> Stat timing n v = Stat n (Timer v) --- | Run an IO Action and record timing +-- | Run an IO Action and record timing in a Stat. withTiming :: MonadIO io => String -> Tags -> io a -> io (a, Stat) withTiming name tags action = do + (res, duration) <- withTiming' action + pure (res, timing name duration tags) + +-- | Run an IO Action and record timing. +withTiming' :: MonadIO io => io a -> io (a, Double) +withTiming' action = do start <- liftIO Time.getCurrentTime result <- action end <- liftIO Time.getCurrentTime let duration = realToFrac (Time.diffUTCTime end start * 1000) - pure (result, timing name duration tags) + pure (result, duration) -- | Histogram measurement. histogram :: String -> Double -> Tags -> Stat diff --git a/src/Semantic/Timeout.hs b/src/Semantic/Timeout.hs index 27c4560fb..3af68f870 100644 --- a/src/Semantic/Timeout.hs +++ b/src/Semantic/Timeout.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE TypeOperators, GADTs, RankNTypes #-} +{-# LANGUAGE ExistentialQuantification, TypeOperators, RankNTypes, UndecidableInstances #-} module Semantic.Timeout ( timeout , Timeout , runTimeout +, TimeoutC(..) , Duration(..) ) where -import Control.Monad.Effect +import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Sum import Control.Monad.IO.Class import Data.Duration import qualified System.Timeout as System @@ -14,21 +17,36 @@ import qualified System.Timeout as System -- | Run an action with a timeout. Returns 'Nothing' when no result is available -- within the specified duration. Uses 'System.Timeout.timeout' so all caveats -- about not operating over FFI boundaries apply. -timeout :: (Member Timeout effs) => Duration -> Eff effs output -> Eff effs (Maybe output) -timeout n = send . Timeout n +timeout :: (Member Timeout sig, Carrier sig m) => Duration -> m output -> m (Maybe output) +timeout n = send . flip (Timeout n) ret -- | 'Timeout' effects run other effects, aborting them if they exceed the -- specified duration. -data Timeout task output where - Timeout :: Duration -> task output -> Timeout task (Maybe output) +data Timeout m k + = forall a . Timeout Duration (m a) (Maybe a -> k) + +deriving instance Functor (Timeout m) + +instance HFunctor Timeout where + hmap f (Timeout n task k) = Timeout n (f task) k -instance PureEffect Timeout instance Effect Timeout where - handleState c dist (Request (Timeout n task) k) = Request (Timeout n (dist (task <$ c))) (dist . maybe (k Nothing <$ c) (fmap (k . Just))) + handle state handler (Timeout n task k) = Timeout n (handler (task <$ state)) (handler . maybe (k Nothing <$ state) (fmap (k . Just))) -- | Evaulate a 'Timeoute' effect. -runTimeout :: (Member (Lift IO) effects, PureEffects effects) - => (forall x . Eff effects x -> IO x) - -> Eff (Timeout ': effects) a - -> Eff effects a -runTimeout handler = interpret (\ (Timeout n task) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeout handler task)))) +runTimeout :: (Carrier sig m, MonadIO m) + => (forall x . m x -> IO x) + -> Eff (TimeoutC m) a + -> m a +runTimeout handler = runTimeoutC handler . interpret + +newtype TimeoutC m a = TimeoutC ((forall x . m x -> IO x) -> m a) + +runTimeoutC :: (forall x . m x -> IO x) -> TimeoutC m a -> m a +runTimeoutC f (TimeoutC m) = m f + +instance (Carrier sig m, MonadIO m) => Carrier (Timeout :+: sig) (TimeoutC m) where + ret a = TimeoutC (const (ret a)) + eff op = TimeoutC (\ handler -> handleSum + (eff . handlePure (runTimeoutC handler)) + (\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k) op) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 7ff377b61..8a8856bbf 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -2,16 +2,15 @@ {-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists #-} module Semantic.Util where -import Prelude hiding (id, (.), readFile) +import Prelude hiding (readFile) -import Analysis.Abstract.Caching +import Analysis.Abstract.Caching.FlowSensitive import Analysis.Abstract.Collecting import Control.Abstract -import Control.Abstract.Heap (runHeapError) -import Control.Abstract.ScopeGraph (runScopeError) -import Control.Category +import Control.Abstract.Heap (runHeapError) +import Control.Abstract.ScopeGraph (runScopeError) import Control.Exception (displayException) -import Control.Monad.Effect.Trace (runPrintingTrace) +import Control.Effect.Trace (runTraceByPrinting) import Data.Abstract.Address.Monovariant as Monovariant import Data.Abstract.Address.Precise as Precise import Data.Abstract.Evaluatable @@ -21,31 +20,29 @@ import Data.Abstract.Package import Data.Abstract.Value.Concrete as Concrete import Data.Abstract.Value.Type as Type import Data.Blob -import Data.Coerce +import Data.File import Data.Graph (topologicalSort) import qualified Data.Language as Language import Data.List (uncons) import Data.Project hiding (readFile) import Data.Quieterm (quieterm) import Data.Sum (weaken) -import Language.Haskell.HsColour -import Language.Haskell.HsColour.Colourise import Parsing.Parser -import Prologue hiding (weaken) +import Prologue +import Semantic.Analysis import Semantic.Config import Semantic.Graph -import Semantic.IO as IO import Semantic.Task import Semantic.Telemetry (LogQueue, StatQueue) import System.Exit (die) import System.FilePath.Posix (takeDirectory) -import Text.Show.Pretty (ppShow) justEvaluating = runM - . runPrintingTrace - . runState lowerBound - . runFresh 0 + . runEvaluator + . raiseHandler runTraceByPrinting + . runHeap + . raiseHandler runFresh . fmap reassociate . runLoadError . runUnspecialized @@ -57,11 +54,11 @@ justEvaluating . runValueError checking - = runM @_ @IO - . runPrintingTrace - . runState (lowerBound @(Heap Monovariant Monovariant Type)) - . runFresh 0 - . runTermEvaluator @_ @Monovariant @Type + = runM + . runEvaluator + . raiseHandler runTraceByPrinting + . runHeap + . raiseHandler runFresh . caching . providingLiveSet . fmap reassociate @@ -85,13 +82,13 @@ typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Langu typecheckRubyFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Ruby) rubyParser callGraphProject parser proxy opts paths = runTaskWithOptions opts $ do - blobs <- catMaybes <$> traverse readFile (flip File (Language.reflect proxy) <$> paths) + blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths) package <- fmap snd <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) []) modules <- topologicalSort <$> runImportGraphToModules proxy package x <- runCallGraph proxy False modules package pure (x, (() <$) <$> modules) -evaluatePythonProject = evaluatePythonProjects (Proxy @'Language.Python) pythonParser Language.Python +evaluatePythonProject = justEvaluating <=< evaluatePythonProjects (Proxy @'Language.Python) pythonParser Language.Python callGraphRubyProject = callGraphProject rubyParser (Proxy @'Language.Ruby) debugOptions @@ -102,42 +99,43 @@ evaluateProject proxy parser paths = withOptions debugOptions $ \ config logger data TaskConfig = TaskConfig Config LogQueue StatQueue evaluateProject' (TaskConfig config logger statter) proxy parser paths = either (die . displayException) pure <=< runTaskWithConfig config logger statter $ do - blobs <- catMaybes <$> traverse readFile (flip File (Language.reflect proxy) <$> paths) + blobs <- catMaybes <$> traverse readBlobFromFile (flip File (Language.reflect proxy) <$> paths) package <- fmap (quieterm . snd) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) []) modules <- topologicalSort <$> runImportGraphToModules proxy package trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules) - pure (runTermEvaluator @_ @_ @(Value Precise (ConcreteEff Precise _)) - (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise (Value Precise (ConcreteEff Precise _))))))) - (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) - (runReader (packageInfo package) - (runState (lowerBound @Span) - (runReader (lowerBound @Span) - (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules))))))) + pure (id @(Evaluator _ Precise (Value _ Precise) _ _) + (runModuleTable + (runModules (ModuleTable.modulePaths (packageModules package)) + (raiseHandler (runReader (packageInfo package)) + (raiseHandler (runState (lowerBound @Span)) + (raiseHandler (runReader (lowerBound @Span)) + (evaluate proxy id (evalTerm withTermSpans) modules))))))) evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do project <- readProject Nothing path lang [] package <- fmap quieterm <$> parsePythonPackage parser project modules <- topologicalSort <$> runImportGraphToModules proxy package trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules) - pure (runTermEvaluator @_ @_ @(Value Precise (ConcreteEff Precise '[Trace])) - (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise (Value Precise (ConcreteEff Precise '[Trace]))))))) - (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) - (runReader (packageInfo package) - (runState (lowerBound @Span) - (runReader (lowerBound @Span) - (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules))))))) + pure (id @(Evaluator _ Precise (Value _ Precise) _ _) + (runModuleTable + (runModules (ModuleTable.modulePaths (packageModules package)) + (raiseHandler (runReader (packageInfo package)) + (raiseHandler (runState (lowerBound @Span)) + (raiseHandler (runReader (lowerBound @Span)) + (evaluate proxy id (evalTerm withTermSpans) modules))))))) evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do project <- readProject Nothing path (Language.reflect proxy) [] package <- fmap (quieterm . snd) <$> parsePackage parser project modules <- topologicalSort <$> runImportGraphToModules proxy package - pure (runReader (packageInfo package) - (runState (lowerBound @Span) - (runReader (lowerBound @Span) - (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Monovariant Type))))) - (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) - (evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (Type.runBoolean . Type.runFunction) modules)))))) + pure (id @(Evaluator _ Monovariant _ _ _) + (raiseHandler (runReader (packageInfo package)) + (raiseHandler (runState (lowerBound @Span)) + (raiseHandler (runReader (lowerBound @Span)) + (runModuleTable + (runModules (ModuleTable.modulePaths (packageModules package)) + (evaluate proxy id (evalTerm withTermSpans) modules))))))) parseFile :: Parser term -> FilePath -> IO term @@ -146,12 +144,10 @@ parseFile parser = runTask . (parse parser <=< readBlob . file) blob :: FilePath -> IO Blob blob = runTask . readBlob . file -mergeExcs :: Either (SomeExc (Sum excs)) (Either (SomeExc exc) result) -> Either (SomeExc (Sum (exc ': excs))) result -mergeExcs = either (\ (SomeExc sum) -> Left (SomeExc (weaken sum))) (either (\ (SomeExc exc) -> Left (SomeExc (inject exc))) Right) +mergeErrors :: Either (SomeError (Sum errs)) (Either (SomeError err) result) -> Either (SomeError (Sum (err ': errs))) result +mergeErrors = either (\ (SomeError sum) -> Left (SomeError (weaken sum))) (either (\ (SomeError err) -> Left (SomeError (inject err))) Right) -reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) (Either (SomeExc exc4) (Either (SomeExc exc5) (Either (SomeExc exc6) (Either (SomeExc exc7) result)))))) -> Either (SomeExc (Sum '[exc7, exc6, exc5, exc4, exc3, exc2, exc1])) result -reassociate = mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . Right +reassociate :: Either (SomeError err1) (Either (SomeError err2) (Either (SomeError err3) (Either (SomeError err4) (Either (SomeError err5) (Either (SomeError err6) (Either (SomeError err7) result)))))) -> Either (SomeError (Sum '[err7, err6, err5, err4, err3, err2, err1])) result +reassociate = mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . Right - -prettyShow :: Show a => a -> IO () -prettyShow = putStrLn . hscolour TTY defaultColourPrefs False False "" False . ppShow +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} diff --git a/src/Semantic/Util/Pretty.hs b/src/Semantic/Util/Pretty.hs new file mode 100644 index 000000000..7cc1bf77b --- /dev/null +++ b/src/Semantic/Util/Pretty.hs @@ -0,0 +1,8 @@ +module Semantic.Util.Pretty (prettyShow) where + +import Language.Haskell.HsColour +import Language.Haskell.HsColour.Colourise +import Text.Show.Pretty (ppShow) + +prettyShow :: Show a => a -> IO () +prettyShow = putStrLn . hscolour TTY defaultColourPrefs False False "" False . ppShow diff --git a/src/Semantic/Util/Rewriting.hs b/src/Semantic/Util/Rewriting.hs index 7108ef1e6..6824c4d4f 100644 --- a/src/Semantic/Util/Rewriting.hs +++ b/src/Semantic/Util/Rewriting.hs @@ -1,38 +1,34 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators #-} -{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists #-} +{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists -Wno-incomplete-uni-patterns #-} module Semantic.Util.Rewriting where -import Prelude hiding (id, (.), readFile) +import Prelude hiding (id, readFile, (.)) +import Prologue -import Control.Abstract -import Control.Abstract.Matching import Control.Category -import Data.Blob import qualified Data.ByteString.Char8 as BC +import Text.Show.Pretty (pPrint) + +import Control.Matching +import Control.Rewriting hiding (fromMatcher, target) +import Data.Blob +import Data.File import Data.History import qualified Data.Language as Language -import Data.Machine -import Data.Machine.Runner -import Data.Project hiding (readFile) -import Data.Record import qualified Data.Source as Source -import qualified Data.Sum as Sum import qualified Data.Syntax.Literal as Literal import Data.Term import Language.JSON.PrettyPrint -import Language.Ruby.PrettyPrint import Language.Python.PrettyPrint -import Matching.Core +import Language.Ruby.PrettyPrint import Parsing.Parser -import Prologue hiding (weaken) import Reprinting.Pipeline -import Semantic.IO as IO import Semantic.Task testPythonFile = do let path = "test/fixtures/python/reprinting/function.py" - src <- blobSource <$> readBlobFromPath (File path Language.Python) - tree <- parseFile miniPythonParser path + src <- blobSource <$> readBlobFromFile' (File path Language.Python) + tree <- parseFile' miniPythonParser path pure (src, tree) testPythonPipeline = do @@ -53,8 +49,8 @@ testPythonPipeline''' = do testRubyFile = do let path = "test/fixtures/ruby/reprinting/infix.rb" - src <- blobSource <$> readBlobFromPath (File path Language.Ruby) - tree <- parseFile miniRubyParser path + src <- blobSource <$> readBlobFromFile' (File path Language.Ruby) + tree <- parseFile' miniRubyParser path pure (src, tree) testRubyPipeline = do @@ -77,87 +73,63 @@ printToTerm = either (putStrLn . show) (BC.putStr . Source.sourceBytes) testJSONFile = do let path = "test/fixtures/javascript/reprinting/map.json" - src <- blobSource <$> readBlobFromPath (File path Language.JSON) - tree <- parseFile jsonParser path + src <- blobSource <$> readBlobFromFile' (File path Language.JSON) + tree <- parseFile' jsonParser path pure (src, tree) -renameKey :: (Literal.TextElement :< fs, Literal.KeyValue :< fs, Apply Functor fs) => Term (Sum fs) (Record (History ': fields)) -> Term (Sum fs) (Record (History ': fields)) -renameKey p = case projectTerm p of - Just (Literal.KeyValue k v) - | Just (Literal.TextElement x) <- Sum.project (termOut k) - , x == "\"foo\"" - -> let newKey = termIn (termAnnotation k) (inject (Literal.TextElement "\"fooA\"")) - in remark Refactored (termIn (termAnnotation p) (inject (Literal.KeyValue newKey v))) - _ -> Term (fmap renameKey (unTerm p)) +renameKey :: ( Literal.TextElement :< fs + , Apply Functor fs + , term ~ Term (Sum fs) History + ) + => Rewrite (env, term) (Literal.KeyValue term) +renameKey = do + Literal.KeyValue k v <- id + guard (projectTerm k == Just (Literal.TextElement "\"foo\"")) + new <- modified (Literal.TextElement "\"fooA\"") + pure (Literal.KeyValue new v) testRenameKey = do (src, tree) <- testJSONFile - let tagged = renameKey (mark Unmodified tree) + let (Right tagged) = rewrite (somewhere' renameKey) () (mark Unmodified tree) + pPrint tagged printToTerm $ runReprinter src defaultJSONPipeline tagged -increaseNumbers :: (Literal.Float :< fs, Apply Functor fs) => Term (Sum fs) (Record (History ': fields)) -> Term (Sum fs) (Record (History ': fields)) -increaseNumbers p = case Sum.project (termOut p) of - Just (Literal.Float t) -> remark Refactored (termIn (termAnnotation p) (inject (Literal.Float (t <> "0")))) - Nothing -> Term (fmap increaseNumbers (unTerm p)) +increaseNumbers :: (term ~ Term (Sum fs) History) => Rewrite (env, term) (Literal.Float term) +increaseNumbers = do + (Literal.Float c) <- id + pure (Literal.Float (c <> "0")) -addKVPair :: forall effs syntax ann fields term . - ( Apply Functor syntax - , Literal.Hash :< syntax - , Literal.Array :< syntax - , Literal.TextElement :< syntax - , Literal.KeyValue :< syntax - , ann ~ Record (History ': fields) - , term ~ Term (Sum syntax) ann - ) => - ProcessT (Eff effs) (Either term (term, Literal.Hash term)) term -addKVPair = repeatedly $ do - t <- await - Data.Machine.yield (either id injKVPair t) - where - injKVPair :: (term, Literal.Hash term) -> term - injKVPair (origTerm, Literal.Hash xs) = - remark Refactored (injectTerm ann (Literal.Hash (xs <> [newItem]))) - where - newItem = termIn ann (inject (Literal.KeyValue k v)) - k = termIn ann (inject (Literal.TextElement "\"added\"")) - v = termIn ann (inject (Literal.Array [])) - ann = termAnnotation origTerm +addKVPair :: ( Literal.TextElement :< syn + , Literal.KeyValue :< syn + , Literal.Array :< syn + , Apply Functor syn + , term ~ Term (Sum syn) History + ) => Rewrite (env, term) (Literal.Hash term) +addKVPair = do + Literal.Hash els <- id + k <- modified $ Literal.TextElement "\"added\"" + v <- modified $ Literal.Array [] + pair <- modified $ Literal.KeyValue k v + pure (Literal.Hash (pair : els)) testAddKVPair = do (src, tree) <- testJSONFile - tagged <- runM $ cata (toAlgebra (fromMatcher matchHash ~> addKVPair)) (mark Unmodified tree) + let (Right tagged) = rewrite (somewhere addKVPair markRefactored) () (mark Unmodified tree) printToTerm $ runReprinter src defaultJSONPipeline tagged -overwriteFloats :: forall effs syntax ann fields term . - ( Apply Functor syntax - , Literal.Float :< syntax - , ann ~ Record (History ': fields) - , term ~ Term (Sum syntax) ann - ) => - ProcessT (Eff effs) (Either term (term, Literal.Float term)) term -overwriteFloats = repeatedly $ do - t <- await - Data.Machine.yield (either id injFloat t) - where injFloat :: (term, Literal.Float term) -> term - injFloat (term, _) = remark Refactored (termIn (termAnnotation term) (inject (Literal.Float "0"))) +overwriteFloats :: Rewrite (env, term) (Literal.Float term) +overwriteFloats = pure (Literal.Float "0") testOverwriteFloats = do (src, tree) <- testJSONFile - tagged <- runM $ cata (toAlgebra (fromMatcher matchFloat ~> overwriteFloats)) (mark Unmodified tree) + let (Right tagged) = rewrite (somewhere overwriteFloats markRefactored) () (mark Unmodified tree) + pPrint tagged printToTerm $ runReprinter src defaultJSONPipeline tagged -findKV :: - ( Literal.KeyValue :< syntax - , Literal.TextElement :< syntax - , term ~ Term (Sum syntax) ann - ) => - Text -> ProcessT (Eff effs) term (Either term (term, Literal.KeyValue term)) -findKV name = fromMatcher (kvMatcher name) - -kvMatcher :: forall fs ann term . +kvMatcher :: forall fs term . ( Literal.KeyValue :< fs , Literal.TextElement :< fs - , term ~ Term (Sum fs) ann + , term ~ Term (Sum fs) History ) => Text -> Matcher term (Literal.KeyValue term) kvMatcher name = matchM projectTerm target <* matchKey where @@ -166,42 +138,23 @@ kvMatcher name = matchM projectTerm target <* matchKey where match Literal.textElementContent $ ensure (== name) -changeKV :: forall effs syntax ann fields term . - ( Apply Functor syntax - , Literal.KeyValue :< syntax - , Literal.Array :< syntax - , Literal.Float :< syntax - , ann ~ Record (History ': fields) - , term ~ Term (Sum syntax) ann - ) => - ProcessT (Eff effs) (Either term (term, Literal.KeyValue term)) term -changeKV = auto $ either id injKV - where - injKV :: (term, Literal.KeyValue term) -> term - injKV (term, Literal.KeyValue k v) = case projectTerm v of - Just (Literal.Array elems) -> remark Refactored (termIn ann (inject (Literal.KeyValue k (newArray elems)))) - _ -> term - where newArray xs = termIn ann (inject (Literal.Array (xs <> [float]))) - float = termIn ann (inject (Literal.Float "4")) - ann = termAnnotation term +changeKV :: ( Apply Functor syntax + , Literal.Array :< syntax + , Literal.Float :< syntax + , term ~ Term (Sum syntax) History + ) + => Rewrite (env, term) (Literal.KeyValue term) +changeKV = do + (Literal.KeyValue k v) <- id + (Literal.Array vals) <- guardTerm v + let float = remark Refactored (injectTerm (annotation v) (Literal.Float "4")) + let newArr = remark Refactored (injectTerm (annotation v) (Literal.Array (float:vals))) + pure (Literal.KeyValue k newArr) testChangeKV = do (src, tree) <- testJSONFile - tagged <- runM $ cata (toAlgebra (findKV "\"bar\"" ~> changeKV)) (mark Unmodified tree) + let (Right tagged) = rewrite (somewhere' changeKV) () (mark Unmodified tree) printToTerm $ runReprinter src defaultJSONPipeline tagged --- Temporary, until new KURE system lands. -fromMatcher :: Matcher from to -> ProcessT (Eff effs) from (Either from (from, to)) -fromMatcher m = auto go where go x = maybe (Left x) (\y -> Right (x, y)) (stepMatcher x m) - --- Turn a 'ProccessT' into an FAlgebra. -toAlgebra :: (Traversable (Base t), Corecursive t) - => ProcessT (Eff effs) t t - -> FAlgebra (Base t) (Eff effs t) -toAlgebra m t = do - inner <- sequenceA t - res <- runT1 (source (Just (embed inner)) ~> m) - pure (fromMaybe (embed inner) res) - -parseFile :: Parser term -> FilePath -> IO term -parseFile parser = runTask . (parse parser <=< readBlob . file) +parseFile' :: Parser term -> FilePath -> IO term +parseFile' parser = runTask . (parse parser <=< readBlob . file) diff --git a/src/Semantic/Version.hs b/src/Semantic/Version.hs index 782cbc1f8..6a71f534f 100644 --- a/src/Semantic/Version.hs +++ b/src/Semantic/Version.hs @@ -1,17 +1,27 @@ +{-# LANGUAGE CPP #-} +#ifdef COMPUTE_GIT_SHA {-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct. {-# LANGUAGE TemplateHaskell #-} +#endif module Semantic.Version ( buildSHA , buildVersion ) where import Data.Version (showVersion) +#ifdef COMPUTE_GIT_SHA import Development.GitRev +#endif import Paths_semantic (version) -- The SHA1 hash of this build of semantic. +-- If compiled as a development build, this will be @@. buildSHA :: String +#ifdef COMPUTE_GIT_SHA buildSHA = $(gitHash) +#else +buildSHA = "" +#endif -- The version string of this build of semantic. buildVersion :: String diff --git a/src/Serializing/DOT.hs b/src/Serializing/DOT.hs index 966228ec1..abf1cf089 100644 --- a/src/Serializing/DOT.hs +++ b/src/Serializing/DOT.hs @@ -4,7 +4,7 @@ module Serializing.DOT , serializeDOT ) where -import Algebra.Graph.Class +import Algebra.Graph.ToGraph import Algebra.Graph.Export hiding ((<+>)) import Algebra.Graph.Export.Dot hiding (export) import Data.List diff --git a/src/Serializing/Format.hs b/src/Serializing/Format.hs index bacbd234d..74dfc6e5c 100644 --- a/src/Serializing/Format.hs +++ b/src/Serializing/Format.hs @@ -7,7 +7,7 @@ module Serializing.Format , Options(..) ) where -import Algebra.Graph.Class +import Algebra.Graph.ToGraph import Data.Aeson (ToJSON(..), fromEncoding) import Data.ByteString.Builder import Language.Haskell.HsColour diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index bd5b16c20..ec844124f 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -6,7 +6,7 @@ import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Number as Number import Data.Abstract.Value.Concrete as Value import Data.AST -import Control.Monad.Effect (SomeExc(..)) +import Control.Effect.Resumable (SomeError(..)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Sum import qualified Language.Ruby.Assignment as Ruby @@ -36,7 +36,7 @@ spec config = parallel $ do it "evaluates load with wrapper" $ do (_, (_, res)) <- evaluate ["load-wrap.rb", "foo.rb"] - res `shouldBe` Left (SomeExc (inject @(BaseError (EnvironmentError Precise)) (BaseError (ModuleInfo "load-wrap.rb") emptySpan (FreeVariable "foo")))) + res `shouldBe` Left (SomeError (inject @(BaseError (EnvironmentError Precise)) (BaseError (ModuleInfo "load-wrap.rb") emptySpan (FreeVariable "foo")))) it "evaluates subclass" $ do (_, (heap, res)) <- evaluate ["subclass.rb"] @@ -97,7 +97,7 @@ spec config = parallel $ do case ModuleTable.lookup "puts.rb" <$> res of Right (Just (Module _ (_, (env, addr)) :| [])) -> do heapLookupAll addr heap `shouldBe` Just [Unit] - traces `shouldContain` [ "\"hello\"" ] + traces `shouldContain` ["String \"\\\"hello\\\"\""] other -> expectationFailure (show other) where diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 24b3f501b..c68daec51 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -38,7 +38,7 @@ spec config = parallel $ do it "fails exporting symbols not defined in the module" $ do (_, (_, res)) <- evaluate ["bad-export.ts", "pip.ts", "a.ts", "foo.ts"] - res `shouldBe` Left (SomeExc (inject @(BaseError EvalError) (BaseError (ModuleInfo "foo.ts") emptySpan (ExportError "foo.ts" (name "pip"))))) + res `shouldBe` Left (SomeError (inject @(BaseError EvalError) (BaseError (ModuleInfo "foo.ts") emptySpan (ExportError "foo.ts" (name "pip"))))) it "evaluates early return statements" $ do (_, (heap, res)) <- evaluate ["early-return.ts"] diff --git a/test/Assigning/Assignment/Spec.hs b/test/Assigning/Assignment/Spec.hs index 914414b76..e188393ab 100644 --- a/test/Assigning/Assignment/Spec.hs +++ b/test/Assigning/Assignment/Spec.hs @@ -253,7 +253,7 @@ spec = do Left [ "symbol" ] node :: symbol -> Int -> Int -> [AST [] symbol] -> AST [] symbol -node symbol start end children = Term (Node symbol (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end))) `In` children) +node symbol start end children = Term (Node symbol (Location (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end)))) `In` children) data Grammar = Palette | Red | Green | Blue | Magenta deriving (Bounded, Enum, Eq, Ix, Ord, Show) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index e10077685..6267f3086 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -7,6 +7,7 @@ import Control.Abstract import Data.Abstract.Address.Precise as Precise import Data.Abstract.BaseError import Data.Abstract.Environment +import Data.Abstract.FreeVariables import Data.Abstract.Module import qualified Data.Abstract.Number as Number import Data.Abstract.Package @@ -26,7 +27,7 @@ spec = parallel $ do it "calls functions" $ do (_, expected) <- evaluate $ do - identity <- function Nothing [name "x"] lowerBound (variable (name "x")) + identity <- function Nothing [name "x"] (SpecEff (variable (name "x"))) recv <- box unit addr <- box (integer 123) call identity recv [addr] @@ -34,44 +35,51 @@ spec = parallel $ do evaluate = runM + . runTraceByIgnoring . runState (lowerBound @(Heap Precise Val)) - . runFresh 0 + . runFresh . runReader (PackageInfo (name "test") mempty) . runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs") . runReader (lowerBound @Span) + . runEvaluator . fmap reassociate . runValueError . runEnvironmentError . runAddressError - . Precise.runDeref @_ @Val - . Precise.runAllocator + . runDeref @Val + . runAllocator . (>>= deref . snd) . runEnv lowerBound . runReturn . runLoopControl - . Value.runBoolean - . Value.runFunction coerce coerce + . runBoolean + . runFunction runSpecEff -reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result)) -> Either (SomeExc (Sum '[exc3, exc2, exc1])) result -reassociate = mergeExcs . mergeExcs . mergeExcs . Right +reassociate :: Either (SomeError exc1) (Either (SomeError exc2) (Either (SomeError exc3) result)) -> Either (SomeError (Sum '[exc3, exc2, exc1])) result +reassociate = mergeErrors . mergeErrors . mergeErrors . Right -type Val = Value Precise SpecEff -newtype SpecEff a = SpecEff - { runSpecEff :: Eff '[ Function Precise Val - , Boolean Val - , Exc (LoopControl Precise) - , Exc (Return Precise) - , Env Precise - , Allocator Precise - , Deref Val - , Resumable (BaseError (AddressError Precise Val)) - , Resumable (BaseError (EnvironmentError Precise)) - , Resumable (BaseError (ValueError Precise SpecEff)) - , Reader Span - , Reader ModuleInfo - , Reader PackageInfo - , Fresh - , State (Heap Precise Val) - , Lift IO - ] a +type Val = Value SpecEff Precise +newtype SpecEff = SpecEff + { runSpecEff :: Evaluator SpecEff Precise Val (FunctionC SpecEff Precise Val + (Eff (BooleanC Val + (Eff (ErrorC (LoopControl Precise) + (Eff (ErrorC (Return Precise) + (Eff (EnvC Precise + (Eff (AllocatorC Precise + (Eff (DerefC Precise Val + (Eff (ResumableC (BaseError (AddressError Precise Val)) + (Eff (ResumableC (BaseError (EnvironmentError Precise)) + (Eff (ResumableC (BaseError (ValueError SpecEff Precise)) + (Eff (ReaderC Span + (Eff (ReaderC ModuleInfo + (Eff (ReaderC PackageInfo + (Eff (FreshC + (Eff (StateC (Heap Precise Val) + (Eff (TraceByIgnoringC + (Eff (LiftC IO))))))))))))))))))))))))))))))))) + Precise } + +instance Eq SpecEff where _ == _ = True +instance Show SpecEff where show _ = "_" +instance FreeVariables SpecEff where freeVariables _ = lowerBound diff --git a/test/Control/Rewriting/Spec.hs b/test/Control/Rewriting/Spec.hs new file mode 100644 index 000000000..a7ff72ca5 --- /dev/null +++ b/test/Control/Rewriting/Spec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TypeFamilies, TypeOperators #-} + +module Control.Rewriting.Spec (spec) where + +import SpecHelpers + +import qualified Data.ByteString as B +import Data.Either +import Data.Text (Text) + +import Control.Matching as Matching +import Control.Rewriting as Rewriting +import Data.History as History +import qualified Data.Source as Source +import Data.Sum +import qualified Data.Syntax.Literal as Literal +import Language.JSON.PrettyPrint +import Reprinting.Pipeline + +-- Adds a "hi": "bye" key-value pair to any empty Hash. +onTrees :: ( Literal.TextElement :< syn + , Literal.KeyValue :< syn + , Apply Functor syn + , term ~ Term (Sum syn) History + ) => Rewrite (env, term) (Literal.Hash term) +onTrees = do + Literal.Hash els <- Rewriting.target + guard (null els) + k <- modified $ Literal.TextElement "\"hi\"" + v <- modified $ Literal.TextElement "\"bye\"" + pair <- modified $ (Literal.KeyValue k v) + pure (Literal.Hash (pair : els)) + +-- Matches only "hi" string literals. +isHi :: ( Literal.TextElement :< fs + ) => Matcher (Term (Sum fs) History) Text +isHi = match Literal.textElementContent (Matching.target <* ensure (== "\"hi\"")) + +spec :: Spec +spec = describe "rewriting" $ do + let path = "test/fixtures/json/rewriting/add_keys.json" + + bytes <- runIO $ Source.fromUTF8 <$> B.readFile path + + refactored <- runIO $ do + json <- parseFile jsonParser path + let result = rewrite (somewhere onTrees markRefactored) () (History.mark Unmodified json) + either (fail . show) pure result + + it "should add keys to JSON values" $ do + length (runMatcher @[] isHi refactored) `shouldBe` 1 + + it "should round-trip correctly" $ do + let res = runReprinter bytes defaultJSONPipeline refactored + expected <- Source.fromUTF8 <$> B.readFile "test/fixtures/json/rewriting/add_keys_expected.json" + res `shouldBe` Right expected diff --git a/test/Data/Abstract/Environment/Spec.hs b/test/Data/Abstract/Environment/Spec.hs new file mode 100644 index 000000000..cb1345ef9 --- /dev/null +++ b/test/Data/Abstract/Environment/Spec.hs @@ -0,0 +1,21 @@ +module Data.Abstract.Environment.Spec where + +import Prelude hiding (head) +import SpecHelpers + +import Data.Abstract.Environment +import Data.Abstract.Address.Precise + +spec :: Spec +spec = describe "Environment" $ do + let bright = push (insertEnv (name "foo") (Precise 0) lowerBound) + let shadowed = insertEnv (name "foo") (Precise 1) bright + + it "can extract bindings" $ + pairs (head shadowed) `shouldBe` [("foo", Precise 1)] + + it "should extract the outermost binding given shadowing" $ + lookupEnv' (name "foo") shadowed `shouldBe` Just (Precise 1) + + it "can delete bindings" $ + delete (name "foo") shadowed `shouldBe` Environment (pure lowerBound) diff --git a/test/Data/Abstract/Name/Spec.hs b/test/Data/Abstract/Name/Spec.hs new file mode 100644 index 000000000..ab65902ff --- /dev/null +++ b/test/Data/Abstract/Name/Spec.hs @@ -0,0 +1,11 @@ +module Data.Abstract.Name.Spec where + +import SpecHelpers + +import Data.Abstract.Name + +spec :: Spec +spec = describe "Data.Abstract.Name" $ + it "should format anonymous names correctly" $ do + show (nameI 0) `shouldBe` "\"_a\"" + show (nameI 26) `shouldBe` "\"_aŹ¹\"" diff --git a/test/Data/Diff/Spec.hs b/test/Data/Diff/Spec.hs index bc091398c..87981de10 100644 --- a/test/Data/Diff/Spec.hs +++ b/test/Data/Diff/Spec.hs @@ -3,11 +3,10 @@ module Data.Diff.Spec where import Data.Diff import Data.Functor.Listable (ListableSyntax) -import Data.Record import Test.Hspec import Test.Hspec.LeanCheck spec :: Spec spec = parallel $ do prop "equality is reflexive" $ - \ diff -> diff `shouldBe` (diff :: Diff ListableSyntax (Record '[]) (Record '[])) + \ diff -> diff `shouldBe` (diff :: Diff ListableSyntax () ()) diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 4fa69019f..1076eb393 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -29,8 +29,9 @@ import qualified Data.Language as Language import Data.List.NonEmpty import Data.Patch import Data.Range -import Data.Record +import Data.Location import Data.Semigroup (Semigroup(..)) +import Data.Semigroup.App import Data.Source import Data.Blob import Data.Span @@ -201,13 +202,6 @@ instance (Listable1 syntax, Listable ann1, Listable ann2) => Listable (Diff synt tiers = tiers2 -instance (Listable head, Listable (Record tail)) => Listable (Record (head ': tail)) where - tiers = cons2 (:.) - -instance Listable (Record '[]) where - tiers = cons0 Nil - - instance Listable2 Patch where liftTiers2 t1 t2 = liftCons1 t2 Insert \/ liftCons1 t1 Delete \/ liftCons2 t1 t2 Replace @@ -519,9 +513,9 @@ instance Listable Text where instance Listable Declaration where tiers - = cons4 MethodDeclaration - \/ cons3 FunctionDeclaration - \/ cons2 (\ a b -> ErrorDeclaration a b Language.Unknown) + = cons5 MethodDeclaration + \/ cons4 FunctionDeclaration + \/ cons3 (\ a b c -> ErrorDeclaration a b c Language.Unknown) instance Listable CyclomaticComplexity where tiers = cons1 CyclomaticComplexity @@ -534,10 +528,18 @@ instance Listable Language.Language where \/ cons0 Language.Ruby \/ cons0 Language.TypeScript +instance Listable (f a) => Listable (App f a) where + tiers = cons1 App + +instance Listable (f a) => Listable (AppMerge f a) where + tiers = cons1 AppMerge + +instance Listable Location where + tiers = cons2 Location + instance Listable Range where tiers = cons2 Range - instance Listable Pos where tiers = cons2 Pos diff --git a/test/Data/Graph/Spec.hs b/test/Data/Graph/Spec.hs new file mode 100644 index 000000000..47a749616 --- /dev/null +++ b/test/Data/Graph/Spec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE PackageImports #-} + +module Data.Graph.Spec where + +import SpecHelpers + +import "semantic" Data.Graph +import qualified Algebra.Graph.Class as Class + +spec :: Spec +spec = describe "Data.Graph" $ + it "has a valid topological sort" $ do + let topo = topologicalSort + topo (Class.path "ab") `shouldBe` "ba" + topo (Class.path "abc") `shouldBe` "cba" + topo ((vertex 'a' `connect` vertex 'b') `connect` vertex 'c') `shouldBe` "cba" + topo (vertex 'a' `connect` (vertex 'b' `connect` vertex 'c')) `shouldBe` "cba" + topo ((vertex 'a' `connect` vertex 'b') <> (vertex 'a' `connect` vertex 'c')) `shouldBe` "cba" + topo (Class.path "abd" <> Class.path "acd") `shouldBe` "dcba" + topo (Class.path "aba") `shouldBe` "ab" diff --git a/test/Data/Range/Spec.hs b/test/Data/Range/Spec.hs new file mode 100644 index 000000000..b6c4e2af2 --- /dev/null +++ b/test/Data/Range/Spec.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Range.Spec where + +import Data.Range +import SpecHelpers + +spec :: Spec +spec = describe "Data.Range" $ + prop "should have an associative Semigroup instance" $ + \(a, b, c) -> a <> (b <> c) `shouldBe` (a <> b) <> (c :: Range) diff --git a/test/Data/Semigroup/App/Spec.hs b/test/Data/Semigroup/App/Spec.hs new file mode 100644 index 000000000..e3acf4bc1 --- /dev/null +++ b/test/Data/Semigroup/App/Spec.hs @@ -0,0 +1,20 @@ +module Data.Semigroup.App.Spec where + +import SpecHelpers +import Data.Semigroup.App + +spec :: Spec +spec = do + describe "App" $ + prop "should be associative" $ + \a b c -> a <> (b <> c) == (a <> b) <> (c :: App Maybe Integer) + + describe "AppMerge" $ do + prop "should be associative" $ + \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String) + + prop "identity/left" $ + \ a -> mempty <> a == (a :: AppMerge Maybe String) + + prop "identity/right" $ + \ a -> a <> mempty == (a :: AppMerge Maybe String) diff --git a/test/Diffing/Algorithm/RWS/Spec.hs b/test/Diffing/Algorithm/RWS/Spec.hs index a6700886f..f4a88a446 100644 --- a/test/Diffing/Algorithm/RWS/Spec.hs +++ b/test/Diffing/Algorithm/RWS/Spec.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds, TypeOperators #-} module Diffing.Algorithm.RWS.Spec where import Analysis.Decorator import Data.Bifunctor import Data.Diff import Data.Functor.Listable (ListableSyntax) -import Data.Record +import Data.Location import Data.Sum import qualified Data.Syntax as Syntax import Data.Term import Data.These import Diffing.Algorithm +import Diffing.Interpreter (stripDiff) import Diffing.Algorithm.RWS import Diffing.Interpreter.Spec (afterTerm, beforeTerm) import Test.Hspec.LeanCheck @@ -21,23 +22,29 @@ spec = parallel $ do let positively = succ . abs describe "pqGramDecorator" $ do prop "produces grams with stems of the specified length" $ - \ (term, p, q) -> pqGramDecorator (positively p) (positively q) (term :: Term ListableSyntax (Record '[])) `shouldSatisfy` all ((== positively p) . length . stem . rhead) + \ (term, p, q) -> pqGramDecorator (positively p) (positively q) (term :: Term ListableSyntax ()) `shouldSatisfy` all ((== positively p) . length . stem . fst) prop "produces grams with bases of the specified width" $ - \ (term, p, q) -> pqGramDecorator (positively p) (positively q) (term :: Term ListableSyntax (Record '[])) `shouldSatisfy` all ((== positively q) . length . base . rhead) + \ (term, p, q) -> pqGramDecorator (positively p) (positively q) (term :: Term ListableSyntax ()) `shouldSatisfy` all ((== positively q) . length . base . fst) describe "rws" $ do prop "produces correct diffs" $ - \ (as, bs) -> let tas = decorate <$> (as :: [Term ListableSyntax (Record '[])]) - tbs = decorate <$> (bs :: [Term ListableSyntax (Record '[])]) - wrap = termIn Nil . inject - diff = merge (Nil, Nil) (inject (stripDiff . diffThese <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in + \ (as, bs) -> let tas = decorate <$> (as :: [Term ListableSyntax ()]) + tbs = decorate <$> (bs :: [Term ListableSyntax ()]) + wrap = termIn emptyAnnotation . inject + diff = merge (emptyAnnotation, emptyAnnotation) (inject (stripDiff . diffThese <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in (beforeTerm diff, afterTerm diff) `shouldBe` (Just (wrap (stripTerm <$> tas)), Just (wrap (stripTerm <$> tbs))) it "produces unbiased insertions within branches" $ - let (a, b) = (decorate (termIn Nil (inject [ termIn Nil (inject (Syntax.Identifier "a")) ])), decorate (termIn Nil (inject [ termIn Nil (inject (Syntax.Identifier "b")) ]))) in + let (a, b) = (decorate (termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier "a")) ])), decorate (termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier "b")) ]))) in fmap (bimap stripTerm stripTerm) (rws comparableTerms (equalTerms comparableTerms) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ] where decorate = defaultFeatureVectorDecorator diffThese = these deleting inserting replacing + +stripTerm :: Functor f => Term f (FeatureVector, ()) -> Term f () +stripTerm = fmap snd + +emptyAnnotation :: () +emptyAnnotation = () diff --git a/test/Diffing/Interpreter/Spec.hs b/test/Diffing/Interpreter/Spec.hs index 2ee0014d9..20812b6fb 100644 --- a/test/Diffing/Interpreter/Spec.hs +++ b/test/Diffing/Interpreter/Spec.hs @@ -7,9 +7,9 @@ import Data.Foldable (asum) import Data.Functor.Foldable (cata) import Data.Functor.Listable import Data.Maybe +import Data.Location import Data.Mergeable import Data.Patch (after, before) -import Data.Record import Data.Sum import Data.Term import Data.These @@ -25,48 +25,48 @@ spec :: Spec spec = parallel $ do describe "diffTerms" $ do it "returns a replacement when comparing two unicode equivalent terms" $ - let termA = termIn Nil (inject (Syntax.Identifier "t\776")) - termB = termIn Nil (inject (Syntax.Identifier "\7831")) in - diffTerms termA termB `shouldBe` replacing termA (termB :: Term ListableSyntax (Record '[])) + let termA = termIn emptyAnnotation (inject (Syntax.Identifier "t\776")) + termB = termIn emptyAnnotation (inject (Syntax.Identifier "\7831")) in + diffTerms termA termB `shouldBe` replacing termA (termB :: Term ListableSyntax ()) prop "produces correct diffs" $ - \ a b -> let diff = diffTerms a b :: Diff ListableSyntax (Record '[]) (Record '[]) in + \ a b -> let diff = diffTerms a b :: Diff ListableSyntax () () in (beforeTerm diff, afterTerm diff) `shouldBe` (Just a, Just b) prop "produces identity diffs for equal terms " $ - \ a -> let diff = diffTerms a a :: Diff ListableSyntax (Record '[]) (Record '[]) in + \ a -> let diff = diffTerms a a :: Diff ListableSyntax () () in length (diffPatches diff) `shouldBe` 0 it "produces unbiased insertions within branches" $ - let term s = termIn Nil (inject [ termIn Nil (inject (Syntax.Identifier s)) ]) :: Term ListableSyntax (Record '[]) - wrap = termIn Nil . inject in - diffTerms (wrap [ term "b" ]) (wrap [ term "a", term "b" ]) `shouldBe` merge (Nil, Nil) (inject [ inserting (term "a"), merging (term "b") ]) + let term s = termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier s)) ]) :: Term ListableSyntax () + wrap = termIn emptyAnnotation . inject in + diffTerms (wrap [ term "b" ]) (wrap [ term "a", term "b" ]) `shouldBe` merge (emptyAnnotation, emptyAnnotation) (inject [ inserting (term "a"), merging (term "b") ]) let noContext :: Term ListableSyntax a -> Bool noContext = isNothing . project @Syntax.Context . termOut prop "compares nodes against context" . forAll (filterT (noContext . fst) tiers) $ - \ (a, b) -> diffTerms a (termIn Nil (inject (Syntax.Context (pure b) a))) `shouldBe` insertF (In Nil (inject (Syntax.Context (pure (inserting b)) (merging (a :: Term ListableSyntax (Record '[])))))) + \ (a, b) -> diffTerms a (termIn emptyAnnotation (inject (Syntax.Context (pure b) a))) `shouldBe` insertF (In emptyAnnotation (inject (Syntax.Context (pure (inserting b)) (merging (a :: Term ListableSyntax ()))))) prop "diffs forward permutations as changes" $ - \ a -> let wrap = termIn Nil . inject + \ a -> let wrap = termIn emptyAnnotation . inject b = wrap [a] c = wrap [a, b] in - diffTerms (wrap [a, b, c]) (wrap [c, a, b :: Term ListableSyntax (Record '[])]) `shouldBe` merge (Nil, Nil) (inject [ inserting c, merging a, merging b, deleting c ]) + diffTerms (wrap [a, b, c]) (wrap [c, a, b :: Term ListableSyntax ()]) `shouldBe` merge (emptyAnnotation, emptyAnnotation) (inject [ inserting c, merging a, merging b, deleting c ]) prop "diffs backward permutations as changes" $ - \ a -> let wrap = termIn Nil . inject + \ a -> let wrap = termIn emptyAnnotation . inject b = wrap [a] c = wrap [a, b] in - diffTerms (wrap [a, b, c]) (wrap [b, c, a :: Term ListableSyntax (Record '[])]) `shouldBe` merge (Nil, Nil) (inject [ deleting a, merging b, merging c, inserting a ]) + diffTerms (wrap [a, b, c]) (wrap [b, c, a :: Term ListableSyntax ()]) `shouldBe` merge (emptyAnnotation, emptyAnnotation) (inject [ deleting a, merging b, merging c, inserting a ]) describe "diffTermPair" $ do prop "produces an Insert when the first term is missing" $ do - \ after -> let diff = diffTermPair (That after) :: Diff ListableSyntax (Record '[]) (Record '[]) in + \ after -> let diff = diffTermPair (That after) :: Diff ListableSyntax () () in diff `shouldBe` inserting after prop "produces a Delete when the second term is missing" $ do - \ before -> let diff = diffTermPair (This before) :: Diff ListableSyntax (Record '[]) (Record '[]) in + \ before -> let diff = diffTermPair (This before) :: Diff ListableSyntax () () in diff `shouldBe` deleting before @@ -81,3 +81,6 @@ afterTerm :: (Foldable syntax, Mergeable syntax) => Diff syntax ann1 ann2 -> May afterTerm = cata $ \ diff -> case diff of Patch patch -> (after patch >>= \ (In b r) -> termIn b <$> sequenceAlt r) <|> (before patch >>= asum) Merge (In (_, b) r) -> termIn b <$> sequenceAlt r + +emptyAnnotation :: () +emptyAnnotation = () diff --git a/test/Doctests.hs b/test/Doctests.hs deleted file mode 100644 index 22218bc8e..000000000 --- a/test/Doctests.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Main -( main -) where - -import System.Environment -import Test.DocTest - -defaultFiles = - [ "src/Data/Abstract/Address/Precise.hs" - , "src/Data/Abstract/Environment.hs" - , "src/Data/Abstract/Name.hs" - , "src/Data/Graph.hs" - , "src/Data/Range.hs" - , "src/Data/Semigroup/App.hs" - ] - -main :: IO () -main = do - args <- getArgs - doctest (map ("-X" ++) extensions ++ "-isrc" : "--fast" : if null args then defaultFiles else args) - -extensions :: [String] -extensions = - [ "DataKinds" - , "DeriveFoldable" - , "DeriveFunctor" - , "DeriveGeneric" - , "DeriveTraversable" - , "FlexibleContexts" - , "FlexibleInstances" - , "MultiParamTypeClasses" - , "OverloadedStrings" - , "RecordWildCards" - , "StandaloneDeriving" - , "StrictData" - , "TypeApplications" - ] diff --git a/test/Examples.hs b/test/Examples.hs new file mode 100644 index 000000000..2e72516ca --- /dev/null +++ b/test/Examples.hs @@ -0,0 +1,106 @@ +module Main (main) where + +import Control.Exception (displayException) +import Control.Monad +import Control.Effect +import qualified Data.ByteString as B +import Data.ByteString.Builder +import qualified Data.ByteString.Char8 as BC +import Data.Either +import Data.File (file) +import Data.Foldable +import Data.List +import Data.Maybe +import Data.Quieterm +import Data.Typeable (cast) +import Data.Void +import Parsing.Parser +import Rendering.Renderer +import Semantic.Config (Config (..), Options (..), defaultOptions) +import qualified Semantic.IO as IO +import Semantic.Parse +import Semantic.Task +import Semantic.Task.Files +import Semantic.Util (TaskConfig (..)) +import System.Directory +import System.Exit (die) +import System.FilePath.Glob +import System.FilePath.Posix +import System.Process +import Test.Hspec + + +main :: IO () +main = withOptions opts $ \ config logger statter -> hspec . parallel $ do + let args = TaskConfig config logger statter + + runIO setupExampleRepos + + for_ languages $ \ lang@LanguageExample{..} -> do + let tsDir = languagesDir languageName ("vendor/tree-sitter-" <> languageName) + parallel . describe languageName $ parseExamples args lang tsDir + + where + parseExamples (TaskConfig config logger statter) LanguageExample{..} tsDir = do + knownFailures <- runIO $ knownFailuresForPath tsDir languageKnownFailuresTxt + files <- runIO $ globDir1 (compile ("**/*" <> languageExtension)) (tsDir languageExampleDir) + for_ files $ \file -> it file $ do + res <- runTaskWithConfig config logger statter (parseFilePath file) + case res of + Left (SomeException e) -> case cast e of + -- We have a number of known assignment timeouts, consider these pending specs instead of failing the build. + Just (AssignmentTimedOut _ _) -> pendingWith $ show (displayException e) + Just (ParserTimedOut _ _) -> pendingWith $ show (displayException e) + -- Other exceptions are true failures + _ -> expectationFailure (show (displayException e)) + _ -> if file `elem` knownFailures + then pendingWith $ "Known parse failures " <> show (const "Assignment: OK" <$> res) + else res `shouldSatisfy` isRight + + setupExampleRepos = readProcess "script/clone-example-repos" mempty mempty >>= print + opts = defaultOptions { optionsFailOnWarning = True, optionsLogLevel = Nothing } + + knownFailuresForPath :: FilePath -> Maybe FilePath -> IO [FilePath] + knownFailuresForPath _ Nothing = pure [] + knownFailuresForPath tsDir (Just path) = do + known <- BC.lines <$> B.readFile (tsDir path) + pure $ (tsDir ) . BC.unpack <$> stripComments known + where stripComments = filter (\line -> not (BC.null line) && BC.head line == '#') + +data LanguageExample + = LanguageExample + { languageName :: FilePath + , languageExtension :: FilePath + , languageExampleDir :: FilePath + , languageKnownFailuresTxt :: Maybe FilePath + } deriving (Eq, Show) + +le :: FilePath -> FilePath -> FilePath -> Maybe FilePath -> LanguageExample +le = LanguageExample + +languages :: [LanguageExample] +languages = + [ le "python" ".py" "examples" (Just "script/known_failures.txt") + , le "go" ".go" "examples" (Just "script/known-failures.txt") + , le "ruby" ".rb" "examples" (Just "script/known_failures.txt") + , le "typescript" ".ts" "examples" (Just "script/known_failures.txt") + , le "typescript" ".js" "examples" Nothing -- parse JavaScript with TypeScript parser. + + -- TODO: Java assignment errors need to be investigated + -- , le "java" ".java" "examples/guava" (Just "script/known_failures_guava.txt") + -- , le "java" ".java" "examples/elasticsearch" (Just "script/known_failures_elasticsearch.txt") + -- , le "java" ".java" "examples/RxJava" (Just "script/known_failures_RxJava.txt") + + -- TODO: Haskell assignment errors need to be investigated + -- , le "haskell" ".hs" "examples/effects" (Just "script/known-failures-effects.txt") + -- , le "haskell" ".hs" "examples/postgrest" (Just "script/known-failures-postgrest.txt") + -- , le "haskell" ".hs" "examples/ivory" (Just "script/known-failures-ivory.txt") + + -- , ("php", ".php") -- TODO: No parse-examples in tree-sitter yet + ] + +parseFilePath :: (Member (Error SomeException) sig, Member Task sig, Member Files sig, Carrier sig m, Monad m) => FilePath -> m Bool +parseFilePath path = readBlob (file path) >>= runParse' >>= const (pure True) + +languagesDir :: FilePath +languagesDir = "vendor/haskell-tree-sitter/languages" diff --git a/test/Graphing/Calls/Spec.hs b/test/Graphing/Calls/Spec.hs index 942bba978..36b7bfa62 100644 --- a/test/Graphing/Calls/Spec.hs +++ b/test/Graphing/Calls/Spec.hs @@ -18,10 +18,10 @@ import Semantic.Config (defaultOptions) import Semantic.Graph import Semantic.IO -callGraphPythonProject paths = runTaskWithOptions defaultOptions $ do +callGraphPythonProject paths = runTask $ do let proxy = Proxy @'Language.Python let lang = Language.Python - blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths) + blobs <- catMaybes <$> traverse readBlobFromFile (flip File lang <$> paths) package <- fmap snd <$> parsePackage pythonParser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang []) modules <- topologicalSort <$> runImportGraphToModules proxy package runCallGraph proxy False modules package diff --git a/test/Matching/Go/Spec.hs b/test/Matching/Go/Spec.hs index a4fdc1e68..76e7fa6ef 100644 --- a/test/Matching/Go/Spec.hs +++ b/test/Matching/Go/Spec.hs @@ -2,7 +2,7 @@ module Matching.Go.Spec (spec) where -import Control.Abstract.Matching +import Control.Matching import Data.Abstract.Module import Data.List import Data.Sum diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index cad8fc354..237f6a6ae 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -2,6 +2,7 @@ module Rendering.TOC.Spec (spec) where import Analysis.Declaration +import Control.Effect import Data.Aeson hiding (defaultOptions) import Data.Bifunctor import Data.Bifunctor.Join @@ -10,13 +11,12 @@ import Data.Functor.Classes import Data.Hashable.Lifted import Data.Patch import Data.Range -import Data.Record +import Data.Location import Data.Span import Data.Sum import Data.Term import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) -import Data.Union import Diffing.Algorithm import Diffing.Interpreter import Prelude @@ -35,7 +35,7 @@ spec = parallel $ do \ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (diff :: Diff ListableSyntax () ()) `shouldBe` [] prop "produces no entries for identity diffs" $ - \ term -> tableOfContentsBy (Just . termFAnnotation) (diffTerms term (term :: Term ListableSyntax (Record '[Range, Span]))) `shouldBe` [] + \ term -> tableOfContentsBy (Just . termFAnnotation) (diffTerms term (term :: Term ListableSyntax ())) `shouldBe` [] prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $ \ p -> tableOfContentsBy (Just . termFAnnotation) (patch deleting inserting replacing p) @@ -62,7 +62,7 @@ spec = parallel $ do , TOCSummary "Method" "baz" (Span (Pos 4 1) (Pos 5 4)) "removed" ] - it "summarizes changed classes" $ do + xit "summarizes changed classes" $ do sourceBlobs <- blobsForPaths (both "ruby/toc/classes.A.rb" "ruby/toc/classes.B.rb") diff <- runTask $ diffWithParser rubyParser sourceBlobs diffTOC diff `shouldBe` @@ -103,7 +103,7 @@ spec = parallel $ do it "properly slices source blob that starts with a newline and has multi-byte chars" $ do sourceBlobs <- blobsForPaths (both "javascript/toc/starts-with-newline.js" "javascript/toc/starts-with-newline.js") - diff <- runTaskWithOptions (defaultOptions { optionsLogLevel = Nothing }) $ diffWithParser rubyParser sourceBlobs + diff <- runTaskWithOptions (defaultOptions { optionsLogLevel = Nothing }) $ diffWithParser typescriptParser sourceBlobs diffTOC diff `shouldBe` [] prop "inserts of methods and functions are summarized" . forAll ((not . isMethodOrFunction . Prelude.snd) `filterT` tiers) $ @@ -152,7 +152,7 @@ spec = parallel $ do it "produces JSON output if there are parse errors" $ do blobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.X.rb") output <- runTaskWithOptions (defaultOptions { optionsLogLevel = Nothing }) (runDiff ToCDiffRenderer [blobs]) - runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString) + runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,3]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString) it "ignores anonymous functions" $ do blobs <- blobsForPaths (both "ruby/toc/lambda.A.rb" "ruby/toc/lambda.B.rb") @@ -165,25 +165,25 @@ spec = parallel $ do runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/markdown/toc/headings.A.md -> test/fixtures/markdown/toc/headings.B.md\":[{\"span\":{\"start\":[1,1],\"end\":[3,16]},\"category\":\"Heading 1\",\"term\":\"Introduction\",\"changeType\":\"removed\"},{\"span\":{\"start\":[5,1],\"end\":[7,4]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"modified\"},{\"span\":{\"start\":[9,1],\"end\":[11,10]},\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"changeType\":\"added\"},{\"span\":{\"start\":[13,1],\"end\":[14,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString) -type Diff' = Diff ListableSyntax (Record '[Maybe Declaration, Range, Span]) (Record '[Maybe Declaration, Range, Span]) -type Term' = Term ListableSyntax (Record '[Maybe Declaration, Range, Span]) +type Diff' = Diff ListableSyntax (Maybe Declaration) (Maybe Declaration) +type Term' = Term ListableSyntax (Maybe Declaration) numTocSummaries :: Diff' -> Int numTocSummaries diff = length $ filter isValidSummary (diffTOC diff) -- Return a diff where body is inserted in the expressions of a function. The function is present in both sides of the diff. programWithChange :: Term' -> Diff' -programWithChange body = merge (programInfo, programInfo) (inject [ function' ]) +programWithChange body = merge (Nothing, Nothing) (inject [ function' ]) where - function' = merge (Just (FunctionDeclaration "foo" mempty Ruby) :. emptyInfo, Just (FunctionDeclaration "foo" mempty Ruby) :. emptyInfo) (inject (Declaration.Function [] name' [] (merge (Nothing :. emptyInfo, Nothing :. emptyInfo) (inject [ inserting body ])))) - name' = let info = Nothing :. emptyInfo in merge (info, info) (inject (Syntax.Identifier (name "foo"))) + function' = merge (Just (FunctionDeclaration "foo" mempty lowerBound Ruby), Just (FunctionDeclaration "foo" mempty lowerBound Ruby)) (inject (Declaration.Function [] name' [] (merge (Nothing, Nothing) (inject [ inserting body ])))) + name' = merge (Nothing, Nothing) (inject (Syntax.Identifier (name "foo"))) -- Return a diff where term is inserted in the program, below a function found on both sides of the diff. programWithChangeOutsideFunction :: Term' -> Diff' -programWithChangeOutsideFunction term = merge (programInfo, programInfo) (inject [ function', term' ]) +programWithChangeOutsideFunction term = merge (Nothing, Nothing) (inject [ function', term' ]) where - function' = merge (Just (FunctionDeclaration "foo" mempty Unknown) :. emptyInfo, Just (FunctionDeclaration "foo" mempty Unknown) :. emptyInfo) (inject (Declaration.Function [] name' [] (merge (Nothing :. emptyInfo, Nothing :. emptyInfo) (inject [])))) - name' = let info = Nothing :. emptyInfo in merge (info, info) (inject (Syntax.Identifier (name "foo"))) + function' = merge (Nothing, Nothing) (inject (Declaration.Function [] name' [] (merge (Nothing, Nothing) (inject [])))) + name' = merge (Nothing, Nothing) (inject (Syntax.Identifier (name "foo"))) term' = inserting term programWithInsert :: Text -> Term' -> Diff' @@ -196,56 +196,47 @@ programWithReplace :: Text -> Term' -> Diff' programWithReplace name body = programOf $ replacing (functionOf name body) (functionOf (name <> "2") body) programOf :: Diff' -> Diff' -programOf diff = merge (programInfo, programInfo) (inject [ diff ]) +programOf diff = merge (Nothing, Nothing) (inject [ diff ]) functionOf :: Text -> Term' -> Term' -functionOf n body = termIn (Just (FunctionDeclaration n mempty Unknown) :. emptyInfo) (inject (Declaration.Function [] name' [] (termIn (Nothing :. emptyInfo) (inject [body])))) +functionOf n body = termIn (Just (FunctionDeclaration n mempty lowerBound Unknown)) (inject (Declaration.Function [] name' [] (termIn Nothing (inject [body])))) where - name' = termIn (Nothing :. emptyInfo) (inject (Syntax.Identifier (name n))) - -programInfo :: Record '[Maybe Declaration, Range, Span] -programInfo = Nothing :. emptyInfo - -emptyInfo :: Record '[Range, Span] -emptyInfo = Range 0 0 :. Span (Pos 0 0) (Pos 0 0) :. Nil + name' = termIn Nothing (inject (Syntax.Identifier (name n))) -- Filter tiers for terms that we consider "meaniningful" in TOC summaries. isMeaningfulTerm :: Term ListableSyntax a -> Bool isMeaningfulTerm a | Just (_:_) <- project (termOut a) = False | Just [] <- project (termOut a) = False - | otherwise = True + | otherwise = True -- Filter tiers for terms if the Syntax is a Method or a Function. isMethodOrFunction :: Term' -> Bool isMethodOrFunction a | Just Declaration.Method{} <- project (termOut a) = True | Just Declaration.Function{} <- project (termOut a) = True - | any isJust (foldMap ((:[]) . rhead) a) = True - | otherwise = False + | any isJust (foldMap (:[]) a) = True + | otherwise = False blobsForPaths :: Both FilePath -> IO BlobPair blobsForPaths = readFilePair . fmap ("test/fixtures" ) blankDiff :: Diff' -blankDiff = merge (arrayInfo, arrayInfo) (inject [ inserting (termIn literalInfo (inject (Syntax.Identifier (name "\"a\"")))) ]) - where - arrayInfo = Nothing :. Range 0 3 :. Span (Pos 1 1) (Pos 1 5) :. Nil - literalInfo = Nothing :. Range 1 2 :. Span (Pos 1 2) (Pos 1 4) :. Nil +blankDiff = merge (Nothing, Nothing) (inject [ inserting (termIn Nothing (inject (Syntax.Identifier (name "\"a\"")))) ]) -- Diff helpers -diffWithParser :: ( HasField fields Data.Span.Span - , HasField fields Range - , Eq1 syntax +diffWithParser :: ( Eq1 syntax , Show1 syntax , Traversable syntax , Diffable syntax , HasDeclaration syntax , Hashable1 syntax - , Member Distribute effs - , Member Task effs + , Member Distribute sig + , Member Task sig + , Carrier sig m + , Monad m ) - => Parser (Term syntax (Record fields)) + => Parser (Term syntax Location) -> BlobPair - -> Eff effs (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields))) + -> m (Diff syntax (Maybe Declaration) (Maybe Declaration)) diffWithParser parser blobs = distributeFor blobs (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin diff --git a/test/Reprinting/Spec.hs b/test/Reprinting/Spec.hs index 14c6bef63..8aaea58d1 100644 --- a/test/Reprinting/Spec.hs +++ b/test/Reprinting/Spec.hs @@ -2,30 +2,34 @@ module Reprinting.Spec where -import SpecHelpers hiding (project, inject) +import SpecHelpers hiding (inject, project) -import Data.Functor.Foldable (embed, cata) -import qualified Data.Language as Language -import qualified Data.Syntax.Literal as Literal -import Data.Algebra -import Reprinting.Tokenize -import Reprinting.Pipeline -import Data.Sum -import Data.Foldable -import Semantic.IO -import Semantic.Util.Rewriting hiding (parseFile) -import Data.Blob -import Language.JSON.PrettyPrint -import Language.Ruby.PrettyPrint -import Language.Python.PrettyPrint +import Data.Foldable +import Data.Functor.Foldable (cata, embed) import qualified Data.Machine as Machine +import Control.Rewriting hiding (context) +import Data.Algebra +import Data.Blob +import qualified Data.Language as Language +import Data.Reprinting.Scope +import Data.Reprinting.Token +import Data.Sum +import qualified Data.Syntax.Literal as Literal +import Language.JSON.PrettyPrint +import Language.Python.PrettyPrint +import Language.Ruby.PrettyPrint +import Reprinting.Pipeline +import Reprinting.Tokenize +import Semantic.IO +import Semantic.Util.Rewriting hiding (parseFile) + spec :: Spec spec = describe "reprinting" $ do context "JSON" $ do let path = "test/fixtures/javascript/reprinting/map.json" (src, tree) <- runIO $ do - src <- blobSource <$> readBlobFromPath (File path Language.JSON) + src <- blobSource <$> readBlobFromFile' (File path Language.JSON) tree <- parseFile jsonParser path pure (src, tree) @@ -40,9 +44,9 @@ spec = describe "reprinting" $ do it "should emit control tokens but only 1 chunk for a wholly-modified tree" $ do let toks = Machine.run $ tokenizing src (mark Refactored tree) - for_ @[] [TList, THash] $ \t -> do - toks `shouldSatisfy` elem (TControl (Enter t)) - toks `shouldSatisfy` elem (TControl (Exit t)) + for_ @[] [List, Hash] $ \t -> do + toks `shouldSatisfy` elem (Control (Enter t)) + toks `shouldSatisfy` elem (Control (Exit t)) describe "pipeline" $ do @@ -57,7 +61,7 @@ spec = describe "reprinting" $ do printed `shouldBe` Right src it "should be able to parse the output of a refactor" $ do - let tagged = increaseNumbers (mark Refactored tree) + let (Right tagged) = rewrite (somewhere increaseNumbers markRefactored) () (mark Unmodified tree) let (Right printed) = runReprinter src defaultJSONPipeline tagged tree' <- runTask (parse jsonParser (Blob printed path Language.JSON)) length tree' `shouldSatisfy` (/= 0) diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index bac839fdd..d7402db1c 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -16,6 +16,8 @@ import qualified TreeSitter.Node as TS import qualified TreeSitter.Parser as TS import qualified TreeSitter.Tree as TS +import Data.Blob +import Data.Handle import SpecHelpers hiding (readFile) @@ -23,17 +25,19 @@ spec :: Spec spec = parallel $ do describe "readFile" $ do it "returns a blob for extant files" $ do - Just blob <- readFile (File "semantic.cabal" Unknown) + Just blob <- readBlobFromFile (File "semantic.cabal" Unknown) blobPath blob `shouldBe` "semantic.cabal" it "throws for absent files" $ do - readFile (File "this file should not exist" Unknown) `shouldThrow` anyIOException + readBlobFromFile (File "this file should not exist" Unknown) `shouldThrow` anyIOException describe "readBlobPairsFromHandle" $ do let a = sourceBlob "method.rb" Ruby "def foo; end" let b = sourceBlob "method.rb" Ruby "def bar(x); end" it "returns blobs for valid JSON encoded diff input" $ do + putStrLn "step 1" blobs <- blobsFromFilePath "test/fixtures/cli/diff.json" + putStrLn "done" blobs `shouldBe` [blobPairDiffing a b] it "returns blobs when there's no before" $ do @@ -106,5 +110,7 @@ spec = parallel $ do where blobsFromFilePath path = do h <- openFileForReading path + putStrLn "got handle" blobs <- readBlobPairsFromHandle h + putStrLn "got blobs" pure blobs diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index c487ba1ae..f53cb9019 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -15,9 +15,8 @@ spec = parallel $ do output <- fmap runBuilder . runTask $ runParse JSONTermRenderer [ methodsBlob { blobLanguage = Unknown } ] output `shouldBe` "{\"trees\":[{\"error\":{\"path\":\"methods.rb\",\"language\":\"Unknown\",\"message\":\"NoLanguageForBlob \\\"methods.rb\\\"\"}}]}\n" - it "drops results for sexpression output" $ do - output <- fmap runBuilder . runTask $ runParse SExpressionTermRenderer [ methodsBlob { blobLanguage = Unknown } ] - output `shouldBe` "" + it "throws if given an unknown language for sexpression output" $ do + runTask (runParse SExpressionTermRenderer [methodsBlob { blobLanguage = Unknown }]) `shouldThrow` (== ExitFailure 1) it "renders with the specified renderer" $ do output <- fmap runBuilder . runTask $ runParse SExpressionTermRenderer [methodsBlob] diff --git a/test/Spec.hs b/test/Spec.hs index 319f7be57..844621665 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,10 +7,16 @@ import qualified Analysis.Ruby.Spec import qualified Analysis.TypeScript.Spec import qualified Assigning.Assignment.Spec import qualified Control.Abstract.Evaluator.Spec +import qualified Control.Rewriting.Spec import qualified Data.Diff.Spec +import qualified Data.Abstract.Environment.Spec +import qualified Data.Abstract.Name.Spec import qualified Data.Abstract.Path.Spec import qualified Data.Functor.Classes.Generic.Spec +import qualified Data.Graph.Spec +import qualified Data.Range.Spec import qualified Data.Scientific.Spec +import qualified Data.Semigroup.App.Spec import qualified Data.Source.Spec import qualified Data.Term.Spec import qualified Diffing.Algorithm.RWS.Spec @@ -45,10 +51,16 @@ main = do describe "Analysis.TypeScript" (Analysis.TypeScript.Spec.spec args) describe "Assigning.Assignment" Assigning.Assignment.Spec.spec describe "Control.Abstract.Evaluator" Control.Abstract.Evaluator.Spec.spec + describe "Control.Rewriting.Spec" Control.Rewriting.Spec.spec describe "Data.Diff" Data.Diff.Spec.spec + describe "Data.Graph" Data.Graph.Spec.spec + describe "Data.Abstract.Environment.Spec" Data.Abstract.Environment.Spec.spec describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec + describe "Data.Abstract.Name" Data.Abstract.Name.Spec.spec describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec + describe "Data.Range" Data.Range.Spec.spec describe "Data.Scientific" Data.Scientific.Spec.spec + describe "Data.Semigroup.App" Data.Semigroup.App.Spec.spec describe "Data.Source" Data.Source.Spec.spec describe "Data.Term" Data.Term.Spec.spec describe "Diffing.Algorithm.RWS" Diffing.Algorithm.RWS.Spec.spec diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index c219edc9a..49a108ca2 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -10,7 +10,6 @@ module SpecHelpers , deNamespace , derefQName , verbatim -, TermEvaluator(..) , Verbatim(..) , toList , Config @@ -20,7 +19,7 @@ module SpecHelpers import Control.Abstract import Control.Arrow ((&&&)) -import Control.Monad.Effect.Trace as X (runIgnoringTrace, runReturningTrace) +import Control.Effect.Trace as X (runTraceByIgnoring, runTraceByReturning) import Control.Monad ((>=>)) import Data.Abstract.Address.Precise as X import Data.Abstract.Environment as Env @@ -37,12 +36,13 @@ import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Lazy (toStrict) import Data.Project as X import Data.Proxy as X +import qualified Data.File as F +import Data.File as X hiding (readFilePair) import Data.Foldable (toList) import Data.Functor.Listable as X import Data.Language as X import Data.List.NonEmpty as X (NonEmpty(..)) import Data.Range as X -import Data.Record as X import Data.Semilattice.Lower as X import Data.Source as X import Data.Span as X @@ -73,7 +73,6 @@ import qualified Data.ByteString as B import qualified Data.Set as Set import qualified Semantic.IO as IO import Semantic.Config (Config) -import Semantic.Graph (ConcreteEff) import Semantic.Telemetry (LogQueue, StatQueue) import System.Exit (die) import Control.Exception (displayException) @@ -91,46 +90,47 @@ diffFilePaths (TaskConfig config logger statter) paths = readFilePair paths >>= -- | Returns an s-expression parse tree for the specified FilePath. parseFilePath :: TaskConfig -> FilePath -> IO ByteString -parseFilePath (TaskConfig config logger statter) path = (fromJust <$> IO.readFile (file path)) >>= runTaskWithConfig config logger statter . runParse SExpressionTermRenderer . pure >>= either (die . displayException) (pure . runBuilder) +parseFilePath (TaskConfig config logger statter) path = (fromJust <$> readBlobFromFile (file path)) >>= runTaskWithConfig config logger statter . runParse SExpressionTermRenderer . pure >>= either (die . displayException) (pure . runBuilder) -- | Read two files to a BlobPair. readFilePair :: Both FilePath -> IO BlobPair readFilePair paths = let paths' = fmap file paths in - runBothWith IO.readFilePair paths' + runBothWith F.readFilePair paths' -type TestEvaluatingEffects = '[ Resumable (BaseError (ValueError Precise (ConcreteEff Precise '[Trace, Lift IO]))) - , Resumable (BaseError (AddressError Precise Val)) - , Resumable (BaseError ResolutionError) - , Resumable (BaseError EvalError) - , Resumable (BaseError (EnvironmentError Precise)) - , Resumable (BaseError (UnspecializedError Val)) - , Resumable (BaseError (LoadError Precise)) - , Fresh - , State (Heap Precise Val) - , Trace - , Lift IO - ] -type TestEvaluatingErrors = '[ BaseError (ValueError Precise (ConcreteEff Precise '[Trace, Lift IO])) - , BaseError (AddressError Precise Val) - , BaseError ResolutionError - , BaseError EvalError - , BaseError (EnvironmentError Precise) - , BaseError (UnspecializedError Val) - , BaseError (LoadError Precise) - ] -testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (Span, a) +type TestEvaluatingC term + = ResumableC (BaseError (ValueError term Precise)) (Eff + ( ResumableC (BaseError (AddressError Precise (Val term))) (Eff + ( ResumableC (BaseError ResolutionError) (Eff + ( ResumableC (BaseError EvalError) (Eff + ( ResumableC (BaseError (EnvironmentError Precise)) (Eff + ( ResumableC (BaseError (UnspecializedError (Val term))) (Eff + ( ResumableC (BaseError (LoadError Precise)) (Eff + ( FreshC (Eff + ( StateC (Heap Precise (Val term)) (Eff + ( TraceByReturningC (Eff + ( LiftC IO)))))))))))))))))))) +type TestEvaluatingErrors term + = '[ BaseError (ValueError term Precise) + , BaseError (AddressError Precise (Val term)) + , BaseError ResolutionError + , BaseError EvalError + , BaseError (EnvironmentError Precise) + , BaseError (UnspecializedError (Val term)) + , BaseError (LoadError Precise) + ] +testEvaluating :: Evaluator term Precise (Val term) (TestEvaluatingC term) (Span, a) -> IO ( [String] - , ( Heap Precise Val - , Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors)) - a + , ( Heap Precise (Val term) + , Either (SomeError (Data.Sum.Sum (TestEvaluatingErrors term))) a ) ) testEvaluating = runM - . runReturningTrace + . runTraceByReturning . runState lowerBound - . runFresh 0 + . runFresh + . runEvaluator . fmap reassociate . runLoadError . runUnspecialized @@ -138,36 +138,37 @@ testEvaluating . runEvalError . runResolutionError . runAddressError - . runValueError @_ @Precise @(ConcreteEff Precise _) + . runValueError @_ @_ @_ @Precise . fmap snd -type Val = Value Precise (ConcreteEff Precise '[Trace, Lift IO]) +type Val term = Value term Precise -deNamespace :: Heap Precise (Value Precise term) - -> Value Precise term +deNamespace :: Heap Precise (Value term Precise) + -> Value term Precise -> Maybe (Name, [Name]) deNamespace heap ns@(Namespace name _ _) = (,) name . Env.allNames <$> namespaceScope heap ns deNamespace _ _ = Nothing -namespaceScope :: Heap Precise (Value Precise term) - -> Value Precise term +namespaceScope :: Heap Precise (Value term Precise) + -> Value term Precise -> Maybe (Environment Precise) namespaceScope heap ns@(Namespace _ _ _) = either (const Nothing) (snd . snd) . run - . runFresh 0 + . runFresh + . runEvaluator . runAddressError - . runState heap - . runState (lowerBound @Span) - . runReader (lowerBound @Span) - . runReader (ModuleInfo "SpecHelper.hs") + . raiseHandler (runState heap) + . raiseHandler (runState (lowerBound @Span)) + . raiseHandler (runReader (lowerBound @Span)) + . raiseHandler (runReader (ModuleInfo "SpecHelper.hs")) . runDeref $ materializeEnvironment ns namespaceScope _ _ = Nothing -derefQName :: Heap Precise (Value Precise term) -> NonEmpty Name -> Bindings Precise -> Maybe (Value Precise term) +derefQName :: Heap Precise (Value term Precise) -> NonEmpty Name -> Bindings Precise -> Maybe (Value term Precise) derefQName heap names binds = go names (Env.newEnv binds) where go (n1 :| ns) env = Env.lookupEnv' n1 env >>= flip heapLookup heap >>= fmap fst . Set.minView >>= case ns of [] -> Just diff --git a/test/fixtures/json/rewriting/add_keys.json b/test/fixtures/json/rewriting/add_keys.json new file mode 100644 index 000000000..24fedec0b --- /dev/null +++ b/test/fixtures/json/rewriting/add_keys.json @@ -0,0 +1,6 @@ +{ + "fore": "aft", + "dang": {"dude": "yeah"}, + "100": "one hundred", + "test": {} +} diff --git a/test/fixtures/json/rewriting/add_keys_expected.json b/test/fixtures/json/rewriting/add_keys_expected.json new file mode 100644 index 000000000..80fd1a994 --- /dev/null +++ b/test/fixtures/json/rewriting/add_keys_expected.json @@ -0,0 +1,8 @@ +{ + "fore": "aft", + "dang": {"dude": "yeah"}, + "100": "one hundred", + "test": { + "hi": "bye" + } +} diff --git a/test/fixtures/python/corpus/if-statement.diffA-B.txt b/test/fixtures/python/corpus/if-statement.diffA-B.txt index e6ee07be7..73373132b 100644 --- a/test/fixtures/python/corpus/if-statement.diffA-B.txt +++ b/test/fixtures/python/corpus/if-statement.diffA-B.txt @@ -6,12 +6,13 @@ {+(Identifier)+} (Identifier) {-(Identifier)-}) - { (If - {-(Identifier)-} + (Statements + {-(If + {-(Identifier)-} + {-(Statements + {-(Identifier)-} + {-(Identifier)-})-} + {-(Statements)-})-} {-(Statements {-(Identifier)-} - {-(Identifier)-})-} - {-(Statements - {-(Identifier)-} - {-(Identifier)-})-}) - ->(Empty) })) + {-(Identifier)-})-}))) diff --git a/test/fixtures/python/corpus/if-statement.diffB-A.txt b/test/fixtures/python/corpus/if-statement.diffB-A.txt index 49ac3de8b..7eb87032d 100644 --- a/test/fixtures/python/corpus/if-statement.diffB-A.txt +++ b/test/fixtures/python/corpus/if-statement.diffB-A.txt @@ -6,12 +6,13 @@ {-(Identifier)-} (Identifier) {+(Identifier)+}) - { (Empty) - ->(If - {+(Identifier)+} + (Statements + {+(If + {+(Identifier)+} + {+(Statements + {+(Identifier)+} + {+(Identifier)+})+} + {+(Statements)+})+} {+(Statements {+(Identifier)+} - {+(Identifier)+})+} - {+(Statements - {+(Identifier)+} - {+(Identifier)+})+}) })) + {+(Identifier)+})+}))) diff --git a/test/fixtures/python/corpus/if-statement.parseA.txt b/test/fixtures/python/corpus/if-statement.parseA.txt index 5c119db77..d66f56a4f 100644 --- a/test/fixtures/python/corpus/if-statement.parseA.txt +++ b/test/fixtures/python/corpus/if-statement.parseA.txt @@ -4,11 +4,13 @@ (Statements (Identifier) (Identifier)) - (If - (Identifier) - (Statements + (Statements + (If (Identifier) - (Identifier)) + (Statements + (Identifier) + (Identifier)) + (Statements)) (Statements (Identifier) (Identifier))))) diff --git a/test/fixtures/python/corpus/if-statement.parseB.txt b/test/fixtures/python/corpus/if-statement.parseB.txt index b289f3fe5..f50e9e432 100644 --- a/test/fixtures/python/corpus/if-statement.parseB.txt +++ b/test/fixtures/python/corpus/if-statement.parseB.txt @@ -4,4 +4,4 @@ (Statements (Identifier) (Identifier)) - (Empty))) + (Statements))) diff --git a/test/fixtures/ruby/corpus/if.diffA-B.txt b/test/fixtures/ruby/corpus/if.diffA-B.txt index ee09c8179..7c4319294 100644 --- a/test/fixtures/ruby/corpus/if.diffA-B.txt +++ b/test/fixtures/ruby/corpus/if.diffA-B.txt @@ -18,5 +18,6 @@ {+(If {+(Send {+(Identifier)+})+} - {+(Statements)+} + {+(Statements + {+(Statements)+})+} {+(Empty)+})+}) diff --git a/test/fixtures/ruby/corpus/if.diffB-A.txt b/test/fixtures/ruby/corpus/if.diffB-A.txt index 68c2a1709..0c1552787 100644 --- a/test/fixtures/ruby/corpus/if.diffB-A.txt +++ b/test/fixtures/ruby/corpus/if.diffB-A.txt @@ -18,5 +18,6 @@ {-(If {-(Send {-(Identifier)-})-} - {-(Statements)-} + {-(Statements + {-(Statements)-})-} {-(Empty)-})-}) diff --git a/test/fixtures/ruby/corpus/if.parseB.txt b/test/fixtures/ruby/corpus/if.parseB.txt index ff39ff4e3..e0e74289d 100644 --- a/test/fixtures/ruby/corpus/if.parseB.txt +++ b/test/fixtures/ruby/corpus/if.parseB.txt @@ -7,5 +7,6 @@ (If (Send (Identifier)) - (Statements) + (Statements + (Statements)) (Empty))) diff --git a/test/fixtures/ruby/corpus/unless.diffA-B.txt b/test/fixtures/ruby/corpus/unless.diffA-B.txt index 5097e8529..de578d6d3 100644 --- a/test/fixtures/ruby/corpus/unless.diffA-B.txt +++ b/test/fixtures/ruby/corpus/unless.diffA-B.txt @@ -14,5 +14,6 @@ {+(Not {+(Send {+(Identifier)+})+})+} - {+(Statements)+} + {+(Statements + {+(Statements)+})+} {+(Empty)+})+}) diff --git a/test/fixtures/ruby/corpus/unless.diffB-A.txt b/test/fixtures/ruby/corpus/unless.diffB-A.txt index 9b84c28f8..1436f1792 100644 --- a/test/fixtures/ruby/corpus/unless.diffB-A.txt +++ b/test/fixtures/ruby/corpus/unless.diffB-A.txt @@ -14,5 +14,6 @@ {-(Not {-(Send {-(Identifier)-})-})-} - {-(Statements)-} + {-(Statements + {-(Statements)-})-} {-(Empty)-})-}) diff --git a/test/fixtures/ruby/corpus/unless.parseB.txt b/test/fixtures/ruby/corpus/unless.parseB.txt index 9662e1fab..15fe52639 100644 --- a/test/fixtures/ruby/corpus/unless.parseB.txt +++ b/test/fixtures/ruby/corpus/unless.parseB.txt @@ -9,5 +9,6 @@ (Not (Send (Identifier))) - (Statements) + (Statements + (Statements)) (Empty))) diff --git a/test/fixtures/ruby/corpus/when-else.B.rb b/test/fixtures/ruby/corpus/when-else.B.rb index 028bb595f..e0cb03e92 100644 --- a/test/fixtures/ruby/corpus/when-else.B.rb +++ b/test/fixtures/ruby/corpus/when-else.B.rb @@ -1,6 +1,8 @@ case foo when bar baz +when x +when y else qoz end diff --git a/test/fixtures/ruby/corpus/when-else.diffA-B.txt b/test/fixtures/ruby/corpus/when-else.diffA-B.txt index 08579b880..9aa7e9f78 100644 --- a/test/fixtures/ruby/corpus/when-else.diffA-B.txt +++ b/test/fixtures/ruby/corpus/when-else.diffA-B.txt @@ -3,23 +3,33 @@ (Send (Identifier)) (Statements + {+(Pattern + {+(Statements + {+(Send + {+(Identifier)+})+})+} + {+(Statements + {+(Send + {+(Identifier)+})+})+})+} (Pattern (Statements (Send { (Identifier) ->(Identifier) })) - (Statements + (Statements)) + {+(Pattern + {+(Statements {+(Send - {+(Identifier)+})+} - {+(Send - {+(Identifier)+})+} - {-(Pattern - {-(Statements - {-(Send - {-(Identifier)-})-} - {-(Send - {-(Identifier)-})-})-} - {-(Statements - {-(Send - {-(Identifier)-})-} - {-(Statements)-})-})-}))))) + {+(Identifier)+})+})+} + {+(Statements)+})+} + {+(Send + {+(Identifier)+})+} + {-(Pattern + {-(Statements + {-(Send + {-(Identifier)-})-} + {-(Send + {-(Identifier)-})-})-} + {-(Statements + {-(Send + {-(Identifier)-})-})-})-} + {-(Statements)-}))) diff --git a/test/fixtures/ruby/corpus/when-else.diffB-A.txt b/test/fixtures/ruby/corpus/when-else.diffB-A.txt index b130388e8..bb9a453d8 100644 --- a/test/fixtures/ruby/corpus/when-else.diffB-A.txt +++ b/test/fixtures/ruby/corpus/when-else.diffB-A.txt @@ -3,23 +3,30 @@ (Send (Identifier)) (Statements + {+(Pattern + {+(Statements + {+(Send + {+(Identifier)+})+})+} + {+(Statements)+})+} (Pattern (Statements (Send - { (Identifier) - ->(Identifier) })) + (Identifier)) + {+(Send + {+(Identifier)+})+}) (Statements - {+(Pattern - {+(Statements - {+(Send - {+(Identifier)+})+} - {+(Send - {+(Identifier)+})+})+} - {+(Statements - {+(Send - {+(Identifier)+})+} - {+(Statements)+})+})+} + (Send + (Identifier)))) + {+(Statements)+} + {-(Pattern + {-(Statements {-(Send - {-(Identifier)-})-} + {-(Identifier)-})-})-} + {-(Statements)-})-} + {-(Pattern + {-(Statements {-(Send - {-(Identifier)-})-}))))) + {-(Identifier)-})-})-} + {-(Statements)-})-} + {-(Send + {-(Identifier)-})-}))) diff --git a/test/fixtures/ruby/corpus/when-else.parseA.txt b/test/fixtures/ruby/corpus/when-else.parseA.txt index e782e5233..4ad38cef0 100644 --- a/test/fixtures/ruby/corpus/when-else.parseA.txt +++ b/test/fixtures/ruby/corpus/when-else.parseA.txt @@ -7,14 +7,14 @@ (Statements (Send (Identifier))) + (Statements)) + (Pattern (Statements - (Pattern - (Statements - (Send - (Identifier)) - (Send - (Identifier))) - (Statements - (Send - (Identifier)) - (Statements)))))))) + (Send + (Identifier)) + (Send + (Identifier))) + (Statements + (Send + (Identifier)))) + (Statements)))) diff --git a/test/fixtures/ruby/corpus/when-else.parseB.txt b/test/fixtures/ruby/corpus/when-else.parseB.txt index d01cc541f..f813939bb 100644 --- a/test/fixtures/ruby/corpus/when-else.parseB.txt +++ b/test/fixtures/ruby/corpus/when-else.parseB.txt @@ -9,6 +9,16 @@ (Identifier))) (Statements (Send - (Identifier)) + (Identifier)))) + (Pattern + (Statements (Send - (Identifier))))))) + (Identifier))) + (Statements)) + (Pattern + (Statements + (Send + (Identifier))) + (Statements)) + (Send + (Identifier))))) diff --git a/test/fixtures/ruby/corpus/when.diffA-B.txt b/test/fixtures/ruby/corpus/when.diffA-B.txt index e9b501002..cfc1de620 100644 --- a/test/fixtures/ruby/corpus/when.diffA-B.txt +++ b/test/fixtures/ruby/corpus/when.diffA-B.txt @@ -8,17 +8,17 @@ (Send (Identifier))) (Statements + {+(Send + {+(Identifier)+})+})) + {+(Pattern + {+(Statements {+(Send {+(Identifier)+})+} - {+(Pattern - {+(Statements - {+(Send - {+(Identifier)+})+} - {+(Send - {+(Identifier)+})+})+} - {+(Statements - {+(Send - {+(Identifier)+})+})+})+})))) + {+(Send + {+(Identifier)+})+})+} + {+(Statements)+})+} + {+(Send + {+(Identifier)+})+})) {-(Match {-(Empty)-} {-(Statements diff --git a/test/fixtures/ruby/corpus/when.diffB-A.txt b/test/fixtures/ruby/corpus/when.diffB-A.txt index 7d2880cc0..ec07279c8 100644 --- a/test/fixtures/ruby/corpus/when.diffB-A.txt +++ b/test/fixtures/ruby/corpus/when.diffB-A.txt @@ -8,17 +8,17 @@ (Send (Identifier))) (Statements + {-(Send + {-(Identifier)-})-})) + {-(Pattern + {-(Statements {-(Send {-(Identifier)-})-} - {-(Pattern - {-(Statements - {-(Send - {-(Identifier)-})-} - {-(Send - {-(Identifier)-})-})-} - {-(Statements - {-(Send - {-(Identifier)-})-})-})-})))) + {-(Send + {-(Identifier)-})-})-} + {-(Statements)-})-} + {-(Send + {-(Identifier)-})-})) {+(Match {+(Empty)+} {+(Statements diff --git a/test/fixtures/ruby/corpus/when.parseB.txt b/test/fixtures/ruby/corpus/when.parseB.txt index 3c54f2901..2144c5a90 100644 --- a/test/fixtures/ruby/corpus/when.parseB.txt +++ b/test/fixtures/ruby/corpus/when.parseB.txt @@ -7,15 +7,15 @@ (Statements (Send (Identifier))) + (Statements + (Send + (Identifier)))) + (Pattern (Statements (Send (Identifier)) - (Pattern - (Statements - (Send - (Identifier)) - (Send - (Identifier))) - (Statements - (Send - (Identifier))))))))) + (Send + (Identifier))) + (Statements)) + (Send + (Identifier))))) diff --git a/test/fixtures/typescript/corpus/class.diffA-B.txt b/test/fixtures/typescript/corpus/class.diffA-B.txt index 29879240f..5c98bcf04 100644 --- a/test/fixtures/typescript/corpus/class.diffA-B.txt +++ b/test/fixtures/typescript/corpus/class.diffA-B.txt @@ -1,8 +1,8 @@ (Statements (Class (TypeParameter - { (Identifier) - ->(Identifier) } + { (TypeIdentifier) + ->(TypeIdentifier) } (Empty) (Empty)) { (TypeIdentifier) diff --git a/test/fixtures/typescript/corpus/class.diffB-A.txt b/test/fixtures/typescript/corpus/class.diffB-A.txt index 926e88625..153584c01 100644 --- a/test/fixtures/typescript/corpus/class.diffB-A.txt +++ b/test/fixtures/typescript/corpus/class.diffB-A.txt @@ -1,8 +1,8 @@ (Statements (Class (TypeParameter - { (Identifier) - ->(Identifier) } + { (TypeIdentifier) + ->(TypeIdentifier) } (Empty) (Empty)) { (TypeIdentifier) diff --git a/test/fixtures/typescript/corpus/class.parseA.txt b/test/fixtures/typescript/corpus/class.parseA.txt index c6cec68e4..4747bd525 100644 --- a/test/fixtures/typescript/corpus/class.parseA.txt +++ b/test/fixtures/typescript/corpus/class.parseA.txt @@ -1,7 +1,7 @@ (Statements (Class (TypeParameter - (Identifier) + (TypeIdentifier) (Empty) (Empty)) (TypeIdentifier) diff --git a/test/fixtures/typescript/corpus/class.parseB.txt b/test/fixtures/typescript/corpus/class.parseB.txt index 9a7ad3a5b..e5b62e6b9 100644 --- a/test/fixtures/typescript/corpus/class.parseB.txt +++ b/test/fixtures/typescript/corpus/class.parseB.txt @@ -1,7 +1,7 @@ (Statements (Class (TypeParameter - (Identifier) + (TypeIdentifier) (Empty) (Empty)) (TypeIdentifier) diff --git a/test/fixtures/typescript/corpus/function.diffA-B.txt b/test/fixtures/typescript/corpus/function.diffA-B.txt index 5c54f63d9..5e05038d2 100644 --- a/test/fixtures/typescript/corpus/function.diffA-B.txt +++ b/test/fixtures/typescript/corpus/function.diffA-B.txt @@ -5,7 +5,7 @@ {+(TypeIdentifier)+})+} {-(TypeParameters {-(TypeParameter - {-(Identifier)-} + {-(TypeIdentifier)-} {-(Empty)-} {-(Empty)-})-})-} {-(Annotation diff --git a/test/fixtures/typescript/corpus/function.diffB-A.txt b/test/fixtures/typescript/corpus/function.diffB-A.txt index 7a9134389..57a351ac8 100644 --- a/test/fixtures/typescript/corpus/function.diffB-A.txt +++ b/test/fixtures/typescript/corpus/function.diffB-A.txt @@ -2,7 +2,7 @@ (Function {+(TypeParameters {+(TypeParameter - {+(Identifier)+} + {+(TypeIdentifier)+} {+(Empty)+} {+(Empty)+})+})+} {+(Annotation diff --git a/test/fixtures/typescript/corpus/function.parseA.txt b/test/fixtures/typescript/corpus/function.parseA.txt index c50656cda..db85ab16c 100644 --- a/test/fixtures/typescript/corpus/function.parseA.txt +++ b/test/fixtures/typescript/corpus/function.parseA.txt @@ -2,7 +2,7 @@ (Function (TypeParameters (TypeParameter - (Identifier) + (TypeIdentifier) (Empty) (Empty))) (Annotation diff --git a/test/fixtures/typescript/corpus/interface.diffA-B.txt b/test/fixtures/typescript/corpus/interface.diffA-B.txt index 6a32ceab7..611ad4d1e 100644 --- a/test/fixtures/typescript/corpus/interface.diffA-B.txt +++ b/test/fixtures/typescript/corpus/interface.diffA-B.txt @@ -3,7 +3,7 @@ {+(Empty)+} {-(TypeParameters {-(TypeParameter - {-(Identifier)-} + {-(TypeIdentifier)-} {-(Empty)-} {-(Empty)-})-})-} { (TypeIdentifier) diff --git a/test/fixtures/typescript/corpus/interface.diffB-A.txt b/test/fixtures/typescript/corpus/interface.diffB-A.txt index 642cc7eab..e7d262f88 100644 --- a/test/fixtures/typescript/corpus/interface.diffB-A.txt +++ b/test/fixtures/typescript/corpus/interface.diffB-A.txt @@ -2,7 +2,7 @@ (InterfaceDeclaration {+(TypeParameters {+(TypeParameter - {+(Identifier)+} + {+(TypeIdentifier)+} {+(Empty)+} {+(Empty)+})+})+} {-(Empty)-} diff --git a/test/fixtures/typescript/corpus/interface.parseA.txt b/test/fixtures/typescript/corpus/interface.parseA.txt index 1b6b96deb..99f663d59 100644 --- a/test/fixtures/typescript/corpus/interface.parseA.txt +++ b/test/fixtures/typescript/corpus/interface.parseA.txt @@ -2,7 +2,7 @@ (InterfaceDeclaration (TypeParameters (TypeParameter - (Identifier) + (TypeIdentifier) (Empty) (Empty))) (TypeIdentifier) diff --git a/vendor/effects b/vendor/effects deleted file mode 160000 index 8ded4a641..000000000 --- a/vendor/effects +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 8ded4a64133ce77ddd2fc734f455753e62af0ad3