ghc-tcplugins-extra (empty) → 0.1
raw patch · 6 files changed
+275/−0 lines, 6 filesdep +basedep +ghcsetup-changed
Dependencies added: base, ghc
Files
- CHANGELOG.md +2/−0
- LICENSE +26/−0
- README.md +6/−0
- Setup.hs +2/−0
- ghc-tcplugins-extra.cabal +37/−0
- src/GHC/TcPluginM/Extra.hs +202/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+## 0.1+* Initial release
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2015, Christiaan Baaij+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
@@ -0,0 +1,6 @@+# ghc-tcplugins-extra+Utilities for writing GHC type-checker plugins++[](http://travis-ci.org/clash-lang/ghc-tcplugins-extra)+[](https://hackage.haskell.org/package/ghc-tcplugins-extra)+[](http://packdeps.haskellers.com/feed?needle=exact%3Aghc-tcplugins-extra)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghc-tcplugins-extra.cabal view
@@ -0,0 +1,37 @@+name: ghc-tcplugins-extra+version: 0.1+synopsis: Utilities for writing GHC type-checker plugins+-- description:+homepage: http://www.clash-lang.org/+bug-reports: http://github.com/clash-lang/ghc-tcplugins-extra/issues+license: BSD2+license-file: LICENSE+author: Christiaan Baaij+maintainer: christiaan.baaij@gmail.com+copyright: Copyright © 2015 University of Twente+category: Type System+build-type: Simple+extra-source-files: README.md+ CHANGELOG.md+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/clash-lang/ghc-tcplugins-extra.git++flag deverror+ description:+ Enables `-Werror` for development mode and TravisCI+ default: False+ manual: True++library+ exposed-modules: GHC.TcPluginM.Extra+ build-depends: base >=4.8 && <4.9,+ ghc >=7.10 && <7.12+ hs-source-dirs: src+ default-language: Haskell2010+ if flag(deverror)+ ghc-options: -Wall -Werror+ else+ ghc-options: -Wall
+ src/GHC/TcPluginM/Extra.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++{-# OPTIONS_HADDOCK show-extensions #-}++{-|+Copyright : (C) 2015, University of Twente+License : BSD2 (see the file LICENSE)+Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+-}+module GHC.TcPluginM.Extra+ ( -- * Create new constraints+ newWanted+ , newGiven+ , newDerived+ , newWantedWithProvenance+ -- * Creating evidence+ , evByFiat+ -- * Report contractions+ , failWithProvenace+ -- * Lookup+ , lookupModule+ , lookupName+ -- * Trace state of the plugin+ , tracePlugin+ )+where++-- External+import Data.Maybe (mapMaybe)++-- GHC API+import BasicTypes (TopLevelFlag (..))+import Coercion (Role (..), mkUnivCo)+import FastString (FastString, fsLit)+import Module (Module, ModuleName)+import Name (Name)+import OccName (OccName)+import Outputable (($$), (<+>), empty, ppr, text)+import Panic (panicDoc)+import TcEvidence (EvTerm (..), TcCoercion (..))+import TcMType (newEvVar)+import TcPluginM (FindResult (..), TcPluginM, findImportedModule, lookupOrig,+ tcPluginIO, tcPluginTrace, unsafeTcPluginTcM)+#if __GLASGOW_HASKELL__ >= 711+import qualified TcPluginM+import HscTypes (FoundHs (..))+#endif+import TcRnTypes (Ct, CtEvidence (..), CtLoc, TcIdBinder (..), TcLclEnv (..),+ TcPlugin (..), TcPluginResult (..), ctEvId, ctEvLoc, ctLoc,+ ctLocEnv, mkNonCanonical, setCtLocEnv)+import Type (EqRel (..), PredTree (..), PredType, Type, classifyPredType)+import Var (varType)++-- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301+import Data.IORef (readIORef)+import Control.Monad (unless)+import StaticFlags (initStaticOpts, v_opt_C_ready)++-- | Create a new [W]anted constraint that remembers from which wanted+-- constraint it was derived+newWantedWithProvenance :: CtEvidence -- ^ Constraint from which the new+ -- wanted is derived+ -> PredType -- ^ The type of the new constraint+ -> TcPluginM CtEvidence+newWantedWithProvenance ev@(CtWanted {}) p = do+ let loc = ctEvLoc ev+ env = ctLocEnv loc+ id_ = ctEvId ev+ env' = env {tcl_bndrs = (TcIdBndr id_ NotTopLevel):tcl_bndrs env}+ loc' = setCtLocEnv loc env'+ evVar <- unsafeTcPluginTcM $ newEvVar p+ return CtWanted {ctev_pred = p, ctev_evar = evVar, ctev_loc = loc'}+newWantedWithProvenance ev _ =+ panicDoc "newWantedWithProvenance: not a Wanted: " (ppr ev)++-- | Create a new [W]anted constraint.+newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence+#if __GLASGOW_HASKELL__ >= 711+newWanted = TcPluginM.newWanted+#else+newWanted loc pty = do+ new_ev <- unsafeTcPluginTcM $ newEvVar pty+ return CtWanted { ctev_pred = pty+ , ctev_evar = new_ev+ , ctev_loc = loc+ }+#endif++-- | Create a new [G]iven constraint, with the supplied evidence. This must not+-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic.+newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence+#if __GLASGOW_HASKELL__ >= 711+newGiven = TcPluginM.newGiven+#else+newGiven loc pty evtm = return+ CtGiven { ctev_pred = pty+ , ctev_evtm = evtm+ , ctev_loc = loc+ }+#endif++-- | Create a new [D]erived constraint.+newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence+#if __GLASGOW_HASKELL__ >= 711+newDerived = TcPluginM.newDerived+#else+newDerived loc pty = return+ CtDerived { ctev_pred = pty+ , ctev_loc = loc+ }+#endif++-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce'+evByFiat :: String -- ^ Name the coercion should have+ -> Type -- ^ The LHS of the equivalence relation (~)+ -> Type -- ^ The RHS of the equivalence relation (~)+ -> EvTerm+evByFiat name t1 t2 = EvCoercion $ TcCoercion+ $ mkUnivCo (fsLit name) Nominal t1 t2++-- | Mark the given constraint as insoluble.+--+-- If the [W]anted constraint was made by 'newWantedWithProvenance', it will+-- also mark the parent(s) from which the constraint was derived as insoluble.+-- Even if they were previously assumed to be solved.+failWithProvenace :: Ct -> TcPluginM TcPluginResult+failWithProvenace ct = return (TcPluginContradiction (ct : parents))+ where+ loc = ctLoc ct+ lclbndrs = mapMaybe (\case {TcIdBndr id_ NotTopLevel -> Just id_+ ;_ -> Nothing })+ $ tcl_bndrs (ctLocEnv loc)+ eqBndrs = filter ((\x -> case x of { EqPred NomEq _ _ -> True+ ; _ -> False })+ . classifyPredType . snd)+ $ map (\ev -> (ev,varType ev)) lclbndrs+ parents = map (\(id_,p) -> mkNonCanonical $ CtWanted p id_ loc) eqBndrs++-- | Find a module+lookupModule :: ModuleName -- ^ Name of the module+ -> FastString -- ^ Name of the package containing the module+ -> TcPluginM Module+lookupModule mod_nm pkg = do+ found_module <- findImportedModule mod_nm $ Just pkg+ case found_module of+#if __GLASGOW_HASKELL__ >= 711+ FoundModule h -> return (fr_mod h)+#else+ Found _ md -> return md+#endif+ _ -> do+ found_module' <- findImportedModule mod_nm $ Just $ fsLit "this"+ case found_module' of+#if __GLASGOW_HASKELL__ >= 711+ FoundModule h -> return (fr_mod h)+#else+ Found _ md -> return md+#endif+ _ -> panicDoc "Unable to resolve module looked up by plugin: "+ (ppr mod_nm)++-- | Find a 'Name' in a 'Module' given an 'OccName'+lookupName :: Module -> OccName -> TcPluginM Name+lookupName md occ = lookupOrig md occ++-- | Print out extra information about the initialisation, stop, and every run+-- of the plugin when @-ddump-tc-trace@ is enabled.+tracePlugin :: String -> TcPlugin -> TcPlugin+tracePlugin s TcPlugin{..} = TcPlugin { tcPluginInit = traceInit+ , tcPluginSolve = traceSolve+ , tcPluginStop = traceStop+ }+ where+ traceInit = do+ -- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301+ initializeStaticFlags+ tcPluginTrace ("tcPluginInit " ++ s) empty >> tcPluginInit++ traceStop z = tcPluginTrace ("tcPluginStop " ++ s) empty >> tcPluginStop z++ traceSolve z given derived wanted = do+ tcPluginTrace ("tcPluginSolve start " ++ s)+ (text "given =" <+> ppr given+ $$ text "derived =" <+> ppr derived+ $$ text "wanted =" <+> ppr wanted)+ r <- tcPluginSolve z given derived wanted+ case r of+ TcPluginOk solved new -> tcPluginTrace ("tcPluginSolve ok " ++ s)+ (text "solved =" <+> ppr solved+ $$ text "new =" <+> ppr new)+ TcPluginContradiction bad -> tcPluginTrace+ ("tcPluginSolve contradiction " ++ s)+ (text "bad =" <+> ppr bad)+ return r++-- workaround for https://ghc.haskell.org/trac/ghc/ticket/10301+initializeStaticFlags :: TcPluginM ()+initializeStaticFlags = tcPluginIO $ do+ r <- readIORef v_opt_C_ready+ unless r initStaticOpts