ghc-tcplugins-extra 0.4.6 → 0.5

raw patch · 69 files changed

+2001/−1731 lines, 69 filesdep ~ghcsetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc

API changes (from Hackage documentation)

+ GHC.TcPluginM.Extra: evByFiatWithDependencies :: String -> [Coercion] -> Type -> Type -> EvTerm

Files

CHANGELOG.md +56/−52
LICENSE +27/−27
README.md +7/−7
Setup.hs +2/−2
defaults.dhall +44/−44
ghc-tcplugins-extra.cabal +18/−5
package.dhall +47/−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 +24/−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 +24/−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 +24/−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 +24/−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 +24/−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 +24/−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 +23/−13
src-ghc-9.0/Internal/Type.hs +30/−30
src-ghc-9.10/GhcApi/Constraint.hs +13/−13
src-ghc-9.10/GhcApi/GhcPlugins.hs +5/−5
src-ghc-9.10/Internal/Constraint.hs +64/−64
src-ghc-9.10/Internal/Evidence.hs +24/−14
src-ghc-9.10/Internal/Type.hs +30/−30
src-ghc-9.12/GhcApi/Constraint.hs +14/−0
src-ghc-9.12/GhcApi/GhcPlugins.hs +5/−0
src-ghc-9.12/Internal/Constraint.hs +64/−0
src-ghc-9.12/Internal/Evidence.hs +25/−0
src-ghc-9.12/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 +23/−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 +24/−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 +24/−14
src-ghc-9.8/Internal/Type.hs +30/−30
src-ghc-flat/GhcApi/Constraint.hs +12/−12
src-ghc-flat/GhcApi/Predicate.hs +3/−3
src-ghc-flat/Internal.hs +152/−151
src-ghc-tree-9.4/GhcApi/Predicate.hs +3/−3
src-ghc-tree-9.4/Internal.hs +134/−133
src-ghc-tree/GhcApi/Predicate.hs +3/−3
src-ghc-tree/Internal.hs +144/−143
src/GHC/TcPluginM/Extra.hs +41/−40

CHANGELOG.md view

