breakpoint 0.1.2.1 → 0.1.2.2

raw patch · 8 files changed

+764/−687 lines, 8 filesdep +deepseqPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• breakpoint.cabal +12/−3
• src/Debug/Breakpoint.hs +10/−679
• src/Debug/Breakpoint/GhcFacade.hs +5/−4
• src/Debug/Breakpoint/Renamer.hs +545/−0
• src/Debug/Breakpoint/TimerManager.hs +0/−1
• src/Debug/Breakpoint/TypeChecker.hs +165/−0
• test/Spec.hs +23/−0

@@ -1,5 +1,9 @@ # Revision history for breakpoint +## 0.1.2.2 -- 2023-09-02+* Improvement to instance resolution for showing arbitrary values+* Strictly evaluate variable output before modifying timeouts+ ## 0.1.2.1 -- 2023-03-12 * Support GHC 9.6.x 

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               breakpoint-version:            0.1.2.1+version:            0.1.2.2 synopsis:   Set breakpoints using a GHC plugin @@ -29,7 +29,8 @@                       Debug.Breakpoint.TimerManager,      -- Modules included in this library but not exported.-    -- other-modules:+    other-modules: Debug.Breakpoint.Renamer,+                   Debug.Breakpoint.TypeChecker      -- LANGUAGE extensions used by modules in this package.     -- other-extensions:@@ -42,7 +43,8 @@                       pretty-simple >= 4.0.0.0,                       text,                       template-haskell,-                      ansi-terminal+                      ansi-terminal,+                      deepseq     hs-source-dirs:   src     default-language: Haskell2010     ghc-options: -Wall@@ -56,3 +58,10 @@   type: exitcode-stdio-1.0   default-language: Haskell2010   ghc-options: -fplugin Debug.Breakpoint++--executable play+--  main-is: Main.hs+--  hs-source-dirs: play+--  build-depends: base, breakpoint+--  default-language: Haskell2010+--  ghc-options: -fplugin Debug.Breakpoint

