ghc-tcplugins-extra 0.4.5 → 0.4.6
raw patch · 65 files changed
+1742/−2013 lines, 65 filesdep ~ghcsetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc
API changes (from Hackage documentation)
- GHC.TcPluginM.Extra: newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence
- GHC.TcPluginM.Extra: newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence
+ GHC.TcPluginM.Extra: newGiven :: EvBindsVar -> CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence
Files
- CHANGELOG.md +52/−48
- LICENSE +27/−27
- README.md +7/−7
- Setup.hs +2/−2
- defaults.dhall +44/−44
- ghc-tcplugins-extra.cabal +16/−8
- package.dhall +46/−46
- 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.10/GhcApi/Constraint.hs +13/−0
- src-ghc-9.10/GhcApi/GhcPlugins.hs +5/−0
- src-ghc-9.10/Internal/Constraint.hs +64/−0
- src-ghc-9.10/Internal/Evidence.hs +14/−0
- src-ghc-9.10/Internal/Type.hs +30/−0
- 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-9.8/GhcApi/Constraint.hs +13/−13
- src-ghc-9.8/GhcApi/GhcPlugins.hs +5/−5
- src-ghc-9.8/Internal/Constraint.hs +64/−64
- src-ghc-9.8/Internal/Evidence.hs +14/−14
- src-ghc-9.8/Internal/Type.hs +30/−30
- src-ghc-cpp/Internal.hs +0/−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,48 +1,52 @@-## 0.4.5 *October 10th 2023*-* Support for GHC-9.8.1--## 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+## 0.4.6 *May 22nd 2024* +* Added support for GHC-9.10.1 +* Removed support for GHC 7.10 + +## 0.4.5 *October 10th 2023* +* Support for GHC-9.8.1 + +## 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.5"-, 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.8, GHC == 9.4.7, GHC == 9.6.3, GHC == 9.8.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.6" +, 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 == 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.8, GHC == 9.4.7, GHC == 9.6.5, GHC == 9.8.2, GHC == 9.10.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
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: ghc-tcplugins-extra-version: 0.4.5+version: 0.4.6 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@@ -21,7 +21,7 @@ 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.8, GHC == 9.4.7, GHC == 9.6.3, GHC == 9.8.1+ 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.8, GHC == 9.4.7, GHC == 9.6.5, GHC == 9.8.2, GHC == 9.10.1 extra-source-files: README.md CHANGELOG.md@@ -47,7 +47,7 @@ ghc-options: -Wall build-depends: base >=4.8 && <5- , ghc >=7.10 && <9.10+ , ghc >=7.10 && <9.12 default-language: Haskell2010 if impl(ghc >= 8.0.0) ghc-options: -Wcompat -Wincomplete-uni-patterns -Widentities -Wredundant-constraints@@ -55,6 +55,19 @@ ghc-options: -fhide-source-paths if flag(deverror) ghc-options: -Werror+ if impl(ghc >= 9.10) && impl(ghc < 9.12)+ 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.10+ build-depends:+ ghc >=9.10 && <9.12 if impl(ghc >= 9.8) && impl(ghc < 9.10) other-modules: GhcApi.Constraint@@ -205,8 +218,3 @@ 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,46 +1,46 @@-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.10" ]- , exposed-modules = "GHC.TcPluginM.Extra"- , other-modules = "Internal"- , when =- [ version "9.8" "9.10" [ "tree-9.4", "9.8" ] ghc mods- , 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)- ]- }- }+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.12" ] + , exposed-modules = "GHC.TcPluginM.Extra" + , other-modules = "Internal" + , when = + [ version "9.10" "9.12" [ "tree-9.4", "9.10" ] ghc mods + , version "9.8" "9.10" [ "tree-9.4", "9.8" ] ghc mods + , 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 + ] + } + }
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.10/GhcApi/Constraint.hs view
@@ -0,0 +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)
+ src-ghc-9.10/GhcApi/GhcPlugins.hs view
@@ -0,0 +1,5 @@+module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where + +import GHC.Plugins hiding (TcPlugin) +import GHC.Unit.Finder (findPluginModule) +import GHC.Tc.Plugin (FindResult(..))
+ src-ghc-9.10/Internal/Constraint.hs view
@@ -0,0 +1,64 @@+{-# 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 (DictCt(..), IrredCt(..), EqCt(..), 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 (EqCt {..})) + | TyVarLHS tyvar <- eq_lhs + = Just ((tyvar,eq_rhs),ct) +mkSubst _ = Nothing + +-- | Modify the predicate type of the evidence term of a constraint +overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct +overEvidencePredType f (CDictCan di) = + let + ev :: CtEvidence + ev = di_ev di + in CDictCan ( di { di_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CIrredCan ir) = + let + ev :: CtEvidence + ev = ir_ev ir + in CIrredCan ( ir { ir_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CEqCan eq) = + let + ev :: CtEvidence + ev = eq_ev eq + in CEqCan ( eq { eq_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CNonCanonical ct) = + let + ev :: CtEvidence + ev = ct + in CNonCanonical ( ev { ctev_pred = f (ctev_pred ev) } ) +overEvidencePredType f (CQuantCan qci) = + let + ev :: CtEvidence + ev = qci_ev qci + in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } )
+ src-ghc-9.10/Internal/Evidence.hs view
@@ -0,0 +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
+ src-ghc-9.10/Internal/Type.hs view
@@ -0,0 +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
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-9.8/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.8/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.8/Internal/Constraint.hs view
@@ -1,64 +1,64 @@-{-# 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 (DictCt(..), IrredCt(..), EqCt(..), 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 (EqCt {..}))- | TyVarLHS tyvar <- eq_lhs- = Just ((tyvar,eq_rhs),ct)-mkSubst _ = Nothing---- | Modify the predicate type of the evidence term of a constraint-overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct-overEvidencePredType f (CDictCan di) =- let- ev :: CtEvidence- ev = di_ev di- in CDictCan ( di { di_ev = ev { ctev_pred = f (ctev_pred ev) } } )-overEvidencePredType f (CIrredCan ir) =- let- ev :: CtEvidence- ev = ir_ev ir- in CIrredCan ( ir { ir_ev = ev { ctev_pred = f (ctev_pred ev) } } )-overEvidencePredType f (CEqCan eq) =- let- ev :: CtEvidence- ev = eq_ev eq- in CEqCan ( eq { eq_ev = ev { ctev_pred = f (ctev_pred ev) } } )-overEvidencePredType f (CNonCanonical ct) =- let- ev :: CtEvidence- ev = ct- in CNonCanonical ( ev { ctev_pred = f (ctev_pred ev) } )-overEvidencePredType f (CQuantCan qci) =- let- ev :: CtEvidence- ev = qci_ev qci- in CQuantCan ( qci { qci_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 (DictCt(..), IrredCt(..), EqCt(..), 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 (EqCt {..})) + | TyVarLHS tyvar <- eq_lhs + = Just ((tyvar,eq_rhs),ct) +mkSubst _ = Nothing + +-- | Modify the predicate type of the evidence term of a constraint +overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct +overEvidencePredType f (CDictCan di) = + let + ev :: CtEvidence + ev = di_ev di + in CDictCan ( di { di_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CIrredCan ir) = + let + ev :: CtEvidence + ev = ir_ev ir + in CIrredCan ( ir { ir_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CEqCan eq) = + let + ev :: CtEvidence + ev = eq_ev eq + in CEqCan ( eq { eq_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CNonCanonical ct) = + let + ev :: CtEvidence + ev = ct + in CNonCanonical ( ev { ctev_pred = f (ctev_pred ev) } ) +overEvidencePredType f (CQuantCan qci) = + let + ev :: CtEvidence + ev = qci_ev qci + in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } )
src-ghc-9.8/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.8/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
@@ -1,409 +0,0 @@-{-|-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