Type-checker plugins as a single patch.
authorIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 9 Nov 2014 23:52:52 +0000 (15:52 -0800)
committerIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 9 Nov 2014 23:52:52 +0000 (15:52 -0800)
14 files changed:
compiler/ghc.mk
compiler/ghci/RtClosureInspect.hs
compiler/main/DynFlags.hs
compiler/main/DynamicLoading.hs
compiler/main/DynamicLoading.hs-boot [new file with mode: 0644]
compiler/prelude/PrelNames.lhs
compiler/simplCore/SimplCore.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcRnTypes.lhs-boot
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcTypeNats.hs

index b5f5dbc..b703da7 100644 (file)
@@ -589,7 +589,6 @@ compiler_stage2_dll0_MODULES = \
        Var \
        VarEnv \
        VarSet
-
 ifeq "$(GhcWithInterpreter)" "YES"
 # These files are reacheable from DynFlags
 # only by GHCi-enabled code (see #9552)
@@ -599,6 +598,7 @@ compiler_stage2_dll0_MODULES += \
        ByteCodeAsm \
        ByteCodeInstr \
        ByteCodeItbls \
+       ByteCodeLink \
        CLabel \
        Cmm \
        CmmCallConv \
@@ -615,16 +615,22 @@ compiler_stage2_dll0_MODULES += \
        CodeGen.Platform.SPARC \
        CodeGen.Platform.X86 \
        CodeGen.Platform.X86_64 \
+       DynamicLoading \
        FastBool \
        Hoopl \
        Hoopl.Dataflow \
        InteractiveEvalTypes \
+       Linker \
        MkGraph \
+       ObjLink \
        PprCmm \
        PprCmmDecl \
        PprCmmExpr \
        Reg \
        RegClass \
+       RnEnv \
+       RnHsDoc \
+       RnNames \
        SMRep \
        StgCmmArgRep \
        StgCmmClosure \
@@ -635,7 +641,10 @@ compiler_stage2_dll0_MODULES += \
        StgCmmTicky \
        StgCmmUtils \
        StgSyn \
-       Stream
+       Stream \
+       SysTools \
+       TcEnv \
+       TcMType
 endif
 
 compiler_stage2_dll0_HS_OBJS = \
index 1f751d1..5df8c0e 100644 (file)
@@ -568,7 +568,9 @@ runTR hsc_env thing = do
 
 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 runTR_maybe hsc_env thing_inside
