diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for breakpoint + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/breakpoint.cabal b/breakpoint.cabal new file mode 100644 --- /dev/null +++ b/breakpoint.cabal @@ -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 diff --git a/src/Debug/Breakpoint.hs b/src/Debug/Breakpoint.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Breakpoint.hs @@ -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 diff --git a/src/Debug/Breakpoint/GhcFacade.hs b/src/Debug/Breakpoint/GhcFacade.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Breakpoint/GhcFacade.hs @@ -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 diff --git a/test/ApplicativeDo.hs b/test/ApplicativeDo.hs new file mode 100644 --- /dev/null +++ b/test/ApplicativeDo.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 +