@@ -1,52 +1,56 @@-## 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
+## 0.5 *March 4th 2024*+* Add `evByFiatWithDependencies`, see https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12037 for more details.+* Added support for GHC 9.12.1++## 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
-
-[![Build Status (cabal)](https://github.com/clash-lang/ghc-tcplugins-extra/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/clash-lang/ghc-tcplugins-extra-undef/actions/workflows/haskell-ci.yml)
-[![Build Status (stack)](https://github.com/clash-lang/ghc-tcplugins-extra/actions/workflows/stack.yml/badge.svg)](https://github.com/clash-lang/ghc-tcplugins-extra-undef/actions/workflows/stack.yml)
-[![Hackage](https://img.shields.io/hackage/v/ghc-tcplugins-extra.svg)](https://hackage.haskell.org/package/ghc-tcplugins-extra)
-[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/ghc-tcplugins-extra.svg?style=flat)](http://packdeps.haskellers.com/feed?needle=exact%3Aghc-tcplugins-extra)
+# ghc-tcplugins-extra+Utilities for writing GHC type-checker plugins++[![Build Status (cabal)](https://github.com/clash-lang/ghc-tcplugins-extra/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/clash-lang/ghc-tcplugins-extra-undef/actions/workflows/haskell-ci.yml)+[![Build Status (stack)](https://github.com/clash-lang/ghc-tcplugins-extra/actions/workflows/stack.yml/badge.svg)](https://github.com/clash-lang/ghc-tcplugins-extra-undef/actions/workflows/stack.yml)+[![Hackage](https://img.shields.io/hackage/v/ghc-tcplugins-extra.svg)](https://hackage.haskell.org/package/ghc-tcplugins-extra)+[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/ghc-tcplugins-extra.svg?style=flat)](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.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" ] }
-  ]
-}
+{ name = "ghc-tcplugins-extra"+, version = "0.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 == 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.6, GHC == 9.8.4, GHC == 9.10.1, GHC == 9.12.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.6+version:        0.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@@ -21,7 +21,7 @@ license-file:   LICENSE build-type:     Simple 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+    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.8, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1, GHC == 9.12.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.12+    , ghc >=7.10 && <9.13   default-language: Haskell2010   if impl(ghc >= 8.0.0)     ghc-options: -Wcompat -Wincomplete-uni-patterns -Widentities -Wredundant-constraints@@ -55,7 +55,7 @@     ghc-options: -fhide-source-paths   if flag(deverror)     ghc-options: -Werror-  if impl(ghc >= 9.10) && impl(ghc < 9.12)+  if impl(ghc >= 9.11) && impl(ghc < 9.13)     other-modules:         GhcApi.Constraint         GhcApi.Predicate@@ -65,9 +65,22 @@         Internal.Evidence     hs-source-dirs:         src-ghc-tree-9.4+        src-ghc-9.12+    build-depends:+        ghc >=9.11 && <9.13+  if impl(ghc >= 9.10) && impl(ghc < 9.11)+    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+        ghc ==9.10.*   if impl(ghc >= 9.8) && impl(ghc < 9.10)     other-modules:         GhcApi.Constraint

package.dhall view

@@ -1,46 +1,47 @@-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
-                        ]
-                      }
-                    }
+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.13" ]+                      , exposed-modules = "GHC.TcPluginM.Extra"+                      , other-modules = "Internal"+                      , when =+                        [ version "9.11" "9.13" [ "tree-9.4", "9.12" ] ghc mods+                        , version "9.10" "9.11" [ "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,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps 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,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps 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,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps 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,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps 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,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps 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,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps 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,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps 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

@@ -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.10/GhcApi/GhcPlugins.hs view

@@ -1,5 +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(..))
+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

@@ -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.10/Internal/Evidence.hs view

@@ -1,14 +1,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps t1 t2 =+  EvExpr $ Coercion $ mkUnivCo (PluginProv name) Nominal t1 t2

src-ghc-9.10/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.12/GhcApi/Constraint.hs view

@@ -0,0 +1,14 @@+module GhcApi.Constraint+  ( Ct(..)+  , CtEvidence(..)+  , CtLoc+  , CanEqLHS(..)+  , ctLoc+  , ctEvId+  , mkNonCanonical+  )+where++import GHC.Tc.Types.Constraint+  (Ct (..), CtEvidence (..), CanEqLHS (..), ctLoc, ctEvId, mkNonCanonical)+import GHC.Tc.Types.CtLoc (CtLoc)

+ src-ghc-9.12/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.12/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.12/Internal/Evidence.hs view

@@ -0,0 +1,25 @@+module Internal.Evidence (evByFiat, evByFiatWithDependencies) 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+{-# DEPRECATED evByFiat "'evByFiat' creates proofs that can lead to unsoundness, use 'evByFiatWithDependencies' instead.\nSee also https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12037" #-}++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name deps t1 t2 =+  EvExpr $ Coercion $ mkUnivCo (PluginProv name) deps Nominal t1 t2

+ src-ghc-9.12/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,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps 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,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps 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,24 @@-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, evByFiatWithDependencies) 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++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiatWithDependencies ::+  String -- ^ Name the coercion should have+  -> [Coercion] -- ^ The set of all the in-scope coercion that the proof makes use of.+  -> Type -- ^ The LHS of the equivalence relation (~)+  -> Type -- ^ The RHS of the equivalence relation (~)+  -> EvTerm+evByFiatWithDependencies name _deps 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-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,152 @@-{-# 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+  , evByFiatWithDependencies+  , 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, evByFiatWithDependencies)++{-# 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,134 @@-{-# 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+  , evByFiatWithDependencies+  , 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 (evByFiatWithDependencies, 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,144 @@-{-# 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+  , evByFiatWithDependencies+  , 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, evByFiatWithDependencies)++{-# 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,41 @@-{-|
-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+  , evByFiatWithDependencies+  , 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