-  = do { (_errs, res) <- initTc hsc_env HsSrcFile False
+  -- When we initialize the type checker we do not load any pluguns.
+  -- Is that OK?
+  = do { (_errs, res) <- initTc False hsc_env HsSrcFile False
                                 (icInteractiveModule (hsc_IC hsc_env))
                                 thing_inside
        ; return res }
index 0c6639a..d3fbe16 100644 (file)
@@ -26,6 +26,7 @@ module DynFlags (
         PlatformConstants(..),
         FatalMessager, LogAction, FlushOut(..), FlushErr(..),
         ProfAuto(..),
+        PluginType(..),
         glasgowExtsFlags,
         dopt, dopt_set, dopt_unset,
         gopt, gopt_set, gopt_unset,
@@ -616,6 +617,8 @@ getSigOf dflags n =
         SigOf m -> Just m
         SigOfMap m -> Map.lookup n m
 
+data PluginType = PluginCore2Core | PluginTypeCheck
+
 -- | Contains not only a collection of 'GeneralFlag's but also a plethora of
 -- information relating to the compilation of a single file or GHC session
 data DynFlags = DynFlags {
@@ -718,8 +721,8 @@ data DynFlags = DynFlags {
   hpcDir                :: String,      -- ^ Path to store the .mix files
 
   -- Plugins
-  pluginModNames        :: [ModuleName],
-  pluginModNameOpts     :: [(ModuleName,String)],
+  pluginModNames        :: [(ModuleName, PluginType)],
+  pluginModNameOpts     :: [(ModuleName, String)],
 
   -- GHC API hooks
   hooks                 :: Hooks,
@@ -1728,7 +1731,7 @@ setLanguage l = upd (`lang_set` Just l)
 
 -- | Some modules have dependencies on others through the DynFlags rather than textual imports
 dynFlagDependencies :: DynFlags -> [ModuleName]
-dynFlagDependencies = pluginModNames
+dynFlagDependencies = map fst . pluginModNames
 
 -- | Is the -fpackage-trust mode on
 packageTrustOn :: DynFlags -> Bool
@@ -1879,8 +1882,9 @@ parseSigOf str = case filter ((=="").snd) (readP_to_S parse str) of
 setSigOf :: String -> DynFlags -> DynFlags
 setSigOf s d = d { sigOf = parseSigOf s }
 
-addPluginModuleName :: String -> DynFlags -> DynFlags
-addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
+addPluginModuleName :: PluginType -> String -> DynFlags -> DynFlags
+addPluginModuleName pty name d =
+  d { pluginModNames = (mkModuleName name, pty) : (pluginModNames d) }
 
 addPluginModuleNameOption :: String -> DynFlags -> DynFlags
 addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }
@@ -2454,8 +2458,9 @@ dynamic_flags = [
   , Flag "w"      (NoArg (upd (\dfs -> dfs {warningFlags = IntSet.empty})))
 
         ------ Plugin flags ------------------------------------------------
-  , Flag "fplugin-opt" (hasArg addPluginModuleNameOption)
-  , Flag "fplugin"     (hasArg addPluginModuleName)
+  , Flag "fplugin-opt"    (hasArg addPluginModuleNameOption)
+  , Flag "fplugin"        (hasArg (addPluginModuleName PluginCore2Core))
+  , Flag "ftc-plugin"     (hasArg (addPluginModuleName PluginTypeCheck))
 
         ------ Optimisation flags ------------------------------------------
   , Flag "O"      (noArgM (setOptLevel 1))
index 046d13c..ae4d5a3 100644 (file)
@@ -22,7 +22,7 @@ module DynamicLoading (
 import Linker           ( linkModule, getHValue )
 import SrcLoc           ( noSrcSpan )
 import Finder           ( findImportedModule, cannotFindModule )
-import TcRnMonad        ( initTcInteractive, initIfaceTcRn )
+import TcRnMonad        ( initTcDynamic, initIfaceTcRn )
 import LoadIface        ( loadPluginInterface )
 import RdrName          ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..)
                         , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName, gre_name )
@@ -52,7 +52,7 @@ import GHC.Exts          ( unsafeCoerce# )
 -- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
 forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
 forceLoadModuleInterfaces hsc_env doc modules
-    = (initTcInteractive hsc_env $
+    = (initTcDynamic hsc_env $
        initIfaceTcRn $
        mapM_ (loadPluginInterface doc) modules) 
       >> return ()
@@ -154,7 +154,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
     case found_module of
         Found _ mod -> do
             -- Find the exports of the module
-            (_, mb_iface) <- initTcInteractive hsc_env $
+            (_, mb_iface) <- initTcDynamic hsc_env $
                              initIfaceTcRn $
                              loadPluginInterface doc mod
             case mb_iface of
diff --git a/compiler/main/DynamicLoading.hs-boot b/compiler/main/DynamicLoading.hs-boot
new file mode 100644 (file)
index 0000000..ec26dd2
--- /dev/null
@@ -0,0 +1,12 @@
+module DynamicLoading where
+
+import HscTypes(HscEnv)
+import Name(Name)
+import TyCon(TyCon)
+import Type(Type)
+import Module(ModuleName)
+import RdrName(RdrName)
+
+forceLoadTyCon :: HscEnv -> Name -> IO TyCon
+getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
+lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
index f669941..e2cbfb0 100644 (file)
@@ -342,6 +342,7 @@ basicKnownKeyNames
 
         -- Plugins
         , pluginTyConName
+        , tcPluginTyConName
 
         -- Generics
         , genClassName, gen1ClassName
@@ -1163,6 +1164,11 @@ cORE_MONAD :: Module
 cORE_MONAD = mkThisGhcModule (fsLit "CoreMonad")
 pluginTyConName :: Name
 pluginTyConName = tcQual cORE_MONAD (fsLit "Plugin") pluginTyConKey
+
+tC_RN_TYPES:: Module
+tC_RN_TYPES = mkThisGhcModule (fsLit "TcRnTypes")
+tcPluginTyConName :: Name
+tcPluginTyConName = tcQual tC_RN_TYPES (fsLit "TcPlugin") tcPluginTyConKey
 \end{code}
 
 %************************************************************************
@@ -1402,8 +1408,9 @@ csel1CoercionTyConKey                   = mkPreludeTyConUnique 99
 csel2CoercionTyConKey                   = mkPreludeTyConUnique 100
 cselRCoercionTyConKey                   = mkPreludeTyConUnique 101
 
-pluginTyConKey :: Unique
+pluginTyConKey, tcPluginTyConKey :: Unique
 pluginTyConKey                          = mkPreludeTyConUnique 102
+tcPluginTyConKey                        = mkPreludeTyConUnique 103
 
 unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey,
     opaqueTyConKey :: Unique
index 1d3b233..66b43b6 100644 (file)
@@ -338,7 +338,8 @@ addPluginPasses dflags builtin_passes
 
 loadPlugins :: HscEnv -> IO [(ModuleName, Plugin)]
 loadPlugins hsc_env
-  = do { let to_load = pluginModNames (hsc_dflags hsc_env)
+  = do { let to_load = [ m | (m,PluginCore2Core) <-
+                                    pluginModNames (hsc_dflags hsc_env) ]
        ; plugins <- mapM (loadPlugin hsc_env) to_load
        ; return $ to_load `zip` plugins }
 
index 6fbed77..78fb3f3 100644 (file)
@@ -39,7 +39,7 @@ import TcErrors
 import TcSMonad
 import Bag
 
-import Data.List( partition )
+import Data.List( partition, foldl' )
 
 import VarEnv
 
@@ -149,18 +149,81 @@ solveFlats cts
   = {-# SCC "solveFlats" #-}
     do { dyn_flags <- getDynFlags
        ; updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts)
-       ; solve_loop (maxSubGoalDepth dyn_flags) }
+       ; solve_loop False (maxSubGoalDepth dyn_flags) }
   where
-    solve_loop max_depth
+    solve_loop inertsModified max_depth
       = {-# SCC "solve_loop" #-}
         do { sel <- selectNextWorkItem max_depth
            ; case sel of
-              NoWorkRemaining     -- Done, successfuly (modulo frozen)
-                -> return ()
+
+              NoWorkRemaining
+                | inertsModified ->
+                    do gblEnv <- getGblEnv
+                       mapM_ runTcPlugin (tcg_tc_plugins gblEnv)
+                       solve_loop False max_depth
+
+                -- Done, successfuly (modulo frozen)
+                | otherwise -> return ()
+
+
               MaxDepthExceeded cnt ct -- Failure, depth exceeded
                 -> wrapErrTcS $ solverDepthErrorTcS cnt (ctEvidence ct)
+
               NextWorkItem ct     -- More work, loop around!
-                -> do { runSolverPipeline thePipeline ct; solve_loop max_depth } }
+                -> do { changes <- runSolverPipeline thePipeline ct
+                      ; let newMod = changes || inertsModified
+                      ; newMod `seq` solve_loop newMod max_depth } }
+
+
+-- | Try to make progress using type-checker plugings.
+-- The plugin is provided only with CTyEq and CFunEq constraints.
+runTcPlugin :: TcPluginSolver -> TcS ()
+runTcPlugin solver =
+  do iSet <- getTcSInerts
+     let iCans    = inert_cans iSet
+         allCts   = foldDicts  (:) (inert_dicts iCans)
+                  $ foldFunEqs (:) (inert_funeqs iCans)
+                  $ concat (varEnvElts (inert_eqs iCans))
+
+         (derived,other) = partition isDerivedCt allCts
+         (wanted,given)  = partition isWantedCt  other
+
+     result <- runTcPluginTcS (solver given derived wanted)
+     case result of
+
+       TcPluginContradiction bad_cts ->
+          do setInertCans (removeInertCts iCans bad_cts)
+             mapM_ emitInsoluble bad_cts
+
+       TcPluginOk solved_cts new_cts ->
+          do setInertCans (removeInertCts iCans (map snd solved_cts))
+             let setEv (ev,ct) = setEvBind (ctev_evar (cc_ev ct)) ev
+             mapM_ setEv solved_cts
+             updWorkListTcS (extendWorkListCts new_cts)
+  where
+  removeInertCts :: InertCans -> [Ct] -> InertCans
+  removeInertCts = foldl' removeInertCt
+
+  -- Remove the constraint from the inert set.  We use this either when:
+  --   * a wanted constraint was solved, or
+  --   * some constraint was marked as insoluable, and so it will be
+  --     put right back into InertSet, but in the insoluable section.
+  removeInertCt :: InertCans -> Ct -> InertCans
+  removeInertCt is ct =
+    case ct of
+
+      CDictCan  { cc_class = cl, cc_tyargs = tys } ->
+        is { inert_dicts = delDict (inert_dicts is) cl tys }
+
+      CFunEqCan { cc_fun  = tf,  cc_tyargs = tys } ->
+        is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }
+
+      CTyEqCan  { cc_tyvar = x,  cc_rhs    = ty  } ->
+        is { inert_eqs = delTyEq (inert_eqs is) x ty }
+
+      CIrredEvCan {}   -> panic "runTcPlugin/removeInert: CIrredEvCan"
+      CNonCanonical {} -> panic "runTcPlugin/removeInert: CNonCanonical"
+      CHoleCan {}      -> panic "runTcPlugin/removeInert: CHoleCan"
 
 type WorkItem = Ct
 type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct)
@@ -191,7 +254,7 @@ selectNextWorkItem max_depth
 
 runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline
                   -> WorkItem                   -- The work item
-                  -> TcS ()
+                  -> TcS Bool                   -- Did we modify the inert set
 -- Run this item down the pipeline, leaving behind new work and inerts
 runSolverPipeline pipeline workItem
   = do { initial_is <- getTcSInerts
@@ -207,13 +270,14 @@ runSolverPipeline pipeline workItem
            Stop ev s       -> do { traceFireTcS ev s
                                  ; traceTcS "End solver pipeline (discharged) }"
                                        (ptext (sLit "inerts =") <+> ppr final_is)
-                                 ; return () }
+                                 ; return False }
            ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (ptext (sLit "Kept as inert"))
                                  ; traceTcS "End solver pipeline (not discharged) }" $
                                        vcat [ ptext (sLit "final_item =") <+> ppr ct
                                             , pprTvBndrs (varSetElems $ tyVarsOfCt ct)
                                             , ptext (sLit "inerts     =") <+> ppr final_is]
-                                 ; insertInertItemTcS ct }
+                                 ; insertInertItemTcS ct
+                                 ; return True }
        }
   where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct 
                      -> TcS (StopOrContinue Ct)
index 9ac01ed..e56ab82 100644 (file)
@@ -134,8 +134,10 @@ tcRnModule hsc_env hsc_src save_rn_syntax
                     Just (L mod_loc mod)  -- The normal case
                         -> (mkModule this_pkg mod, mod_loc) } ;
 
