diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +## 0.1 +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# ghc-tcplugins-extra +Utilities for writing GHC type-checker plugins + +[![Build Status](https://secure.travis-ci.org/clash-lang/ghc-tcplugins-extra.png?branch=master)](http://travis-ci.org/clash-lang/ghc-tcplugins-extra) +[![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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghc-tcplugins-extra.cabal b/ghc-tcplugins-extra.cabal new file mode 100644 --- /dev/null +++ b/ghc-tcplugins-extra.cabal @@ -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 diff --git a/src/GHC/TcPluginM/Extra.hs b/src/GHC/TcPluginM/Extra.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TcPluginM/Extra.hs @@ -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 +-} +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