ghc-tcplugins-extra-0.4.6/0000755000000000000000000000000007346545000013602 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/CHANGELOG.md0000644000000000000000000000234207346545000015414 0ustar0000000000000000## 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 ghc-tcplugins-extra-0.4.6/LICENSE0000644000000000000000000000254207346545000014612 0ustar0000000000000000Copyright (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. ghc-tcplugins-extra-0.4.6/README.md0000644000000000000000000000142307346545000015061 0ustar0000000000000000# 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-0.4.6/Setup.hs0000644000000000000000000000006007346545000015232 0ustar0000000000000000import Distribution.Simple main = defaultMain ghc-tcplugins-extra-0.4.6/defaults.dhall0000644000000000000000000000264207346545000016423 0ustar0000000000000000{ name = "ghc-tcplugins-extra" , version = "0.4.6" , synopsis = "Utilities for writing GHC type-checker plugins" , description = '' Utilities for writing GHC type-checker plugins, such as creating constraints, with a stable API covering multiple GHC releases.'' , category = "Type System" , author = "Christiaan Baaij" , maintainer = "christiaan.baaij@gmail.com" , copyright = '' Copyright © 2015-2016, University of Twente, 2017-2018, QBayLogic'' , github = "clash-lang/ghc-tcplugins-extra" , license = "BSD2" , license-file = "LICENSE" , tested-with = "GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.5, GHC == 9.8.2, GHC == 9.10.1" , extra-source-files = [ "README.md", "CHANGELOG.md", "defaults.dhall", "package.dhall" ] , ghc-options = [ "-Wall" ] , flags.deverror = { description = "Enables `-Werror` for development mode and TravisCI" , default = False , manual = True } , when = [ { condition = "impl(ghc >= 8.0.0)" , ghc-options = [ "-Wcompat" , "-Wincomplete-uni-patterns" , "-Widentities" , "-Wredundant-constraints" ] } , { condition = "impl(ghc >= 8.4.0)" , ghc-options = [ "-fhide-source-paths" ] } , { condition = "flag(deverror)", ghc-options = [ "-Werror" ] } ] } ghc-tcplugins-extra-0.4.6/ghc-tcplugins-extra.cabal0000644000000000000000000001333607346545000020464 0ustar0000000000000000cabal-version: 2.0 -- This file has been generated from package.dhall by hpack version 0.35.5. -- -- see: https://github.com/sol/hpack 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 homepage: https://github.com/clash-lang/ghc-tcplugins-extra#readme bug-reports: https://github.com/clash-lang/ghc-tcplugins-extra/issues author: Christiaan Baaij maintainer: christiaan.baaij@gmail.com copyright: Copyright © 2015-2016, University of Twente, 2017-2018, QBayLogic license: BSD2 license-file: LICENSE build-type: Simple tested-with: GHC == 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 source-repository head type: git location: https://github.com/clash-lang/ghc-tcplugins-extra flag deverror description: Enables `-Werror` for development mode and TravisCI manual: True default: False library exposed-modules: GHC.TcPluginM.Extra other-modules: Internal hs-source-dirs: src ghc-options: -Wall build-depends: base >=4.8 && <5 , ghc >=7.10 && <9.12 default-language: Haskell2010 if impl(ghc >= 8.0.0) ghc-options: -Wcompat -Wincomplete-uni-patterns -Widentities -Wredundant-constraints if impl(ghc >= 8.4.0) ghc-options: -fhide-source-paths if flag(deverror) ghc-options: -Werror if impl(ghc >= 9.10) && impl(ghc < 9.12) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-tree-9.4 src-ghc-9.10 build-depends: ghc >=9.10 && <9.12 if impl(ghc >= 9.8) && impl(ghc < 9.10) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-tree-9.4 src-ghc-9.8 build-depends: ghc >=9.8 && <9.10 if impl(ghc >= 9.4) && impl(ghc < 9.8) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-tree-9.4 src-ghc-9.4 build-depends: ghc >=9.4 && <9.8 if impl(ghc >= 9.2) && impl(ghc < 9.4) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-tree src-ghc-9.2 build-depends: ghc >=9.2 && <9.4 if impl(ghc >= 9.0) && impl(ghc < 9.2) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-tree src-ghc-9.0 build-depends: ghc >=9.0 && <9.2 if impl(ghc >= 8.10) && impl(ghc < 9.0) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-flat src-ghc-8.10 build-depends: ghc >=8.10 && <9.0 if impl(ghc >= 8.8) && impl(ghc < 8.10) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-flat src-ghc-8.8 build-depends: ghc >=8.8 && <8.10 mixins: ghc hiding () , ghc (TcRnTypes as Constraint) , ghc (Type as Predicate) if impl(ghc >= 8.6) && impl(ghc < 8.8) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-flat src-ghc-8.6 build-depends: ghc >=8.6 && <8.8 mixins: ghc hiding () , ghc (TcRnTypes as Constraint) , ghc (Type as Predicate) if impl(ghc >= 8.4) && impl(ghc < 8.6) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-flat src-ghc-8.4 build-depends: ghc >=8.4 && <8.6 mixins: ghc hiding () , ghc (TcRnTypes as Constraint) , ghc (Type as Predicate) if impl(ghc >= 8.2) && impl(ghc < 8.4) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-flat src-ghc-8.2 build-depends: ghc >=8.2 && <8.4 mixins: ghc hiding () , ghc (TcRnTypes as Constraint) , ghc (Type as Predicate) if impl(ghc >= 8.0) && impl(ghc < 8.2) other-modules: GhcApi.Constraint GhcApi.Predicate GhcApi.GhcPlugins Internal.Type Internal.Constraint Internal.Evidence hs-source-dirs: src-ghc-flat src-ghc-8.0 build-depends: ghc >=8.0 && <8.2 mixins: ghc hiding () , ghc (TcRnTypes as Constraint) , ghc (Type as Predicate) ghc-tcplugins-extra-0.4.6/package.dhall0000644000000000000000000000361407346545000016207 0ustar0000000000000000let 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 ] } } ghc-tcplugins-extra-0.4.6/src-ghc-8.0/GhcApi/0000755000000000000000000000000007346545000016566 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.0/GhcApi/GhcPlugins.hs0000644000000000000000000000025107346545000021163 0ustar0000000000000000module GhcApi.GhcPlugins (module GhcPlugins, TcTyVar, EvTerm(..)) where import GhcPlugins hiding (mkSubst) import TcType (TcTyVar) import TcEvidence (EvTerm(..)) ghc-tcplugins-extra-0.4.6/src-ghc-8.0/Internal/0000755000000000000000000000000007346545000017207 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.0/Internal/Constraint.hs0000644000000000000000000000136507346545000021674 0ustar0000000000000000module 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) } }ghc-tcplugins-extra-0.4.6/src-ghc-8.0/Internal/Evidence.hs0000644000000000000000000000075007346545000021267 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.0/Internal/Type.hs0000644000000000000000000000143207346545000020464 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.10/GhcApi/0000755000000000000000000000000007346545000016647 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.10/GhcApi/GhcPlugins.hs0000644000000000000000000000014407346545000021245 0ustar0000000000000000module GhcApi.GhcPlugins (module GhcPlugins) where import GhcPlugins hiding (TcPlugin, mkSubst) ghc-tcplugins-extra-0.4.6/src-ghc-8.10/Internal/0000755000000000000000000000000007346545000017270 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.10/Internal/Constraint.hs0000644000000000000000000000255607346545000021760 0ustar0000000000000000module 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) } }ghc-tcplugins-extra-0.4.6/src-ghc-8.10/Internal/Evidence.hs0000644000000000000000000000075707346545000021357 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.10/Internal/Type.hs0000644000000000000000000000163107346545000020546 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.2/GhcApi/0000755000000000000000000000000007346545000016570 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.2/GhcApi/GhcPlugins.hs0000644000000000000000000000025107346545000021165 0ustar0000000000000000module GhcApi.GhcPlugins (module GhcPlugins, TcTyVar, EvTerm(..)) where import GhcPlugins hiding (mkSubst) import TcType (TcTyVar) import TcEvidence (EvTerm(..)) ghc-tcplugins-extra-0.4.6/src-ghc-8.2/Internal/0000755000000000000000000000000007346545000017211 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.2/Internal/Constraint.hs0000644000000000000000000000135307346545000021673 0ustar0000000000000000module 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) } }ghc-tcplugins-extra-0.4.6/src-ghc-8.2/Internal/Evidence.hs0000644000000000000000000000075007346545000021271 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.2/Internal/Type.hs0000644000000000000000000000155607346545000020475 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.4/GhcApi/0000755000000000000000000000000007346545000016572 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.4/GhcApi/GhcPlugins.hs0000644000000000000000000000025107346545000021167 0ustar0000000000000000module GhcApi.GhcPlugins (module GhcPlugins, TcTyVar, EvTerm(..)) where import GhcPlugins hiding (mkSubst) import TcType (TcTyVar) import TcEvidence (EvTerm(..)) ghc-tcplugins-extra-0.4.6/src-ghc-8.4/Internal/0000755000000000000000000000000007346545000017213 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.4/Internal/Constraint.hs0000644000000000000000000000134307346545000021674 0ustar0000000000000000module 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) } }ghc-tcplugins-extra-0.4.6/src-ghc-8.4/Internal/Evidence.hs0000644000000000000000000000075007346545000021273 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.4/Internal/Type.hs0000644000000000000000000000155607346545000020477 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.6/GhcApi/0000755000000000000000000000000007346545000016574 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.6/GhcApi/GhcPlugins.hs0000644000000000000000000000013207346545000021167 0ustar0000000000000000module GhcApi.GhcPlugins (module GhcPlugins) where import GhcPlugins hiding (mkSubst) ghc-tcplugins-extra-0.4.6/src-ghc-8.6/Internal/0000755000000000000000000000000007346545000017215 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.6/Internal/Constraint.hs0000644000000000000000000000262507346545000021702 0ustar0000000000000000module 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) } }ghc-tcplugins-extra-0.4.6/src-ghc-8.6/Internal/Evidence.hs0000644000000000000000000000075707346545000021304 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.6/Internal/Type.hs0000644000000000000000000000161107346545000020471 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.8/GhcApi/0000755000000000000000000000000007346545000016576 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.8/GhcApi/GhcPlugins.hs0000644000000000000000000000014407346545000021174 0ustar0000000000000000module GhcApi.GhcPlugins (module GhcPlugins) where import GhcPlugins hiding (TcPlugin, mkSubst) ghc-tcplugins-extra-0.4.6/src-ghc-8.8/Internal/0000755000000000000000000000000007346545000017217 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-8.8/Internal/Constraint.hs0000644000000000000000000000254407346545000021704 0ustar0000000000000000module 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) } }ghc-tcplugins-extra-0.4.6/src-ghc-8.8/Internal/Evidence.hs0000644000000000000000000000075707346545000021306 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-8.8/Internal/Type.hs0000644000000000000000000000162307346545000020476 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-9.0/GhcApi/0000755000000000000000000000000007346545000016567 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-9.0/GhcApi/Constraint.hs0000644000000000000000000000034207346545000021246 0ustar0000000000000000module GhcApi.Constraint ( Ct(..) , CtEvidence(..) , CtLoc , ctLoc , ctEvId , mkNonCanonical ) where import GHC.Tc.Types.Constraint (Ct (..), CtEvidence (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) ghc-tcplugins-extra-0.4.6/src-ghc-9.0/GhcApi/GhcPlugins.hs0000644000000000000000000000032207346545000021163 0ustar0000000000000000module GhcApi.GhcPlugins (module GHC.Plugins, findPluginModule, panicDoc) where import GHC.Plugins hiding (TcPlugin, mkSubst) import GHC.Driver.Finder (findPluginModule) import GHC.Utils.Panic (panicDoc) ghc-tcplugins-extra-0.4.6/src-ghc-9.0/Internal/0000755000000000000000000000000007346545000017210 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-9.0/Internal/Constraint.hs0000644000000000000000000000334507346545000021675 0ustar0000000000000000{-# 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) } } ghc-tcplugins-extra-0.4.6/src-ghc-9.0/Internal/Evidence.hs0000644000000000000000000000100207346545000021257 0ustar0000000000000000module 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 t2ghc-tcplugins-extra-0.4.6/src-ghc-9.0/Internal/Type.hs0000644000000000000000000000165007346545000020467 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-9.10/GhcApi/0000755000000000000000000000000007346545000016650 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-9.10/GhcApi/Constraint.hs0000644000000000000000000000040307346545000021325 0ustar0000000000000000module GhcApi.Constraint ( Ct(..) , CtEvidence(..) , CtLoc , CanEqLHS(..) , ctLoc , ctEvId , mkNonCanonical ) where import GHC.Tc.Types.Constraint (Ct (..), CtEvidence (..), CanEqLHS (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) ghc-tcplugins-extra-0.4.6/src-ghc-9.10/GhcApi/GhcPlugins.hs0000644000000000000000000000032107346545000021243 0ustar0000000000000000module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where import GHC.Plugins hiding (TcPlugin) import GHC.Unit.Finder (findPluginModule) import GHC.Tc.Plugin (FindResult(..)) ghc-tcplugins-extra-0.4.6/src-ghc-9.10/Internal/0000755000000000000000000000000007346545000017271 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-9.10/Internal/Constraint.hs0000644000000000000000000000433207346545000021753 0ustar0000000000000000{-# 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) } } ) ghc-tcplugins-extra-0.4.6/src-ghc-9.10/Internal/Evidence.hs0000644000000000000000000000100407346545000021342 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-9.10/Internal/Type.hs0000644000000000000000000000165007346545000020550 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-9.2/GhcApi/0000755000000000000000000000000007346545000016571 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-9.2/GhcApi/Constraint.hs0000644000000000000000000000040307346545000021246 0ustar0000000000000000module GhcApi.Constraint ( Ct(..) , CtEvidence(..) , CtLoc , CanEqLHS(..) , ctLoc , ctEvId , mkNonCanonical ) where import GHC.Tc.Types.Constraint (Ct (..), CtEvidence (..), CanEqLHS (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) ghc-tcplugins-extra-0.4.6/src-ghc-9.2/GhcApi/GhcPlugins.hs0000644000000000000000000000033007346545000021164 0ustar0000000000000000module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where import GHC.Plugins hiding (TcPlugin, mkSubst) import GHC.Unit.Finder (findPluginModule) import GHC.Tc.Plugin (FindResult(..))ghc-tcplugins-extra-0.4.6/src-ghc-9.2/Internal/0000755000000000000000000000000007346545000017212 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-9.2/Internal/Constraint.hs0000644000000000000000000000323207346545000021672 0ustar0000000000000000{-# 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) } }ghc-tcplugins-extra-0.4.6/src-ghc-9.2/Internal/Evidence.hs0000644000000000000000000000100207346545000021261 0ustar0000000000000000module 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 t2ghc-tcplugins-extra-0.4.6/src-ghc-9.2/Internal/Type.hs0000644000000000000000000000165007346545000020471 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-9.4/GhcApi/0000755000000000000000000000000007346545000016573 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-9.4/GhcApi/Constraint.hs0000644000000000000000000000040307346545000021250 0ustar0000000000000000module GhcApi.Constraint ( Ct(..) , CtEvidence(..) , CtLoc , CanEqLHS(..) , ctLoc , ctEvId , mkNonCanonical ) where import GHC.Tc.Types.Constraint (Ct (..), CtEvidence (..), CanEqLHS (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) ghc-tcplugins-extra-0.4.6/src-ghc-9.4/GhcApi/GhcPlugins.hs0000644000000000000000000000033207346545000021170 0ustar0000000000000000module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where import GHC.Plugins hiding (TcPlugin, mkSubst) import GHC.Unit.Finder (findPluginModule) import GHC.Tc.Plugin (FindResult(..)) ghc-tcplugins-extra-0.4.6/src-ghc-9.4/Internal/0000755000000000000000000000000007346545000017214 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-9.4/Internal/Constraint.hs0000644000000000000000000000331307346545000021674 0ustar0000000000000000{-# 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) } } ghc-tcplugins-extra-0.4.6/src-ghc-9.4/Internal/Evidence.hs0000644000000000000000000000100407346545000021265 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-9.4/Internal/Type.hs0000644000000000000000000000165007346545000020473 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-9.8/GhcApi/0000755000000000000000000000000007346545000016577 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-9.8/GhcApi/Constraint.hs0000644000000000000000000000040307346545000021254 0ustar0000000000000000module GhcApi.Constraint ( Ct(..) , CtEvidence(..) , CtLoc , CanEqLHS(..) , ctLoc , ctEvId , mkNonCanonical ) where import GHC.Tc.Types.Constraint (Ct (..), CtEvidence (..), CanEqLHS (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) ghc-tcplugins-extra-0.4.6/src-ghc-9.8/GhcApi/GhcPlugins.hs0000644000000000000000000000033207346545000021174 0ustar0000000000000000module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where import GHC.Plugins hiding (TcPlugin, mkSubst) import GHC.Unit.Finder (findPluginModule) import GHC.Tc.Plugin (FindResult(..)) ghc-tcplugins-extra-0.4.6/src-ghc-9.8/Internal/0000755000000000000000000000000007346545000017220 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-9.8/Internal/Constraint.hs0000644000000000000000000000433207346545000021702 0ustar0000000000000000{-# 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) } } ) ghc-tcplugins-extra-0.4.6/src-ghc-9.8/Internal/Evidence.hs0000644000000000000000000000100407346545000021271 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-9.8/Internal/Type.hs0000644000000000000000000000165007346545000020477 0ustar0000000000000000module 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 ghc-tcplugins-extra-0.4.6/src-ghc-flat/GhcApi/0000755000000000000000000000000007346545000017207 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-flat/GhcApi/Constraint.hs0000644000000000000000000000032507346545000021667 0ustar0000000000000000module GhcApi.Constraint ( Ct(..) , CtEvidence(..) , CtLoc , ctLoc , ctEvId , mkNonCanonical ) where import Constraint (Ct (..), CtEvidence (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) ghc-tcplugins-extra-0.4.6/src-ghc-flat/GhcApi/Predicate.hs0000644000000000000000000000012107346545000021435 0ustar0000000000000000module GhcApi.Predicate (mkPrimEqPred) where import Predicate (mkPrimEqPred) ghc-tcplugins-extra-0.4.6/src-ghc-flat/0000755000000000000000000000000007346545000016054 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-flat/Internal.hs0000644000000000000000000001240107346545000020162 0ustar0000000000000000{-# 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) ghc-tcplugins-extra-0.4.6/src-ghc-tree-9.4/GhcApi/0000755000000000000000000000000007346545000017530 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-tree-9.4/GhcApi/Predicate.hs0000644000000000000000000000013107346545000021757 0ustar0000000000000000module GhcApi.Predicate (mkPrimEqPred) where import GHC.Core.Coercion (mkPrimEqPred) ghc-tcplugins-extra-0.4.6/src-ghc-tree-9.4/0000755000000000000000000000000007346545000016375 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-tree-9.4/Internal.hs0000644000000000000000000001152607346545000020512 0ustar0000000000000000{-# 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) ghc-tcplugins-extra-0.4.6/src-ghc-tree/GhcApi/0000755000000000000000000000000007346545000017220 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-tree/GhcApi/Predicate.hs0000644000000000000000000000013107346545000021447 0ustar0000000000000000module GhcApi.Predicate (mkPrimEqPred) where import GHC.Core.Coercion (mkPrimEqPred) ghc-tcplugins-extra-0.4.6/src-ghc-tree/0000755000000000000000000000000007346545000016065 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src-ghc-tree/Internal.hs0000644000000000000000000001202107346545000020171 0ustar0000000000000000{-# 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) ghc-tcplugins-extra-0.4.6/src/GHC/TcPluginM/0000755000000000000000000000000007346545000016634 5ustar0000000000000000ghc-tcplugins-extra-0.4.6/src/GHC/TcPluginM/Extra.hs0000644000000000000000000000145307346545000020256 0ustar0000000000000000{-| Copyright : (C) 2015-2016, University of Twente License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} {-# 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