-      ; initTc hsc_env hsc_src save_rn_syntax this_mod $
-        tcRnModuleTcRnM hsc_env hsc_src parsedModule pair }
+      ; res <- initTc True hsc_env hsc_src save_rn_syntax this_mod $
+        tcRnModuleTcRnM hsc_env hsc_src parsedModule pair
+      ; return res
+      }
 
 -- To be called at the beginning of renaming hsig files.
 -- If we're processing a signature, load up the RdrEnv
@@ -371,6 +373,7 @@ implicitPreludeWarn
 \end{code}
 
 
+
 %************************************************************************
 %*                                                                      *
                 Import declarations
index cd41499..b119a16 100644 (file)
@@ -59,6 +59,8 @@ import Control.Monad
 
 #ifdef GHCI
 import qualified Data.Map as Map
+import {-# SOURCE #-} DynamicLoading ( forceLoadTyCon, getValueSafely
+                                     , lookupRdrNameInModuleForPlugins )
 #endif
 \end{code}
 
@@ -72,8 +74,10 @@ import qualified Data.Map as Map
 
 \begin{code}
 
+
 -- | Setup the initial typechecking environment
-initTc :: HscEnv
+initTc :: Bool          -- True <=> load plugins
+       -> HscEnv
        -> HscSource
        -> Bool          -- True <=> retain renamed syntax trees
        -> Module