@@ -1,18 +1,14 @@+{-# LANGUAGE DataKinds #-} -- for 9.0 {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} module Debug.Breakpoint   ( -- * Plugin@@ -38,32 +34,18 @@   , getSrcLoc   ) where -import           Control.Applicative ((<|>), empty)-import           Control.Arrow ((&&&))+import           Control.DeepSeq (force) import           Control.Monad.IO.Class-import           Control.Monad.Reader-import           Control.Monad.Trans.Maybe-import           Control.Monad.Trans.Writer.CPS import           Data.Char (isSpace)-import           Data.Data hiding (IntRep, FloatRep)-import           Data.Either import           Data.Foldable import           Data.Functor-import qualified Data.Graph as Graph import qualified Data.List as L import qualified Data.Map.Lazy as M import           Data.Maybe-import           Data.Monoid (Any(..)) import qualified Data.Text.Lazy as T-import           Data.Traversable (for) import           Debug.Trace (trace, traceIO, traceM) import qualified GHC.Exts as Exts import           GHC.Int-#if MIN_VERSION_ghc(9,0,0)-import qualified GHC.Tc.Plugin as Plugin-#else-import qualified TcPluginM as Plugin-#endif import           GHC.Word import qualified System.Console.ANSI as ANSI import qualified System.Console.Haskeline as HL@@ -74,7 +56,9 @@ import qualified Text.Pretty.Simple.Internal.Color as PS  import qualified Debug.Breakpoint.GhcFacade as Ghc+import qualified Debug.Breakpoint.Renamer as Renamer import qualified Debug.Breakpoint.TimerManager as TM+import qualified Debug.Breakpoint.TypeChecker as TypeChecker  -------------------------------------------------------------------------------- -- API@@ -105,11 +89,12 @@   let ?useColor = useColor   prettyPrint <- usePrettyPrinting   let ?prettyPrint = prettyPrint+  let !printedVars = force (printVars vars)   TM.suspendTimeouts $ do     traceIO $ L.intercalate "\n"       [ color red "### Breakpoint Hit ###"       , color grey "(" <> srcLoc <> ")"-      , printVars vars+      , printedVars       , color green "Press enter to continue"       ]     void blockOnInput@@ -260,663 +245,9 @@ plugin :: Ghc.Plugin plugin = Ghc.defaultPlugin   { Ghc.pluginRecompile = Ghc.purePlugin-  , Ghc.renamedResultAction = const renameAction-  , Ghc.tcPlugin = const $ Just tcPlugin-  }--renameAction-  :: Ghc.TcGblEnv-  -> Ghc.HsGroup Ghc.GhcRn-  -> Ghc.TcM (Ghc.TcGblEnv, Ghc.HsGroup Ghc.GhcRn)-renameAction gblEnv group = do-  Ghc.Found _ breakpointMod <--    Ghc.findPluginModule' (Ghc.mkModuleName "Debug.Breakpoint")--  captureVarsName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "captureVars")-  showLevName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "showLev")-  fromListName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "fromAscList")-  breakpointName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "breakpoint")-  queryVarsName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "queryVars")-  breakpointMName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "breakpointM")-  queryVarsMName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "queryVarsM")-  breakpointIOName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "breakpointIO")-  queryVarsIOName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "queryVarsIO")-  printAndWaitName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "printAndWait")-  printAndWaitMName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "printAndWaitM")-  printAndWaitIOName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "printAndWaitIO")-  runPromptIOName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "runPromptIO")-  runPromptMName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "runPromptM")-  runPromptName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "runPrompt")-  getSrcLocName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "getSrcLoc")-  excludeVarsName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "excludeVars")--  (group', _) <--    runReaderT (runWriterT $ recurse group)-      MkEnv { varSet = mempty, .. }--  pure (gblEnv, group')--recurse :: Data a => a -> EnvReader a-recurse a =-  maybe (gmapM recurse a) pure-    =<< transform a--newtype T a = T (a -> EnvReader (Maybe a))--transform :: forall a. Data a => a -> EnvReader (Maybe a)-transform a = runMaybeT-      $ wrap hsVarCase-    <|> wrap hsAppCase-    <|> wrap matchCase-    <|> wrap grhssCase-    <|> wrap hsLetCase-    <|> wrap grhsCase-    <|> wrap hsDoCase-    <|> wrap hsProcCase-  where-    wrap :: forall b. Data b-         => (b -> EnvReader (Maybe b))-         -> MaybeT EnvReader a-    wrap f = do-      case gcast @b @a (T f) of-        Nothing -> empty-        Just (T f') -> MaybeT $ f' a------------------------------------------------------------------------------------- Variable Expr-----------------------------------------------------------------------------------hsVarCase :: Ghc.HsExpr Ghc.GhcRn-          -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))-hsVarCase (Ghc.HsVar _ (Ghc.L loc name)) = do-  MkEnv{..} <- lift ask--  let srcLocStringExpr-        = Ghc.nlHsLit . Ghc.mkHsString-        . Ghc.showSDocUnsafe-        . Ghc.ppr-        $ Ghc.locA' loc--      captureVarsExpr mResultName =-        let mkTuple (Ghc.fromLexicalFastString -> varStr, n) =-              Ghc.mkLHsTupleExpr-                [ Ghc.nlHsLit . Ghc.mkHsString $ Ghc.unpackFS varStr-                , Ghc.nlHsApp (Ghc.nlHsVar showLevName) (Ghc.nlHsVar n)-                ]-#if MIN_VERSION_ghc(9,2,0)-                Ghc.NoExtField-#endif--            mkList exprs = Ghc.noLocA' (Ghc.ExplicitList' Ghc.NoExtField exprs)--            varSetWithResult-              | Just resName <- mResultName =-                  M.insert (Ghc.mkLexicalFastString $ Ghc.mkFastString "*result")-                           resName-                           varSet-              | otherwise = varSet--         in Ghc.nlHsApp (Ghc.nlHsVar fromListName) . mkList-              $ mkTuple <$> M.toList varSetWithResult--      bpExpr = do-        resultName <- Ghc.newName (Ghc.mkOccName Ghc.varName "_result_")-        pure $-          Ghc.mkHsLam [Ghc.nlVarPat resultName] $-            Ghc.nlHsApp-              (Ghc.nlHsApp-                (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitName) srcLocStringExpr)-                (captureVarsExpr $ Just resultName)-              )-              (Ghc.nlHsVar resultName)--      bpMExpr =-        Ghc.nlHsApp-          (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitMName) srcLocStringExpr)-          $ captureVarsExpr Nothing--      bpIOExpr =-        Ghc.nlHsApp-          (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitIOName) srcLocStringExpr)-          $ captureVarsExpr Nothing--      queryVarsIOExpr =-        Ghc.nlHsApp-          (Ghc.nlHsApp (Ghc.nlHsVar runPromptIOName) srcLocStringExpr)-          $ captureVarsExpr Nothing--      queryVarsExpr = do-        resultName <- Ghc.newName (Ghc.mkOccName Ghc.varName "_result_")-        pure $-          Ghc.mkHsLam [Ghc.nlVarPat resultName] $-            Ghc.nlHsApp-              (Ghc.nlHsApp-                (Ghc.nlHsApp (Ghc.nlHsVar runPromptName) srcLocStringExpr)-                (captureVarsExpr $ Just resultName)-              )-              (Ghc.nlHsVar resultName)--      queryVarsMExpr =-        Ghc.nlHsApp-          (Ghc.nlHsApp (Ghc.nlHsVar runPromptMName) srcLocStringExpr)-          $ captureVarsExpr Nothing--  if | captureVarsName == name -> do-         tell $ Any True-         pure (Just . Ghc.unLoc $ captureVarsExpr Nothing)--     | breakpointName == name -> do-         tell $ Any True-         Just . Ghc.unLoc <$> lift (lift bpExpr)--     | breakpointMName == name -> do-         tell $ Any True-         pure (Just $ Ghc.unLoc bpMExpr)--     | breakpointIOName == name -> do-         tell $ Any True-         pure (Just $ Ghc.unLoc bpIOExpr)--     | queryVarsIOName == name -> do-         tell $ Any True-         pure (Just $ Ghc.unLoc queryVarsIOExpr)--     | queryVarsName == name -> do-         tell $ Any True-         Just . Ghc.unLoc <$> lift (lift queryVarsExpr)--     | queryVarsMName == name -> do-         tell $ Any True-         pure (Just $ Ghc.unLoc queryVarsMExpr)--     | getSrcLocName == name ->-         pure (Just $ Ghc.unLoc srcLocStringExpr)--     | otherwise -> pure Nothing-hsVarCase _ = pure Nothing------------------------------------------------------------------------------------- App Expr-----------------------------------------------------------------------------------hsAppCase :: Ghc.LHsExpr Ghc.GhcRn-          -> EnvReader (Maybe (Ghc.LHsExpr Ghc.GhcRn))-hsAppCase (Ghc.unLoc -> Ghc.HsApp _ f innerExpr)-  | Ghc.HsApp _ (Ghc.unLoc -> Ghc.HsVar _ (Ghc.unLoc -> name))-                (Ghc.unLoc -> Ghc.ExplicitList' _ exprsToExclude)-      <- Ghc.unLoc f-  = do-    MkEnv{..} <- lift ask-    if excludeVarsName /= name-       then pure Nothing-       else do-         let extractVarName (Ghc.HsLit _ (Ghc.HsString _ fs)) =-               Just $ Ghc.mkLexicalFastString fs-             extractVarName (Ghc.HsOverLit _ (Ghc.OverLit' (Ghc.HsIsString _ fs))) =-               Just $ Ghc.mkLexicalFastString fs-             extractVarName _ = Nothing--             varsToExclude =-               mapMaybe (extractVarName . Ghc.unLoc) exprsToExclude--         Just <$>-           mapWriterT-            (local (overVarSet $ \vs -> foldr M.delete vs varsToExclude))-            (recurse innerExpr)-hsAppCase _ = pure Nothing------------------------------------------------------------------------------------- Match-----------------------------------------------------------------------------------matchCase :: Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)-          -> EnvReader (Maybe (Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))-matchCase Ghc.Match {..} = do-  let names = foldMap extractVarPats m_pats-  grhRes <- addScopedVars names $ recurse m_grhss-  pure $ Just-    Ghc.Match { Ghc.m_grhss = grhRes, .. }-#if !MIN_VERSION_ghc(9,0,0)-matchCase _ = pure Nothing-#endif--extractVarPats :: Ghc.LPat Ghc.GhcRn -> VarSet-extractVarPats = mkVarSet . Ghc.collectPatBinders'------------------------------------------------------------------------------------- Guarded Right-hand Sides-----------------------------------------------------------------------------------grhssCase :: Ghc.GRHSs Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)-         -> EnvReader (Maybe (Ghc.GRHSs Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))-grhssCase Ghc.GRHSs {..} = do-  (localBindsRes, names)-    <- dealWithLocalBinds-#if MIN_VERSION_ghc(9,2,0)-         grhssLocalBinds-#else-         (Ghc.unLoc grhssLocalBinds)-#endif--  grhsRes <- addScopedVars names $ recurse grhssGRHSs-  pure $ Just-    Ghc.GRHSs { Ghc.grhssGRHSs = grhsRes-#if MIN_VERSION_ghc(9,2,0)-              , grhssLocalBinds = localBindsRes-#else-              , grhssLocalBinds = localBindsRes <$ grhssLocalBinds-#endif-              , ..-              }-#if !MIN_VERSION_ghc(9,0,0)-grhssCase _ = pure Nothing-#endif--dealWithBind :: VarSet-             -> Ghc.LHsBind Ghc.GhcRn-             -> EnvReader (Ghc.LHsBind Ghc.GhcRn)-dealWithBind resultNames lbind = for lbind $ \case-  Ghc.FunBind {..} -> do-    let resultNamesSansSelf =-          M.delete (getOccNameFS $ Ghc.unLoc fun_id) resultNames-    (matchesRes, Any containsTarget)-      <- listen-       . addScopedVars resultNamesSansSelf-       $ recurse fun_matches-    -- be sure to use the result names on the right so that they are overriden-    -- by any shadowing vars inside the expr.-    let rhsVars-          | containsTarget-          = Ghc.mkUniqSet . M.elems-            . (<> resultNamesSansSelf) . mkVarSet-            $ Ghc.nonDetEltsUniqSet fun_ext-          | otherwise = fun_ext-    pure Ghc.FunBind { Ghc.fun_matches = matchesRes, Ghc.fun_ext = rhsVars, .. }--  Ghc.PatBind {..} -> do-    (rhsRes, Any containsTarget)-      <- listen-       . addScopedVars resultNames-       $ recurse pat_rhs-    let rhsVars-          | containsTarget-          = Ghc.mkUniqSet . M.elems-            . (<> resultNames) . mkVarSet-            $ Ghc.nonDetEltsUniqSet pat_ext-          | otherwise = pat_ext-    pure Ghc.PatBind { Ghc.pat_rhs = rhsRes, pat_ext = rhsVars, .. }--  -- Does this not occur in the renamer?-  Ghc.VarBind {..} -> do-    rhsRes-      <- addScopedVars resultNames-       $ recurse var_rhs-    pure Ghc.VarBind { Ghc.var_rhs = rhsRes, .. }--  Ghc.PatSynBind x Ghc.PSB {..} -> do-    (defRes, Any containsTarget)-      <- listen-       . addScopedVars resultNames-       $ recurse psb_def-    let rhsVars-          | containsTarget-          = Ghc.mkUniqSet . M.elems-            . (<> resultNames) . mkVarSet-            $ Ghc.nonDetEltsUniqSet psb_ext-          | otherwise = psb_ext-    pure $ Ghc.PatSynBind x Ghc.PSB { psb_def = defRes, psb_ext = rhsVars, .. }--#if !MIN_VERSION_ghc(9,4,0)-  other -> pure other-#endif--grhsCase :: Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)-         -> EnvReader (Maybe (Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))-grhsCase (Ghc.GRHS x guards body) = do-  (guardsRes, names) <- runWriterT $ dealWithStatements guards-  bodyRes <- addScopedVars names $ recurse body-  pure . Just $ Ghc.GRHS x guardsRes bodyRes-#if !MIN_VERSION_ghc(9,0,0)-grhsCase _ = pure Nothing-#endif------------------------------------------------------------------------------------- Let Binds (Non-do)------------------------------------------------------------------------------------- TODO could combine with hsVar case to allow for "quick failure"-hsLetCase :: Ghc.HsExpr Ghc.GhcRn-          -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))-hsLetCase (Ghc.HsLet' x letToken (Ghc.L loc localBinds) inToken inExpr) = do-  (bindsRes, names) <- dealWithLocalBinds localBinds--  inExprRes <- addScopedVars names $ recurse inExpr-  pure . Just $-    Ghc.HsLet' x letToken (Ghc.L loc bindsRes) inToken inExprRes-hsLetCase _ = pure Nothing--dealWithLocalBinds-  :: Ghc.HsLocalBinds Ghc.GhcRn-  -> EnvReader (Ghc.HsLocalBinds Ghc.GhcRn, VarSet)-dealWithLocalBinds = \case-  hlb@(Ghc.HsValBinds x valBinds) -> case valBinds of-    Ghc.ValBinds{} -> pure (hlb, mempty)-    Ghc.XValBindsLR (Ghc.NValBinds bindPairs sigs) -> do-      let binds = Ghc.bagToList-                . Ghc.unionManyBags-                $ map snd bindPairs :: [Ghc.LHsBind Ghc.GhcRn]-          names = map (foldMap Ghc.collectHsBindBinders')-                      binds-          resultNames = mkVarSet $ concat names--      (resBindsWithNames, Any containsTarget)-        <- listen-         . fmap (`zip` names)-         $ traverse (dealWithBind resultNames) binds--      if not containsTarget-         then pure (hlb, resultNames) -- if no bind contained the target then we're done-         else do-           -- Need to reorder the binds because the variables references on the-           -- RHS of some binds have changed-           let mkTuple (bind, ns)-                 = (bind, ns, foldMap getRhsFreeVars bind)--               finalResult = depAnalBinds $ mkTuple <$> resBindsWithNames--           pure ( Ghc.HsValBinds x-                    $ Ghc.XValBindsLR-                        $ Ghc.NValBinds finalResult sigs-                , resultNames-                )--  x@(Ghc.HsIPBinds _ _) -> pure (x, mempty) -- TODO ImplicitParams--  other -> pure (other, mempty)--getRhsFreeVars :: Ghc.HsBind Ghc.GhcRn -> Ghc.UniqSet Ghc.Name-getRhsFreeVars = \case-  Ghc.FunBind {..} -> fun_ext-  Ghc.PatBind {..} -> pat_ext-  Ghc.PatSynBind _ Ghc.PSB {..} -> psb_ext-  _ -> mempty------------------------------------------------------------------------------------- Do Block-----------------------------------------------------------------------------------hsDoCase :: Ghc.HsExpr Ghc.GhcRn-         -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))--- TODO look at the context to determine if it's a recursive do-hsDoCase (Ghc.HsDo x ctx lStmts) = do-  (stmtsRes, _) <- runWriterT $ for lStmts dealWithStatements-  pure . Just $ Ghc.HsDo x ctx stmtsRes-hsDoCase _ = pure Nothing--dealWithStatements-  :: (Data body, Data (Ghc.Stmt Ghc.GhcRn body))-  => [Ghc.LStmt Ghc.GhcRn body]-  -> WriterT VarSet EnvReader [Ghc.LStmt Ghc.GhcRn body]-dealWithStatements [] = pure []-dealWithStatements (lstmt : xs) = do-  (stmtRes, names) <- listen $ traverse dealWithStmt lstmt-  (stmtRes :) <$> mapWriterT (addScopedVars names) (dealWithStatements xs)--dealWithStmt :: (Data (Ghc.Stmt Ghc.GhcRn body), Data body)-             => Ghc.Stmt Ghc.GhcRn body-             -> WriterT VarSet EnvReader (Ghc.Stmt Ghc.GhcRn body)-dealWithStmt = \case-  Ghc.BindStmt' x lpat body bindExpr failExpr -> do-    let names = extractVarPats lpat-    tell names-    bodyRes <- lift $ recurse body-    pure $ Ghc.BindStmt' x lpat bodyRes bindExpr failExpr--  Ghc.LetStmt' x (Ghc.L loc localBinds) -> do-    (bindsRes, names) <- lift $ dealWithLocalBinds localBinds-    tell names-    pure $ Ghc.LetStmt' x (Ghc.L loc bindsRes)--  Ghc.ApplicativeStmt x pairs mbJoin -> do-    let dealWithAppArg = \case-          a@Ghc.ApplicativeArgOne{..} -> do-            tell $ extractVarPats app_arg_pattern-            pure a-          a@Ghc.ApplicativeArgMany{..} -> do-            tell $ extractVarPats bv_pattern-            (stmtsRes, _) <- lift . runWriterT $ dealWithStatements app_stmts-            pure a {Ghc.app_stmts = stmtsRes}-#if !MIN_VERSION_ghc(9,0,0)-          a -> lift $ gmapM recurse a-#endif-    pairsRes <- (traverse . traverse) dealWithAppArg pairs-    pure $ Ghc.ApplicativeStmt x pairsRes mbJoin--  other -> lift $ gmapM recurse other------------------------------------------------------------------------------------- Arrow Notation-----------------------------------------------------------------------------------hsProcCase :: Ghc.HsExpr Ghc.GhcRn-           -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))-hsProcCase (Ghc.HsProc x1 lpat cmdTop) = do-  let inputNames = extractVarPats lpat-  runMaybeT $ do-    cmdTopRes <- for cmdTop $ \case-      Ghc.HsCmdTop x2 lcmd -> do-        cmdRes <- for lcmd $ \case-          Ghc.HsCmdDo x3 lstmts -> do-            (stmtsRes, _) <- lift . runWriterT . for lstmts $ \stmts -> do-              tell inputNames-              mapWriterT (addScopedVars inputNames) $ dealWithStatements stmts-            pure $ Ghc.HsCmdDo x3 stmtsRes--          _ -> empty -- TODO what other cases should be handled?--        pure $ Ghc.HsCmdTop x2 cmdRes-#if !MIN_VERSION_ghc(9,0,0)-      _ -> empty-#endif-    pure $ Ghc.HsProc x1 lpat cmdTopRes-hsProcCase _ = pure Nothing------------------------------------------------------------------------------------- Env------------------------------------------------------------------------------------- The writer is for tracking if an inner expression contains the target name-type EnvReader = WriterT Any (ReaderT Env Ghc.TcM)--type VarSet = M.Map Ghc.LexicalFastString' Ghc.Name--data Env = MkEnv-  { varSet :: !VarSet-  , captureVarsName :: !Ghc.Name-  , showLevName :: !Ghc.Name-  , fromListName :: !Ghc.Name-  , breakpointName :: !Ghc.Name-  , queryVarsName :: !Ghc.Name-  , breakpointMName :: !Ghc.Name-  , queryVarsMName :: !Ghc.Name-  , breakpointIOName :: !Ghc.Name-  , queryVarsIOName :: !Ghc.Name-  , printAndWaitName :: !Ghc.Name-  , printAndWaitMName :: !Ghc.Name-  , printAndWaitIOName :: !Ghc.Name-  , runPromptIOName :: !Ghc.Name-  , runPromptName :: !Ghc.Name-  , runPromptMName :: !Ghc.Name-  , getSrcLocName :: !Ghc.Name-  , excludeVarsName :: !Ghc.Name-  }--overVarSet :: (VarSet -> VarSet) -> Env -> Env-overVarSet f env = env { varSet = f $ varSet env }--getOccNameFS :: Ghc.Name -> Ghc.LexicalFastString'-getOccNameFS = Ghc.mkLexicalFastString . Ghc.occNameFS . Ghc.getOccName--mkVarSet :: [Ghc.Name] -> VarSet-mkVarSet names = M.fromList $ (getOccNameFS &&& id) <$> names--addScopedVars :: VarSet -> EnvReader a -> EnvReader a-addScopedVars names = mapWriterT $ local (overVarSet (names <>))------------------------------------------------------------------------------------- Vendored from GHC-----------------------------------------------------------------------------------depAnalBinds :: [(Ghc.LHsBind Ghc.GhcRn, [Ghc.Name], Ghc.UniqSet Ghc.Name)]-             -> [(Ghc.RecFlag, Ghc.LHsBinds Ghc.GhcRn)]-depAnalBinds binds_w_dus-  = map get_binds sccs-  where-    sccs = Ghc.depAnal-             (\(_, defs, _) -> defs)-             (\(_, _, uses) -> Ghc.nonDetEltsUniqSet uses)-             binds_w_dus--    get_binds (Graph.AcyclicSCC (bind, _, _)) =-      (Ghc.NonRecursive, Ghc.unitBag bind)-    get_binds (Graph.CyclicSCC  binds_w_dus') =-      (Ghc.Recursive, Ghc.listToBag [b | (b,_,_) <- binds_w_dus'])------------------------------------------------------------------------------------- Type Checker Plugin-----------------------------------------------------------------------------------data TcPluginNames =-  MkTcPluginNames-    { showLevClassName :: !Ghc.Name-    , showClass :: !Ghc.Class-    , succeedClass :: !Ghc.Class-    , showWrapperTyCon :: !Ghc.TyCon-    }--tcPlugin :: Ghc.TcPlugin-tcPlugin = Ghc.TcPlugin-  { Ghc.tcPluginInit  = initTcPlugin-  , Ghc.tcPluginSolve = solver-  , Ghc.tcPluginStop = const $ pure ()-#if MIN_VERSION_ghc(9,4,0)-  , Ghc.tcPluginRewrite = mempty-#endif+  , Ghc.renamedResultAction = const Renamer.renameAction+  , Ghc.tcPlugin = const $ Just TypeChecker.tcPlugin   }--initTcPlugin :: Ghc.TcPluginM TcPluginNames-initTcPlugin = do-  Ghc.Found _ breakpointMod <--    Ghc.findImportedModule' (Ghc.mkModuleName "Debug.Breakpoint")-  Ghc.Found _ showMod <--    Ghc.findImportedModule' (Ghc.mkModuleName "GHC.Show")--  showLevClassName <- Plugin.lookupOrig breakpointMod (Ghc.mkClsOcc "ShowLev")-  showClass <- Plugin.tcLookupClass =<< Plugin.lookupOrig showMod (Ghc.mkClsOcc "Show")-  succeedClass <- Plugin.tcLookupClass =<< Plugin.lookupOrig breakpointMod (Ghc.mkClsOcc "Succeed")-  showWrapperTyCon <- Plugin.tcLookupTyCon =<< Plugin.lookupOrig breakpointMod (Ghc.mkClsOcc "ShowWrapper")--  pure MkTcPluginNames{..}--findShowLevWanted-  :: TcPluginNames-  -> Ghc.Ct-  -> Maybe (Either (Ghc.Type, Ghc.Ct) (Ghc.Type, Ghc.Ct))-findShowLevWanted names ct-  | Ghc.CDictCan{..} <- ct-  , showLevClassName names == Ghc.getName cc_class-  , [Ghc.TyConApp tyCon [], arg2] <- cc_tyargs-  = Just $ if Ghc.getName tyCon == Ghc.liftedRepName-       then Right (arg2, ct)-       else Left (arg2, ct)-  | otherwise = Nothing--solver :: TcPluginNames -> Ghc.TcPluginSolver-solver names _given _derived wanted = do-  instEnvs <- Plugin.getInstEnvs-  solved <- for (findShowLevWanted names `mapMaybe` wanted) $ \case-    Left (ty, ct) -> do -- unlifted type-      unshowableDict <- Ghc.unsafeTcPluginTcM $ buildUnshowableDict ty-      pure $ Just (unshowableDict, ct)-    Right (ty, ct) -> do-      mShowDict <- buildDict names (showClass names) [ty]-      pure $ mShowDict <&> \showDict ->-        let (succInst, _) = fromRight (error "impossible: no Succeed instance") $-              Ghc.lookupUniqueInstEnv instEnvs (succeedClass names) [ty]-         in (liftDict succInst ty (getEvExprFromDict showDict), ct)-  pure $ Ghc.TcPluginOk (catMaybes solved) []--buildDict-  :: TcPluginNames-  -> Ghc.Class-  -> [Ghc.Type]-  -> Ghc.TcPluginM (Maybe Ghc.EvTerm)-buildDict names cls tys = do-  instEnvs <- Plugin.getInstEnvs-  case Ghc.lookupUniqueInstEnv instEnvs cls tys of-    Right (clsInst, _) -> do-      let dfun = Ghc.is_dfun clsInst-          (vars, subclasses, inst) = Ghc.tcSplitSigmaTy $ Ghc.idType dfun-      if null subclasses-         then pure . Just $ Ghc.evDFunApp dfun [] [] -- why no use of vars here?-         else do-           let tyVarMap = mkTyVarMapping inst tys-           mSolvedSubClassDicts <- fmap sequence . for subclasses $ \subclass -> do-             let (subCls, subTys) = Ghc.tcSplitDFunHead subclass-                 subTys' = instantiateVars tyVarMap subTys-             buildDict names subCls subTys'-           pure $ do-             vars' <- traverse (tyVarMap M.!?) vars-             Ghc.evDFunApp dfun vars' . map getEvExprFromDict-               <$> mSolvedSubClassDicts-    Left _-      | cls == showClass names-      , [ty] <- tys -> do-          unshowableDict <- Ghc.unsafeTcPluginTcM $ buildUnshowableDict ty-          let (inst, _) = fromRight (error "impossible: no Show instance for ShowWrapper") $-                Ghc.lookupUniqueInstEnv-                  instEnvs-                  (showClass names)-                  [Ghc.mkTyConApp (showWrapperTyCon names) [ty]]-              liftedDict =-                liftDict inst ty (getEvExprFromDict unshowableDict)-          pure $ Just liftedDict-      | otherwise -> pure Nothing--getEvExprFromDict :: Ghc.EvTerm -> Ghc.EvExpr-getEvExprFromDict = \case-  Ghc.EvExpr expr -> expr-  _ -> error "invalid argument to getEvExprFromDict"--mkTyVarMapping-  :: Ghc.Type -- Wanted instance-  -> [Ghc.Type] -- Concrete types-  -> M.Map Ghc.TyVar Ghc.Type-mkTyVarMapping wanted tys =-  let wantedHead = snd $ Ghc.splitAppTys wanted-      wantedTyVars = concatMap (snd . Ghc.splitAppTys) wantedHead-      concreteTys = concatMap (snd . Ghc.splitAppTys) tys-   in M.fromList $ do-     (a, b) <- zip wantedTyVars concreteTys-     Just tyVar <- [Ghc.getTyVar_maybe a]-     pure (tyVar, b)--instantiateVars :: M.Map Ghc.TyVar Ghc.Type -> [Ghc.Type] -> [Ghc.Type]-instantiateVars tyVarMap tys = replace <$> tys-  where-    replace arg = fromMaybe arg $ do-      tyVar <- Ghc.getTyVar_maybe arg-      M.lookup tyVar tyVarMap -- this lookup shouldn't fail--buildUnshowableDict :: Ghc.Type -> Ghc.TcM Ghc.EvTerm-buildUnshowableDict ty = do-  let tyString = Ghc.showSDocOneLine' $ Ghc.pprTypeForUser' ty-  str <- Ghc.mkStringExpr $ "<" <> tyString <> ">"-  pure . Ghc.EvExpr $-    Ghc.mkCoreLams [Ghc.mkWildValBinder' ty] str--liftDict :: Ghc.ClsInst -> Ghc.Type -> Ghc.EvExpr -> Ghc.EvTerm-liftDict succ_inst ty dict = Ghc.evDFunApp (Ghc.is_dfun succ_inst) [ty] [dict]  -------------------------------------------------------------------------------- -- Showing

@@ -41,7 +41,6 @@ import           GHC.Types.Unique.Set as Ghc import           GHC.Utils.Outputable as Ghc import           GHC.Hs.Binds as Ghc-import           GHC.Rename.Bind as Ghc import           GHC.Data.Bag as Ghc import           GHC.Types.Basic as Ghc import           GHC.Types.Name.Env as Ghc@@ -59,6 +58,7 @@ import           GHC.Types.TyThing.Ppr as Ghc import           GHC.Hs.Expr as Ghc import           GHC.Types.PkgQual as Ghc+import           GHC.Tc.Types.Origin as Ghc  #elif MIN_VERSION_ghc(9,4,0) import           GHC.Driver.Plugins as Ghc hiding (TcPlugin)@@ -78,7 +78,6 @@ import           GHC.Types.Unique.Set as Ghc import           GHC.Utils.Outputable as Ghc import           GHC.Hs.Binds as Ghc-import           GHC.Rename.Bind as Ghc import           GHC.Data.Bag as Ghc import           GHC.Types.Basic as Ghc import           GHC.Types.Name.Env as Ghc@@ -96,6 +95,7 @@ import           GHC.Types.TyThing.Ppr as Ghc import           GHC.Hs.Expr as Ghc import           GHC.Types.PkgQual as Ghc+import           GHC.Tc.Types.Origin as Ghc  #elif MIN_VERSION_ghc(9,2,0) import           GHC.Driver.Plugins as Ghc hiding (TcPlugin)@@ -115,7 +115,6 @@ import           GHC.Types.Unique.Set as Ghc import           GHC.Utils.Outputable as Ghc import           GHC.Hs.Binds as Ghc-import           GHC.Rename.Bind as Ghc import           GHC.Data.Bag as Ghc import           GHC.Types.Basic as Ghc import           GHC.Types.Name.Env as Ghc@@ -132,6 +131,7 @@ import           GHC.Core.TyCon as Ghc import           GHC.Types.TyThing.Ppr as Ghc import           GHC.Hs.Expr as Ghc+import           GHC.Tc.Types.Origin as Ghc  #elif MIN_VERSION_ghc(9,0,0) import           GHC.Driver.Plugins as Ghc hiding (TcPlugin)@@ -150,7 +150,6 @@ import           GHC.Types.Unique.Set as Ghc import           GHC.Utils.Outputable as Ghc import           GHC.Hs.Binds as Ghc-import           GHC.Rename.Bind as Ghc import           GHC.Data.Bag as Ghc import           GHC.Types.Basic as Ghc import           GHC.Types.Name.Env as Ghc@@ -172,6 +171,7 @@ import           GHC.Hs.Pat as Ghc import           GHC.Hs.Decls as Ghc import           GHC.Hs.Lit as Ghc+import           GHC.Tc.Types.Origin as Ghc  #elif MIN_VERSION_ghc(8,10,0) import           GHC.Hs.Expr as Ghc@@ -211,6 +211,7 @@ import           Plugins as Ghc hiding (TcPlugin) import           DynFlags as Ghc import qualified TcPluginM as Plugin+import           TcOrigin as Ghc #endif  liftedRepName :: Ghc.Name

@@ -0,0 +1,545 @@+{-# LANGUAGE GADTs #-} -- for 8.10+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+module Debug.Breakpoint.Renamer+  ( renameAction+  ) where++import           Control.Applicative ((<|>), empty)+import           Control.Arrow ((&&&))+import           Control.Monad.Reader+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Writer.CPS+import           Data.Data hiding (IntRep, FloatRep)+import qualified Data.Graph as Graph+import qualified Data.Map.Lazy as M+import           Data.Maybe+import           Data.Monoid (Any(..))+import           Data.Traversable (for)++import qualified Debug.Breakpoint.GhcFacade as Ghc++renameAction+  :: Ghc.TcGblEnv+  -> Ghc.HsGroup Ghc.GhcRn+  -> Ghc.TcM (Ghc.TcGblEnv, Ghc.HsGroup Ghc.GhcRn)+renameAction gblEnv group = do+  Ghc.Found _ breakpointMod <-+    Ghc.findPluginModule' (Ghc.mkModuleName "Debug.Breakpoint")++  captureVarsName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "captureVars")+  showLevName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "showLev")+  fromListName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "fromAscList")+  breakpointName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "breakpoint")+  queryVarsName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "queryVars")+  breakpointMName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "breakpointM")+  queryVarsMName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "queryVarsM")+  breakpointIOName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "breakpointIO")+  queryVarsIOName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "queryVarsIO")+  printAndWaitName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "printAndWait")+  printAndWaitMName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "printAndWaitM")+  printAndWaitIOName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "printAndWaitIO")+  runPromptIOName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "runPromptIO")+  runPromptMName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "runPromptM")+  runPromptName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "runPrompt")+  getSrcLocName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "getSrcLoc")+  excludeVarsName <- Ghc.lookupOrig breakpointMod (Ghc.mkVarOcc "excludeVars")++  (group', _) <-+    runReaderT (runWriterT $ recurse group)+      MkEnv { varSet = mempty, .. }++  pure (gblEnv, group')++recurse :: Data a => a -> EnvReader a+recurse a =+  maybe (gmapM recurse a) pure+    =<< transform a++newtype T a = T (a -> EnvReader (Maybe a))++transform :: forall a. Data a => a -> EnvReader (Maybe a)+transform a = runMaybeT+      $ wrap hsVarCase+    <|> wrap hsAppCase+    <|> wrap matchCase+    <|> wrap grhssCase+    <|> wrap hsLetCase+    <|> wrap grhsCase+    <|> wrap hsDoCase+    <|> wrap hsProcCase+  where+    wrap :: forall b. Data b+         => (b -> EnvReader (Maybe b))+         -> MaybeT EnvReader a+    wrap f = do+      case gcast @b @a (T f) of+        Nothing -> empty+        Just (T f') -> MaybeT $ f' a++--------------------------------------------------------------------------------+-- Variable Expr+--------------------------------------------------------------------------------++hsVarCase :: Ghc.HsExpr Ghc.GhcRn+          -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))+hsVarCase (Ghc.HsVar _ (Ghc.L loc name)) = do+  MkEnv{..} <- lift ask++  let srcLocStringExpr+        = Ghc.nlHsLit . Ghc.mkHsString+        . Ghc.showSDocUnsafe+        . Ghc.ppr+        $ Ghc.locA' loc++      captureVarsExpr mResultName =+        let mkTuple (Ghc.fromLexicalFastString -> varStr, n) =+              Ghc.mkLHsTupleExpr+                [ Ghc.nlHsLit . Ghc.mkHsString $ Ghc.unpackFS varStr+                , Ghc.nlHsApp (Ghc.nlHsVar showLevName) (Ghc.nlHsVar n)+                ]+#if MIN_VERSION_ghc(9,2,0)+                Ghc.NoExtField+#endif++            mkList exprs = Ghc.noLocA' (Ghc.ExplicitList' Ghc.NoExtField exprs)++            varSetWithResult+              | Just resName <- mResultName =+                  M.insert (Ghc.mkLexicalFastString $ Ghc.mkFastString "*result")+                           resName+                           varSet+              | otherwise = varSet++         in Ghc.nlHsApp (Ghc.nlHsVar fromListName) . mkList+              $ mkTuple <$> M.toList varSetWithResult++      bpExpr = do+        resultName <- Ghc.newName (Ghc.mkOccName Ghc.varName "_result_")+        pure $+          Ghc.mkHsLam [Ghc.nlVarPat resultName] $+            Ghc.nlHsApp+              (Ghc.nlHsApp+                (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitName) srcLocStringExpr)+                (captureVarsExpr $ Just resultName)+              )+              (Ghc.nlHsVar resultName)++      bpMExpr =+        Ghc.nlHsApp+          (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitMName) srcLocStringExpr)+          $ captureVarsExpr Nothing++      bpIOExpr =+        Ghc.nlHsApp+          (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitIOName) srcLocStringExpr)+          $ captureVarsExpr Nothing++      queryVarsIOExpr =+        Ghc.nlHsApp+          (Ghc.nlHsApp (Ghc.nlHsVar runPromptIOName) srcLocStringExpr)+          $ captureVarsExpr Nothing++      queryVarsExpr = do+        resultName <- Ghc.newName (Ghc.mkOccName Ghc.varName "_result_")+        pure $+          Ghc.mkHsLam [Ghc.nlVarPat resultName] $+            Ghc.nlHsApp+              (Ghc.nlHsApp+                (Ghc.nlHsApp (Ghc.nlHsVar runPromptName) srcLocStringExpr)+                (captureVarsExpr $ Just resultName)+              )+              (Ghc.nlHsVar resultName)++      queryVarsMExpr =+        Ghc.nlHsApp+          (Ghc.nlHsApp (Ghc.nlHsVar runPromptMName) srcLocStringExpr)+          $ captureVarsExpr Nothing++  if | captureVarsName == name -> do+         tell $ Any True+         pure (Just . Ghc.unLoc $ captureVarsExpr Nothing)++     | breakpointName == name -> do+         tell $ Any True+         Just . Ghc.unLoc <$> lift (lift bpExpr)++     | breakpointMName == name -> do+         tell $ Any True+         pure (Just $ Ghc.unLoc bpMExpr)++     | breakpointIOName == name -> do+         tell $ Any True+         pure (Just $ Ghc.unLoc bpIOExpr)++     | queryVarsIOName == name -> do+         tell $ Any True+         pure (Just $ Ghc.unLoc queryVarsIOExpr)++     | queryVarsName == name -> do+         tell $ Any True+         Just . Ghc.unLoc <$> lift (lift queryVarsExpr)++     | queryVarsMName == name -> do+         tell $ Any True+         pure (Just $ Ghc.unLoc queryVarsMExpr)++     | getSrcLocName == name ->+         pure (Just $ Ghc.unLoc srcLocStringExpr)++     | otherwise -> pure Nothing+hsVarCase _ = pure Nothing++--------------------------------------------------------------------------------+-- App Expr+--------------------------------------------------------------------------------++hsAppCase :: Ghc.LHsExpr Ghc.GhcRn+          -> EnvReader (Maybe (Ghc.LHsExpr Ghc.GhcRn))+hsAppCase (Ghc.unLoc -> Ghc.HsApp _ f innerExpr)+  | Ghc.HsApp _ (Ghc.unLoc -> Ghc.HsVar _ (Ghc.unLoc -> name))+                (Ghc.unLoc -> Ghc.ExplicitList' _ exprsToExclude)+      <- Ghc.unLoc f+  = do+    MkEnv{..} <- lift ask+    if excludeVarsName /= name+       then pure Nothing+       else do+         let extractVarName (Ghc.HsLit _ (Ghc.HsString _ fs)) =+               Just $ Ghc.mkLexicalFastString fs+             extractVarName (Ghc.HsOverLit _ (Ghc.OverLit' (Ghc.HsIsString _ fs))) =+               Just $ Ghc.mkLexicalFastString fs+             extractVarName _ = Nothing++             varsToExclude =+               mapMaybe (extractVarName . Ghc.unLoc) exprsToExclude++         Just <$>+           mapWriterT+            (local (overVarSet $ \vs -> foldr M.delete vs varsToExclude))+            (recurse innerExpr)+hsAppCase _ = pure Nothing++--------------------------------------------------------------------------------+-- Match+--------------------------------------------------------------------------------++matchCase :: Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)+          -> EnvReader (Maybe (Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))+matchCase Ghc.Match {..} = do+  let names = foldMap extractVarPats m_pats+  grhRes <- addScopedVars names $ recurse m_grhss+  pure $ Just+    Ghc.Match { Ghc.m_grhss = grhRes, .. }+#if !MIN_VERSION_ghc(9,0,0)+matchCase _ = pure Nothing+#endif++extractVarPats :: Ghc.LPat Ghc.GhcRn -> VarSet+extractVarPats = mkVarSet . Ghc.collectPatBinders'++--------------------------------------------------------------------------------+-- Guarded Right-hand Sides+--------------------------------------------------------------------------------++grhssCase :: Ghc.GRHSs Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)+         -> EnvReader (Maybe (Ghc.GRHSs Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))+grhssCase Ghc.GRHSs {..} = do+  (localBindsRes, names)+    <- dealWithLocalBinds+#if MIN_VERSION_ghc(9,2,0)+         grhssLocalBinds+#else+         (Ghc.unLoc grhssLocalBinds)+#endif++  grhsRes <- addScopedVars names $ recurse grhssGRHSs+  pure $ Just+    Ghc.GRHSs { Ghc.grhssGRHSs = grhsRes+#if MIN_VERSION_ghc(9,2,0)+              , grhssLocalBinds = localBindsRes+#else+              , grhssLocalBinds = localBindsRes <$ grhssLocalBinds+#endif+              , ..+              }+#if !MIN_VERSION_ghc(9,0,0)+grhssCase _ = pure Nothing+#endif++dealWithBind :: VarSet+             -> Ghc.LHsBind Ghc.GhcRn+             -> EnvReader (Ghc.LHsBind Ghc.GhcRn)+dealWithBind resultNames lbind = for lbind $ \case+  Ghc.FunBind {..} -> do+    let resultNamesSansSelf =+          M.delete (getOccNameFS $ Ghc.unLoc fun_id) resultNames+    (matchesRes, Any containsTarget)+      <- listen+       . addScopedVars resultNamesSansSelf+       $ recurse fun_matches+    -- be sure to use the result names on the right so that they are overriden+    -- by any shadowing vars inside the expr.+    let rhsVars+          | containsTarget+          = Ghc.mkUniqSet . M.elems+            . (<> resultNamesSansSelf) . mkVarSet+            $ Ghc.nonDetEltsUniqSet fun_ext+          | otherwise = fun_ext+    pure Ghc.FunBind { Ghc.fun_matches = matchesRes, Ghc.fun_ext = rhsVars, .. }++  Ghc.PatBind {..} -> do+    (rhsRes, Any containsTarget)+      <- listen+       . addScopedVars resultNames+       $ recurse pat_rhs+    let rhsVars+          | containsTarget+          = Ghc.mkUniqSet . M.elems+            . (<> resultNames) . mkVarSet+            $ Ghc.nonDetEltsUniqSet pat_ext+          | otherwise = pat_ext+    pure Ghc.PatBind { Ghc.pat_rhs = rhsRes, pat_ext = rhsVars, .. }++  -- Does this not occur in the renamer?+  Ghc.VarBind {..} -> do+    rhsRes+      <- addScopedVars resultNames+       $ recurse var_rhs+    pure Ghc.VarBind { Ghc.var_rhs = rhsRes, .. }++  Ghc.PatSynBind x Ghc.PSB {..} -> do+    (defRes, Any containsTarget)+      <- listen+       . addScopedVars resultNames+       $ recurse psb_def+    let rhsVars+          | containsTarget+          = Ghc.mkUniqSet . M.elems+            . (<> resultNames) . mkVarSet+            $ Ghc.nonDetEltsUniqSet psb_ext+          | otherwise = psb_ext+    pure $ Ghc.PatSynBind x Ghc.PSB { psb_def = defRes, psb_ext = rhsVars, .. }++#if !MIN_VERSION_ghc(9,4,0)+  other -> pure other+#endif++grhsCase :: Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)+         -> EnvReader (Maybe (Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)))+grhsCase (Ghc.GRHS x guards body) = do+  (guardsRes, names) <- runWriterT $ dealWithStatements guards+  bodyRes <- addScopedVars names $ recurse body+  pure . Just $ Ghc.GRHS x guardsRes bodyRes+#if !MIN_VERSION_ghc(9,0,0)+grhsCase _ = pure Nothing+#endif++--------------------------------------------------------------------------------+-- Let Binds (Non-do)+--------------------------------------------------------------------------------++-- TODO could combine with hsVar case to allow for "quick failure"+hsLetCase :: Ghc.HsExpr Ghc.GhcRn+          -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))+hsLetCase (Ghc.HsLet' x letToken (Ghc.L loc localBinds) inToken inExpr) = do+  (bindsRes, names) <- dealWithLocalBinds localBinds++  inExprRes <- addScopedVars names $ recurse inExpr+  pure . Just $+    Ghc.HsLet' x letToken (Ghc.L loc bindsRes) inToken inExprRes+hsLetCase _ = pure Nothing++dealWithLocalBinds+  :: Ghc.HsLocalBinds Ghc.GhcRn+  -> EnvReader (Ghc.HsLocalBinds Ghc.GhcRn, VarSet)+dealWithLocalBinds = \case+  hlb@(Ghc.HsValBinds x valBinds) -> case valBinds of+    Ghc.ValBinds{} -> pure (hlb, mempty)+    Ghc.XValBindsLR (Ghc.NValBinds bindPairs sigs) -> do+      let binds = Ghc.bagToList+                . Ghc.unionManyBags+                $ map snd bindPairs :: [Ghc.LHsBind Ghc.GhcRn]+          names = map (foldMap Ghc.collectHsBindBinders')+                      binds+          resultNames = mkVarSet $ concat names++      (resBindsWithNames, Any containsTarget)+        <- listen+         . fmap (`zip` names)+         $ traverse (dealWithBind resultNames) binds++      if not containsTarget+         then pure (hlb, resultNames) -- if no bind contained the target then we're done+         else do+           -- Need to reorder the binds because the variables references on the+           -- RHS of some binds have changed+           let mkTuple (bind, ns)+                 = (bind, ns, foldMap getRhsFreeVars bind)++               finalResult = depAnalBinds $ mkTuple <$> resBindsWithNames++           pure ( Ghc.HsValBinds x+                    $ Ghc.XValBindsLR+                        $ Ghc.NValBinds finalResult sigs+                , resultNames+                )++  x@(Ghc.HsIPBinds _ _) -> pure (x, mempty) -- TODO ImplicitParams++  other -> pure (other, mempty)++getRhsFreeVars :: Ghc.HsBind Ghc.GhcRn -> Ghc.UniqSet Ghc.Name+getRhsFreeVars = \case+  Ghc.FunBind {..} -> fun_ext+  Ghc.PatBind {..} -> pat_ext+  Ghc.PatSynBind _ Ghc.PSB {..} -> psb_ext+  _ -> mempty++--------------------------------------------------------------------------------+-- Do Block+--------------------------------------------------------------------------------++hsDoCase :: Ghc.HsExpr Ghc.GhcRn+         -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))+-- TODO look at the context to determine if it's a recursive do+hsDoCase (Ghc.HsDo x ctx lStmts) = do+  (stmtsRes, _) <- runWriterT $ for lStmts dealWithStatements+  pure . Just $ Ghc.HsDo x ctx stmtsRes+hsDoCase _ = pure Nothing++dealWithStatements+  :: (Data body, Data (Ghc.Stmt Ghc.GhcRn body))+  => [Ghc.LStmt Ghc.GhcRn body]+  -> WriterT VarSet EnvReader [Ghc.LStmt Ghc.GhcRn body]+dealWithStatements [] = pure []+dealWithStatements (lstmt : xs) = do+  (stmtRes, names) <- listen $ traverse dealWithStmt lstmt+  (stmtRes :) <$> mapWriterT (addScopedVars names) (dealWithStatements xs)++dealWithStmt :: (Data (Ghc.Stmt Ghc.GhcRn body), Data body)+             => Ghc.Stmt Ghc.GhcRn body+             -> WriterT VarSet EnvReader (Ghc.Stmt Ghc.GhcRn body)+dealWithStmt = \case+  Ghc.BindStmt' x lpat body bindExpr failExpr -> do+    let names = extractVarPats lpat+    tell names+    bodyRes <- lift $ recurse body+    pure $ Ghc.BindStmt' x lpat bodyRes bindExpr failExpr++  Ghc.LetStmt' x (Ghc.L loc localBinds) -> do+    (bindsRes, names) <- lift $ dealWithLocalBinds localBinds+    tell names+    pure $ Ghc.LetStmt' x (Ghc.L loc bindsRes)++  Ghc.ApplicativeStmt x pairs mbJoin -> do+    let dealWithAppArg = \case+          a@Ghc.ApplicativeArgOne{..} -> do+            tell $ extractVarPats app_arg_pattern+            pure a+          a@Ghc.ApplicativeArgMany{..} -> do+            tell $ extractVarPats bv_pattern+            (stmtsRes, _) <- lift . runWriterT $ dealWithStatements app_stmts+            pure a {Ghc.app_stmts = stmtsRes}+#if !MIN_VERSION_ghc(9,0,0)+          a -> lift $ gmapM recurse a+#endif+    pairsRes <- (traverse . traverse) dealWithAppArg pairs+    pure $ Ghc.ApplicativeStmt x pairsRes mbJoin++  other -> lift $ gmapM recurse other++--------------------------------------------------------------------------------+-- Arrow Notation+--------------------------------------------------------------------------------++hsProcCase :: Ghc.HsExpr Ghc.GhcRn+           -> EnvReader (Maybe (Ghc.HsExpr Ghc.GhcRn))+hsProcCase (Ghc.HsProc x1 lpat cmdTop) = do+  let inputNames = extractVarPats lpat+  runMaybeT $ do+    cmdTopRes <- for cmdTop $ \case+      Ghc.HsCmdTop x2 lcmd -> do+        cmdRes <- for lcmd $ \case+          Ghc.HsCmdDo x3 lstmts -> do+            (stmtsRes, _) <- lift . runWriterT . for lstmts $ \stmts -> do+              tell inputNames+              mapWriterT (addScopedVars inputNames) $ dealWithStatements stmts+            pure $ Ghc.HsCmdDo x3 stmtsRes++          _ -> empty -- TODO what other cases should be handled?++        pure $ Ghc.HsCmdTop x2 cmdRes+#if !MIN_VERSION_ghc(9,0,0)+      _ -> empty+#endif+    pure $ Ghc.HsProc x1 lpat cmdTopRes+hsProcCase _ = pure Nothing++--------------------------------------------------------------------------------+-- Env+--------------------------------------------------------------------------------++-- The writer is for tracking if an inner expression contains the target name+type EnvReader = WriterT Any (ReaderT Env Ghc.TcM)++type VarSet = M.Map Ghc.LexicalFastString' Ghc.Name++data Env = MkEnv+  { varSet :: !VarSet+  , captureVarsName :: !Ghc.Name+  , showLevName :: !Ghc.Name+  , fromListName :: !Ghc.Name+  , breakpointName :: !Ghc.Name+  , queryVarsName :: !Ghc.Name+  , breakpointMName :: !Ghc.Name+  , queryVarsMName :: !Ghc.Name+  , breakpointIOName :: !Ghc.Name+  , queryVarsIOName :: !Ghc.Name+  , printAndWaitName :: !Ghc.Name+  , printAndWaitMName :: !Ghc.Name+  , printAndWaitIOName :: !Ghc.Name+  , runPromptIOName :: !Ghc.Name+  , runPromptName :: !Ghc.Name+  , runPromptMName :: !Ghc.Name+  , getSrcLocName :: !Ghc.Name+  , excludeVarsName :: !Ghc.Name+  }++overVarSet :: (VarSet -> VarSet) -> Env -> Env+overVarSet f env = env { varSet = f $ varSet env }++getOccNameFS :: Ghc.Name -> Ghc.LexicalFastString'+getOccNameFS = Ghc.mkLexicalFastString . Ghc.occNameFS . Ghc.getOccName++mkVarSet :: [Ghc.Name] -> VarSet+mkVarSet names = M.fromList $ (getOccNameFS &&& id) <$> names++addScopedVars :: VarSet -> EnvReader a -> EnvReader a+addScopedVars names = mapWriterT $ local (overVarSet (names <>))++--------------------------------------------------------------------------------+-- Vendored from GHC+--------------------------------------------------------------------------------++depAnalBinds :: [(Ghc.LHsBind Ghc.GhcRn, [Ghc.Name], Ghc.UniqSet Ghc.Name)]+             -> [(Ghc.RecFlag, Ghc.LHsBinds Ghc.GhcRn)]+depAnalBinds binds_w_dus+  = map get_binds sccs+  where+    sccs = Ghc.depAnal+             (\(_, defs, _) -> defs)+             (\(_, _, uses) -> Ghc.nonDetEltsUniqSet uses)+             binds_w_dus++    get_binds (Graph.AcyclicSCC (bind, _, _)) =+      (Ghc.NonRecursive, Ghc.unitBag bind)+    get_binds (Graph.CyclicSCC  binds_w_dus') =+      (Ghc.Recursive, Ghc.listToBag [b | (b,_,_) <- binds_w_dus'])+

@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Debug.Breakpoint.TimerManager

@@ -0,0 +1,165 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+module Debug.Breakpoint.TypeChecker+  ( tcPlugin+  ) where++import           Data.Either+import           Data.Maybe+import           Data.Traversable (for)+#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Tc.Plugin as Plugin+#else+import qualified TcPluginM as Plugin+#endif++import qualified Debug.Breakpoint.GhcFacade as Ghc++--------------------------------------------------------------------------------+-- Type Checker Plugin+--------------------------------------------------------------------------------++data TcPluginNames =+  MkTcPluginNames+    { showLevClassName :: !Ghc.Name+    , showLevNameTc :: !Ghc.Name+    , showClass :: !Ghc.Class+    , succeedClass :: !Ghc.Class+    , showWrapperTyCon :: !Ghc.TyCon+    }++tcPlugin :: Ghc.TcPlugin+tcPlugin = Ghc.TcPlugin+  { Ghc.tcPluginInit  = initTcPlugin+  , Ghc.tcPluginSolve = solver+  , Ghc.tcPluginStop = const $ pure ()+#if MIN_VERSION_ghc(9,4,0)+  , Ghc.tcPluginRewrite = mempty+#endif+  }++initTcPlugin :: Ghc.TcPluginM TcPluginNames+initTcPlugin = do+  Ghc.Found _ breakpointMod <-+    Ghc.findImportedModule' (Ghc.mkModuleName "Debug.Breakpoint")+  Ghc.Found _ showMod <-+    Ghc.findImportedModule' (Ghc.mkModuleName "GHC.Show")++  showLevClassName <- Plugin.lookupOrig breakpointMod (Ghc.mkClsOcc "ShowLev")+  showLevNameTc <- Plugin.lookupOrig breakpointMod (Ghc.mkVarOcc "showLev")+  showClass <- Plugin.tcLookupClass =<< Plugin.lookupOrig showMod (Ghc.mkClsOcc "Show")+  succeedClass <- Plugin.tcLookupClass =<< Plugin.lookupOrig breakpointMod (Ghc.mkClsOcc "Succeed")+  showWrapperTyCon <- Plugin.tcLookupTyCon =<< Plugin.lookupOrig breakpointMod (Ghc.mkClsOcc "ShowWrapper")++  pure MkTcPluginNames{..}++data FindWantedResult+  = FoundLifted Ghc.Type Ghc.Ct+  | FoundUnlifted Ghc.Type Ghc.Ct+  | NotFound++findShowLevWanted+  :: TcPluginNames+  -> Ghc.Ct+  -> FindWantedResult+findShowLevWanted names ct+  | Ghc.CDictCan{..} <- ct+  , showLevClassName names == Ghc.getName cc_class+  , [Ghc.TyConApp tyCon [], arg2] <- cc_tyargs+  = if Ghc.getName tyCon == Ghc.liftedRepName+       then FoundLifted arg2 ct+       else FoundUnlifted arg2 ct+  | otherwise = NotFound++findShowWithSuperclass+  :: TcPluginNames+  -> Ghc.Ct+  -> Maybe (Ghc.Type, Ghc.Ct)+findShowWithSuperclass names ct+  | Ghc.CDictCan{..} <- ct+  , Ghc.getName (showClass names) == Ghc.getName cc_class+  , hasShowLevSuperclass . Ghc.ctLocOrigin $ Ghc.ctev_loc cc_ev+  , [arg] <- cc_tyargs+  = Just (arg, ct)+  | otherwise = Nothing+  where+    hasShowLevSuperclass (Ghc.OccurrenceOf name)+      = name == showLevNameTc names+    hasShowLevSuperclass _ = False++solver :: TcPluginNames -> Ghc.TcPluginSolver+solver names _given _derived wanted = do+  instEnvs <- Plugin.getInstEnvs++  -- Check if wanted is ShowLev+  --   * Create a new wanted for Show+  --   * Use its EvBindId as the inner dict for ShowLev+  --   * Emit the new wanted+  (showLevDicts, mNewWanteds) <- fmap (unzip . catMaybes) $+    for (findShowLevWanted names <$> wanted) $ \case+      FoundUnlifted ty ct -> do+        unshowableDict <- Ghc.unsafeTcPluginTcM $ buildUnshowableDict ty+        pure $ Just ((unshowableDict, ct), Nothing)+      FoundLifted ty ct -> do+        (showDict, newWanted) <- buildShowLevDict names ct ty+        let (succInst, _) = fromRight (error "impossible: no Succeed instance") $+              Ghc.lookupUniqueInstEnv instEnvs (succeedClass names) [ty]+        pure $ Just+          ((liftDict succInst ty (getEvExprFromDict showDict), ct)+          , Just newWanted+          )+      NotFound -> pure Nothing++  -- Check if wanted is Show that arises from a use of showLev and create the+  -- missing Show dict if so.+  unshowableDicts <- for (findShowWithSuperclass names `mapMaybe` wanted) $+    \(ty, ct) -> do+        dict <- lookupUnshowableDict names ty+        pure (dict, ct)++  pure $ Ghc.TcPluginOk+           (showLevDicts ++ unshowableDicts)+           (catMaybes mNewWanteds)++buildShowLevDict+  :: TcPluginNames+  -> Ghc.Ct+  -> Ghc.Type+  -> Ghc.TcPluginM (Ghc.EvTerm, Ghc.Ct)+buildShowLevDict names showLevWanted ty = do+  showWantedEv <-+    Plugin.newWanted+      (Ghc.ctLoc showLevWanted)+      (Ghc.mkTyConApp (Ghc.classTyCon $ showClass names) [ty])+  let showCt = Ghc.mkNonCanonical showWantedEv+  pure (Ghc.ctEvTerm showWantedEv, showCt)++lookupUnshowableDict+  :: TcPluginNames+  -> Ghc.Type+  -> Ghc.TcPluginM Ghc.EvTerm+lookupUnshowableDict names ty = do+  instEnvs <- Plugin.getInstEnvs+  unshowableDict <- Ghc.unsafeTcPluginTcM $ buildUnshowableDict ty+  let (inst, _) = fromRight (error "impossible: no Show instance for ShowWrapper") $+        Ghc.lookupUniqueInstEnv+          instEnvs+          (showClass names)+          [Ghc.mkTyConApp (showWrapperTyCon names) [ty]]+  pure $ liftDict inst ty (getEvExprFromDict unshowableDict)++getEvExprFromDict :: Ghc.EvTerm -> Ghc.EvExpr+getEvExprFromDict = \case+  Ghc.EvExpr expr -> expr+  _ -> error "invalid argument to getEvExprFromDict"++buildUnshowableDict :: Ghc.Type -> Ghc.TcM Ghc.EvTerm+buildUnshowableDict ty = do+  let tyString = Ghc.showSDocOneLine' $ Ghc.pprTypeForUser' ty+  str <- Ghc.mkStringExpr $ "<" <> tyString <> ">"+  pure . Ghc.EvExpr $+    Ghc.mkCoreLams [Ghc.mkWildValBinder' ty] str++liftDict :: Ghc.ClsInst -> Ghc.Type -> Ghc.EvExpr -> Ghc.EvTerm+liftDict succ_inst ty dict = Ghc.evDFunApp (Ghc.is_dfun succ_inst) [ty] [dict]

@@ -1,3 +1,7 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Arrows #-}@@ -6,6 +10,7 @@ import           Data.Fixed import qualified Data.Map as M import           Data.Maybe+import           GHC.Records (HasField(..)) import           Test.Tasty import           Test.Tasty.HUnit @@ -42,6 +47,7 @@     , testCase "don't capture do bind in its body" captureInBodyOfDoBind     , testCase "Shows type that subclass for Show" showFixedPointNumber     , testCase "exclude vars" excludeVarsTest+    , testCase "built-in instance subclasses" showBuiltinSubclass     , ApDo.testTree     , OS.testTree     ]@@ -251,3 +257,20 @@   let x = True       y = False    in excludeVars ["y"] captureVars++showBuiltinSubclass :: Assertion+showBuiltinSubclass = do+  let m = test24+  m @?= M.fromList [("x", "1"), ("y", "91.00")]++test24 :: M.Map String String+test24 =+  let x = HF $ FFF 1+      y = 91 :: Fixed 91+   in captureVars++newtype HF a = HF a+instance (HasField "fff" a b, Show b) => Show (HF a) where+  show (HF a) = show $ getField @"fff" a++newtype FFF = FFF { fff :: Int }