ghc-tcplugins-extra 0.4.3 → 0.4.4
raw patch · 55 files changed
+2074/−2072 lines, 55 filesdep ~ghcsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc
API changes (from Hackage documentation)
Files
- CHANGELOG.md +45/−42
- LICENSE +27/−27
- README.md +7/−7
- Setup.hs +2/−2
- defaults.dhall +44/−44
- ghc-tcplugins-extra.cabal +199/−200
- package.dhall +45/−45
- src-ghc-8.0/GhcApi/GhcPlugins.hs +5/−5
- src-ghc-8.0/Internal/Constraint.hs +25/−25
- src-ghc-8.0/Internal/Evidence.hs +14/−14
- src-ghc-8.0/Internal/Type.hs +27/−27
- src-ghc-8.10/GhcApi/GhcPlugins.hs +3/−3
- src-ghc-8.10/Internal/Constraint.hs +40/−40
- src-ghc-8.10/Internal/Evidence.hs +14/−14
- src-ghc-8.10/Internal/Type.hs +30/−30
- src-ghc-8.2/GhcApi/GhcPlugins.hs +5/−5
- src-ghc-8.2/Internal/Constraint.hs +25/−25
- src-ghc-8.2/Internal/Evidence.hs +14/−14
- src-ghc-8.2/Internal/Type.hs +29/−29
- src-ghc-8.4/GhcApi/GhcPlugins.hs +5/−5
- src-ghc-8.4/Internal/Constraint.hs +25/−25
- src-ghc-8.4/Internal/Evidence.hs +14/−14
- src-ghc-8.4/Internal/Type.hs +29/−29
- src-ghc-8.6/GhcApi/GhcPlugins.hs +3/−3
- src-ghc-8.6/Internal/Constraint.hs +42/−42
- src-ghc-8.6/Internal/Evidence.hs +14/−14
- src-ghc-8.6/Internal/Type.hs +30/−30
- src-ghc-8.8/GhcApi/GhcPlugins.hs +3/−3
- src-ghc-8.8/Internal/Constraint.hs +40/−40
- src-ghc-8.8/Internal/Evidence.hs +14/−14
- src-ghc-8.8/Internal/Type.hs +30/−30
- src-ghc-9.0/GhcApi/Constraint.hs +12/−12
- src-ghc-9.0/GhcApi/GhcPlugins.hs +5/−5
- src-ghc-9.0/Internal/Constraint.hs +49/−49
- src-ghc-9.0/Internal/Evidence.hs +13/−13
- src-ghc-9.0/Internal/Type.hs +30/−30
- src-ghc-9.2/GhcApi/Constraint.hs +13/−13
- src-ghc-9.2/GhcApi/GhcPlugins.hs +4/−4
- src-ghc-9.2/Internal/Constraint.hs +48/−48
- src-ghc-9.2/Internal/Evidence.hs +13/−13
- src-ghc-9.2/Internal/Type.hs +30/−30
- src-ghc-9.4/GhcApi/Constraint.hs +13/−13
- src-ghc-9.4/GhcApi/GhcPlugins.hs +5/−5
- src-ghc-9.4/Internal/Constraint.hs +49/−49
- src-ghc-9.4/Internal/Evidence.hs +14/−14
- src-ghc-9.4/Internal/Type.hs +30/−30
- src-ghc-cpp/Internal.hs +409/−409
- src-ghc-flat/GhcApi/Constraint.hs +12/−12
- src-ghc-flat/GhcApi/Predicate.hs +3/−3
- src-ghc-flat/Internal.hs +151/−151
- src-ghc-tree-9.4/GhcApi/Predicate.hs +3/−3
- src-ghc-tree-9.4/Internal.hs +133/−133
- src-ghc-tree/GhcApi/Predicate.hs +3/−3
- src-ghc-tree/Internal.hs +143/−143
- src/GHC/TcPluginM/Extra.hs +40/−40
CHANGELOG.md view
@@ -1,42 +1,45 @@-## 0.4.3 *September 2nd 2022* -* Support for GHC-9.4.2 - -## 0.4.2 *June 17th 2021* -* Support for GHC-9.2.0.20210422 - -## 0.4.1 *January 1st 2021* -* Support for GHC-9.0.1-rc1 - -## 0.4 *January 31st 2020* -* Expose functions for flattening constraints in GHC 8.2 and earlier - -## 0.3.2 *January 18th 2020* -* [#11](https://github.com/clash-lang/ghc-tcplugins-extra/pull/11) Support `-hide-all-plugin-packages`/`-plugin-package-id` - -## 0.3.1 *January 6th 2020* -* Support for GHC-8.9 - -## 0.3 *May 8th 2018* -* Fix bug where results of `flattenGivens` was ambiguous - -## 0.2.5 *April 15th 2018* -* Support for GHC-8.5.20180306 - -## 0.2.4 *March 17th 2018* -* Fix exports - -## 0.2.3 *March 17th 2018* -* Functions for flattening constraints - -## 0.2.2 *January 4th 2018* -* Support for GHC-8.4.1-alpha1 - -## 0.2.1 *August 15th 2017* -* Support for GHC-8.2.1 - -## 0.2 *January 19th 2016* -* `newWantedWithProvenance` and `failWithProvancence` no longer available in - GHC 8.0+ - -## 0.1 *June 3rd 2015* -* Initial release +## 0.4.4 *February 20th 2023*+* Support for GHC-9.6.0.20230210++## 0.4.3 *September 2nd 2022*+* Support for GHC-9.4.2++## 0.4.2 *June 17th 2021*+* Support for GHC-9.2.0.20210422++## 0.4.1 *January 1st 2021*+* Support for GHC-9.0.1-rc1++## 0.4 *January 31st 2020*+* Expose functions for flattening constraints in GHC 8.2 and earlier++## 0.3.2 *January 18th 2020*+* [#11](https://github.com/clash-lang/ghc-tcplugins-extra/pull/11) Support `-hide-all-plugin-packages`/`-plugin-package-id`++## 0.3.1 *January 6th 2020*+* Support for GHC-8.9++## 0.3 *May 8th 2018*+* Fix bug where results of `flattenGivens` was ambiguous++## 0.2.5 *April 15th 2018*+* Support for GHC-8.5.20180306++## 0.2.4 *March 17th 2018*+* Fix exports++## 0.2.3 *March 17th 2018*+* Functions for flattening constraints++## 0.2.2 *January 4th 2018*+* Support for GHC-8.4.1-alpha1++## 0.2.1 *August 15th 2017*+* Support for GHC-8.2.1++## 0.2 *January 19th 2016*+* `newWantedWithProvenance` and `failWithProvancence` no longer available in+ GHC 8.0+++## 0.1 *June 3rd 2015*+* Initial release
LICENSE view
@@ -1,27 +1,27 @@-Copyright (c) 2015-2016, University of Twente, - 2017-2018, QBayLogic -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. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2015-2016, University of Twente,+ 2017-2018, QBayLogic+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.++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.
README.md view
@@ -1,7 +1,7 @@-# ghc-tcplugins-extra -Utilities for writing GHC type-checker plugins - -[](https://github.com/clash-lang/ghc-tcplugins-extra-undef/actions/workflows/haskell-ci.yml) -[](https://github.com/clash-lang/ghc-tcplugins-extra-undef/actions/workflows/stack.yml) -[](https://hackage.haskell.org/package/ghc-tcplugins-extra) -[](http://packdeps.haskellers.com/feed?needle=exact%3Aghc-tcplugins-extra) +# ghc-tcplugins-extra+Utilities for writing GHC type-checker plugins++[](https://github.com/clash-lang/ghc-tcplugins-extra-undef/actions/workflows/haskell-ci.yml)+[](https://github.com/clash-lang/ghc-tcplugins-extra-undef/actions/workflows/stack.yml)+[](https://hackage.haskell.org/package/ghc-tcplugins-extra)+[](http://packdeps.haskellers.com/feed?needle=exact%3Aghc-tcplugins-extra)
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
defaults.dhall view
@@ -1,44 +1,44 @@-{ name = "ghc-tcplugins-extra" -, version = "0.4.2" -, synopsis = "Utilities for writing GHC type-checker plugins" -, description = - '' - Utilities for writing GHC type-checker plugins, such as - creating constraints, with a stable API covering multiple - GHC releases.'' -, category = "Type System" -, author = "Christiaan Baaij" -, maintainer = "christiaan.baaij@gmail.com" -, copyright = - '' - Copyright © 2015-2016, University of Twente, - 2017-2018, QBayLogic'' -, github = "clash-lang/ghc-tcplugins-extra" -, license = "BSD2" -, license-file = "LICENSE" -, tested-with = - "GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.2, GHC == 9.2.1, GHC == 9.4.1" -, extra-source-files = - [ "README.md", "CHANGELOG.md", "defaults.dhall", "package.dhall" ] -, ghc-options = [ "-Wall" ] -, flags.deverror - = - { description = "Enables `-Werror` for development mode and TravisCI" - , default = False - , manual = True - } -, when = - [ { condition = "impl(ghc >= 8.0.0)" - , ghc-options = - [ "-Wcompat" - , "-Wincomplete-uni-patterns" - , "-Widentities" - , "-Wredundant-constraints" - ] - } - , { condition = "impl(ghc >= 8.4.0)" - , ghc-options = [ "-fhide-source-paths" ] - } - , { condition = "flag(deverror)", ghc-options = [ "-Werror" ] } - ] -} +{ name = "ghc-tcplugins-extra"+, version = "0.4.4"+, synopsis = "Utilities for writing GHC type-checker plugins"+, description =+ ''+ Utilities for writing GHC type-checker plugins, such as+ creating constraints, with a stable API covering multiple+ GHC releases.''+, category = "Type System"+, author = "Christiaan Baaij"+, maintainer = "christiaan.baaij@gmail.com"+, copyright =+ ''+ Copyright © 2015-2016, University of Twente,+ 2017-2018, QBayLogic''+, github = "clash-lang/ghc-tcplugins-extra"+, license = "BSD2"+, license-file = "LICENSE"+, tested-with =+ "GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.6, GHC == 9.4.4, GHC == 9.6.1"+, extra-source-files =+ [ "README.md", "CHANGELOG.md", "defaults.dhall", "package.dhall" ]+, ghc-options = [ "-Wall" ]+, flags.deverror+ =+ { description = "Enables `-Werror` for development mode and TravisCI"+ , default = False+ , manual = True+ }+, when =+ [ { condition = "impl(ghc >= 8.0.0)"+ , ghc-options =+ [ "-Wcompat"+ , "-Wincomplete-uni-patterns"+ , "-Widentities"+ , "-Wredundant-constraints"+ ]+ }+ , { condition = "impl(ghc >= 8.4.0)"+ , ghc-options = [ "-fhide-source-paths" ]+ }+ , { condition = "flag(deverror)", ghc-options = [ "-Werror" ] }+ ]+}
ghc-tcplugins-extra.cabal view
@@ -1,200 +1,199 @@-cabal-version: 2.0 - --- This file has been generated from package.dhall by hpack version 0.35.0. --- --- see: https://github.com/sol/hpack - -name: ghc-tcplugins-extra -version: 0.4.3 -synopsis: Utilities for writing GHC type-checker plugins -description: Utilities for writing GHC type-checker plugins, such as - creating constraints, with a stable API covering multiple - GHC releases. -category: Type System -homepage: https://github.com/clash-lang/ghc-tcplugins-extra#readme -bug-reports: https://github.com/clash-lang/ghc-tcplugins-extra/issues -author: Christiaan Baaij -maintainer: christiaan.baaij@gmail.com -copyright: Copyright © 2015-2016, University of Twente, - 2017-2018, QBayLogic -license: BSD2 -license-file: LICENSE -build-type: Simple -tested-with: - GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, - GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.4, GHC == 9.4.2 -extra-source-files: - README.md - CHANGELOG.md - defaults.dhall - package.dhall - -source-repository head - type: git - location: https://github.com/clash-lang/ghc-tcplugins-extra - -flag deverror - description: Enables `-Werror` for development mode and TravisCI - manual: True - default: False - -library - exposed-modules: - GHC.TcPluginM.Extra - other-modules: - Internal - hs-source-dirs: - src - ghc-options: -Wall - build-depends: - base >=4.8 && <5 - , ghc >=7.10 && <9.6 - default-language: Haskell2010 - if impl(ghc >= 8.0.0) - ghc-options: -Wcompat -Wincomplete-uni-patterns -Widentities -Wredundant-constraints - if impl(ghc >= 8.4.0) - ghc-options: -fhide-source-paths - if flag(deverror) - ghc-options: -Werror - if impl(ghc >= 9.4) && impl(ghc < 9.6) - other-modules: - GhcApi.Constraint - GhcApi.Predicate - GhcApi.GhcPlugins - Internal.Type - Internal.Constraint - Internal.Evidence - hs-source-dirs: - src-ghc-tree-9.4 - src-ghc-9.4 - build-depends: - ghc >=9.4 && <9.6 - if impl(ghc >= 9.2) && impl(ghc < 9.4) - other-modules: - GhcApi.Constraint - GhcApi.Predicate - GhcApi.GhcPlugins - Internal.Type - Internal.Constraint - Internal.Evidence - hs-source-dirs: - src-ghc-tree - src-ghc-9.2 - build-depends: - ghc >=9.2 && <9.4 - if impl(ghc >= 9.0) && impl(ghc < 9.2) - other-modules: - GhcApi.Constraint - GhcApi.Predicate - GhcApi.GhcPlugins - Internal.Type - Internal.Constraint - Internal.Evidence - hs-source-dirs: - src-ghc-tree - src-ghc-9.0 - build-depends: - ghc >=9.0 && <9.2 - if impl(ghc >= 8.10) && impl(ghc < 9.0) - other-modules: - GhcApi.Constraint - GhcApi.Predicate - GhcApi.GhcPlugins - Internal.Type - Internal.Constraint - Internal.Evidence - hs-source-dirs: - src-ghc-flat - src-ghc-8.10 - build-depends: - ghc >=8.10 && <9.0 - if impl(ghc >= 8.8) && impl(ghc < 8.10) - other-modules: - GhcApi.Constraint - GhcApi.Predicate - GhcApi.GhcPlugins - Internal.Type - Internal.Constraint - Internal.Evidence - hs-source-dirs: - src-ghc-flat - src-ghc-8.8 - build-depends: - ghc >=8.8 && <8.10 - mixins: - ghc hiding () - , ghc (TcRnTypes as Constraint) - , ghc (Type as Predicate) - if impl(ghc >= 8.6) && impl(ghc < 8.8) - other-modules: - GhcApi.Constraint - GhcApi.Predicate - GhcApi.GhcPlugins - Internal.Type - Internal.Constraint - Internal.Evidence - hs-source-dirs: - src-ghc-flat - src-ghc-8.6 - build-depends: - ghc >=8.6 && <8.8 - mixins: - ghc hiding () - , ghc (TcRnTypes as Constraint) - , ghc (Type as Predicate) - if impl(ghc >= 8.4) && impl(ghc < 8.6) - other-modules: - GhcApi.Constraint - GhcApi.Predicate - GhcApi.GhcPlugins - Internal.Type - Internal.Constraint - Internal.Evidence - hs-source-dirs: - src-ghc-flat - src-ghc-8.4 - build-depends: - ghc >=8.4 && <8.6 - mixins: - ghc hiding () - , ghc (TcRnTypes as Constraint) - , ghc (Type as Predicate) - if impl(ghc >= 8.2) && impl(ghc < 8.4) - other-modules: - GhcApi.Constraint - GhcApi.Predicate - GhcApi.GhcPlugins - Internal.Type - Internal.Constraint - Internal.Evidence - hs-source-dirs: - src-ghc-flat - src-ghc-8.2 - build-depends: - ghc >=8.2 && <8.4 - mixins: - ghc hiding () - , ghc (TcRnTypes as Constraint) - , ghc (Type as Predicate) - if impl(ghc >= 8.0) && impl(ghc < 8.2) - other-modules: - GhcApi.Constraint - GhcApi.Predicate - GhcApi.GhcPlugins - Internal.Type - Internal.Constraint - Internal.Evidence - hs-source-dirs: - src-ghc-flat - src-ghc-8.0 - build-depends: - ghc >=8.0 && <8.2 - mixins: - ghc hiding () - , ghc (TcRnTypes as Constraint) - , ghc (Type as Predicate) - if impl(ghc >= 7.10) && impl(ghc < 8.0) - hs-source-dirs: - src-ghc-cpp - build-depends: - ghc >=7.10 && <8.0 +cabal-version: 2.0++-- This file has been generated from package.dhall by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name: ghc-tcplugins-extra+version: 0.4.4+synopsis: Utilities for writing GHC type-checker plugins+description: Utilities for writing GHC type-checker plugins, such as+ creating constraints, with a stable API covering multiple+ GHC releases.+category: Type System+homepage: https://github.com/clash-lang/ghc-tcplugins-extra#readme+bug-reports: https://github.com/clash-lang/ghc-tcplugins-extra/issues+author: Christiaan Baaij+maintainer: christiaan.baaij@gmail.com+copyright: Copyright © 2015-2016, University of Twente,+ 2017-2018, QBayLogic+license: BSD2+license-file: LICENSE+build-type: Simple+tested-with:+ GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.6, GHC == 9.4.4, GHC == 9.6.1+extra-source-files:+ README.md+ CHANGELOG.md+ defaults.dhall+ package.dhall++source-repository head+ type: git+ location: https://github.com/clash-lang/ghc-tcplugins-extra++flag deverror+ description: Enables `-Werror` for development mode and TravisCI+ manual: True+ default: False++library+ exposed-modules:+ GHC.TcPluginM.Extra+ other-modules:+ Internal+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.8 && <5+ , ghc >=7.10 && <9.8+ default-language: Haskell2010+ if impl(ghc >= 8.0.0)+ ghc-options: -Wcompat -Wincomplete-uni-patterns -Widentities -Wredundant-constraints+ if impl(ghc >= 8.4.0)+ ghc-options: -fhide-source-paths+ if flag(deverror)+ ghc-options: -Werror+ if impl(ghc >= 9.4) && impl(ghc < 9.8)+ other-modules:+ GhcApi.Constraint+ GhcApi.Predicate+ GhcApi.GhcPlugins+ Internal.Type+ Internal.Constraint+ Internal.Evidence+ hs-source-dirs:+ src-ghc-tree-9.4+ src-ghc-9.4+ build-depends:+ ghc >=9.4 && <9.8+ if impl(ghc >= 9.2) && impl(ghc < 9.4)+ other-modules:+ GhcApi.Constraint+ GhcApi.Predicate+ GhcApi.GhcPlugins+ Internal.Type+ Internal.Constraint+ Internal.Evidence+ hs-source-dirs:+ src-ghc-tree+ src-ghc-9.2+ build-depends:+ ghc >=9.2 && <9.4+ if impl(ghc >= 9.0) && impl(ghc < 9.2)+ other-modules:+ GhcApi.Constraint+ GhcApi.Predicate+ GhcApi.GhcPlugins+ Internal.Type+ Internal.Constraint+ Internal.Evidence+ hs-source-dirs:+ src-ghc-tree+ src-ghc-9.0+ build-depends:+ ghc >=9.0 && <9.2+ if impl(ghc >= 8.10) && impl(ghc < 9.0)+ other-modules:+ GhcApi.Constraint+ GhcApi.Predicate+ GhcApi.GhcPlugins+ Internal.Type+ Internal.Constraint+ Internal.Evidence+ hs-source-dirs:+ src-ghc-flat+ src-ghc-8.10+ build-depends:+ ghc >=8.10 && <9.0+ if impl(ghc >= 8.8) && impl(ghc < 8.10)+ other-modules:+ GhcApi.Constraint+ GhcApi.Predicate+ GhcApi.GhcPlugins+ Internal.Type+ Internal.Constraint+ Internal.Evidence+ hs-source-dirs:+ src-ghc-flat+ src-ghc-8.8+ build-depends:+ ghc >=8.8 && <8.10+ mixins:+ ghc hiding ()+ , ghc (TcRnTypes as Constraint)+ , ghc (Type as Predicate)+ if impl(ghc >= 8.6) && impl(ghc < 8.8)+ other-modules:+ GhcApi.Constraint+ GhcApi.Predicate+ GhcApi.GhcPlugins+ Internal.Type+ Internal.Constraint+ Internal.Evidence+ hs-source-dirs:+ src-ghc-flat+ src-ghc-8.6+ build-depends:+ ghc >=8.6 && <8.8+ mixins:+ ghc hiding ()+ , ghc (TcRnTypes as Constraint)+ , ghc (Type as Predicate)+ if impl(ghc >= 8.4) && impl(ghc < 8.6)+ other-modules:+ GhcApi.Constraint+ GhcApi.Predicate+ GhcApi.GhcPlugins+ Internal.Type+ Internal.Constraint+ Internal.Evidence+ hs-source-dirs:+ src-ghc-flat+ src-ghc-8.4+ build-depends:+ ghc >=8.4 && <8.6+ mixins:+ ghc hiding ()+ , ghc (TcRnTypes as Constraint)+ , ghc (Type as Predicate)+ if impl(ghc >= 8.2) && impl(ghc < 8.4)+ other-modules:+ GhcApi.Constraint+ GhcApi.Predicate+ GhcApi.GhcPlugins+ Internal.Type+ Internal.Constraint+ Internal.Evidence+ hs-source-dirs:+ src-ghc-flat+ src-ghc-8.2+ build-depends:+ ghc >=8.2 && <8.4+ mixins:+ ghc hiding ()+ , ghc (TcRnTypes as Constraint)+ , ghc (Type as Predicate)+ if impl(ghc >= 8.0) && impl(ghc < 8.2)+ other-modules:+ GhcApi.Constraint+ GhcApi.Predicate+ GhcApi.GhcPlugins+ Internal.Type+ Internal.Constraint+ Internal.Evidence+ hs-source-dirs:+ src-ghc-flat+ src-ghc-8.0+ build-depends:+ ghc >=8.0 && <8.2+ mixins:+ ghc hiding ()+ , ghc (TcRnTypes as Constraint)+ , ghc (Type as Predicate)+ if impl(ghc >= 7.10) && impl(ghc < 8.0)+ hs-source-dirs:+ src-ghc-cpp+ build-depends:+ ghc >=7.10 && <8.0
package.dhall view
@@ -1,45 +1,45 @@-let defs = ./defaults.dhall - -let version = ./version.dhall - -in let ghc = { name = "ghc", mixin = [] : List Text } - - in let gin = - ghc - // { mixin = - [ "hiding ()" - , "(TcRnTypes as Constraint)" - , "(Type as Predicate)" - ] - } - - in let mods = - [ "GhcApi.Constraint" - , "GhcApi.Predicate" - , "GhcApi.GhcPlugins" - , "Internal.Type" - , "Internal.Constraint" - , "Internal.Evidence" - ] - - in defs - // { library = - { source-dirs = "src" - , dependencies = - [ "base >=4.8 && <5", "ghc >=7.10 && <9.6" ] - , exposed-modules = "GHC.TcPluginM.Extra" - , other-modules = "Internal" - , when = - [ version "9.4" "9.6" [ "tree-9.4", "9.4" ] ghc mods - , version "9.2" "9.4" [ "tree", "9.2" ] ghc mods - , version "9.0" "9.2" [ "tree", "9.0" ] ghc mods - , version "8.10" "9.0" [ "flat", "8.10" ] ghc mods - , version "8.8" "8.10" [ "flat", "8.8" ] gin mods - , version "8.6" "8.8" [ "flat", "8.6" ] gin mods - , version "8.4" "8.6" [ "flat", "8.4" ] gin mods - , version "8.2" "8.4" [ "flat", "8.2" ] gin mods - , version "8.0" "8.2" [ "flat", "8.0" ] gin mods - , version "7.10" "8.0" [ "cpp" ] ghc ([] : List Text) - ] - } - } +let defs = ./defaults.dhall++let version = ./version.dhall++in let ghc = { name = "ghc", mixin = [] : List Text }++ in let gin =+ ghc+ // { mixin =+ [ "hiding ()"+ , "(TcRnTypes as Constraint)"+ , "(Type as Predicate)"+ ]+ }++ in let mods =+ [ "GhcApi.Constraint"+ , "GhcApi.Predicate"+ , "GhcApi.GhcPlugins"+ , "Internal.Type"+ , "Internal.Constraint"+ , "Internal.Evidence"+ ]++ in defs+ // { library =+ { source-dirs = "src"+ , dependencies =+ [ "base >=4.8 && <5", "ghc >=7.10 && <9.8" ]+ , exposed-modules = "GHC.TcPluginM.Extra"+ , other-modules = "Internal"+ , when =+ [ version "9.4" "9.8" [ "tree-9.4", "9.4" ] ghc mods+ , version "9.2" "9.4" [ "tree", "9.2" ] ghc mods+ , version "9.0" "9.2" [ "tree", "9.0" ] ghc mods+ , version "8.10" "9.0" [ "flat", "8.10" ] ghc mods+ , version "8.8" "8.10" [ "flat", "8.8" ] gin mods+ , version "8.6" "8.8" [ "flat", "8.6" ] gin mods+ , version "8.4" "8.6" [ "flat", "8.4" ] gin mods+ , version "8.2" "8.4" [ "flat", "8.2" ] gin mods+ , version "8.0" "8.2" [ "flat", "8.0" ] gin mods+ , version "7.10" "8.0" [ "cpp" ] ghc ([] : List Text)+ ]+ }+ }
src-ghc-8.0/GhcApi/GhcPlugins.hs view
@@ -1,5 +1,5 @@-module GhcApi.GhcPlugins (module GhcPlugins, TcTyVar, EvTerm(..)) where - -import GhcPlugins hiding (mkSubst) -import TcType (TcTyVar) -import TcEvidence (EvTerm(..)) +module GhcApi.GhcPlugins (module GhcPlugins, TcTyVar, EvTerm(..)) where++import GhcPlugins hiding (mkSubst)+import TcType (TcTyVar)+import TcEvidence (EvTerm(..))
src-ghc-8.0/Internal/Constraint.hs view
@@ -1,26 +1,26 @@-module Internal.Constraint (module TcPluginM, flatToCt, overEvidencePredType) where - -import GhcApi.GhcPlugins -import GhcApi.Constraint - (Ct(..), CtEvidence(..), ctLoc, ctEvId, mkNonCanonical) - -import TcType (TcType) -import TcPluginM (newGiven) - -flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct -flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) - (ctEvId (cc_ev ct)) - (ctLoc ct) - -flatToCt _ = Nothing - --- | Modify the predicate type of the evidence term of a constraint -overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct -overEvidencePredType f ct = - let - ev :: CtEvidence - ev = cc_ev ct +module Internal.Constraint (module TcPluginM, flatToCt, overEvidencePredType) where++import GhcApi.GhcPlugins+import GhcApi.Constraint+ (Ct(..), CtEvidence(..), ctLoc, ctEvId, mkNonCanonical)++import TcType (TcType)+import TcPluginM (newGiven)++flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct+flatToCt [((_,lhs),ct),((_,rhs),_)]+ = Just+ $ mkNonCanonical+ $ CtGiven (mkPrimEqPred lhs rhs)+ (ctEvId (cc_ev ct))+ (ctLoc ct)++flatToCt _ = Nothing++-- | Modify the predicate type of the evidence term of a constraint+overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct+overEvidencePredType f ct =+ let+ ev :: CtEvidence+ ev = cc_ev ct in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } }
src-ghc-8.0/Internal/Evidence.hs view
@@ -1,14 +1,14 @@-module Internal.Evidence (evByFiat) where - -import TcEvidence (EvTerm(..)) -import TyCoRep (UnivCoProvenance (..)) - -import GhcApi.GhcPlugins - --- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' -evByFiat :: String -- ^ Name the coercion should have - -> Type -- ^ The LHS of the equivalence relation (~) - -> Type -- ^ The RHS of the equivalence relation (~) - -> EvTerm -evByFiat name t1 t2 = - EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2 +module Internal.Evidence (evByFiat) where++import TcEvidence (EvTerm(..))+import TyCoRep (UnivCoProvenance (..))++import GhcApi.GhcPlugins++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 =+ EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2
src-ghc-8.0/Internal/Type.hs view
@@ -1,27 +1,27 @@-module Internal.Type (substType) where - -import Data.Maybe (fromMaybe) -import TcType (TcTyVar, TcType) -import TyCoRep (Type (..)) - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = - fromMaybe tv (lookup v subst) -substType subst (AppTy t1 t2) = - AppTy (substType subst t1) (substType subst t2) -substType subst (TyConApp tc xs) = - TyConApp tc (map (substType subst) xs) -substType _subst t@(ForAllTy _tv _ty) = - -- TODO: Is it safe to do "dumb" substitution under binders? - -- ForAllTy tv (substType subst ty) - t -substType _ l@(LitTy _) = l -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co +module Internal.Type (substType) where++import Data.Maybe (fromMaybe)+import TcType (TcTyVar, TcType)+import TyCoRep (Type (..))++-- | Apply substitutions in Types+--+-- __NB:__ Doesn't substitute under binders+substType+ :: [(TcTyVar, TcType)]+ -> TcType+ -> TcType+substType subst tv@(TyVarTy v) =+ fromMaybe tv (lookup v subst)+substType subst (AppTy t1 t2) =+ AppTy (substType subst t1) (substType subst t2)+substType subst (TyConApp tc xs) =+ TyConApp tc (map (substType subst) xs)+substType _subst t@(ForAllTy _tv _ty) =+ -- TODO: Is it safe to do "dumb" substitution under binders?+ -- ForAllTy tv (substType subst ty)+ t+substType _ l@(LitTy _) = l+substType subst (CastTy ty co) =+ CastTy (substType subst ty) co+substType _ co@(CoercionTy _) = co
src-ghc-8.10/GhcApi/GhcPlugins.hs view
@@ -1,3 +1,3 @@-module GhcApi.GhcPlugins (module GhcPlugins) where - -import GhcPlugins hiding (TcPlugin, mkSubst) +module GhcApi.GhcPlugins (module GhcPlugins) where++import GhcPlugins hiding (TcPlugin, mkSubst)
src-ghc-8.10/Internal/Constraint.hs view
@@ -1,41 +1,41 @@-module Internal.Constraint (newGiven, flatToCt, overEvidencePredType) where - -import GhcApi.GhcPlugins -import GhcApi.Constraint - (Ct(..), CtEvidence(..), CtLoc, ctLoc, ctEvId, mkNonCanonical) - -import Panic (panicDoc) -import TcType (TcType) -import Constraint (QCInst(..)) -import TcEvidence (EvTerm(..)) -import TcPluginM (TcPluginM) -import qualified TcPluginM (newGiven) - --- | Create a new [G]iven constraint, with the supplied evidence. This must not --- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic. -newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence -newGiven loc pty (EvExpr ev) = TcPluginM.newGiven loc pty ev -newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev) - -flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct -flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) - (ctEvId ct) - (ctLoc ct) - -flatToCt _ = Nothing - --- | Modify the predicate type of the evidence term of a constraint -overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct -overEvidencePredType f (CQuantCan qci) = - let - ev :: CtEvidence - ev = qci_ev qci - in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } ) -overEvidencePredType f ct = - let - ev :: CtEvidence - ev = cc_ev ct +module Internal.Constraint (newGiven, flatToCt, overEvidencePredType) where++import GhcApi.GhcPlugins+import GhcApi.Constraint+ (Ct(..), CtEvidence(..), CtLoc, ctLoc, ctEvId, mkNonCanonical)++import Panic (panicDoc)+import TcType (TcType)+import Constraint (QCInst(..))+import TcEvidence (EvTerm(..))+import TcPluginM (TcPluginM)+import qualified TcPluginM (newGiven)++-- | Create a new [G]iven constraint, with the supplied evidence. This must not+-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic.+newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence+newGiven loc pty (EvExpr ev) = TcPluginM.newGiven loc pty ev+newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev)++flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct+flatToCt [((_,lhs),ct),((_,rhs),_)]+ = Just+ $ mkNonCanonical+ $ CtGiven (mkPrimEqPred lhs rhs)+ (ctEvId ct)+ (ctLoc ct)++flatToCt _ = Nothing++-- | Modify the predicate type of the evidence term of a constraint+overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct+overEvidencePredType f (CQuantCan qci) =+ let+ ev :: CtEvidence+ ev = qci_ev qci+ in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } )+overEvidencePredType f ct =+ let+ ev :: CtEvidence+ ev = cc_ev ct in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } }
src-ghc-8.10/Internal/Evidence.hs view
@@ -1,14 +1,14 @@-module Internal.Evidence (evByFiat) where - -import TcEvidence (EvTerm(..)) -import TyCoRep (UnivCoProvenance (..)) - -import GhcApi.GhcPlugins - --- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' -evByFiat :: String -- ^ Name the coercion should have - -> Type -- ^ The LHS of the equivalence relation (~) - -> Type -- ^ The RHS of the equivalence relation (~) - -> EvTerm -evByFiat name t1 t2 = - EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 +module Internal.Evidence (evByFiat) where++import TcEvidence (EvTerm(..))+import TyCoRep (UnivCoProvenance (..))++import GhcApi.GhcPlugins++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 =+ EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2
src-ghc-8.10/Internal/Type.hs view
@@ -1,30 +1,30 @@-module Internal.Type (substType) where - -import Data.Maybe (fromMaybe) -import GhcPlugins hiding (TcPlugin, mkSubst) -import TcType (TcType) -import TyCoRep (Type (..)) - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = - fromMaybe tv (lookup v subst) -substType subst (AppTy t1 t2) = - AppTy (substType subst t1) (substType subst t2) -substType subst (TyConApp tc xs) = - TyConApp tc (map (substType subst) xs) -substType _subst t@(ForAllTy _tv _ty) = - -- TODO: Is it safe to do "dumb" substitution under binders? - -- ForAllTy tv (substType subst ty) - t -substType subst (FunTy af t1 t2) = - FunTy af (substType subst t1) (substType subst t2) -substType _ l@(LitTy _) = l -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co +module Internal.Type (substType) where++import Data.Maybe (fromMaybe)+import GhcPlugins hiding (TcPlugin, mkSubst)+import TcType (TcType)+import TyCoRep (Type (..))++-- | Apply substitutions in Types+--+-- __NB:__ Doesn't substitute under binders+substType+ :: [(TcTyVar, TcType)]+ -> TcType+ -> TcType+substType subst tv@(TyVarTy v) =+ fromMaybe tv (lookup v subst)+substType subst (AppTy t1 t2) =+ AppTy (substType subst t1) (substType subst t2)+substType subst (TyConApp tc xs) =+ TyConApp tc (map (substType subst) xs)+substType _subst t@(ForAllTy _tv _ty) =+ -- TODO: Is it safe to do "dumb" substitution under binders?+ -- ForAllTy tv (substType subst ty)+ t+substType subst (FunTy af t1 t2) =+ FunTy af (substType subst t1) (substType subst t2)+substType _ l@(LitTy _) = l+substType subst (CastTy ty co) =+ CastTy (substType subst ty) co+substType _ co@(CoercionTy _) = co
src-ghc-8.2/GhcApi/GhcPlugins.hs view
@@ -1,5 +1,5 @@-module GhcApi.GhcPlugins (module GhcPlugins, TcTyVar, EvTerm(..)) where - -import GhcPlugins hiding (mkSubst) -import TcType (TcTyVar) -import TcEvidence (EvTerm(..)) +module GhcApi.GhcPlugins (module GhcPlugins, TcTyVar, EvTerm(..)) where++import GhcPlugins hiding (mkSubst)+import TcType (TcTyVar)+import TcEvidence (EvTerm(..))
src-ghc-8.2/Internal/Constraint.hs view
@@ -1,26 +1,26 @@-module Internal.Constraint (module TcPluginM, flatToCt, overEvidencePredType) where - -import GhcApi.GhcPlugins -import GhcApi.Constraint - (Ct(..), CtEvidence(..), ctLoc, ctEvId, mkNonCanonical) - -import TcType (TcType) -import TcPluginM (newGiven) - -flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct -flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) - (ctEvId (cc_ev ct)) - (ctLoc ct) - -flatToCt _ = Nothing - --- | Modify the predicate type of the evidence term of a constraint -overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct -overEvidencePredType f ct = - let - ev :: CtEvidence - ev = cc_ev ct +module Internal.Constraint (module TcPluginM, flatToCt, overEvidencePredType) where++import GhcApi.GhcPlugins+import GhcApi.Constraint+ (Ct(..), CtEvidence(..), ctLoc, ctEvId, mkNonCanonical)++import TcType (TcType)+import TcPluginM (newGiven)++flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct+flatToCt [((_,lhs),ct),((_,rhs),_)]+ = Just+ $ mkNonCanonical+ $ CtGiven (mkPrimEqPred lhs rhs)+ (ctEvId (cc_ev ct))+ (ctLoc ct)++flatToCt _ = Nothing++-- | Modify the predicate type of the evidence term of a constraint+overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct+overEvidencePredType f ct =+ let+ ev :: CtEvidence+ ev = cc_ev ct in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } }
src-ghc-8.2/Internal/Evidence.hs view
@@ -1,14 +1,14 @@-module Internal.Evidence (evByFiat) where - -import TcEvidence (EvTerm(..)) -import TyCoRep (UnivCoProvenance (..)) - -import GhcApi.GhcPlugins - --- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' -evByFiat :: String -- ^ Name the coercion should have - -> Type -- ^ The LHS of the equivalence relation (~) - -> Type -- ^ The RHS of the equivalence relation (~) - -> EvTerm -evByFiat name t1 t2 = - EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2 +module Internal.Evidence (evByFiat) where++import TcEvidence (EvTerm(..))+import TyCoRep (UnivCoProvenance (..))++import GhcApi.GhcPlugins++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 =+ EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2
src-ghc-8.2/Internal/Type.hs view
@@ -1,29 +1,29 @@-module Internal.Type (substType) where - -import Data.Maybe (fromMaybe) -import TcType (TcTyVar, TcType) -import TyCoRep (Type (..)) - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = - fromMaybe tv (lookup v subst) -substType subst (AppTy t1 t2) = - AppTy (substType subst t1) (substType subst t2) -substType subst (TyConApp tc xs) = - TyConApp tc (map (substType subst) xs) -substType _subst t@(ForAllTy _tv _ty) = - -- TODO: Is it safe to do "dumb" substitution under binders? - -- ForAllTy tv (substType subst ty) - t -substType subst (FunTy t1 t2) = - FunTy (substType subst t1) (substType subst t2) -substType _ l@(LitTy _) = l -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co +module Internal.Type (substType) where++import Data.Maybe (fromMaybe)+import TcType (TcTyVar, TcType)+import TyCoRep (Type (..))++-- | Apply substitutions in Types+--+-- __NB:__ Doesn't substitute under binders+substType+ :: [(TcTyVar, TcType)]+ -> TcType+ -> TcType+substType subst tv@(TyVarTy v) =+ fromMaybe tv (lookup v subst)+substType subst (AppTy t1 t2) =+ AppTy (substType subst t1) (substType subst t2)+substType subst (TyConApp tc xs) =+ TyConApp tc (map (substType subst) xs)+substType _subst t@(ForAllTy _tv _ty) =+ -- TODO: Is it safe to do "dumb" substitution under binders?+ -- ForAllTy tv (substType subst ty)+ t+substType subst (FunTy t1 t2) =+ FunTy (substType subst t1) (substType subst t2)+substType _ l@(LitTy _) = l+substType subst (CastTy ty co) =+ CastTy (substType subst ty) co+substType _ co@(CoercionTy _) = co
src-ghc-8.4/GhcApi/GhcPlugins.hs view
@@ -1,5 +1,5 @@-module GhcApi.GhcPlugins (module GhcPlugins, TcTyVar, EvTerm(..)) where - -import GhcPlugins hiding (mkSubst) -import TcType (TcTyVar) -import TcEvidence (EvTerm(..)) +module GhcApi.GhcPlugins (module GhcPlugins, TcTyVar, EvTerm(..)) where++import GhcPlugins hiding (mkSubst)+import TcType (TcTyVar)+import TcEvidence (EvTerm(..))
src-ghc-8.4/Internal/Constraint.hs view
@@ -1,26 +1,26 @@-module Internal.Constraint (module TcPluginM, flatToCt, overEvidencePredType) where - -import GhcApi.GhcPlugins -import GhcApi.Constraint - (Ct(..), CtEvidence(..), ctLoc, ctEvId, mkNonCanonical) - -import TcType (TcType) -import TcPluginM (newGiven) - -flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct -flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) - (ctEvId ct) - (ctLoc ct) - -flatToCt _ = Nothing - --- | Modify the predicate type of the evidence term of a constraint -overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct -overEvidencePredType f ct = - let - ev :: CtEvidence - ev = cc_ev ct +module Internal.Constraint (module TcPluginM, flatToCt, overEvidencePredType) where++import GhcApi.GhcPlugins+import GhcApi.Constraint+ (Ct(..), CtEvidence(..), ctLoc, ctEvId, mkNonCanonical)++import TcType (TcType)+import TcPluginM (newGiven)++flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct+flatToCt [((_,lhs),ct),((_,rhs),_)]+ = Just+ $ mkNonCanonical+ $ CtGiven (mkPrimEqPred lhs rhs)+ (ctEvId ct)+ (ctLoc ct)++flatToCt _ = Nothing++-- | Modify the predicate type of the evidence term of a constraint+overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct+overEvidencePredType f ct =+ let+ ev :: CtEvidence+ ev = cc_ev ct in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } }
src-ghc-8.4/Internal/Evidence.hs view
@@ -1,14 +1,14 @@-module Internal.Evidence (evByFiat) where - -import TcEvidence (EvTerm(..)) -import TyCoRep (UnivCoProvenance (..)) - -import GhcApi.GhcPlugins - --- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' -evByFiat :: String -- ^ Name the coercion should have - -> Type -- ^ The LHS of the equivalence relation (~) - -> Type -- ^ The RHS of the equivalence relation (~) - -> EvTerm -evByFiat name t1 t2 = - EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2 +module Internal.Evidence (evByFiat) where++import TcEvidence (EvTerm(..))+import TyCoRep (UnivCoProvenance (..))++import GhcApi.GhcPlugins++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 =+ EvCoercion $ mkUnivCo (PluginProv name) Nominal t1 t2
src-ghc-8.4/Internal/Type.hs view
@@ -1,29 +1,29 @@-module Internal.Type (substType) where - -import Data.Maybe (fromMaybe) -import TcType (TcTyVar, TcType) -import TyCoRep (Type (..)) - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = - fromMaybe tv (lookup v subst) -substType subst (AppTy t1 t2) = - AppTy (substType subst t1) (substType subst t2) -substType subst (TyConApp tc xs) = - TyConApp tc (map (substType subst) xs) -substType _subst t@(ForAllTy _tv _ty) = - -- TODO: Is it safe to do "dumb" substitution under binders? - -- ForAllTy tv (substType subst ty) - t -substType subst (FunTy t1 t2) = - FunTy (substType subst t1) (substType subst t2) -substType _ l@(LitTy _) = l -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co +module Internal.Type (substType) where++import Data.Maybe (fromMaybe)+import TcType (TcTyVar, TcType)+import TyCoRep (Type (..))++-- | Apply substitutions in Types+--+-- __NB:__ Doesn't substitute under binders+substType+ :: [(TcTyVar, TcType)]+ -> TcType+ -> TcType+substType subst tv@(TyVarTy v) =+ fromMaybe tv (lookup v subst)+substType subst (AppTy t1 t2) =+ AppTy (substType subst t1) (substType subst t2)+substType subst (TyConApp tc xs) =+ TyConApp tc (map (substType subst) xs)+substType _subst t@(ForAllTy _tv _ty) =+ -- TODO: Is it safe to do "dumb" substitution under binders?+ -- ForAllTy tv (substType subst ty)+ t+substType subst (FunTy t1 t2) =+ FunTy (substType subst t1) (substType subst t2)+substType _ l@(LitTy _) = l+substType subst (CastTy ty co) =+ CastTy (substType subst ty) co+substType _ co@(CoercionTy _) = co
src-ghc-8.6/GhcApi/GhcPlugins.hs view
@@ -1,3 +1,3 @@-module GhcApi.GhcPlugins (module GhcPlugins) where - -import GhcPlugins hiding (mkSubst) +module GhcApi.GhcPlugins (module GhcPlugins) where++import GhcPlugins hiding (mkSubst)
src-ghc-8.6/Internal/Constraint.hs view
@@ -1,43 +1,43 @@-module Internal.Constraint (newGiven, flatToCt, overEvidencePredType) where - -import GhcApi.GhcPlugins -import GhcApi.Constraint - (Ct(..), CtEvidence(..), CtLoc, ctLoc, ctEvId, mkNonCanonical) - -import Panic (panicDoc) -import TcType (TcType) -import Constraint (QCInst(..)) -import TcEvidence (EvTerm(..)) -import TcPluginM (TcPluginM) -import qualified TcPluginM (newGiven) -import Outputable (ppr) -import Type (PredType) - --- | Create a new [G]iven constraint, with the supplied evidence. This must not --- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic. -newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence -newGiven loc pty (EvExpr ev) = TcPluginM.newGiven loc pty ev -newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev) - -flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct -flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) - (ctEvId ct) - (ctLoc ct) - -flatToCt _ = Nothing - --- | Modify the predicate type of the evidence term of a constraint -overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct -overEvidencePredType f (CQuantCan qci) = - let - ev :: CtEvidence - ev = qci_ev qci - in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } ) -overEvidencePredType f ct = - let - ev :: CtEvidence - ev = cc_ev ct +module Internal.Constraint (newGiven, flatToCt, overEvidencePredType) where++import GhcApi.GhcPlugins+import GhcApi.Constraint+ (Ct(..), CtEvidence(..), CtLoc, ctLoc, ctEvId, mkNonCanonical)++import Panic (panicDoc)+import TcType (TcType)+import Constraint (QCInst(..))+import TcEvidence (EvTerm(..))+import TcPluginM (TcPluginM)+import qualified TcPluginM (newGiven)+import Outputable (ppr)+import Type (PredType)++-- | Create a new [G]iven constraint, with the supplied evidence. This must not+-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic.+newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence+newGiven loc pty (EvExpr ev) = TcPluginM.newGiven loc pty ev+newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev)++flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct+flatToCt [((_,lhs),ct),((_,rhs),_)]+ = Just+ $ mkNonCanonical+ $ CtGiven (mkPrimEqPred lhs rhs)+ (ctEvId ct)+ (ctLoc ct)++flatToCt _ = Nothing++-- | Modify the predicate type of the evidence term of a constraint+overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct+overEvidencePredType f (CQuantCan qci) =+ let+ ev :: CtEvidence+ ev = qci_ev qci+ in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } )+overEvidencePredType f ct =+ let+ ev :: CtEvidence+ ev = cc_ev ct in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } }
src-ghc-8.6/Internal/Evidence.hs view
@@ -1,14 +1,14 @@-module Internal.Evidence (evByFiat) where - -import TcEvidence (EvTerm(..)) -import TyCoRep (UnivCoProvenance (..)) - -import GhcApi.GhcPlugins - --- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' -evByFiat :: String -- ^ Name the coercion should have - -> Type -- ^ The LHS of the equivalence relation (~) - -> Type -- ^ The RHS of the equivalence relation (~) - -> EvTerm -evByFiat name t1 t2 = - EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 +module Internal.Evidence (evByFiat) where++import TcEvidence (EvTerm(..))+import TyCoRep (UnivCoProvenance (..))++import GhcApi.GhcPlugins++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 =+ EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2
src-ghc-8.6/Internal/Type.hs view
@@ -1,30 +1,30 @@-module Internal.Type (substType) where - -import Data.Maybe (fromMaybe) -import GhcPlugins hiding (mkSubst) -import TcType (TcType) -import TyCoRep (Type (..)) - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = - fromMaybe tv (lookup v subst) -substType subst (AppTy t1 t2) = - AppTy (substType subst t1) (substType subst t2) -substType subst (TyConApp tc xs) = - TyConApp tc (map (substType subst) xs) -substType _subst t@(ForAllTy _tv _ty) = - -- TODO: Is it safe to do "dumb" substitution under binders? - -- ForAllTy tv (substType subst ty) - t -substType subst (FunTy t1 t2) = - FunTy (substType subst t1) (substType subst t2) -substType _ l@(LitTy _) = l -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co +module Internal.Type (substType) where++import Data.Maybe (fromMaybe)+import GhcPlugins hiding (mkSubst)+import TcType (TcType)+import TyCoRep (Type (..))++-- | Apply substitutions in Types+--+-- __NB:__ Doesn't substitute under binders+substType+ :: [(TcTyVar, TcType)]+ -> TcType+ -> TcType+substType subst tv@(TyVarTy v) =+ fromMaybe tv (lookup v subst)+substType subst (AppTy t1 t2) =+ AppTy (substType subst t1) (substType subst t2)+substType subst (TyConApp tc xs) =+ TyConApp tc (map (substType subst) xs)+substType _subst t@(ForAllTy _tv _ty) =+ -- TODO: Is it safe to do "dumb" substitution under binders?+ -- ForAllTy tv (substType subst ty)+ t+substType subst (FunTy t1 t2) =+ FunTy (substType subst t1) (substType subst t2)+substType _ l@(LitTy _) = l+substType subst (CastTy ty co) =+ CastTy (substType subst ty) co+substType _ co@(CoercionTy _) = co
src-ghc-8.8/GhcApi/GhcPlugins.hs view
@@ -1,3 +1,3 @@-module GhcApi.GhcPlugins (module GhcPlugins) where - -import GhcPlugins hiding (TcPlugin, mkSubst) +module GhcApi.GhcPlugins (module GhcPlugins) where++import GhcPlugins hiding (TcPlugin, mkSubst)
src-ghc-8.8/Internal/Constraint.hs view
@@ -1,41 +1,41 @@-module Internal.Constraint (newGiven, flatToCt, overEvidencePredType) where - -import GhcApi.GhcPlugins -import GhcApi.Constraint - (Ct(..), CtEvidence(..), CtLoc, ctLoc, ctEvId, mkNonCanonical) - -import Panic (panicDoc) -import TcType (TcType) -import Constraint (QCInst(..)) -import TcEvidence (EvTerm(..)) -import TcPluginM (TcPluginM) -import qualified TcPluginM (newGiven) - --- | Create a new [G]iven constraint, with the supplied evidence. This must not --- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic. -newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence -newGiven loc pty (EvExpr ev) = TcPluginM.newGiven loc pty ev -newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev) - -flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct -flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) - (ctEvId ct) - (ctLoc ct) - -flatToCt _ = Nothing - --- | Modify the predicate type of the evidence term of a constraint -overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct -overEvidencePredType f (CQuantCan qci) = - let - ev :: CtEvidence - ev = qci_ev qci - in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } ) -overEvidencePredType f ct = - let - ev :: CtEvidence - ev = cc_ev ct +module Internal.Constraint (newGiven, flatToCt, overEvidencePredType) where++import GhcApi.GhcPlugins+import GhcApi.Constraint+ (Ct(..), CtEvidence(..), CtLoc, ctLoc, ctEvId, mkNonCanonical)++import Panic (panicDoc)+import TcType (TcType)+import Constraint (QCInst(..))+import TcEvidence (EvTerm(..))+import TcPluginM (TcPluginM)+import qualified TcPluginM (newGiven)++-- | Create a new [G]iven constraint, with the supplied evidence. This must not+-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic.+newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence+newGiven loc pty (EvExpr ev) = TcPluginM.newGiven loc pty ev+newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev)++flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct+flatToCt [((_,lhs),ct),((_,rhs),_)]+ = Just+ $ mkNonCanonical+ $ CtGiven (mkPrimEqPred lhs rhs)+ (ctEvId ct)+ (ctLoc ct)++flatToCt _ = Nothing++-- | Modify the predicate type of the evidence term of a constraint+overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct+overEvidencePredType f (CQuantCan qci) =+ let+ ev :: CtEvidence+ ev = qci_ev qci+ in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } )+overEvidencePredType f ct =+ let+ ev :: CtEvidence+ ev = cc_ev ct in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } }
src-ghc-8.8/Internal/Evidence.hs view
@@ -1,14 +1,14 @@-module Internal.Evidence (evByFiat) where - -import TcEvidence (EvTerm(..)) -import TyCoRep (UnivCoProvenance (..)) - -import GhcApi.GhcPlugins - --- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' -evByFiat :: String -- ^ Name the coercion should have - -> Type -- ^ The LHS of the equivalence relation (~) - -> Type -- ^ The RHS of the equivalence relation (~) - -> EvTerm -evByFiat name t1 t2 = - EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 +module Internal.Evidence (evByFiat) where++import TcEvidence (EvTerm(..))+import TyCoRep (UnivCoProvenance (..))++import GhcApi.GhcPlugins++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 =+ EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2
src-ghc-8.8/Internal/Type.hs view
@@ -1,30 +1,30 @@-module Internal.Type (substType) where - -import Data.Maybe (fromMaybe) -import GhcPlugins hiding (TcPlugin, mkSubst) -import TcType (TcType) -import TyCoRep (Type (..)) - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = - fromMaybe tv (lookup v subst) -substType subst (AppTy t1 t2) = - AppTy (substType subst t1) (substType subst t2) -substType subst (TyConApp tc xs) = - TyConApp tc (map (substType subst) xs) -substType _subst t@(ForAllTy _tv _ty) = - -- TODO: Is it safe to do "dumb" substitution under binders? - -- ForAllTy tv (substType subst ty) - t -substType subst (FunTy t1 t2) = - FunTy (substType subst t1) (substType subst t2) -substType _ l@(LitTy _) = l -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co +module Internal.Type (substType) where++import Data.Maybe (fromMaybe)+import GhcPlugins hiding (TcPlugin, mkSubst)+import TcType (TcType)+import TyCoRep (Type (..))++-- | Apply substitutions in Types+--+-- __NB:__ Doesn't substitute under binders+substType+ :: [(TcTyVar, TcType)]+ -> TcType+ -> TcType+substType subst tv@(TyVarTy v) =+ fromMaybe tv (lookup v subst)+substType subst (AppTy t1 t2) =+ AppTy (substType subst t1) (substType subst t2)+substType subst (TyConApp tc xs) =+ TyConApp tc (map (substType subst) xs)+substType _subst t@(ForAllTy _tv _ty) =+ -- TODO: Is it safe to do "dumb" substitution under binders?+ -- ForAllTy tv (substType subst ty)+ t+substType subst (FunTy t1 t2) =+ FunTy (substType subst t1) (substType subst t2)+substType _ l@(LitTy _) = l+substType subst (CastTy ty co) =+ CastTy (substType subst ty) co+substType _ co@(CoercionTy _) = co
src-ghc-9.0/GhcApi/Constraint.hs view
@@ -1,12 +1,12 @@-module GhcApi.Constraint - ( Ct(..) - , CtEvidence(..) - , CtLoc - , ctLoc - , ctEvId - , mkNonCanonical - ) -where - -import GHC.Tc.Types.Constraint - (Ct (..), CtEvidence (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) +module GhcApi.Constraint+ ( Ct(..)+ , CtEvidence(..)+ , CtLoc+ , ctLoc+ , ctEvId+ , mkNonCanonical+ )+where++import GHC.Tc.Types.Constraint+ (Ct (..), CtEvidence (..), CtLoc, ctLoc, ctEvId, mkNonCanonical)
src-ghc-9.0/GhcApi/GhcPlugins.hs view
@@ -1,5 +1,5 @@-module GhcApi.GhcPlugins (module GHC.Plugins, findPluginModule, panicDoc) where - -import GHC.Plugins hiding (TcPlugin, mkSubst) -import GHC.Driver.Finder (findPluginModule) -import GHC.Utils.Panic (panicDoc) +module GhcApi.GhcPlugins (module GHC.Plugins, findPluginModule, panicDoc) where++import GHC.Plugins hiding (TcPlugin, mkSubst)+import GHC.Driver.Finder (findPluginModule)+import GHC.Utils.Panic (panicDoc)
src-ghc-9.0/Internal/Constraint.hs view
@@ -1,49 +1,49 @@-{-# LANGUAGE RecordWildCards #-} - -module Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) where - -import GhcApi.GhcPlugins -import GhcApi.Constraint - (Ct(..), CtEvidence(..), CtLoc, ctLoc, ctEvId, mkNonCanonical) - -import GHC.Tc.Utils.TcType (TcType) -import GHC.Core.TyCo.Rep (Type (..)) -import GHC.Tc.Types.Constraint (QCInst(..)) -import GHC.Tc.Types.Evidence (EvTerm(..)) -import GHC.Tc.Plugin (TcPluginM) -import qualified GHC.Tc.Plugin as TcPlugin (newGiven) - --- | Create a new [G]iven constraint, with the supplied evidence. This must not --- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic. -newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence -newGiven loc pty (EvExpr ev) = TcPlugin.newGiven loc pty ev -newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev) - -flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct -flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) - (ctEvId ct) - (ctLoc ct) - -flatToCt _ = Nothing - --- | Create simple substitution from type equalities -mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct) -mkSubst ct@(CTyEqCan {..}) = Just ((cc_tyvar,cc_rhs),ct) -mkSubst ct@(CFunEqCan {..}) = Just ((cc_fsk,TyConApp cc_fun cc_tyargs),ct) -mkSubst _ = Nothing - --- | Modify the predicate type of the evidence term of a constraint -overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct -overEvidencePredType f (CQuantCan qci) = - let - ev :: CtEvidence - ev = qci_ev qci - in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } ) -overEvidencePredType f ct = - let - ev :: CtEvidence - ev = cc_ev ct - in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } } +{-# LANGUAGE RecordWildCards #-}++module Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) where++import GhcApi.GhcPlugins+import GhcApi.Constraint+ (Ct(..), CtEvidence(..), CtLoc, ctLoc, ctEvId, mkNonCanonical)++import GHC.Tc.Utils.TcType (TcType)+import GHC.Core.TyCo.Rep (Type (..))+import GHC.Tc.Types.Constraint (QCInst(..))+import GHC.Tc.Types.Evidence (EvTerm(..))+import GHC.Tc.Plugin (TcPluginM)+import qualified GHC.Tc.Plugin as TcPlugin (newGiven)++-- | Create a new [G]iven constraint, with the supplied evidence. This must not+-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic.+newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence+newGiven loc pty (EvExpr ev) = TcPlugin.newGiven loc pty ev+newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev)++flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct+flatToCt [((_,lhs),ct),((_,rhs),_)]+ = Just+ $ mkNonCanonical+ $ CtGiven (mkPrimEqPred lhs rhs)+ (ctEvId ct)+ (ctLoc ct)++flatToCt _ = Nothing++-- | Create simple substitution from type equalities+mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct)+mkSubst ct@(CTyEqCan {..}) = Just ((cc_tyvar,cc_rhs),ct)+mkSubst ct@(CFunEqCan {..}) = Just ((cc_fsk,TyConApp cc_fun cc_tyargs),ct)+mkSubst _ = Nothing++-- | Modify the predicate type of the evidence term of a constraint+overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct+overEvidencePredType f (CQuantCan qci) =+ let+ ev :: CtEvidence+ ev = qci_ev qci+ in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } )+overEvidencePredType f ct =+ let+ ev :: CtEvidence+ ev = cc_ev ct+ in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } }
src-ghc-9.0/Internal/Evidence.hs view
@@ -1,14 +1,14 @@-module Internal.Evidence (evByFiat) where - -import GHC.Tc.Types.Evidence (EvTerm(..)) -import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) - -import GhcApi.GhcPlugins - --- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' -evByFiat :: String -- ^ Name the coercion should have - -> Type -- ^ The LHS of the equivalence relation (~) - -> Type -- ^ The RHS of the equivalence relation (~) - -> EvTerm -evByFiat name t1 t2 = +module Internal.Evidence (evByFiat) where++import GHC.Tc.Types.Evidence (EvTerm(..))+import GHC.Core.TyCo.Rep (UnivCoProvenance (..))++import GhcApi.GhcPlugins++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 = EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2
src-ghc-9.0/Internal/Type.hs view
@@ -1,30 +1,30 @@-module Internal.Type (substType) where - -import Data.Maybe (fromMaybe) -import GHC.Tc.Utils.TcType (TcType) -import GHC.Core.TyCo.Rep (Type (..)) -import GHC.Types.Var (TcTyVar) - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = - fromMaybe tv (lookup v subst) -substType subst (AppTy t1 t2) = - AppTy (substType subst t1) (substType subst t2) -substType subst (TyConApp tc xs) = - TyConApp tc (map (substType subst) xs) -substType _subst t@(ForAllTy _tv _ty) = - -- TODO: Is it safe to do "dumb" substitution under binders? - -- ForAllTy tv (substType subst ty) - t -substType subst (FunTy k1 k2 t1 t2) = - FunTy k1 k2 (substType subst t1) (substType subst t2) -substType _ l@(LitTy _) = l -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co +module Internal.Type (substType) where++import Data.Maybe (fromMaybe)+import GHC.Tc.Utils.TcType (TcType)+import GHC.Core.TyCo.Rep (Type (..))+import GHC.Types.Var (TcTyVar)++-- | Apply substitutions in Types+--+-- __NB:__ Doesn't substitute under binders+substType+ :: [(TcTyVar, TcType)]+ -> TcType+ -> TcType+substType subst tv@(TyVarTy v) =+ fromMaybe tv (lookup v subst)+substType subst (AppTy t1 t2) =+ AppTy (substType subst t1) (substType subst t2)+substType subst (TyConApp tc xs) =+ TyConApp tc (map (substType subst) xs)+substType _subst t@(ForAllTy _tv _ty) =+ -- TODO: Is it safe to do "dumb" substitution under binders?+ -- ForAllTy tv (substType subst ty)+ t+substType subst (FunTy k1 k2 t1 t2) =+ FunTy k1 k2 (substType subst t1) (substType subst t2)+substType _ l@(LitTy _) = l+substType subst (CastTy ty co) =+ CastTy (substType subst ty) co+substType _ co@(CoercionTy _) = co
src-ghc-9.2/GhcApi/Constraint.hs view
@@ -1,13 +1,13 @@-module GhcApi.Constraint - ( Ct(..) - , CtEvidence(..) - , CtLoc - , CanEqLHS(..) - , ctLoc - , ctEvId - , mkNonCanonical - ) -where - -import GHC.Tc.Types.Constraint - (Ct (..), CtEvidence (..), CanEqLHS (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) +module GhcApi.Constraint+ ( Ct(..)+ , CtEvidence(..)+ , CtLoc+ , CanEqLHS(..)+ , ctLoc+ , ctEvId+ , mkNonCanonical+ )+where++import GHC.Tc.Types.Constraint+ (Ct (..), CtEvidence (..), CanEqLHS (..), CtLoc, ctLoc, ctEvId, mkNonCanonical)
src-ghc-9.2/GhcApi/GhcPlugins.hs view
@@ -1,5 +1,5 @@-module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where - -import GHC.Plugins hiding (TcPlugin, mkSubst) -import GHC.Unit.Finder (findPluginModule) +module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where++import GHC.Plugins hiding (TcPlugin, mkSubst)+import GHC.Unit.Finder (findPluginModule) import GHC.Tc.Plugin (FindResult(..))
src-ghc-9.2/Internal/Constraint.hs view
@@ -1,49 +1,49 @@-{-# LANGUAGE RecordWildCards #-} - -module Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) where - -import GhcApi.GhcPlugins -import GhcApi.Constraint - (Ct(..), CtEvidence(..), CanEqLHS(..), CtLoc, ctLoc, ctEvId, mkNonCanonical) - -import GHC.Tc.Utils.TcType (TcType) -import GHC.Tc.Types.Constraint (QCInst(..)) -import GHC.Tc.Types.Evidence (EvTerm(..)) -import GHC.Tc.Plugin (TcPluginM) -import qualified GHC.Tc.Plugin as TcPlugin (newGiven) - --- | Create a new [G]iven constraint, with the supplied evidence. This must not --- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic. -newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence -newGiven loc pty (EvExpr ev) = TcPlugin.newGiven loc pty ev -newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev) - -flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct -flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) - (ctEvId ct) - (ctLoc ct) - -flatToCt _ = Nothing - --- | Create simple substitution from type equalities -mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct) -mkSubst ct@(CEqCan {..}) - | TyVarLHS tyvar <- cc_lhs - = Just ((tyvar,cc_rhs),ct) -mkSubst _ = Nothing - --- | Modify the predicate type of the evidence term of a constraint -overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct -overEvidencePredType f (CQuantCan qci) = - let - ev :: CtEvidence - ev = qci_ev qci - in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } ) -overEvidencePredType f ct = - let - ev :: CtEvidence - ev = cc_ev ct +{-# LANGUAGE RecordWildCards #-}++module Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) where++import GhcApi.GhcPlugins+import GhcApi.Constraint+ (Ct(..), CtEvidence(..), CanEqLHS(..), CtLoc, ctLoc, ctEvId, mkNonCanonical)++import GHC.Tc.Utils.TcType (TcType)+import GHC.Tc.Types.Constraint (QCInst(..))+import GHC.Tc.Types.Evidence (EvTerm(..))+import GHC.Tc.Plugin (TcPluginM)+import qualified GHC.Tc.Plugin as TcPlugin (newGiven)++-- | Create a new [G]iven constraint, with the supplied evidence. This must not+-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic.+newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence+newGiven loc pty (EvExpr ev) = TcPlugin.newGiven loc pty ev+newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev)++flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct+flatToCt [((_,lhs),ct),((_,rhs),_)]+ = Just+ $ mkNonCanonical+ $ CtGiven (mkPrimEqPred lhs rhs)+ (ctEvId ct)+ (ctLoc ct)++flatToCt _ = Nothing++-- | Create simple substitution from type equalities+mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct)+mkSubst ct@(CEqCan {..})+ | TyVarLHS tyvar <- cc_lhs+ = Just ((tyvar,cc_rhs),ct)+mkSubst _ = Nothing++-- | Modify the predicate type of the evidence term of a constraint+overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct+overEvidencePredType f (CQuantCan qci) =+ let+ ev :: CtEvidence+ ev = qci_ev qci+ in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } )+overEvidencePredType f ct =+ let+ ev :: CtEvidence+ ev = cc_ev ct in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } }
src-ghc-9.2/Internal/Evidence.hs view
@@ -1,14 +1,14 @@-module Internal.Evidence (evByFiat) where - -import GHC.Tc.Types.Evidence (EvTerm(..)) -import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) - -import GhcApi.GhcPlugins - --- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' -evByFiat :: String -- ^ Name the coercion should have - -> Type -- ^ The LHS of the equivalence relation (~) - -> Type -- ^ The RHS of the equivalence relation (~) - -> EvTerm -evByFiat name t1 t2 = +module Internal.Evidence (evByFiat) where++import GHC.Tc.Types.Evidence (EvTerm(..))+import GHC.Core.TyCo.Rep (UnivCoProvenance (..))++import GhcApi.GhcPlugins++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 = EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2
src-ghc-9.2/Internal/Type.hs view
@@ -1,30 +1,30 @@-module Internal.Type (substType) where - -import Data.Maybe (fromMaybe) -import GHC.Tc.Utils.TcType (TcType) -import GHC.Core.TyCo.Rep (Type (..)) -import GHC.Types.Var (TcTyVar) - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = - fromMaybe tv (lookup v subst) -substType subst (AppTy t1 t2) = - AppTy (substType subst t1) (substType subst t2) -substType subst (TyConApp tc xs) = - TyConApp tc (map (substType subst) xs) -substType _subst t@(ForAllTy _tv _ty) = - -- TODO: Is it safe to do "dumb" substitution under binders? - -- ForAllTy tv (substType subst ty) - t -substType subst (FunTy k1 k2 t1 t2) = - FunTy k1 k2 (substType subst t1) (substType subst t2) -substType _ l@(LitTy _) = l -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co +module Internal.Type (substType) where++import Data.Maybe (fromMaybe)+import GHC.Tc.Utils.TcType (TcType)+import GHC.Core.TyCo.Rep (Type (..))+import GHC.Types.Var (TcTyVar)++-- | Apply substitutions in Types+--+-- __NB:__ Doesn't substitute under binders+substType+ :: [(TcTyVar, TcType)]+ -> TcType+ -> TcType+substType subst tv@(TyVarTy v) =+ fromMaybe tv (lookup v subst)+substType subst (AppTy t1 t2) =+ AppTy (substType subst t1) (substType subst t2)+substType subst (TyConApp tc xs) =+ TyConApp tc (map (substType subst) xs)+substType _subst t@(ForAllTy _tv _ty) =+ -- TODO: Is it safe to do "dumb" substitution under binders?+ -- ForAllTy tv (substType subst ty)+ t+substType subst (FunTy k1 k2 t1 t2) =+ FunTy k1 k2 (substType subst t1) (substType subst t2)+substType _ l@(LitTy _) = l+substType subst (CastTy ty co) =+ CastTy (substType subst ty) co+substType _ co@(CoercionTy _) = co
src-ghc-9.4/GhcApi/Constraint.hs view
@@ -1,13 +1,13 @@-module GhcApi.Constraint - ( Ct(..) - , CtEvidence(..) - , CtLoc - , CanEqLHS(..) - , ctLoc - , ctEvId - , mkNonCanonical - ) -where - -import GHC.Tc.Types.Constraint - (Ct (..), CtEvidence (..), CanEqLHS (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) +module GhcApi.Constraint+ ( Ct(..)+ , CtEvidence(..)+ , CtLoc+ , CanEqLHS(..)+ , ctLoc+ , ctEvId+ , mkNonCanonical+ )+where++import GHC.Tc.Types.Constraint+ (Ct (..), CtEvidence (..), CanEqLHS (..), CtLoc, ctLoc, ctEvId, mkNonCanonical)
src-ghc-9.4/GhcApi/GhcPlugins.hs view
@@ -1,5 +1,5 @@-module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where - -import GHC.Plugins hiding (TcPlugin, mkSubst) -import GHC.Unit.Finder (findPluginModule) -import GHC.Tc.Plugin (FindResult(..)) +module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where++import GHC.Plugins hiding (TcPlugin, mkSubst)+import GHC.Unit.Finder (findPluginModule)+import GHC.Tc.Plugin (FindResult(..))
src-ghc-9.4/Internal/Constraint.hs view
@@ -1,49 +1,49 @@-{-# LANGUAGE RecordWildCards #-} - -module Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) where - -import GhcApi.GhcPlugins -import GhcApi.Constraint - (Ct(..), CtEvidence(..), CanEqLHS(..), CtLoc, ctLoc, ctEvId, mkNonCanonical) - -import GHC.Tc.Utils.TcType (TcType) -import GHC.Tc.Types.Constraint (QCInst(..)) -import GHC.Tc.Types.Evidence (EvTerm(..), EvBindsVar) -import GHC.Tc.Plugin (TcPluginM) -import qualified GHC.Tc.Plugin as TcPlugin (newGiven) - --- | Create a new [G]iven constraint, with the supplied evidence. This must not --- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic. -newGiven :: EvBindsVar -> CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence -newGiven tcEvbinds loc pty (EvExpr ev) = TcPlugin.newGiven tcEvbinds loc pty ev -newGiven _ _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev) - -flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct -flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) - (ctEvId ct) - (ctLoc ct) - -flatToCt _ = Nothing - --- | Create simple substitution from type equalities -mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct) -mkSubst ct@(CEqCan {..}) - | TyVarLHS tyvar <- cc_lhs - = Just ((tyvar,cc_rhs),ct) -mkSubst _ = Nothing - --- | Modify the predicate type of the evidence term of a constraint -overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct -overEvidencePredType f (CQuantCan qci) = - let - ev :: CtEvidence - ev = qci_ev qci - in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } ) -overEvidencePredType f ct = - let - ev :: CtEvidence - ev = cc_ev ct - in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } } +{-# LANGUAGE RecordWildCards #-}++module Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) where++import GhcApi.GhcPlugins+import GhcApi.Constraint+ (Ct(..), CtEvidence(..), CanEqLHS(..), CtLoc, ctLoc, ctEvId, mkNonCanonical)++import GHC.Tc.Utils.TcType (TcType)+import GHC.Tc.Types.Constraint (QCInst(..))+import GHC.Tc.Types.Evidence (EvTerm(..), EvBindsVar)+import GHC.Tc.Plugin (TcPluginM)+import qualified GHC.Tc.Plugin as TcPlugin (newGiven)++-- | Create a new [G]iven constraint, with the supplied evidence. This must not+-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic.+newGiven :: EvBindsVar -> CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence+newGiven tcEvbinds loc pty (EvExpr ev) = TcPlugin.newGiven tcEvbinds loc pty ev+newGiven _ _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev)++flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct+flatToCt [((_,lhs),ct),((_,rhs),_)]+ = Just+ $ mkNonCanonical+ $ CtGiven (mkPrimEqPred lhs rhs)+ (ctEvId ct)+ (ctLoc ct)++flatToCt _ = Nothing++-- | Create simple substitution from type equalities+mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct)+mkSubst ct@(CEqCan {..})+ | TyVarLHS tyvar <- cc_lhs+ = Just ((tyvar,cc_rhs),ct)+mkSubst _ = Nothing++-- | Modify the predicate type of the evidence term of a constraint+overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct+overEvidencePredType f (CQuantCan qci) =+ let+ ev :: CtEvidence+ ev = qci_ev qci+ in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } )+overEvidencePredType f ct =+ let+ ev :: CtEvidence+ ev = cc_ev ct+ in ct { cc_ev = ev { ctev_pred = f (ctev_pred ev) } }
src-ghc-9.4/Internal/Evidence.hs view
@@ -1,14 +1,14 @@-module Internal.Evidence (evByFiat) where - -import GHC.Tc.Types.Evidence (EvTerm(..)) -import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) - -import GhcApi.GhcPlugins - --- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' -evByFiat :: String -- ^ Name the coercion should have - -> Type -- ^ The LHS of the equivalence relation (~) - -> Type -- ^ The RHS of the equivalence relation (~) - -> EvTerm -evByFiat name t1 t2 = - EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2 +module Internal.Evidence (evByFiat) where++import GHC.Tc.Types.Evidence (EvTerm(..))+import GHC.Core.TyCo.Rep (UnivCoProvenance (..))++import GhcApi.GhcPlugins++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 =+ EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2
src-ghc-9.4/Internal/Type.hs view
@@ -1,30 +1,30 @@-module Internal.Type (substType) where - -import Data.Maybe (fromMaybe) -import GHC.Tc.Utils.TcType (TcType) -import GHC.Core.TyCo.Rep (Type (..)) -import GHC.Types.Var (TcTyVar) - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = - fromMaybe tv (lookup v subst) -substType subst (AppTy t1 t2) = - AppTy (substType subst t1) (substType subst t2) -substType subst (TyConApp tc xs) = - TyConApp tc (map (substType subst) xs) -substType _subst t@(ForAllTy _tv _ty) = - -- TODO: Is it safe to do "dumb" substitution under binders? - -- ForAllTy tv (substType subst ty) - t -substType subst (FunTy k1 k2 t1 t2) = - FunTy k1 k2 (substType subst t1) (substType subst t2) -substType _ l@(LitTy _) = l -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co +module Internal.Type (substType) where++import Data.Maybe (fromMaybe)+import GHC.Tc.Utils.TcType (TcType)+import GHC.Core.TyCo.Rep (Type (..))+import GHC.Types.Var (TcTyVar)++-- | Apply substitutions in Types+--+-- __NB:__ Doesn't substitute under binders+substType+ :: [(TcTyVar, TcType)]+ -> TcType+ -> TcType+substType subst tv@(TyVarTy v) =+ fromMaybe tv (lookup v subst)+substType subst (AppTy t1 t2) =+ AppTy (substType subst t1) (substType subst t2)+substType subst (TyConApp tc xs) =+ TyConApp tc (map (substType subst) xs)+substType _subst t@(ForAllTy _tv _ty) =+ -- TODO: Is it safe to do "dumb" substitution under binders?+ -- ForAllTy tv (substType subst ty)+ t+substType subst (FunTy k1 k2 t1 t2) =+ FunTy k1 k2 (substType subst t1) (substType subst t2)+substType _ l@(LitTy _) = l+substType subst (CastTy ty co) =+ CastTy (substType subst ty) co+substType _ co@(CoercionTy _) = co
src-ghc-cpp/Internal.hs view
@@ -1,409 +1,409 @@-{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> --} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module Internal - ( -- * Create new constraints - newWanted - , newGiven - , newDerived -#if __GLASGOW_HASKELL__ < 711 - , newWantedWithProvenance -#endif - -- * Creating evidence - , evByFiat -#if __GLASGOW_HASKELL__ < 711 - -- * Report contractions - , failWithProvenace -#endif - -- * Lookup - , lookupModule - , lookupName - -- * Trace state of the plugin - , tracePlugin - -- * Substitutions - , flattenGivens - , mkSubst - , mkSubst' - , substType - , substCt - ) -where - --- External -#if __GLASGOW_HASKELL__ < 711 -import Data.Maybe (mapMaybe) -#endif - --- GHC API -#if __GLASGOW_HASKELL__ < 711 -import BasicTypes (TopLevelFlag (..)) -#endif -#if MIN_VERSION_ghc(8,5,0) -import CoreSyn (Expr(..)) -#endif -import Coercion (Role (..), mkUnivCo) -import FastString (FastString, fsLit) -import Module (Module, ModuleName) -import Name (Name) -import OccName (OccName) -import Outputable (($$), (<+>), empty, ppr, text) -import Panic (panicDoc) -#if __GLASGOW_HASKELL__ >= 711 -import TcEvidence (EvTerm (..)) -#else -import TcEvidence (EvTerm (..), TcCoercion (..)) -import TcMType (newEvVar) -#endif -#if __GLASGOW_HASKELL__ < 711 -import TcPluginM (FindResult (..), TcPluginM, findImportedModule, lookupOrig, - tcPluginTrace, unsafeTcPluginTcM) -import TcRnTypes (Ct, CtEvidence (..), CtLoc, TcIdBinder (..), TcLclEnv (..), - TcPlugin (..), TcPluginResult (..), ctEvLoc, - ctLocEnv, setCtLocEnv) -#else -import TcPluginM (FindResult (..), TcPluginM, lookupOrig, tcPluginTrace) -import qualified TcPluginM -import qualified Finder -#if __GLASGOW_HASKELL__ < 809 -import TcRnTypes (CtEvidence (..), CtLoc, - TcPlugin (..), TcPluginResult (..)) -#else -import TcRnTypes (TcPlugin (..), TcPluginResult (..)) -#endif -#endif -#if __GLASGOW_HASKELL__ < 802 -import TcPluginM (tcPluginIO) -#endif -#if __GLASGOW_HASKELL__ >= 711 -import TyCoRep (UnivCoProvenance (..)) -import Type (PredType, Type) -#else -import Type (EqRel (..), PredTree (..), PredType, Type, classifyPredType) -import Var (varType) -#endif -import Control.Arrow (first, second) -import Data.Function (on) -import Data.List (groupBy, partition, sortOn) -#if __GLASGOW_HASKELL__ < 809 -import TcRnTypes (Ct (..), ctLoc, ctEvId, mkNonCanonical) -#else -import Constraint - (Ct (..), CtEvidence (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) -#endif -import TcType (TcTyVar, TcType) -#if __GLASGOW_HASKELL__ < 809 -import Type (mkPrimEqPred) -#else -import Predicate (mkPrimEqPred) -#endif -#if __GLASGOW_HASKELL__ < 711 -import TcRnTypes (ctEvTerm) -import TypeRep (Type (..)) -#else -import Data.Maybe (mapMaybe) -import TyCoRep (Type (..)) -#endif - --- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 -#if __GLASGOW_HASKELL__ < 802 -import Data.IORef (readIORef) -import Control.Monad (unless) -import StaticFlags (initStaticOpts, v_opt_C_ready) -#endif - -{-# ANN module "HLint: ignore" #-} - -#if __GLASGOW_HASKELL__ >= 711 -pattern FoundModule :: Module -> FindResult -pattern FoundModule a <- Found _ a -fr_mod :: a -> a -fr_mod = id -#endif - - -#if __GLASGOW_HASKELL__ < 711 -{-# DEPRECATED newWantedWithProvenance "No longer available in GHC 8.0+" #-} --- | Create a new [W]anted constraint that remembers from which wanted --- constraint it was derived -newWantedWithProvenance :: CtEvidence -- ^ Constraint from which the new - -- wanted is derived - -> PredType -- ^ The type of the new constraint - -> TcPluginM CtEvidence -newWantedWithProvenance ev@(CtWanted {}) p = do - let loc = ctEvLoc ev - env = ctLocEnv loc - id_ = ctEvId ev - env' = env {tcl_bndrs = (TcIdBndr id_ NotTopLevel):tcl_bndrs env} - loc' = setCtLocEnv loc env' - evVar <- unsafeTcPluginTcM $ newEvVar p - return CtWanted { ctev_pred = p - , ctev_evar = evVar - , ctev_loc = loc'} - -newWantedWithProvenance ev _ = - panicDoc "newWantedWithProvenance: not a Wanted: " (ppr ev) -#endif - --- | Create a new [W]anted constraint. -newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence -#if __GLASGOW_HASKELL__ >= 711 -newWanted = TcPluginM.newWanted -#else -newWanted loc pty = do - new_ev <- unsafeTcPluginTcM $ newEvVar pty - return CtWanted { ctev_pred = pty - , ctev_evar = new_ev - , ctev_loc = loc - } -#endif - --- | Create a new [G]iven constraint, with the supplied evidence. This must not --- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic. -newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence -#if MIN_VERSION_ghc(8,5,0) -newGiven loc pty (EvExpr ev) = TcPluginM.newGiven loc pty ev -newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev) -#elif __GLASGOW_HASKELL__ >= 711 -newGiven = TcPluginM.newGiven -#else -newGiven loc pty evtm = return - CtGiven { ctev_pred = pty - , ctev_evtm = evtm - , ctev_loc = loc - } -#endif - --- | Create a new [D]erived constraint. -newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence -#if __GLASGOW_HASKELL__ >= 711 -newDerived = TcPluginM.newDerived -#else -newDerived loc pty = return - CtDerived { ctev_pred = pty - , ctev_loc = loc - } -#endif - --- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' -evByFiat :: String -- ^ Name the coercion should have - -> Type -- ^ The LHS of the equivalence relation (~) - -> Type -- ^ The RHS of the equivalence relation (~) - -> EvTerm -evByFiat name t1 t2 = -#if MIN_VERSION_ghc(8,5,0) - EvExpr - $ Coercion -#else - EvCoercion -#if __GLASGOW_HASKELL__ < 711 - $ TcCoercion -#endif -#endif - $ mkUnivCo -#if __GLASGOW_HASKELL__ >= 711 - (PluginProv name) -#else - (fsLit name) -#endif - Nominal t1 t2 - -#if __GLASGOW_HASKELL__ < 711 -{-# DEPRECATED failWithProvenace "No longer available in GHC 8.0+" #-} --- | Mark the given constraint as insoluble. --- --- If the [W]anted constraint was made by 'newWantedWithProvenance', it will --- also mark the parent(s) from which the constraint was derived as insoluble. --- Even if they were previously assumed to be solved. -failWithProvenace :: Ct -> TcPluginM TcPluginResult -failWithProvenace ct = return (TcPluginContradiction (ct : parents)) - where - loc = ctLoc ct - lclbndrs = mapMaybe (\case {TcIdBndr id_ NotTopLevel -> Just id_ - ;_ -> Nothing }) - $ tcl_bndrs (ctLocEnv loc) - eqBndrs = filter ((\x -> case x of { EqPred NomEq _ _ -> True - ; _ -> False }) - . classifyPredType . snd) - $ map (\ev -> (ev,varType ev)) lclbndrs - parents = map (\(id_,p) -> mkNonCanonical $ CtWanted p id_ loc) eqBndrs -#endif - --- | Find a module -lookupModule :: ModuleName -- ^ Name of the module - -> FastString -- ^ Name of the package containing the module. - -- NOTE: This value is ignored on ghc>=8.0. - -> TcPluginM Module -lookupModule mod_nm _pkg = do -#if __GLASGOW_HASKELL__ >= 711 - hsc_env <- TcPluginM.getTopEnv - found_module <- TcPluginM.tcPluginIO $ Finder.findPluginModule hsc_env mod_nm -#else - found_module <- findImportedModule mod_nm $ Just _pkg -#endif - case found_module of -#if __GLASGOW_HASKELL__ >= 711 - FoundModule h -> return (fr_mod h) -#else - Found _ md -> return md -#endif - _ -> do - found_module' <- TcPluginM.findImportedModule mod_nm $ Just $ fsLit "this" - case found_module' of -#if __GLASGOW_HASKELL__ >= 711 - FoundModule h -> return (fr_mod h) -#else - Found _ md -> return md -#endif - _ -> panicDoc "Unable to resolve module looked up by plugin: " - (ppr mod_nm) - --- | Find a 'Name' in a 'Module' given an 'OccName' -lookupName :: Module -> OccName -> TcPluginM Name -lookupName md occ = lookupOrig md occ - --- | Print out extra information about the initialisation, stop, and every run --- of the plugin when @-ddump-tc-trace@ is enabled. -tracePlugin :: String -> TcPlugin -> TcPlugin -tracePlugin s TcPlugin{..} = TcPlugin { tcPluginInit = traceInit - , tcPluginSolve = traceSolve - , tcPluginStop = traceStop - } - where - traceInit = do - -- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 - initializeStaticFlags - tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit - - traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z - - traceSolve z given derived wanted = do - tcPluginTrace ("tcPluginSolve start " ++ s) - (text "given =" <+> ppr given - $$ text "derived =" <+> ppr derived - $$ text "wanted =" <+> ppr wanted) - r <- tcPluginSolve z given derived wanted - case r of - TcPluginOk solved new -> tcPluginTrace ("tcPluginSolve ok " ++ s) - (text "solved =" <+> ppr solved - $$ text "new =" <+> ppr new) - TcPluginContradiction bad -> tcPluginTrace - ("tcPluginSolve contradiction " ++ s) - (text "bad =" <+> ppr bad) - return r - --- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 -initializeStaticFlags :: TcPluginM () -#if __GLASGOW_HASKELL__ < 802 -initializeStaticFlags = tcPluginIO $ do - r <- readIORef v_opt_C_ready - unless r initStaticOpts -#else -initializeStaticFlags = return () -#endif - --- | Flattens evidence of constraints by substituting each others equalities. --- --- __NB:__ Should only be used on /[G]iven/ constraints! --- --- __NB:__ Doesn't flatten under binders -flattenGivens - :: [Ct] - -> [Ct] -flattenGivens givens = - mapMaybe flatToCt flat ++ map (substCt subst') givens - where - subst = mkSubst' givens - (flat,subst') - = second (map fst . concat) - $ partition ((>= 2) . length) - $ groupBy ((==) `on` (fst.fst)) - $ sortOn (fst.fst) subst - - flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct - flatToCt [((_,lhs),ct),((_,rhs),_)] - = Just - $ mkNonCanonical - $ CtGiven (mkPrimEqPred lhs rhs) -#if MIN_VERSION_ghc(8,4,0) - (ctEvId ct) -#elif MIN_VERSION_ghc(8,0,0) - (ctEvId (cc_ev ct)) -#else - (ctEvTerm (cc_ev ct)) -#endif - (ctLoc ct) - - flatToCt _ = Nothing - - --- | Create flattened substitutions from type equalities, i.e. the substitutions --- have been applied to each others right hand sides. -mkSubst' :: [Ct] -> [((TcTyVar,TcType),Ct)] -mkSubst' = foldr substSubst [] . mapMaybe mkSubst - where - substSubst :: ((TcTyVar,TcType),Ct) - -> [((TcTyVar,TcType),Ct)] - -> [((TcTyVar,TcType),Ct)] - substSubst ((tv,t),ct) s = ((tv,substType (map fst s) t),ct) - : map (first (second (substType [(tv,t)]))) s - --- | Create simple substitution from type equalities -mkSubst - :: Ct - -> Maybe ((TcTyVar, TcType),Ct) -mkSubst ct@(CTyEqCan {..}) = Just ((cc_tyvar,cc_rhs),ct) -mkSubst ct@(CFunEqCan {..}) = Just ((cc_fsk,TyConApp cc_fun cc_tyargs),ct) -mkSubst _ = Nothing - --- | Apply substitution in the evidence of Cts -substCt - :: [(TcTyVar, TcType)] - -> Ct - -> Ct -substCt subst ct = - ct { cc_ev = (cc_ev ct) {ctev_pred = substType subst (ctev_pred (cc_ev ct))} - } - --- | Apply substitutions in Types --- --- __NB:__ Doesn't substitute under binders -substType - :: [(TcTyVar, TcType)] - -> TcType - -> TcType -substType subst tv@(TyVarTy v) = case lookup v subst of - Just t -> t - Nothing -> tv -substType subst (AppTy t1 t2) = - AppTy (substType subst t1) (substType subst t2) -substType subst (TyConApp tc xs) = - TyConApp tc (map (substType subst) xs) -substType _subst t@(ForAllTy _tv _ty) = - -- TODO: Is it safe to do "dumb" substitution under binders? - -- ForAllTy tv (substType subst ty) - t -#if __GLASGOW_HASKELL__ >= 809 -substType subst (FunTy af t1 t2) = - FunTy af (substType subst t1) (substType subst t2) -#elif __GLASGOW_HASKELL__ >= 802 -substType subst (FunTy t1 t2) = - FunTy (substType subst t1) (substType subst t2) -#elif __GLASGOW_HASKELL__ < 711 -substType subst (FunTy t1 t2) = - FunTy (substType subst t1) (substType subst t2) -#endif -substType _ l@(LitTy _) = l -#if __GLASGOW_HASKELL__ > 711 -substType subst (CastTy ty co) = - CastTy (substType subst ty) co -substType _ co@(CoercionTy _) = co -#endif +{-|+Copyright : (C) 2015-2016, University of Twente+License : BSD2 (see the file LICENSE)+Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PatternSynonyms #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Internal+ ( -- * Create new constraints+ newWanted+ , newGiven+ , newDerived+#if __GLASGOW_HASKELL__ < 711+ , newWantedWithProvenance+#endif+ -- * Creating evidence+ , evByFiat+#if __GLASGOW_HASKELL__ < 711+ -- * Report contractions+ , failWithProvenace+#endif+ -- * Lookup+ , lookupModule+ , lookupName+ -- * Trace state of the plugin+ , tracePlugin+ -- * Substitutions+ , flattenGivens+ , mkSubst+ , mkSubst'+ , substType+ , substCt+ )+where++-- External+#if __GLASGOW_HASKELL__ < 711+import Data.Maybe (mapMaybe)+#endif++-- GHC API+#if __GLASGOW_HASKELL__ < 711+import BasicTypes (TopLevelFlag (..))+#endif+#if MIN_VERSION_ghc(8,5,0)+import CoreSyn (Expr(..))+#endif+import Coercion (Role (..), mkUnivCo)+import FastString (FastString, fsLit)+import Module (Module, ModuleName)+import Name (Name)+import OccName (OccName)+import Outputable (($$), (<+>), empty, ppr, text)+import Panic (panicDoc)+#if __GLASGOW_HASKELL__ >= 711+import TcEvidence (EvTerm (..))+#else+import TcEvidence (EvTerm (..), TcCoercion (..))+import TcMType (newEvVar)+#endif+#if __GLASGOW_HASKELL__ < 711+import TcPluginM (FindResult (..), TcPluginM, findImportedModule, lookupOrig,+ tcPluginTrace, unsafeTcPluginTcM)+import TcRnTypes (Ct, CtEvidence (..), CtLoc, TcIdBinder (..), TcLclEnv (..),+ TcPlugin (..), TcPluginResult (..), ctEvLoc,+ ctLocEnv, setCtLocEnv)+#else+import TcPluginM (FindResult (..), TcPluginM, lookupOrig, tcPluginTrace)+import qualified TcPluginM+import qualified Finder+#if __GLASGOW_HASKELL__ < 809+import TcRnTypes (CtEvidence (..), CtLoc,+ TcPlugin (..), TcPluginResult (..))+#else+import TcRnTypes (TcPlugin (..), TcPluginResult (..))+#endif+#endif+#if __GLASGOW_HASKELL__ < 802+import TcPluginM (tcPluginIO)+#endif+#if __GLASGOW_HASKELL__ >= 711+import TyCoRep (UnivCoProvenance (..))+import Type (PredType, Type)+#else+import Type (EqRel (..), PredTree (..), PredType, Type, classifyPredType)+import Var (varType)+#endif+import Control.Arrow (first, second)+import Data.Function (on)+import Data.List (groupBy, partition, sortOn)+#if __GLASGOW_HASKELL__ < 809+import TcRnTypes (Ct (..), ctLoc, ctEvId, mkNonCanonical)+#else+import Constraint+ (Ct (..), CtEvidence (..), CtLoc, ctLoc, ctEvId, mkNonCanonical)+#endif+import TcType (TcTyVar, TcType)+#if __GLASGOW_HASKELL__ < 809+import Type (mkPrimEqPred)+#else+import Predicate (mkPrimEqPred)+#endif+#if __GLASGOW_HASKELL__ < 711+import TcRnTypes (ctEvTerm)+import TypeRep (Type (..))+#else+import Data.Maybe (mapMaybe)+import TyCoRep (Type (..))+#endif++-- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301+#if __GLASGOW_HASKELL__ < 802+import Data.IORef (readIORef)+import Control.Monad (unless)+import StaticFlags (initStaticOpts, v_opt_C_ready)+#endif++{-# ANN module "HLint: ignore" #-}++#if __GLASGOW_HASKELL__ >= 711+pattern FoundModule :: Module -> FindResult+pattern FoundModule a <- Found _ a+fr_mod :: a -> a+fr_mod = id+#endif+++#if __GLASGOW_HASKELL__ < 711+{-# DEPRECATED newWantedWithProvenance "No longer available in GHC 8.0+" #-}+-- | Create a new [W]anted constraint that remembers from which wanted+-- constraint it was derived+newWantedWithProvenance :: CtEvidence -- ^ Constraint from which the new+ -- wanted is derived+ -> PredType -- ^ The type of the new constraint+ -> TcPluginM CtEvidence+newWantedWithProvenance ev@(CtWanted {}) p = do+ let loc = ctEvLoc ev+ env = ctLocEnv loc+ id_ = ctEvId ev+ env' = env {tcl_bndrs = (TcIdBndr id_ NotTopLevel):tcl_bndrs env}+ loc' = setCtLocEnv loc env'+ evVar <- unsafeTcPluginTcM $ newEvVar p+ return CtWanted { ctev_pred = p+ , ctev_evar = evVar+ , ctev_loc = loc'}++newWantedWithProvenance ev _ =+ panicDoc "newWantedWithProvenance: not a Wanted: " (ppr ev)+#endif++-- | Create a new [W]anted constraint.+newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence+#if __GLASGOW_HASKELL__ >= 711+newWanted = TcPluginM.newWanted+#else+newWanted loc pty = do+ new_ev <- unsafeTcPluginTcM $ newEvVar pty+ return CtWanted { ctev_pred = pty+ , ctev_evar = new_ev+ , ctev_loc = loc+ }+#endif++-- | Create a new [G]iven constraint, with the supplied evidence. This must not+-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic.+newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence+#if MIN_VERSION_ghc(8,5,0)+newGiven loc pty (EvExpr ev) = TcPluginM.newGiven loc pty ev+newGiven _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev)+#elif __GLASGOW_HASKELL__ >= 711+newGiven = TcPluginM.newGiven+#else+newGiven loc pty evtm = return+ CtGiven { ctev_pred = pty+ , ctev_evtm = evtm+ , ctev_loc = loc+ }+#endif++-- | Create a new [D]erived constraint.+newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence+#if __GLASGOW_HASKELL__ >= 711+newDerived = TcPluginM.newDerived+#else+newDerived loc pty = return+ CtDerived { ctev_pred = pty+ , ctev_loc = loc+ }+#endif++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 =+#if MIN_VERSION_ghc(8,5,0)+ EvExpr+ $ Coercion+#else+ EvCoercion+#if __GLASGOW_HASKELL__ < 711+ $ TcCoercion+#endif+#endif+ $ mkUnivCo+#if __GLASGOW_HASKELL__ >= 711+ (PluginProv name)+#else+ (fsLit name)+#endif+ Nominal t1 t2++#if __GLASGOW_HASKELL__ < 711+{-# DEPRECATED failWithProvenace "No longer available in GHC 8.0+" #-}+-- | Mark the given constraint as insoluble.+--+-- If the [W]anted constraint was made by 'newWantedWithProvenance', it will+-- also mark the parent(s) from which the constraint was derived as insoluble.+-- Even if they were previously assumed to be solved.+failWithProvenace :: Ct -> TcPluginM TcPluginResult+failWithProvenace ct = return (TcPluginContradiction (ct : parents))+ where+ loc = ctLoc ct+ lclbndrs = mapMaybe (\case {TcIdBndr id_ NotTopLevel -> Just id_+ ;_ -> Nothing })+ $ tcl_bndrs (ctLocEnv loc)+ eqBndrs = filter ((\x -> case x of { EqPred NomEq _ _ -> True+ ; _ -> False })+ . classifyPredType . snd)+ $ map (\ev -> (ev,varType ev)) lclbndrs+ parents = map (\(id_,p) -> mkNonCanonical $ CtWanted p id_ loc) eqBndrs+#endif++-- | Find a module+lookupModule :: ModuleName -- ^ Name of the module+ -> FastString -- ^ Name of the package containing the module.+ -- NOTE: This value is ignored on ghc>=8.0.+ -> TcPluginM Module+lookupModule mod_nm _pkg = do+#if __GLASGOW_HASKELL__ >= 711+ hsc_env <- TcPluginM.getTopEnv+ found_module <- TcPluginM.tcPluginIO $ Finder.findPluginModule hsc_env mod_nm+#else+ found_module <- findImportedModule mod_nm $ Just _pkg+#endif+ case found_module of+#if __GLASGOW_HASKELL__ >= 711+ FoundModule h -> return (fr_mod h)+#else+ Found _ md -> return md+#endif+ _ -> do+ found_module' <- TcPluginM.findImportedModule mod_nm $ Just $ fsLit "this"+ case found_module' of+#if __GLASGOW_HASKELL__ >= 711+ FoundModule h -> return (fr_mod h)+#else+ Found _ md -> return md+#endif+ _ -> panicDoc "Unable to resolve module looked up by plugin: "+ (ppr mod_nm)++-- | Find a 'Name' in a 'Module' given an 'OccName'+lookupName :: Module -> OccName -> TcPluginM Name+lookupName md occ = lookupOrig md occ++-- | Print out extra information about the initialisation, stop, and every run+-- of the plugin when @-ddump-tc-trace@ is enabled.+tracePlugin :: String -> TcPlugin -> TcPlugin+tracePlugin s TcPlugin{..} = TcPlugin { tcPluginInit = traceInit+ , tcPluginSolve = traceSolve+ , tcPluginStop = traceStop+ }+ where+ traceInit = do+ -- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301+ initializeStaticFlags+ tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit++ traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z++ traceSolve z given derived wanted = do+ tcPluginTrace ("tcPluginSolve start " ++ s)+ (text "given =" <+> ppr given+ $$ text "derived =" <+> ppr derived+ $$ text "wanted =" <+> ppr wanted)+ r <- tcPluginSolve z given derived wanted+ case r of+ TcPluginOk solved new -> tcPluginTrace ("tcPluginSolve ok " ++ s)+ (text "solved =" <+> ppr solved+ $$ text "new =" <+> ppr new)+ TcPluginContradiction bad -> tcPluginTrace+ ("tcPluginSolve contradiction " ++ s)+ (text "bad =" <+> ppr bad)+ return r++-- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301+initializeStaticFlags :: TcPluginM ()+#if __GLASGOW_HASKELL__ < 802+initializeStaticFlags = tcPluginIO $ do+ r <- readIORef v_opt_C_ready+ unless r initStaticOpts+#else+initializeStaticFlags = return ()+#endif++-- | Flattens evidence of constraints by substituting each others equalities.+--+-- __NB:__ Should only be used on /[G]iven/ constraints!+--+-- __NB:__ Doesn't flatten under binders+flattenGivens+ :: [Ct]+ -> [Ct]+flattenGivens givens =+ mapMaybe flatToCt flat ++ map (substCt subst') givens+ where+ subst = mkSubst' givens+ (flat,subst')+ = second (map fst . concat)+ $ partition ((>= 2) . length)+ $ groupBy ((==) `on` (fst.fst))+ $ sortOn (fst.fst) subst++ flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct+ flatToCt [((_,lhs),ct),((_,rhs),_)]+ = Just+ $ mkNonCanonical+ $ CtGiven (mkPrimEqPred lhs rhs)+#if MIN_VERSION_ghc(8,4,0)+ (ctEvId ct)+#elif MIN_VERSION_ghc(8,0,0)+ (ctEvId (cc_ev ct))+#else+ (ctEvTerm (cc_ev ct))+#endif+ (ctLoc ct)++ flatToCt _ = Nothing+++-- | Create flattened substitutions from type equalities, i.e. the substitutions+-- have been applied to each others right hand sides.+mkSubst' :: [Ct] -> [((TcTyVar,TcType),Ct)]+mkSubst' = foldr substSubst [] . mapMaybe mkSubst+ where+ substSubst :: ((TcTyVar,TcType),Ct)+ -> [((TcTyVar,TcType),Ct)]+ -> [((TcTyVar,TcType),Ct)]+ substSubst ((tv,t),ct) s = ((tv,substType (map fst s) t),ct)+ : map (first (second (substType [(tv,t)]))) s++-- | Create simple substitution from type equalities+mkSubst+ :: Ct+ -> Maybe ((TcTyVar, TcType),Ct)+mkSubst ct@(CTyEqCan {..}) = Just ((cc_tyvar,cc_rhs),ct)+mkSubst ct@(CFunEqCan {..}) = Just ((cc_fsk,TyConApp cc_fun cc_tyargs),ct)+mkSubst _ = Nothing++-- | Apply substitution in the evidence of Cts+substCt+ :: [(TcTyVar, TcType)]+ -> Ct+ -> Ct+substCt subst ct =+ ct { cc_ev = (cc_ev ct) {ctev_pred = substType subst (ctev_pred (cc_ev ct))}+ }++-- | Apply substitutions in Types+--+-- __NB:__ Doesn't substitute under binders+substType+ :: [(TcTyVar, TcType)]+ -> TcType+ -> TcType+substType subst tv@(TyVarTy v) = case lookup v subst of+ Just t -> t+ Nothing -> tv+substType subst (AppTy t1 t2) =+ AppTy (substType subst t1) (substType subst t2)+substType subst (TyConApp tc xs) =+ TyConApp tc (map (substType subst) xs)+substType _subst t@(ForAllTy _tv _ty) =+ -- TODO: Is it safe to do "dumb" substitution under binders?+ -- ForAllTy tv (substType subst ty)+ t+#if __GLASGOW_HASKELL__ >= 809+substType subst (FunTy af t1 t2) =+ FunTy af (substType subst t1) (substType subst t2)+#elif __GLASGOW_HASKELL__ >= 802+substType subst (FunTy t1 t2) =+ FunTy (substType subst t1) (substType subst t2)+#elif __GLASGOW_HASKELL__ < 711+substType subst (FunTy t1 t2) =+ FunTy (substType subst t1) (substType subst t2)+#endif+substType _ l@(LitTy _) = l+#if __GLASGOW_HASKELL__ > 711+substType subst (CastTy ty co) =+ CastTy (substType subst ty) co+substType _ co@(CoercionTy _) = co+#endif
src-ghc-flat/GhcApi/Constraint.hs view
@@ -1,12 +1,12 @@-module GhcApi.Constraint - ( Ct(..) - , CtEvidence(..) - , CtLoc - , ctLoc - , ctEvId - , mkNonCanonical - ) -where - -import Constraint - (Ct (..), CtEvidence (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) +module GhcApi.Constraint+ ( Ct(..)+ , CtEvidence(..)+ , CtLoc+ , ctLoc+ , ctEvId+ , mkNonCanonical+ )+where++import Constraint+ (Ct (..), CtEvidence (..), CtLoc, ctLoc, ctEvId, mkNonCanonical)
src-ghc-flat/GhcApi/Predicate.hs view
@@ -1,3 +1,3 @@-module GhcApi.Predicate (mkPrimEqPred) where - -import Predicate (mkPrimEqPred) +module GhcApi.Predicate (mkPrimEqPred) where++import Predicate (mkPrimEqPred)
src-ghc-flat/Internal.hs view
@@ -1,151 +1,151 @@-{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module Internal - ( -- * Create new constraints - newWanted - , newGiven - , newDerived - -- * Creating evidence - , evByFiat - -- * Lookup - , lookupModule - , lookupName - -- * Trace state of the plugin - , tracePlugin - -- * Substitutions - , flattenGivens - , mkSubst - , mkSubst' - , substType - , substCt - ) -where - -import Panic (panicDoc) -import TcPluginM (TcPluginM, lookupOrig, tcPluginTrace) -import qualified TcPluginM -import qualified Finder -import TcRnTypes (TcPlugin(..), TcPluginResult(..)) -import Control.Arrow (first, second) -import Data.Function (on) -import Data.List (groupBy, partition, sortOn) -import TcType (TcType) -import Data.Maybe (mapMaybe) -import TyCoRep (Type(..)) - -import GhcApi.Constraint (Ct(..), CtEvidence(..), CtLoc) -import GhcApi.GhcPlugins - -import Internal.Type (substType) -import Internal.Constraint (newGiven, flatToCt, overEvidencePredType) -import Internal.Evidence (evByFiat) - -{-# ANN fr_mod "HLint: ignore Use camelCase" #-} - -pattern FoundModule :: Module -> FindResult -pattern FoundModule a <- Found _ a - -fr_mod :: a -> a -fr_mod = id - --- | Create a new [W]anted constraint. -newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence -newWanted = TcPluginM.newWanted - --- | Create a new [D]erived constraint. -newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence -newDerived = TcPluginM.newDerived - --- | Find a module -lookupModule :: ModuleName -- ^ Name of the module - -> FastString -- ^ Name of the package containing the module. - -- NOTE: This value is ignored on ghc>=8.0. - -> TcPluginM Module -lookupModule mod_nm _pkg = do - hsc_env <- TcPluginM.getTopEnv - found_module <- TcPluginM.tcPluginIO $ Finder.findPluginModule hsc_env mod_nm - case found_module of - FoundModule h -> return (fr_mod h) - _ -> do - found_module' <- TcPluginM.findImportedModule mod_nm $ Just $ fsLit "this" - case found_module' of - FoundModule h -> return (fr_mod h) - _ -> panicDoc "Couldn't find module" (ppr mod_nm) - --- | Find a 'Name' in a 'Module' given an 'OccName' -lookupName :: Module -> OccName -> TcPluginM Name -lookupName = lookupOrig - --- | Print out extra information about the initialisation, stop, and every run --- of the plugin when @-ddump-tc-trace@ is enabled. -tracePlugin :: String -> TcPlugin -> TcPlugin -tracePlugin s TcPlugin{..} = TcPlugin { tcPluginInit = traceInit - , tcPluginSolve = traceSolve - , tcPluginStop = traceStop - } - where - traceInit = do - -- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 - initializeStaticFlags - tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit - - traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z - - traceSolve z given derived wanted = do - tcPluginTrace ("tcPluginSolve start " ++ s) - (text "given =" <+> ppr given - $$ text "derived =" <+> ppr derived - $$ text "wanted =" <+> ppr wanted) - r <- tcPluginSolve z given derived wanted - case r of - TcPluginOk solved new -> tcPluginTrace ("tcPluginSolve ok " ++ s) - (text "solved =" <+> ppr solved - $$ text "new =" <+> ppr new) - TcPluginContradiction bad -> tcPluginTrace - ("tcPluginSolve contradiction " ++ s) - (text "bad =" <+> ppr bad) - return r - --- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 -initializeStaticFlags :: TcPluginM () -initializeStaticFlags = return () - --- | Flattens evidence of constraints by substituting each others equalities. --- --- __NB:__ Should only be used on /[G]iven/ constraints! --- --- __NB:__ Doesn't flatten under binders -flattenGivens :: [Ct] -> [Ct] -flattenGivens givens = - mapMaybe flatToCt flat ++ map (substCt subst') givens - where - subst = mkSubst' givens - (flat,subst') - = second (map fst . concat) - $ partition ((>= 2) . length) - $ groupBy ((==) `on` (fst.fst)) - $ sortOn (fst.fst) subst - --- | Create flattened substitutions from type equalities, i.e. the substitutions --- have been applied to each others right hand sides. -mkSubst' :: [Ct] -> [((TcTyVar,TcType),Ct)] -mkSubst' = foldr substSubst [] . mapMaybe mkSubst - where - substSubst :: ((TcTyVar,TcType),Ct) - -> [((TcTyVar,TcType),Ct)] - -> [((TcTyVar,TcType),Ct)] - substSubst ((tv,t),ct) s = ((tv,substType (map fst s) t),ct) - : map (first (second (substType [(tv,t)]))) s - --- | Create simple substitution from type equalities -mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct) -mkSubst ct@CTyEqCan{..} = Just ((cc_tyvar,cc_rhs),ct) -mkSubst ct@CFunEqCan{..} = Just ((cc_fsk,TyConApp cc_fun cc_tyargs),ct) -mkSubst _ = Nothing - --- | Apply substitution in the evidence of Cts -substCt :: [(TcTyVar, TcType)] -> Ct -> Ct -substCt subst = overEvidencePredType (substType subst) +{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PatternSynonyms #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Internal+ ( -- * Create new constraints+ newWanted+ , newGiven+ , newDerived+ -- * Creating evidence+ , evByFiat+ -- * Lookup+ , lookupModule+ , lookupName+ -- * Trace state of the plugin+ , tracePlugin+ -- * Substitutions+ , flattenGivens+ , mkSubst+ , mkSubst'+ , substType+ , substCt+ )+where++import Panic (panicDoc)+import TcPluginM (TcPluginM, lookupOrig, tcPluginTrace)+import qualified TcPluginM+import qualified Finder+import TcRnTypes (TcPlugin(..), TcPluginResult(..))+import Control.Arrow (first, second)+import Data.Function (on)+import Data.List (groupBy, partition, sortOn)+import TcType (TcType)+import Data.Maybe (mapMaybe)+import TyCoRep (Type(..))++import GhcApi.Constraint (Ct(..), CtEvidence(..), CtLoc)+import GhcApi.GhcPlugins++import Internal.Type (substType)+import Internal.Constraint (newGiven, flatToCt, overEvidencePredType)+import Internal.Evidence (evByFiat)++{-# ANN fr_mod "HLint: ignore Use camelCase" #-}++pattern FoundModule :: Module -> FindResult+pattern FoundModule a <- Found _ a++fr_mod :: a -> a+fr_mod = id++-- | Create a new [W]anted constraint.+newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence+newWanted = TcPluginM.newWanted++-- | Create a new [D]erived constraint.+newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence+newDerived = TcPluginM.newDerived++-- | Find a module+lookupModule :: ModuleName -- ^ Name of the module+ -> FastString -- ^ Name of the package containing the module.+ -- NOTE: This value is ignored on ghc>=8.0.+ -> TcPluginM Module+lookupModule mod_nm _pkg = do+ hsc_env <- TcPluginM.getTopEnv+ found_module <- TcPluginM.tcPluginIO $ Finder.findPluginModule hsc_env mod_nm+ case found_module of+ FoundModule h -> return (fr_mod h)+ _ -> do+ found_module' <- TcPluginM.findImportedModule mod_nm $ Just $ fsLit "this"+ case found_module' of+ FoundModule h -> return (fr_mod h)+ _ -> panicDoc "Couldn't find module" (ppr mod_nm)++-- | Find a 'Name' in a 'Module' given an 'OccName'+lookupName :: Module -> OccName -> TcPluginM Name+lookupName = lookupOrig++-- | Print out extra information about the initialisation, stop, and every run+-- of the plugin when @-ddump-tc-trace@ is enabled.+tracePlugin :: String -> TcPlugin -> TcPlugin+tracePlugin s TcPlugin{..} = TcPlugin { tcPluginInit = traceInit+ , tcPluginSolve = traceSolve+ , tcPluginStop = traceStop+ }+ where+ traceInit = do+ -- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301+ initializeStaticFlags+ tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit++ traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z++ traceSolve z given derived wanted = do+ tcPluginTrace ("tcPluginSolve start " ++ s)+ (text "given =" <+> ppr given+ $$ text "derived =" <+> ppr derived+ $$ text "wanted =" <+> ppr wanted)+ r <- tcPluginSolve z given derived wanted+ case r of+ TcPluginOk solved new -> tcPluginTrace ("tcPluginSolve ok " ++ s)+ (text "solved =" <+> ppr solved+ $$ text "new =" <+> ppr new)+ TcPluginContradiction bad -> tcPluginTrace+ ("tcPluginSolve contradiction " ++ s)+ (text "bad =" <+> ppr bad)+ return r++-- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301+initializeStaticFlags :: TcPluginM ()+initializeStaticFlags = return ()++-- | Flattens evidence of constraints by substituting each others equalities.+--+-- __NB:__ Should only be used on /[G]iven/ constraints!+--+-- __NB:__ Doesn't flatten under binders+flattenGivens :: [Ct] -> [Ct]+flattenGivens givens =+ mapMaybe flatToCt flat ++ map (substCt subst') givens+ where+ subst = mkSubst' givens+ (flat,subst')+ = second (map fst . concat)+ $ partition ((>= 2) . length)+ $ groupBy ((==) `on` (fst.fst))+ $ sortOn (fst.fst) subst++-- | Create flattened substitutions from type equalities, i.e. the substitutions+-- have been applied to each others right hand sides.+mkSubst' :: [Ct] -> [((TcTyVar,TcType),Ct)]+mkSubst' = foldr substSubst [] . mapMaybe mkSubst+ where+ substSubst :: ((TcTyVar,TcType),Ct)+ -> [((TcTyVar,TcType),Ct)]+ -> [((TcTyVar,TcType),Ct)]+ substSubst ((tv,t),ct) s = ((tv,substType (map fst s) t),ct)+ : map (first (second (substType [(tv,t)]))) s++-- | Create simple substitution from type equalities+mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct)+mkSubst ct@CTyEqCan{..} = Just ((cc_tyvar,cc_rhs),ct)+mkSubst ct@CFunEqCan{..} = Just ((cc_fsk,TyConApp cc_fun cc_tyargs),ct)+mkSubst _ = Nothing++-- | Apply substitution in the evidence of Cts+substCt :: [(TcTyVar, TcType)] -> Ct -> Ct+substCt subst = overEvidencePredType (substType subst)
src-ghc-tree-9.4/GhcApi/Predicate.hs view
@@ -1,3 +1,3 @@-module GhcApi.Predicate (mkPrimEqPred) where - -import GHC.Core.Coercion (mkPrimEqPred) +module GhcApi.Predicate (mkPrimEqPred) where++import GHC.Core.Coercion (mkPrimEqPred)
src-ghc-tree-9.4/Internal.hs view
@@ -1,133 +1,133 @@-{-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module Internal - ( -- * Create new constraints - TcPlugin.newWanted - , newGiven - -- * Creating evidence - , evByFiat - -- * Lookup - , lookupModule - , lookupName - -- * Trace state of the plugin - , tracePlugin - -- * Substitutions - , flattenGivens - , mkSubst - , mkSubst' - , substType - , substCt - ) -where - -import GHC.Driver.Config.Finder (initFinderOpts) -import GHC.Tc.Plugin (TcPluginM, lookupOrig, tcPluginTrace) -import qualified GHC.Tc.Plugin as TcPlugin - (newWanted, getTopEnv, tcPluginIO, findImportedModule) -import GHC.Tc.Types (TcPlugin(..), TcPluginSolveResult(..)) -import Control.Arrow (first, second) -import Data.Function (on) -import Data.List (groupBy, partition, sortOn) -import GHC.Tc.Utils.TcType (TcType) -import Data.Maybe (mapMaybe) - -import GhcApi.Constraint (Ct(..)) -import GhcApi.GhcPlugins - -import Internal.Type (substType) -import Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) -import Internal.Evidence (evByFiat) - --- | Find a module -lookupModule :: ModuleName -- ^ Name of the module - -> FastString -- ^ Name of the package containing the module. - -- NOTE: This value is ignored on ghc>=8.0. - -> TcPluginM Module -lookupModule mod_nm _pkg = do - hsc_env <- TcPlugin.getTopEnv - let fc = hsc_FC hsc_env - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags - units = hsc_units hsc_env - mhome_unit = hsc_home_unit_maybe hsc_env - found_module <- TcPlugin.tcPluginIO $ findPluginModule fc fopts units - mhome_unit mod_nm - case found_module of - Found _ h -> return h - _ -> do - let pkg_qual = maybe NoPkgQual (ThisPkg . homeUnitId) mhome_unit - found_module' <- TcPlugin.findImportedModule mod_nm pkg_qual - case found_module' of - Found _ h -> return h - _ -> panicDoc "Couldn't find module" (ppr mod_nm) - --- | Find a 'Name' in a 'Module' given an 'OccName' -lookupName :: Module -> OccName -> TcPluginM Name -lookupName = lookupOrig - --- | Print out extra information about the initialisation, stop, and every run --- of the plugin when @-ddump-tc-trace@ is enabled. -tracePlugin :: String -> TcPlugin -> TcPlugin -tracePlugin s TcPlugin{..} = TcPlugin { tcPluginInit = traceInit - , tcPluginSolve = traceSolve - , tcPluginRewrite = tcPluginRewrite - , tcPluginStop = traceStop - } - where - traceInit = do - tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit - - traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z - - traceSolve z ev given wanted = do - tcPluginTrace ("tcPluginSolve start " ++ s) - (text "given =" <+> ppr given - $$ text "wanted =" <+> ppr wanted) - r <- tcPluginSolve z ev given wanted - case r of - TcPluginOk solved new - -> tcPluginTrace ("tcPluginSolve ok " ++ s) - (text "solved =" <+> ppr solved - $$ text "new =" <+> ppr new) - TcPluginContradiction bad - -> tcPluginTrace ("tcPluginSolve contradiction " ++ s) - (text "bad =" <+> ppr bad) - TcPluginSolveResult bad solved new - -> tcPluginTrace ("tcPluginSolveResult " ++ s) - (text "solved =" <+> ppr solved - $$ text "bad =" <+> ppr bad - $$ text "new =" <+> ppr new) - return r - --- | Flattens evidence of constraints by substituting each others equalities. --- --- __NB:__ Should only be used on /[G]iven/ constraints! --- --- __NB:__ Doesn't flatten under binders -flattenGivens :: [Ct] -> [Ct] -flattenGivens givens = - mapMaybe flatToCt flat ++ map (substCt subst') givens - where - subst = mkSubst' givens - (flat,subst') - = second (map fst . concat) - $ partition ((>= 2) . length) - $ groupBy ((==) `on` (fst.fst)) - $ sortOn (fst.fst) subst - --- | Create flattened substitutions from type equalities, i.e. the substitutions --- have been applied to each others right hand sides. -mkSubst' :: [Ct] -> [((TcTyVar,TcType),Ct)] -mkSubst' = foldr substSubst [] . mapMaybe mkSubst - where - substSubst :: ((TcTyVar,TcType),Ct) - -> [((TcTyVar,TcType),Ct)] - -> [((TcTyVar,TcType),Ct)] - substSubst ((tv,t),ct) s = ((tv,substType (map fst s) t),ct) - : map (first (second (substType [(tv,t)]))) s - --- | Apply substitution in the evidence of Cts -substCt :: [(TcTyVar, TcType)] -> Ct -> Ct -substCt subst = overEvidencePredType (substType subst) +{-# LANGUAGE RecordWildCards #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Internal+ ( -- * Create new constraints+ TcPlugin.newWanted+ , newGiven+ -- * Creating evidence+ , evByFiat+ -- * Lookup+ , lookupModule+ , lookupName+ -- * Trace state of the plugin+ , tracePlugin+ -- * Substitutions+ , flattenGivens+ , mkSubst+ , mkSubst'+ , substType+ , substCt+ )+where++import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Tc.Plugin (TcPluginM, lookupOrig, tcPluginTrace)+import qualified GHC.Tc.Plugin as TcPlugin+ (newWanted, getTopEnv, tcPluginIO, findImportedModule)+import GHC.Tc.Types (TcPlugin(..), TcPluginSolveResult(..))+import Control.Arrow (first, second)+import Data.Function (on)+import Data.List (groupBy, partition, sortOn)+import GHC.Tc.Utils.TcType (TcType)+import Data.Maybe (mapMaybe)++import GhcApi.Constraint (Ct(..))+import GhcApi.GhcPlugins++import Internal.Type (substType)+import Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType)+import Internal.Evidence (evByFiat)++-- | Find a module+lookupModule :: ModuleName -- ^ Name of the module+ -> FastString -- ^ Name of the package containing the module.+ -- NOTE: This value is ignored on ghc>=8.0.+ -> TcPluginM Module+lookupModule mod_nm _pkg = do+ hsc_env <- TcPlugin.getTopEnv+ let fc = hsc_FC hsc_env+ dflags = hsc_dflags hsc_env+ fopts = initFinderOpts dflags+ units = hsc_units hsc_env+ mhome_unit = hsc_home_unit_maybe hsc_env+ found_module <- TcPlugin.tcPluginIO $ findPluginModule fc fopts units+ mhome_unit mod_nm+ case found_module of+ Found _ h -> return h+ _ -> do+ let pkg_qual = maybe NoPkgQual (ThisPkg . homeUnitId) mhome_unit+ found_module' <- TcPlugin.findImportedModule mod_nm pkg_qual+ case found_module' of+ Found _ h -> return h+ _ -> panicDoc "Couldn't find module" (ppr mod_nm)++-- | Find a 'Name' in a 'Module' given an 'OccName'+lookupName :: Module -> OccName -> TcPluginM Name+lookupName = lookupOrig++-- | Print out extra information about the initialisation, stop, and every run+-- of the plugin when @-ddump-tc-trace@ is enabled.+tracePlugin :: String -> TcPlugin -> TcPlugin+tracePlugin s TcPlugin{..} = TcPlugin { tcPluginInit = traceInit+ , tcPluginSolve = traceSolve+ , tcPluginRewrite = tcPluginRewrite+ , tcPluginStop = traceStop+ }+ where+ traceInit = do+ tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit++ traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z++ traceSolve z ev given wanted = do+ tcPluginTrace ("tcPluginSolve start " ++ s)+ (text "given =" <+> ppr given+ $$ text "wanted =" <+> ppr wanted)+ r <- tcPluginSolve z ev given wanted+ case r of+ TcPluginOk solved new+ -> tcPluginTrace ("tcPluginSolve ok " ++ s)+ (text "solved =" <+> ppr solved+ $$ text "new =" <+> ppr new)+ TcPluginContradiction bad+ -> tcPluginTrace ("tcPluginSolve contradiction " ++ s)+ (text "bad =" <+> ppr bad)+ TcPluginSolveResult bad solved new+ -> tcPluginTrace ("tcPluginSolveResult " ++ s)+ (text "solved =" <+> ppr solved+ $$ text "bad =" <+> ppr bad+ $$ text "new =" <+> ppr new)+ return r++-- | Flattens evidence of constraints by substituting each others equalities.+--+-- __NB:__ Should only be used on /[G]iven/ constraints!+--+-- __NB:__ Doesn't flatten under binders+flattenGivens :: [Ct] -> [Ct]+flattenGivens givens =+ mapMaybe flatToCt flat ++ map (substCt subst') givens+ where+ subst = mkSubst' givens+ (flat,subst')+ = second (map fst . concat)+ $ partition ((>= 2) . length)+ $ groupBy ((==) `on` (fst.fst))+ $ sortOn (fst.fst) subst++-- | Create flattened substitutions from type equalities, i.e. the substitutions+-- have been applied to each others right hand sides.+mkSubst' :: [Ct] -> [((TcTyVar,TcType),Ct)]+mkSubst' = foldr substSubst [] . mapMaybe mkSubst+ where+ substSubst :: ((TcTyVar,TcType),Ct)+ -> [((TcTyVar,TcType),Ct)]+ -> [((TcTyVar,TcType),Ct)]+ substSubst ((tv,t),ct) s = ((tv,substType (map fst s) t),ct)+ : map (first (second (substType [(tv,t)]))) s++-- | Apply substitution in the evidence of Cts+substCt :: [(TcTyVar, TcType)] -> Ct -> Ct+substCt subst = overEvidencePredType (substType subst)
src-ghc-tree/GhcApi/Predicate.hs view
@@ -1,3 +1,3 @@-module GhcApi.Predicate (mkPrimEqPred) where - -import GHC.Core.Coercion (mkPrimEqPred) +module GhcApi.Predicate (mkPrimEqPred) where++import GHC.Core.Coercion (mkPrimEqPred)
src-ghc-tree/Internal.hs view
@@ -1,143 +1,143 @@-{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module Internal - ( -- * Create new constraints - newWanted - , newGiven - , newDerived - -- * Creating evidence - , evByFiat - -- * Lookup - , lookupModule - , lookupName - -- * Trace state of the plugin - , tracePlugin - -- * Substitutions - , flattenGivens - , mkSubst - , mkSubst' - , substType - , substCt - ) -where - -import GHC.Tc.Plugin (TcPluginM, lookupOrig, tcPluginTrace) -import qualified GHC.Tc.Plugin as TcPlugin - (newDerived, newWanted, getTopEnv, tcPluginIO, findImportedModule) -import GHC.Tc.Types (TcPlugin(..), TcPluginResult(..)) -import Control.Arrow (first, second) -import Data.Function (on) -import Data.List (groupBy, partition, sortOn) -import GHC.Tc.Utils.TcType (TcType) -import Data.Maybe (mapMaybe) - -import GhcApi.Constraint (Ct(..), CtEvidence(..), CtLoc) -import GhcApi.GhcPlugins - -import Internal.Type (substType) -import Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) -import Internal.Evidence (evByFiat) - -{-# ANN fr_mod "HLint: ignore Use camelCase" #-} - -pattern FoundModule :: Module -> FindResult -pattern FoundModule a <- Found _ a - -fr_mod :: a -> a -fr_mod = id - --- | Create a new [W]anted constraint. -newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence -newWanted = TcPlugin.newWanted - --- | Create a new [D]erived constraint. -newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence -newDerived = TcPlugin.newDerived - --- | Find a module -lookupModule :: ModuleName -- ^ Name of the module - -> FastString -- ^ Name of the package containing the module. - -- NOTE: This value is ignored on ghc>=8.0. - -> TcPluginM Module -lookupModule mod_nm _pkg = do - hsc_env <- TcPlugin.getTopEnv - found_module <- TcPlugin.tcPluginIO $ findPluginModule hsc_env mod_nm - case found_module of - FoundModule h -> return (fr_mod h) - _ -> do - found_module' <- TcPlugin.findImportedModule mod_nm $ Just $ fsLit "this" - case found_module' of - FoundModule h -> return (fr_mod h) - _ -> panicDoc "Couldn't find module" (ppr mod_nm) - --- | Find a 'Name' in a 'Module' given an 'OccName' -lookupName :: Module -> OccName -> TcPluginM Name -lookupName = lookupOrig - --- | Print out extra information about the initialisation, stop, and every run --- of the plugin when @-ddump-tc-trace@ is enabled. -tracePlugin :: String -> TcPlugin -> TcPlugin -tracePlugin s TcPlugin{..} = TcPlugin { tcPluginInit = traceInit - , tcPluginSolve = traceSolve - , tcPluginStop = traceStop - } - where - traceInit = do - -- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 - initializeStaticFlags - tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit - - traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z - - traceSolve z given derived wanted = do - tcPluginTrace ("tcPluginSolve start " ++ s) - (text "given =" <+> ppr given - $$ text "derived =" <+> ppr derived - $$ text "wanted =" <+> ppr wanted) - r <- tcPluginSolve z given derived wanted - case r of - TcPluginOk solved new -> tcPluginTrace ("tcPluginSolve ok " ++ s) - (text "solved =" <+> ppr solved - $$ text "new =" <+> ppr new) - TcPluginContradiction bad -> tcPluginTrace - ("tcPluginSolve contradiction " ++ s) - (text "bad =" <+> ppr bad) - return r - --- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 -initializeStaticFlags :: TcPluginM () -initializeStaticFlags = return () - --- | Flattens evidence of constraints by substituting each others equalities. --- --- __NB:__ Should only be used on /[G]iven/ constraints! --- --- __NB:__ Doesn't flatten under binders -flattenGivens :: [Ct] -> [Ct] -flattenGivens givens = - mapMaybe flatToCt flat ++ map (substCt subst') givens - where - subst = mkSubst' givens - (flat,subst') - = second (map fst . concat) - $ partition ((>= 2) . length) - $ groupBy ((==) `on` (fst.fst)) - $ sortOn (fst.fst) subst - --- | Create flattened substitutions from type equalities, i.e. the substitutions --- have been applied to each others right hand sides. -mkSubst' :: [Ct] -> [((TcTyVar,TcType),Ct)] -mkSubst' = foldr substSubst [] . mapMaybe mkSubst - where - substSubst :: ((TcTyVar,TcType),Ct) - -> [((TcTyVar,TcType),Ct)] - -> [((TcTyVar,TcType),Ct)] - substSubst ((tv,t),ct) s = ((tv,substType (map fst s) t),ct) - : map (first (second (substType [(tv,t)]))) s - --- | Apply substitution in the evidence of Cts -substCt :: [(TcTyVar, TcType)] -> Ct -> Ct -substCt subst = overEvidencePredType (substType subst) +{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PatternSynonyms #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Internal+ ( -- * Create new constraints+ newWanted+ , newGiven+ , newDerived+ -- * Creating evidence+ , evByFiat+ -- * Lookup+ , lookupModule+ , lookupName+ -- * Trace state of the plugin+ , tracePlugin+ -- * Substitutions+ , flattenGivens+ , mkSubst+ , mkSubst'+ , substType+ , substCt+ )+where++import GHC.Tc.Plugin (TcPluginM, lookupOrig, tcPluginTrace)+import qualified GHC.Tc.Plugin as TcPlugin+ (newDerived, newWanted, getTopEnv, tcPluginIO, findImportedModule)+import GHC.Tc.Types (TcPlugin(..), TcPluginResult(..))+import Control.Arrow (first, second)+import Data.Function (on)+import Data.List (groupBy, partition, sortOn)+import GHC.Tc.Utils.TcType (TcType)+import Data.Maybe (mapMaybe)++import GhcApi.Constraint (Ct(..), CtEvidence(..), CtLoc)+import GhcApi.GhcPlugins++import Internal.Type (substType)+import Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType)+import Internal.Evidence (evByFiat)++{-# ANN fr_mod "HLint: ignore Use camelCase" #-}++pattern FoundModule :: Module -> FindResult+pattern FoundModule a <- Found _ a++fr_mod :: a -> a+fr_mod = id++-- | Create a new [W]anted constraint.+newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence+newWanted = TcPlugin.newWanted++-- | Create a new [D]erived constraint.+newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence+newDerived = TcPlugin.newDerived++-- | Find a module+lookupModule :: ModuleName -- ^ Name of the module+ -> FastString -- ^ Name of the package containing the module.+ -- NOTE: This value is ignored on ghc>=8.0.+ -> TcPluginM Module+lookupModule mod_nm _pkg = do+ hsc_env <- TcPlugin.getTopEnv+ found_module <- TcPlugin.tcPluginIO $ findPluginModule hsc_env mod_nm+ case found_module of+ FoundModule h -> return (fr_mod h)+ _ -> do+ found_module' <- TcPlugin.findImportedModule mod_nm $ Just $ fsLit "this"+ case found_module' of+ FoundModule h -> return (fr_mod h)+ _ -> panicDoc "Couldn't find module" (ppr mod_nm)++-- | Find a 'Name' in a 'Module' given an 'OccName'+lookupName :: Module -> OccName -> TcPluginM Name+lookupName = lookupOrig++-- | Print out extra information about the initialisation, stop, and every run+-- of the plugin when @-ddump-tc-trace@ is enabled.+tracePlugin :: String -> TcPlugin -> TcPlugin+tracePlugin s TcPlugin{..} = TcPlugin { tcPluginInit = traceInit+ , tcPluginSolve = traceSolve+ , tcPluginStop = traceStop+ }+ where+ traceInit = do+ -- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301+ initializeStaticFlags+ tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit++ traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z++ traceSolve z given derived wanted = do+ tcPluginTrace ("tcPluginSolve start " ++ s)+ (text "given =" <+> ppr given+ $$ text "derived =" <+> ppr derived+ $$ text "wanted =" <+> ppr wanted)+ r <- tcPluginSolve z given derived wanted+ case r of+ TcPluginOk solved new -> tcPluginTrace ("tcPluginSolve ok " ++ s)+ (text "solved =" <+> ppr solved+ $$ text "new =" <+> ppr new)+ TcPluginContradiction bad -> tcPluginTrace+ ("tcPluginSolve contradiction " ++ s)+ (text "bad =" <+> ppr bad)+ return r++-- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301+initializeStaticFlags :: TcPluginM ()+initializeStaticFlags = return ()++-- | Flattens evidence of constraints by substituting each others equalities.+--+-- __NB:__ Should only be used on /[G]iven/ constraints!+--+-- __NB:__ Doesn't flatten under binders+flattenGivens :: [Ct] -> [Ct]+flattenGivens givens =+ mapMaybe flatToCt flat ++ map (substCt subst') givens+ where+ subst = mkSubst' givens+ (flat,subst')+ = second (map fst . concat)+ $ partition ((>= 2) . length)+ $ groupBy ((==) `on` (fst.fst))+ $ sortOn (fst.fst) subst++-- | Create flattened substitutions from type equalities, i.e. the substitutions+-- have been applied to each others right hand sides.+mkSubst' :: [Ct] -> [((TcTyVar,TcType),Ct)]+mkSubst' = foldr substSubst [] . mapMaybe mkSubst+ where+ substSubst :: ((TcTyVar,TcType),Ct)+ -> [((TcTyVar,TcType),Ct)]+ -> [((TcTyVar,TcType),Ct)]+ substSubst ((tv,t),ct) s = ((tv,substType (map fst s) t),ct)+ : map (first (second (substType [(tv,t)]))) s++-- | Apply substitution in the evidence of Cts+substCt :: [(TcTyVar, TcType)] -> Ct -> Ct+substCt subst = overEvidencePredType (substType subst)
src/GHC/TcPluginM/Extra.hs view
@@ -1,40 +1,40 @@-{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> --} -{-# LANGUAGE CPP #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module GHC.TcPluginM.Extra - ( -- * Create new constraints - newWanted - , newGiven -#if __GLASGOW_HASKELL__ < 904 - , newDerived -#endif -#if __GLASGOW_HASKELL__ < 711 - , newWantedWithProvenance -#endif - -- * Creating evidence - , evByFiat -#if __GLASGOW_HASKELL__ < 711 - -- * Report contractions - , failWithProvenace -#endif - -- * Lookup - , lookupModule - , lookupName - -- * Trace state of the plugin - , tracePlugin - -- * Substitutions - , flattenGivens - , mkSubst - , mkSubst' - , substType - , substCt - ) -where - -import Internal +{-|+Copyright : (C) 2015-2016, University of Twente+License : BSD2 (see the file LICENSE)+Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+-}+{-# LANGUAGE CPP #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module GHC.TcPluginM.Extra+ ( -- * Create new constraints+ newWanted+ , newGiven+#if __GLASGOW_HASKELL__ < 904+ , newDerived+#endif+#if __GLASGOW_HASKELL__ < 711+ , newWantedWithProvenance+#endif+ -- * Creating evidence+ , evByFiat+#if __GLASGOW_HASKELL__ < 711+ -- * Report contractions+ , failWithProvenace+#endif+ -- * Lookup+ , lookupModule+ , lookupName+ -- * Trace state of the plugin+ , tracePlugin+ -- * Substitutions+ , flattenGivens+ , mkSubst+ , mkSubst'+ , substType+ , substCt+ )+where++import Internal