@@ -82,7 +86,7 @@ initTc :: HscEnv
                 -- Nothing => error thrown by the thing inside
                 -- (error messages should have been printed already)
 
-initTc hsc_env hsc_src keep_rn_syntax mod do_this
+initTc load_plugins hsc_env hsc_src keep_rn_syntax mod do_this
  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
         tvs_var      <- newIORef emptyVarSet ;
         keep_var     <- newIORef emptyNameSet ;
@@ -162,7 +166,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_hpc            = False,
                 tcg_main           = Nothing,
                 tcg_safeInfer      = infer_var,
-                tcg_dependent_files = dependent_files_var
+                tcg_dependent_files = dependent_files_var,
+                tcg_tc_plugins     = []
              } ;
              lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
@@ -183,7 +188,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
 
         -- OK, here's the business end!
         maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
-                     do { r <- tryM do_this
+                     do { r <- tryM $ if load_plugins
+                                         then withTcPlugins hsc_env do_this
+                                         else do_this
                         ; case r of
                           Right res -> return (Just res)
                           Left _    -> return Nothing } ;
@@ -207,15 +214,23 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
 initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
 -- Initialise the type checker monad for use in GHCi
 initTcInteractive hsc_env thing_inside
-  = initTc hsc_env HsSrcFile False
+  = initTc True hsc_env HsSrcFile False
+           (icInteractiveModule (hsc_IC hsc_env))
+           thing_inside
+
+initTcDynamic :: HscEnv -> TcM a -> IO (Messages, Maybe a)
+-- ^ Initialise the type checker for use in in dynamic loading
+initTcDynamic hsc_env thing_inside
+  = initTc False hsc_env HsSrcFile False
            (icInteractiveModule (hsc_IC hsc_env))
            thing_inside
 
+
 initTcForLookup :: HscEnv -> TcM a -> IO a
 -- The thing_inside is just going to look up something
 -- in the environment, so we don't need much setup
 initTcForLookup hsc_env thing_inside
-    = do (msgs, m) <- initTc hsc_env HsSrcFile False
+    = do (msgs, m) <- initTc False hsc_env HsSrcFile False
                              (icInteractiveModule (hsc_IC hsc_env))  -- Irrelevant really
                              thing_inside
          case m of
@@ -1364,3 +1379,76 @@ asynchronous exception as a synchronous exception, and the exception will end
 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
 discussion).  We don't currently know a general solution to this problem, but
 we can use uninterruptibleMask_ to avoid the situation. 
