breakpoint (empty) → 0.1.0.0
raw patch · 7 files changed
+1428/−0 lines, 7 filesdep +basedep +breakpointdep +containers
Dependencies added: base, breakpoint, containers, ghc, haskeline, mtl, tasty, tasty-hunit, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- breakpoint.cabal +53/−0
- src/Debug/Breakpoint.hs +857/−0
- src/Debug/Breakpoint/GhcFacade.hs +249/−0
- test/ApplicativeDo.hs +44/−0
- test/Spec.hs +200/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for breakpoint++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2022 Aaron Allen++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ breakpoint.cabal view
@@ -0,0 +1,53 @@+cabal-version: 3.0+name: breakpoint+version: 0.1.0.0+synopsis:+ Set breakpoints using a GHC plugin++description:+ A plugin that allows you to set breakpoints for debugging purposes.++ See the [README](https://github.com/aaronallen8455/breakpoint#breakpoint) for details.++-- A URL where users can report bugs.+-- bug-reports:+license: MIT+license-file: LICENSE+author: Aaron Allen+maintainer: aaronallen8455@gmail.com+tested-with: GHC==9.2.2, GHC==9.0.2, GHC==8.10.7+bug-reports: https://github.com/aaronallen8455/breakpoint/issues++-- A copyright notice.+-- copyright:+category: Development+extra-source-files: CHANGELOG.md++library+ exposed-modules: Debug.Breakpoint,+ Debug.Breakpoint.GhcFacade++ -- Modules included in this library but not exported.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ build-depends: base >=4.14.0.0 && <4.17.0.0,+ ghc,+ containers,+ mtl,+ transformers,+ haskeline+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ -Wno-unticked-promoted-constructors++test-suite spec+ main-is: Spec.hs+ other-modules: ApplicativeDo+ hs-source-dirs: test+ build-depends: base, tasty, tasty-hunit, breakpoint, containers+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ ghc-options: -fplugin Debug.Breakpoint
+ src/Debug/Breakpoint.hs view
@@ -0,0 +1,857 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+module Debug.Breakpoint+ ( plugin+ , captureVars+ , showLev+ , fromAscList+ , printAndWait+ , printAndWaitM+ , printAndWaitIO+ , runPrompt+ , runPromptM+ , runPromptIO+ , breakpoint+ , queryVars+ , breakpointM+ , queryVarsM+ , breakpointIO+ , queryVarsIO+ , getSrcLoc+ ) where++import Control.Applicative ((<|>), empty)+import Control.Arrow ((&&&))+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 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.Haskeline as HL+import System.IO.Unsafe (unsafePerformIO)++import qualified Debug.Breakpoint.GhcFacade as Ghc++--------------------------------------------------------------------------------+-- API+--------------------------------------------------------------------------------++-- | Constructs a lazy 'Map' from the names of all visible variables at the call+-- site to a string representation of their value. Be careful about binding this+-- to a variable because that variable will also be captured, resulting in an+-- infinite loop if that element of the Map is evaluated.+captureVars :: M.Map String String+captureVars = mempty++-- re-exported to avoid requiring the client to depend on the containers package+fromAscList :: Ord k => [(k, v)] -> M.Map k v+fromAscList = M.fromAscList++printAndWait :: String -> M.Map String String -> a -> a+printAndWait srcLoc vars x =+ unsafePerformIO $ printAndWaitIO srcLoc vars >> pure x+{-# NOINLINE printAndWait #-}++printAndWaitM :: Applicative m => String -> M.Map String String -> m ()+printAndWaitM srcLoc vars = printAndWait srcLoc vars $ pure ()++printAndWaitIO :: MonadIO m => String -> M.Map String String -> m ()+printAndWaitIO srcLoc vars = liftIO $ do+ traceIO $ L.intercalate "\n"+ [ color "31" "### Breakpoint Hit ###"+ , color "37" "(" <> srcLoc <> ")"+ , printVars vars+ , color "32" "Press enter to continue"+ ]+ _ <- blockOnInput+ pure ()++runPrompt :: String -> M.Map String String -> a -> a+runPrompt srcLoc vars x =+ unsafePerformIO $ runPromptIO srcLoc vars >> pure x+{-# NOINLINE runPrompt #-}++runPromptM :: Applicative m => String -> M.Map String String -> m ()+runPromptM srcLoc vars = runPrompt srcLoc vars $ pure ()++runPromptIO :: MonadIO m => String -> M.Map String String -> m ()+runPromptIO srcLoc vars = liftIO . HL.runInputTBehavior HL.defaultBehavior settings $ do+ HL.outputStrLn . unlines $+ [ color "31" "### Breakpoint Hit ###"+ , color "37" $ "(" <> srcLoc <> ")"+ ] ++ (color "36" <$> varNames)+ inputLoop+ where+ varNames = M.keys vars+ settings = HL.setComplete completion HL.defaultSettings+ completion = HL.completeWord' Nothing isSpace $ \str ->+ pure $ HL.simpleCompletion+ <$> filter (str `L.isPrefixOf`) varNames+ printVar var val = HL.outputStrLn $ color "36" (var ++ " = ") ++ val+ inputLoop = do+ mInp <- HL.getInputLine $ color "32" "Enter variable name: "+ case mInp of+ Just (L.dropWhileEnd isSpace . dropWhile isSpace -> inp)+ | not (null inp) -> do+ traverse_ (printVar inp) $ M.lookup inp vars+ inputLoop+ _ -> pure ()++color :: String -> String -> String+color c s = "\ESC[" <> c <> "m\STX" <> s <> "\ESC[m\STX"++printVars :: M.Map String String -> String+printVars vars =+ let mkLine (k, v) = color "36" (k <> " = ") <> v+ in unlines $ mkLine <$> M.toList vars++inactivePluginStr :: String+inactivePluginStr =+ "Cannot set breakpoint: the Debug.Trace plugin is not active"++-- | Sets a breakpoint in pure code+breakpoint :: a -> a+breakpoint = trace inactivePluginStr++-- | When evaluated, displays the names of variables visible from the callsite+-- and starts a prompt where entering a variable will display its value. You+-- may want to use this instead of 'breakpoint' if there are value which should+-- stay unevaluated or you are only interested in certain values. Only the+-- current thread is blocked while the prompt is active. To resume execution,+-- press enter with a blank prompt.+queryVars :: a -> a+queryVars = trace inactivePluginStr++-- | Similar to 'queryVars' but for use in an arbitrary 'Applicative' context.+-- This uses 'unsafePerformIO' which means that laziness and common sub-expression+-- elimination can result in unexpected behavior. For this reason you should+-- prefer 'queryVarsIO' if a 'MonadIO' instance is available.+queryVarsM :: Applicative m => m ()+queryVarsM = traceM inactivePluginStr++-- | Similar to 'queryVars' but specialized to an 'IO' context. You should favor+-- this over 'queryVarsM' if a 'MonadIO' instance is available.+queryVarsIO :: MonadIO m => m ()+queryVarsIO =+ liftIO (traceIO inactivePluginStr)++-- | Sets a breakpoint in an arbitrary 'Applicative'. Uses 'unsafePerformIO'+-- which means that laziness and common sub-expression elimination can result+-- in the breakpoint not being hit as expected. For this reason, you should+-- prefer 'breakpointIO' if a `MonadIO` instance is available.+breakpointM :: Applicative m => m ()+breakpointM = traceM inactivePluginStr++-- | Sets a breakpoint in an 'IO' based 'Monad'. You should favor this over+-- 'breakpointM' if the monad can perform IO.+breakpointIO :: MonadIO m => m ()+breakpointIO =+ liftIO (traceIO inactivePluginStr)++-- | Pretty prints the source code location of its call site+getSrcLoc :: String+getSrcLoc = ""++#if MIN_VERSION_ghc(9,2,0)+-- Use an "unsafe" foreign function to more or less stop the runtime.+-- In older GHCs this can cause out of control CPU usage so settle for getLine instead+foreign import ccall unsafe "stdio.h getchar" blockOnInput :: IO Int+#else+blockOnInput :: IO Int+blockOnInput = 1 <$ getLine+#endif++--------------------------------------------------------------------------------+-- Plugin+--------------------------------------------------------------------------------++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+ hscEnv <- Ghc.getTopEnv+ Ghc.Found _ breakpointMod <- liftIO $+ Ghc.findPluginModule hscEnv (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")++ let (group', _) =+ runReader (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 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 =+ 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)++ in Ghc.nlHsApp (Ghc.nlHsVar fromListName) . mkList+ $ mkTuple <$> M.toList varSet++ bpExpr =+ Ghc.nlHsApp+ (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitName) srcLocStringExpr)+ captureVarsExpr++ bpMExpr =+ Ghc.nlHsApp+ (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitMName) srcLocStringExpr)+ captureVarsExpr++ bpIOExpr =+ Ghc.nlHsApp+ (Ghc.nlHsApp (Ghc.nlHsVar printAndWaitIOName) srcLocStringExpr)+ captureVarsExpr++ queryVarsIOExpr =+ Ghc.nlHsApp+ (Ghc.nlHsApp (Ghc.nlHsVar runPromptIOName) srcLocStringExpr)+ captureVarsExpr++ queryVarsExpr =+ Ghc.nlHsApp+ (Ghc.nlHsApp (Ghc.nlHsVar runPromptName) srcLocStringExpr)+ captureVarsExpr++ queryVarsMExpr =+ Ghc.nlHsApp+ (Ghc.nlHsApp (Ghc.nlHsVar runPromptMName) srcLocStringExpr)+ captureVarsExpr++ if | captureVarsName == name -> do+ tell $ Any True+ pure (Just $ Ghc.unLoc captureVarsExpr)++ | breakpointName == name -> do+ tell $ Any True+ pure (Just $ Ghc.unLoc 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+ pure (Just $ Ghc.unLoc 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++--------------------------------------------------------------------------------+-- 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+ (matchesRes, Any containsTarget)+ <- listen+ . addScopedVars resultNames+ $ 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+ . (<> resultNames) . 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, .. }++ other -> pure other++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 (Ghc.L loc localBinds) inExpr) = do+ (bindsRes, names) <- dealWithLocalBinds localBinds++ inExprRes <- addScopedVars names $ recurse inExpr+ pure . Just $+ Ghc.HsLet' x (Ghc.L loc bindsRes) 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 . addScopedVars names $ 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 (Reader Env)++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+ }++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 ()+ }++initTcPlugin :: Ghc.TcPluginM TcPluginNames+initTcPlugin = do+ Ghc.Found _ breakpointMod <-+ Plugin.findImportedModule (Ghc.mkModuleName "Debug.Breakpoint") Nothing+ Ghc.Found _ showMod <-+ Plugin.findImportedModule (Ghc.mkModuleName "GHC.Show") (Just $ Ghc.fsLit "base")++ 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 (showClass names) 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+ cls+ [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.showSDocUnsafe $ 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+--------------------------------------------------------------------------------++-- | Levity polymorphic 'Show'+class ShowLev (rep :: Exts.RuntimeRep) (a :: Exts.TYPE rep) where+ showLev :: a -> String++instance ShowLev 'Exts.IntRep Exts.Int# where+ showLev i = show $ I# i++#if MIN_VERSION_base(4,16,0)+instance ShowLev 'Exts.Int8Rep Exts.Int8# where+ showLev i = show $ I8# i++instance ShowLev 'Exts.Int16Rep Exts.Int16# where+ showLev i = show $ I16# i++instance ShowLev 'Exts.Int32Rep Exts.Int32# where+ showLev i = show $ I32# i+#endif++instance ShowLev 'Exts.WordRep Exts.Word# where+ showLev w = show $ W# w++#if MIN_VERSION_base(4,16,0)+instance ShowLev 'Exts.Word8Rep Exts.Word8# where+ showLev w = show $ W8# w++instance ShowLev 'Exts.Word16Rep Exts.Word16# where+ showLev w = show $ W16# w++instance ShowLev 'Exts.Word32Rep Exts.Word32# where+ showLev w = show $ W32# w+#endif++instance ShowLev 'Exts.FloatRep Exts.Float# where+ showLev f = show $ Exts.F# f++instance ShowLev 'Exts.DoubleRep Exts.Double# where+ showLev d = show $ Exts.D# d++newtype ShowWrapper a = MkShowWrapper a++instance ShowLev Exts.LiftedRep a => Show (ShowWrapper a) where+ show (MkShowWrapper a) = showLev a++class Succeed a where+ _succeed :: a -> String++-- Looking up an instance of this class for any type will always succeed. To+-- produce actual evidence, a Show dict must be provided.+instance Show a => Succeed a where+ _succeed = show
+ src/Debug/Breakpoint/GhcFacade.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE CPP #-}+module Debug.Breakpoint.GhcFacade+ ( module Ghc+ , liftedRepName+ , LexicalFastString'+ , mkLexicalFastString+ , fromLexicalFastString+ , collectHsBindBinders'+ , collectPatBinders'+ , noLocA'+ , locA'+ , mkWildValBinder'+ , pattern HsLet'+ , pattern LetStmt'+ , pattern ExplicitList'+ , pattern BindStmt'+ ) where++#if MIN_VERSION_ghc(9,2,0)+import GHC.Driver.Plugins as Ghc hiding (TcPlugin)+import GHC.Hs.Extension as Ghc+import Language.Haskell.Syntax as Ghc+import GHC.Tc.Types as Ghc+import GHC.Parser.Annotation as Ghc+import GHC.Types.SrcLoc as Ghc+import GHC.Types.Name as Ghc+import GHC.Iface.Env as Ghc+import GHC.Unit.Finder as Ghc+import GHC.Unit.Module.Name as Ghc+import GHC.Tc.Utils.Monad as Ghc hiding (TcPlugin)+import GHC.Data.FastString as Ghc+import GHC.Hs.Utils as Ghc+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+import GHC.Builtin.Types as Ghc+import GHC.Core.TyCo.Rep as Ghc+import GHC.Tc.Types.Constraint as Ghc+import GHC.Core.Make as Ghc+import GHC.Tc.Types.Evidence as Ghc+import GHC.Types.Id as Ghc+import GHC.Core.InstEnv as Ghc+import GHC.Core.Class as Ghc hiding (FunDep)+import GHC.Tc.Utils.TcType as Ghc+import GHC.Core.Type as Ghc+import GHC.Core.TyCon as Ghc+import GHC.Types.TyThing.Ppr as Ghc+import GHC.Hs.Expr as Ghc++#elif MIN_VERSION_ghc(9,0,0)+import GHC.Driver.Plugins as Ghc hiding (TcPlugin)+import GHC.Driver.Finder as Ghc+import GHC.Hs.Extension as Ghc+import GHC.Tc.Types as Ghc+import GHC.Parser.Annotation as Ghc+import GHC.Types.SrcLoc as Ghc+import GHC.Types.Name as Ghc+import GHC.Iface.Env as Ghc+import GHC.Unit.Module.Name as Ghc+import GHC.Tc.Utils.Monad as Ghc hiding (TcPlugin)+import GHC.Data.FastString as Ghc+import GHC.Hs.Utils as Ghc+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+import GHC.Builtin.Types as Ghc+import GHC.Core.TyCo.Rep as Ghc+import GHC.Tc.Types.Constraint as Ghc+import GHC.Core.Make as Ghc+import GHC.Tc.Types.Evidence as Ghc+import GHC.Types.Id as Ghc+import GHC.Core.InstEnv as Ghc+import GHC.Core.Class as Ghc hiding (FunDep)+import GHC.Tc.Utils.TcType as Ghc+import GHC.Core.Type as Ghc+import GHC.Core.TyCon as Ghc+import GHC.Core.Ppr.TyThing as Ghc+import GHC.Driver.Types as Ghc+import GHC.Hs.Expr as Ghc+import GHC.Hs.Pat as Ghc+import GHC.Hs.Decls as Ghc++#elif MIN_VERSION_ghc(8,10,0)+import GHC.Hs.Expr as Ghc+import GHC.Hs.Extension as Ghc+import GHC.Hs.Binds as Ghc+import SrcLoc as Ghc+import GHC.Hs.Utils as Ghc+import Name as Ghc+import GHC.Hs.Pat as Ghc+import FastString as Ghc+import TysWiredIn as Ghc+import InstEnv as Ghc+import TcEvidence as Ghc+import TyCoRep as Ghc+import MkCore as Ghc+import PprTyThing as Ghc+import Outputable as Ghc+import TcRnTypes as Ghc+import Type as Ghc+import TcType as Ghc+import Id as Ghc+import Class as Ghc+import Constraint as Ghc+import Module as Ghc+import HscTypes as Ghc+import TyCon as Ghc+import Bag as Ghc+import BasicTypes as Ghc+import UniqSet as Ghc+import NameEnv as Ghc+import IfaceEnv as Ghc+import Finder as Ghc hiding (findImportedModule)+import TcPluginM as Ghc hiding (lookupOrig, getTopEnv, getEnvs, newUnique)+import GHC.Hs.Decls as Ghc+import TcRnMonad as Ghc+import Plugins as Ghc hiding (TcPlugin)+#endif++liftedRepName :: Ghc.Name+#if MIN_VERSION_ghc(9,2,0)+liftedRepName = Ghc.getName Ghc.liftedRepTyCon+#else+liftedRepName = Ghc.getName Ghc.liftedRepDataCon+#endif++#if MIN_VERSION_ghc(9,2,0)+type LexicalFastString' = Ghc.LexicalFastString+#else+type LexicalFastString' = Ghc.FastString+#endif++mkLexicalFastString :: Ghc.FastString -> LexicalFastString'+fromLexicalFastString :: LexicalFastString' -> Ghc.FastString+#if MIN_VERSION_ghc(9,2,0)+mkLexicalFastString = Ghc.LexicalFastString+fromLexicalFastString (Ghc.LexicalFastString fs) = fs+#else+mkLexicalFastString = id+fromLexicalFastString = id+#endif++collectHsBindBinders' :: Ghc.HsBindLR Ghc.GhcRn idR -> [Ghc.Name]+collectHsBindBinders' = Ghc.collectHsBindBinders+#if MIN_VERSION_ghc(9,2,0)+ Ghc.CollNoDictBinders+#endif++collectPatBinders' :: Ghc.LPat Ghc.GhcRn -> [Ghc.Name]+collectPatBinders' = Ghc.collectPatBinders+#if MIN_VERSION_ghc(9,2,0)+ Ghc.CollNoDictBinders+#endif++noLocA'+#if MIN_VERSION_ghc(9,2,0)+ :: a -> LocatedAn an a+noLocA'+ = noLocA+#else+ :: a -> Located a+noLocA'+ = noLoc+#endif++#if MIN_VERSION_ghc(9,2,0)+locA' :: Ghc.SrcSpanAnn' ann -> Ghc.SrcSpan+locA' = Ghc.locA+#else+locA' :: Ghc.SrcSpan -> Ghc.SrcSpan+locA' = id+#endif++mkWildValBinder' :: Ghc.Type -> Ghc.Id+#if MIN_VERSION_ghc(9,0,0)+mkWildValBinder' = Ghc.mkWildValBinder Ghc.oneDataConTy+#else+mkWildValBinder' = Ghc.mkWildValBinder+#endif++pattern HsLet'+ :: Ghc.XLet Ghc.GhcRn+ -> Ghc.Located (Ghc.HsLocalBinds Ghc.GhcRn)+ -> Ghc.LHsExpr Ghc.GhcRn+ -> Ghc.HsExpr Ghc.GhcRn+#if MIN_VERSION_ghc(9,2,0)+pattern HsLet' x lbinds expr <-+ Ghc.HsLet x (Ghc.L Ghc.noSrcSpan -> lbinds) expr+ where+ HsLet' x (Ghc.L _ binds) expr = Ghc.HsLet x binds expr+#else+pattern HsLet' x lbinds expr = Ghc.HsLet x lbinds expr+#endif++pattern LetStmt'+ :: XLetStmt Ghc.GhcRn Ghc.GhcRn body+ -> Ghc.Located (HsLocalBinds Ghc.GhcRn)+ -> Ghc.StmtLR Ghc.GhcRn Ghc.GhcRn body+#if MIN_VERSION_ghc(9,2,0)+pattern LetStmt' x lbinds <-+ Ghc.LetStmt x (Ghc.L Ghc.noSrcSpan -> lbinds)+ where+ LetStmt' x (Ghc.L _ binds) = Ghc.LetStmt x binds+#else+pattern LetStmt' x lbinds = Ghc.LetStmt x lbinds+#endif++pattern ExplicitList'+ :: Ghc.XExplicitList p+ -> [Ghc.LHsExpr p]+ -> Ghc.HsExpr p+#if MIN_VERSION_ghc(9,2,0)+pattern ExplicitList' x exprs = Ghc.ExplicitList x exprs+#else+pattern ExplicitList' x exprs <- Ghc.ExplicitList x _ exprs+ where+ ExplicitList' x exprs = Ghc.ExplicitList x Nothing exprs+#endif++#if MIN_VERSION_ghc(9,0,0)+mkSyntaxExprs :: x -> (SyntaxExpr Ghc.GhcRn, SyntaxExpr Ghc.GhcRn, x)+mkSyntaxExprs x = (Ghc.noSyntaxExpr, Ghc.noSyntaxExpr, x)+#endif++pattern BindStmt'+ :: Ghc.XBindStmt Ghc.GhcRn Ghc.GhcRn body+ -> Ghc.LPat Ghc.GhcRn+ -> body+ -> SyntaxExpr Ghc.GhcRn+ -> SyntaxExpr Ghc.GhcRn+ -> Ghc.Stmt Ghc.GhcRn body+#if MIN_VERSION_ghc(9,0,0)+pattern BindStmt' x pat body expr1 expr2+ <- Ghc.BindStmt x pat (mkSyntaxExprs -> (expr1, expr2, body))+ where+ BindStmt' x pat body _ _ = Ghc.BindStmt x pat body+#else+pattern BindStmt' x pat body bindExpr failExpr = Ghc.BindStmt x pat body bindExpr failExpr+#endif
+ test/ApplicativeDo.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ApplicativeDo #-}+module ApplicativeDo+ ( testTree+ ) where++import qualified Data.Map as M+import Data.Maybe+import Test.Tasty+import Test.Tasty.HUnit++import Debug.Breakpoint++-- Needs to be a separate module b/c ApplicativeDo affects other tests++testTree :: TestTree+testTree = testGroup "ApplicativeDo"+ [ testCase "applicative do bindings" applicativeDoBindings+ , testCase "monadic binds scoped" monadicBindsScoped+ ]++applicativeDoBindings :: Assertion+applicativeDoBindings =+ runM test1 @?= Just (M.fromList [("a", "True"), ("b", "False")])++newtype M a = M { runM :: Maybe a }+ deriving newtype (Functor, Applicative)++test1 :: Applicative m => m (M.Map String String)+test1 = do+ let b = False+ a <- pure True+ return captureVars++monadicBindsScoped :: Assertion+monadicBindsScoped = M.delete "m" test2 @?= M.fromList [("a", "True")]++test2 :: M.Map String String+test2 = fromMaybe mempty $ do+ a <- Just True+ let m = const captureVars a -- NB: need to reference 'a' here b/c of ApplicativeDo+ b <- Just False+ pure m
+ test/Spec.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Arrows #-}+import Control.Arrow+import qualified Data.Map as M+import Data.Maybe+import Test.Tasty+import Test.Tasty.HUnit++import Debug.Breakpoint+import qualified ApplicativeDo as ApDo++main :: IO ()+main = defaultMain testTree++testTree :: TestTree+testTree =+ testGroup "Tests"+ [ testCase "function args" functionArgs+ , testCase "where binds" whereBinds+ , testCase "args and where" argsAndWhere+ , testCase "let bindings" letBindings+ , testCase "nested in let" nestedInLet+ , testCase "let scoping" letScoping+ , testCase "nested in where" nestedInWhere+ , testCase "guard binding" guardBinding+ , testCase "pattern guard" patternGuard+ , testCase "lambda bind" lambdaBind+ , testCase "no let escape" noLetEscape+ , testCase "case pattern bind" casePatBind+ , testCase "monadic binds" monadicBinds+ , testCase "monadic binds scoped" monadicBindsScoped+ , testCase "do block let bind" doBlockLetBind+ , testCase "list comprehension" listComprehension+ , testCase "arrow notation" arrowNotation+ , testCase "record field bindings" recFieldBindings+ , testCase "record wild cards" recWildCards+ , ApDo.testTree+ ]+ -- TODO+ -- Implicit Params+ -- Pattern synonyms+ -- recursive do+ -- qualified do++functionArgs :: Assertion+functionArgs = test1 1 True @?= M.fromList [("b", "True"), ("i", "1")]++test1 :: Int -> Bool -> M.Map String String+test1 i b = captureVars++whereBinds :: Assertion+whereBinds = test2 @?= M.fromList [("a", "1"), ("b", "True")]++test2 :: M.Map String String+test2 = captureVars+ where a = 1 :: Int+ b = True++argsAndWhere :: Assertion+argsAndWhere = test3 1 @?= M.fromList [("a", "1"), ("b", "2"), ("c", "3")]++test3 :: Int -> M.Map String String+test3 a = captureVars+ where b = 2 :: Int+ c = 3 :: Int++letBindings :: Assertion+letBindings =+ test4 @?= M.fromList [("a", "True"), ("b", "1")]++test4 :: M.Map String String+test4 =+ let a = True+ b = 1 :: Int+ in captureVars++nestedInLet :: Assertion+nestedInLet = M.delete "x" (test5 1) @?= M.fromList [("a", "1"), ("b", "2"), ("c", "3")]++test5 :: Int -> M.Map String String+test5 a =+ let x =+ let b = 2 :: Int+ c = 3 :: Int+ in captureVars+ in x++noLetEscape :: Assertion+noLetEscape = test6 @?= M.fromList [("a", "()")]++test6 :: M.Map String String+test6 =+ let a =+ let b = True+ c = False+ in ()+ in captureVars++nestedInWhere :: Assertion+nestedInWhere = test7 @?= M.fromList [("a", "()")]++test7 :: M.Map String String+test7 = captureVars where+ a = () where+ b = True+ c = False++guardBinding :: Assertion+guardBinding = test8 @?= M.fromList [("a", "()"), ("b", "()")]++test8 :: M.Map String String+test8 | let a = (), let b = a = captureVars++patternGuard :: Assertion+patternGuard = test9 @?= M.fromList [("a", "()")]++test9 :: M.Map String String+test9 | Just a <- Just () = captureVars++lambdaBind :: Assertion+lambdaBind = test10 () @?= M.fromList [("a", "()")]++test10 :: () -> M.Map String String+test10 = \a -> captureVars++letScoping :: Assertion+letScoping = M.delete "a" test11 @?= M.fromList [("b", "True"), ("c", "False")]++test11 :: M.Map String String+test11 =+ let b = True+ a = captureVars+ c = False+ in a++casePatBind :: Assertion+casePatBind = test12 @?= M.fromList [("a", "()")]++test12 :: M.Map String String+test12 = case Just () of+ Just a -> captureVars++monadicBinds :: Assertion+monadicBinds = test13 @?= M.fromList [("a", "True"), ("b", "False"), ("x", "5")]++test13 :: M.Map String String+test13 = fromMaybe mempty $ do+ a <- Just True+ b <- Just False+ let x = 5 :: Int+ pure captureVars++monadicBindsScoped :: Assertion+monadicBindsScoped = M.delete "m" test14 @?= M.fromList [("a", "True")]++test14 :: M.Map String String+test14 = fromMaybe mempty $ do+ a <- Just True+ let m = captureVars+ b <- Just False+ pure m++doBlockLetBind :: Assertion+doBlockLetBind = test15 @?= M.fromList [("a", "True"), ("b", "False")]++test15 :: M.Map String String+test15 = fromMaybe mempty $ do+ let a = True+ b <- Just False+ pure captureVars++listComprehension :: Assertion+listComprehension = test16 @?= M.fromList [("a", "True"), ("b", "False")]++test16 = head [ captureVars | let b = False, a <- [True] ]++arrowNotation :: Assertion+arrowNotation = M.delete "go" test17 @?= M.fromList [("a", "2"), ("b", "0"), ("x", "1")]+-- "go" has different printed type sigs for 9.0 vs 8.10++test17 :: M.Map String String+test17 = go (1 :: Int) where+ go = proc x -> do+ a <- succ -< (x :: Int)+ let b = pred x+ returnA -< captureVars++recFieldBindings :: Assertion+recFieldBindings = test18 MkRec {fld=True} @?= M.fromList [("a", "True")]++data Rec = MkRec { fld :: Bool }+test18 :: Rec -> M.Map String String+test18 MkRec { fld = a } = captureVars++recWildCards :: Assertion+recWildCards = test19 MkRec {fld=True} @?= M.fromList [("fld", "True")]++test19 :: Rec -> M.Map String String+test19 MkRec{..} = captureVars+