+
+
+
+
+********************************************************************************
+
+Type Checker Plugins
+
+********************************************************************************
+
+
+\begin{code}
+withTcPlugins :: HscEnv -> TcM a -> TcM a
+withTcPlugins hsc_env m =
+  do plugins <- liftIO (loadTcPlugins hsc_env)
+     case plugins of
+       [] -> m  -- Common fast case
+       _  -> do (solvers,stops) <- unzip `fmap` mapM startPlugin plugins
+                res <- updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m
+                mapM_ runTcPluginM stops
+                return res
+  where
+  startPlugin (TcPlugin start solve stop, opts) =
+    do s <- runTcPluginM (start opts)
+       return (solve s, stop s)
+
+-- | Perform some IO, typically to inetract with an extrnal tool.
+tcPluginIO :: IO a -> TcPluginM a
+tcPluginIO a = unsafeTcPluginTcM (liftIO a)
+
+-- | Output useful for debugging the compiler.
+tcPluginTrace :: String -> SDoc -> TcPluginM ()
+tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
+
+
+loadTcPlugins :: HscEnv -> IO [ (TcPlugin, [String]) ]
+#ifndef GHCI
+loadTcPlugins _ = return []
+#else
+loadTcPlugins hsc_env =
+  mapM load [ m | (m, PluginTypeCheck) <- pluginModNames dflags ]
+  where
+  dflags    = hsc_dflags hsc_env
+  getOpts mod_name = [ opt | (m,opt) <- pluginModNameOpts dflags
+                           , m == mod_name ]
+  load mod_name =
+    do let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "tcPlugin")
+       mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
+                                                            plugin_rdr_name
+       case mb_name of
+         Nothing ->
+             throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
+                       [ ptext (sLit "The module"), ppr mod_name
+                       , ptext (sLit "did not export the plugin name")
+                       , ppr plugin_rdr_name ])
+         Just name ->
+
+           do tcPluginTycon <- forceLoadTyCon hsc_env tcPluginTyConName
+              let ty = mkTyConTy tcPluginTycon
+              mb_plugin <- getValueSafely hsc_env name ty
+              case mb_plugin of
+                Nothing ->
+                    throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ hsep
+                        [ ptext (sLit "The value"), ppr name
+                        , ptext (sLit "did not have the type")
+                        , ppr ty, ptext (sLit "as required")
+                        ]
+                Just plugin -> return (plugin, getOpts mod_name)
+#endif
+
+
+\end{code}
+
index e1762a8..57b2ec2 100644 (file)
@@ -16,7 +16,7 @@ For state that is global and should be returned at the end (e.g not part
 of the stack mechanism), you should use an TcRef (= IORef) to store them.
 
 \begin{code}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, ExistentialQuantification #-}
 
 module TcRnTypes(
         TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module
@@ -74,6 +74,10 @@ module TcRnTypes(
         mkGivenLoc,
         isWanted, isGiven, isDerived,
 
+        -- Constraint solver plugins
+        TcPlugin(..), TcPluginResult(..), TcPluginSolver,
+        TcPluginM, runTcPluginM, unsafeTcPluginTcM,
+
         -- Pretty printing
         pprEvVarTheta, 
         pprEvVars, pprEvVarWithType,
@@ -122,6 +126,7 @@ import ListSetOps
 import FastString
 
 import Data.Set (Set)
+import Control.Monad (ap, liftM)
 
 #ifdef GHCI
 import Data.Map      ( Map )
@@ -354,9 +359,12 @@ data TcGblEnv
         tcg_main      :: Maybe Name,         -- ^ The Name of the main
                                              -- function, if this module is
                                              -- the main module.
-        tcg_safeInfer :: TcRef Bool          -- Has the typechecker
+        tcg_safeInfer :: TcRef Bool,         -- Has the typechecker
                                              -- inferred this module
                                              -- as -XSafe (Safe Haskell)
+
+        -- | A list of user-defined plugins for the constraint solver.
+        tcg_tc_plugins :: [TcPluginSolver]
     }
 
 -- Note [Signature parameters in TcGblEnv and DynFlags]
@@ -1955,3 +1963,72 @@ pprCtO HoleOrigin            = ptext (sLit "a use of") <+> quotes (ptext $ sLit
 pprCtO ListOrigin            = ptext (sLit "an overloaded list")
 pprCtO _                     = panic "pprCtOrigin"
 \end{code}
+
+
+
+
+
+Constraint Solver Plugins
+-------------------------
+
+
+\begin{code}
+
+type TcPluginSolver = [Ct]    -- given
+                   -> [Ct]    -- derived
+                   -> [Ct]    -- wanted
+                   -> TcPluginM TcPluginResult
+
+newtype TcPluginM a = TcPluginM (TcM a)
+
+instance Functor     TcPluginM where
+  fmap = liftM
+
+instance Applicative TcPluginM where
+  pure  = return
+  (<*>) = ap
+
+instance Monad TcPluginM where
+  return x = TcPluginM (return x)
+  fail x   = TcPluginM (fail x)
+  TcPluginM m >>= k =
+    TcPluginM (do a <- m
+                  let TcPluginM m1 = k a
+                  m1)
+
+runTcPluginM :: TcPluginM a -> TcM a
+runTcPluginM (TcPluginM m) = m
+
+-- | This function provides an escape for direct access to
+-- the 'TcM` monad.  It should not be used lightly, and
+-- the provided 'TcPluginM' API should be favoured instead.
+unsafeTcPluginTcM :: TcM a -> TcPluginM a
+unsafeTcPluginTcM = TcPluginM
+
+data TcPlugin = forall s. TcPlugin
+  { tcPluginInit  :: [String] -> TcPluginM s
+    -- ^ Initialize plugin, when entering type-checker.
+
+  , tcPluginSolve :: s -> TcPluginSolver
+    -- ^ Solve some constraints.
+    -- TODO: WRITE MORE DETAILS ON HOW THIS WORKS.
+
+  , tcPluginStop  :: s -> TcPluginM ()
+   -- ^ Clean up after the plugin, when exiting the type-checker.
+  }
+
+data TcPluginResult
+  = TcPluginContradiction [Ct]
+    -- ^ The plugin found a contradiction.
+    -- The returned constraints are removed from the inert set,
+    -- and recorded as insoluable.
+
+  | TcPluginOk [(EvTerm,Ct)] [Ct]
+    -- ^ The first field is for constraints that were solved.
+    -- These are removed from the inert set,
+    -- and the evidence for them is recorded.
+    -- The second field contains new work, that should be processed by
+    -- the constraint solver.
+
+\end{code}
+
index 36c43fc..8a5ee15 100644 (file)
@@ -1,11 +1,11 @@
 \begin{code}
 module TcRnTypes where
 
-import IOEnv 
+import IOEnv
 
-type TcM a = TcRn a
-type TcRn a = TcRnIf TcGblEnv TcLclEnv a
-type TcRnIf a b c = IOEnv (Env a b) c
+type TcM = TcRn
+type TcRn = TcRnIf TcGblEnv TcLclEnv
+type TcRnIf a b = IOEnv (Env a b)
 
 data Env a b
 data TcGblEnv
index cd778cf..da79f32 100644 (file)
@@ -12,7 +12,7 @@ module TcSMonad (
     extendWorkListCts, appendWorkList, selectWorkItem,
     workListSize,
 
-    updWorkListTcS, updWorkListTcS_return, 
+    updWorkListTcS, updWorkListTcS_return,
 
     updInertCans, updInertDicts, updInertIrreds, updInertFunEqs,
 
@@ -28,6 +28,7 @@ module TcSMonad (
     traceFireTcS, bumpStepCountTcS, csTraceTcS,
     tryTcS, nestTcS, nestImplicTcS, recoverTcS,
     wrapErrTcS, wrapWarnTcS,
+    runTcPluginTcS,
 
     -- Getting and setting the flattening cache
     addSolvedDict, 
@@ -75,11 +76,16 @@ module TcSMonad (
     EqualCtList,
     lookupSolvedDict, extendFlatCache,
 
-    lookupInertDict, findDictsByClass, addDict, addDictsByClass, delDict, partitionDicts,
+    lookupInertDict, findDictsByClass, addDict, addDictsByClass, delDict,
+    partitionDicts, foldDicts,
 
-    findFunEq, findTyEqs, 
+    emptyFunEqs, funEqsToBag,
+    findFunEq, findTyEqs,
     findFunEqsByTyCon, findFunEqs, partitionFunEqs,
     sizeFunEqMap,
+    foldFunEqs,
+    delFunEq,
+    delTyEq,
 
     instDFunType,                              -- Instantiation
     newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS,
@@ -810,6 +816,11 @@ type TyEqMap a = TyVarEnv a
 
 findTyEqs :: TyEqMap EqualCtList -> TyVar -> EqualCtList
 findTyEqs m tv = lookupVarEnv m tv `orElse` []
+
+delTyEq :: TyEqMap EqualCtList -> TcTyVar -> TcType -> TyEqMap EqualCtList
+delTyEq m tv t = modifyVarEnv (filter (not . isThisOne)) m tv
+  where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1
+        isThisOne _                          = False
 \end{code}
 
 
@@ -963,6 +974,9 @@ partitionFunEqs f m = foldTcAppMap k m (emptyBag, emptyFunEqs)
     k ct (yeses, noes)
       | f ct      = (yeses `snocBag` ct, noes)
       | otherwise = (yeses, insertFunEqCt noes ct)
+
+delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
+delFunEq m tc tys = delTcApp m (getUnique tc) tys
 \end{code}
 
 
@@ -1046,6 +1060,9 @@ panicTcS doc = pprPanic "TcCanonical" doc
 traceTcS :: String -> SDoc -> TcS ()
 traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
 
+runTcPluginTcS :: TcPluginM a -> TcS a
+runTcPluginTcS = wrapTcS . runTcPluginM
+
 instance HasDynFlags TcS where
     getDynFlags = wrapTcS getDynFlags
 
index 37fc6e0..8f02c9a 100644 (file)
@@ -2,6 +2,14 @@ module TcTypeNats
   ( typeNatTyCons
   , typeNatCoAxiomRules
   , BuiltInSynFamily(..)
+
+  , typeNatAddTyCon
+  , typeNatMulTyCon
+  , typeNatExpTyCon
+  , typeNatLeqTyCon
+  , typeNatSubTyCon
+  , typeNatCmpTyCon
+  , typeSymbolCmpTyCon
   ) where
 
 import Type