commit d70b442577ac5a400c974c309dca1a692f35b71c Author: Aaron Allen Date: Sat Oct 9 14:55:57 2021 -0500 figuring stuff out diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..48a004c --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..5799b32 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for DebugPlugin + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/DebugPlugin.cabal b/DebugPlugin.cabal new file mode 100644 index 0000000..2576060 --- /dev/null +++ b/DebugPlugin.cabal @@ -0,0 +1,37 @@ +cabal-version: >=1.10 +-- Initial package description 'DebugPlugin.cabal' generated by 'cabal +-- init'. For further documentation, see +-- http://haskell.org/cabal/users-guide/ + +name: debug-plugin +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +-- license: +license-file: LICENSE +-- author: +maintainer: aaronallen8455@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md + +library + default-language: Haskell2010 + exposed-modules: + Debug + build-depends: base + , ghc + , containers + , syb + hs-source-dirs: src + +executable exe + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base + , debug-plugin + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..3ef2070 --- /dev/null +++ b/Main.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -fplugin=Debug #-} +{-# LANGUAGE ImplicitParams #-} + +import System.IO.Unsafe (unsafePerformIO) + +main :: IO () +main = do + let ?_debug_ip = (Nothing, "test") + test + +-- test :: (?_debug_ip :: (Maybe String, String)) => IO () +-- test = test2 + +test :: (?_debug_ip :: (Maybe String, String)) => IO () +test = print (?_debug_ip :: (Maybe String, String)) + +-- test :: (?x :: String) => IO () +-- test = print ?x + +blah :: () +blah = unsafePerformIO $ putStrLn "test" diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test.hs b/Test.hs new file mode 100644 index 0000000..30a48b9 --- /dev/null +++ b/Test.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +module DebugPlugin.Test where + +import Data.Kind +import GHC.TypeLits + +type Debug (str :: Symbol) = (?x :: String) + +test :: (Debug "yo", Num r) => r -> IO String +test _ = do + x <- getLine + let ?x = x + pure ?x + diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..2239e10 --- /dev/null +++ b/shell.nix @@ -0,0 +1,10 @@ +{ system ? builtins.currentSystem }: + +with import { inherit system; }; + +mkShell { + buildInputs = [ + haskell.compiler.ghc901 + cabal-install + ]; +} diff --git a/src/Debug.hs b/src/Debug.hs new file mode 100644 index 0000000..def94bd --- /dev/null +++ b/src/Debug.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +module Debug where + +import Control.Applicative ((<|>)) +import Data.Foldable +import Data.Traversable +import Data.IORef +import qualified Data.Set as S +import Data.Maybe + +import qualified GHC.Builtin.Names as Ghc +import qualified GHC.Builtin.Types as Ghc +import qualified GHC.Core as Ghc +import qualified GHC.Core.Class as Ghc +import qualified GHC.Core.Make as Ghc +import qualified GHC.Core.Type as Ghc +import qualified GHC.Core.Utils as Ghc +import qualified GHC.Data.FastString as Ghc +import qualified GHC.Driver.Plugins as Ghc hiding (TcPlugin) +import qualified GHC.Driver.Types as Ghc +import qualified GHC.Hs.Expr as Ghc +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Tc.Plugin as Ghc +import qualified GHC.Tc.Types as Ghc +import qualified GHC.Tc.Types.Constraint as Ghc +import qualified GHC.Tc.Types.Evidence as Ghc +import qualified GHC.Types.Basic as Ghc +import qualified GHC.Types.Id as Ghc +import qualified GHC.Types.Name as Ghc hiding (varName) +import qualified GHC.Types.Name.Occurrence as Ghc hiding (varName) +import qualified GHC.Types.SrcLoc as Ghc +import qualified GHC.Types.Unique.Supply as Ghc +import qualified GHC.Types.Var as Ghc +import qualified GHC.Utils.Outputable as Ghc + +import Data.Generics (everywhereM, mkM) + +plugin :: Ghc.Plugin +plugin = + Ghc.defaultPlugin + { Ghc.pluginRecompile = Ghc.purePlugin + , Ghc.tcPlugin = \_ -> Just tcPlugin + , Ghc.typeCheckResultAction = const typeCheckResultAction + } + +typeCheckResultAction :: Ghc.ModSummary -> Ghc.TcGblEnv -> Ghc.TcM Ghc.TcGblEnv +typeCheckResultAction _modSummary tcGblEnv = do + x <- mkM test `everywhereM` Ghc.tcg_binds tcGblEnv + pure tcGblEnv + +test :: Ghc.LHsExpr Ghc.GhcTc -> Ghc.TcM ( Ghc.LHsExpr Ghc.GhcTc ) +test = undefined + +tcPlugin :: Ghc.TcPlugin +tcPlugin = + Ghc.TcPlugin + { Ghc.tcPluginInit = Ghc.tcPluginIO $ newIORef False + , Ghc.tcPluginStop = \_ -> pure () + , Ghc.tcPluginSolve = tcPluginSolver + } + +ppr :: Ghc.Outputable a => a -> String +ppr = Ghc.showSDocUnsafe . Ghc.ppr + +debuggerIpKey :: Ghc.FastString +debuggerIpKey = "_debug_ip" + +isDebuggerIpCt :: Ghc.Ct -> Bool +isDebuggerIpCt ct@Ghc.CDictCan{} + | Ghc.className (Ghc.cc_class ct) == Ghc.ipClassName + , ty : _ <- Ghc.cc_tyargs ct + , Just ipKey <- Ghc.isStrLitTy ty + , ipKey == debuggerIpKey + = True + | otherwise = False + +-- I'll be able to know how many times the IP constraint will appear for each +-- function? No because the user controls where the traces are used. +-- Actually will have some knowledge of which function it is occurring for +-- because there will also be a wanted for the debug label constraint (or tf) + +tcPluginSolver :: IORef Bool -> Ghc.TcPluginSolver +tcPluginSolver givenHandledRef given derived wanted = do + firstGivenHandled <- Ghc.tcPluginIO $ readIORef givenHandledRef + + case ( filter isDebuggerIpCt given + , filter isDebuggerIpCt wanted + ) of + ([g], []) -> do + Ghc.tcPluginIO $ putStrLn "case 1" + let ev = Ghc.ctEvTerm $ Ghc.cc_ev g + Ghc.tcPluginIO $ writeIORef givenHandledRef True + pure $ if firstGivenHandled + then Ghc.TcPluginOk [] [] + else Ghc.TcPluginOk [(ev, g)] [g] -- this can also be [] []! + + ([g], [w]) -> do + Ghc.tcPluginIO $ putStrLn "case 2" + + let ev = Ghc.cc_ev g + prevExpr = Ghc.ctEvExpr ev + + tupFstUniq <- Ghc.unsafeTcPluginTcM Ghc.getUniqueM + let tupFstName = Ghc.mkSystemVarName tupFstUniq "a" + tupFstTy = Ghc.mkTyConApp Ghc.maybeTyCon [Ghc.stringTy] + tupFstId = Ghc.mkLocalId tupFstName Ghc.Many tupFstTy + + tupSndUniq <- Ghc.unsafeTcPluginTcM Ghc.getUniqueM + let tupSndName = Ghc.mkSystemVarName tupSndUniq "b" + tupSndTy = Ghc.stringTy + tupSndId = Ghc.mkLocalId tupSndName Ghc.Many tupSndTy + + tupUniq <- Ghc.unsafeTcPluginTcM Ghc.getUniqueM + let tupName = Ghc.mkSystemVarName tupUniq "c" + tupTy = Ghc.mkTupleTy Ghc.Boxed [tupFstTy, tupSndTy] + tupId = Ghc.mkLocalId tupName Ghc.Many tupTy + + let x = case prevExpr of + Ghc.Var i -> + let n = Ghc.mkClonedInternalName tupUniq $ Ghc.varName i + in Ghc.Var $ Ghc.setVarName i n + + let ip_co = Ghc.unwrapIP (Ghc.exprType prevExpr) + castedPrevExpr = Ghc.Cast prevExpr ip_co + + let mPrevStr = Ghc.mkJustExpr Ghc.stringTy + . Ghc.mkTupleSelector [tupFstId, tupSndId] tupSndId tupId + $ castedPrevExpr + + newStr <- Ghc.unsafeTcPluginTcM $ Ghc.mkStringExpr "inserted2" + let newTup = Ghc.mkCoreTup [mPrevStr, newStr] + + pure $ Ghc.TcPluginOk [(Ghc.EvExpr newTup, w)] [] + + ([], [w]) -> do + Ghc.tcPluginIO $ putStrLn "case 3" + str <- Ghc.unsafeTcPluginTcM $ Ghc.mkStringExpr "inserted" + let tuple = Ghc.mkCoreTup [Ghc.mkNothingExpr Ghc.stringTy, str] + pure $ Ghc.TcPluginOk [(Ghc.EvExpr tuple, w)] [] + + ([], []) -> do + Ghc.tcPluginIO $ putStrLn "case 4" + pure $ Ghc.TcPluginOk [] [] + + _ -> do + Ghc.tcPluginIO $ putStrLn "unexpected givens/wanteds" + pure $ Ghc.TcPluginOk [] [] + +-- ys <- fmap catMaybes . for given $ \ct -> do +-- let ev = Ghc.cc_ev ct +-- prevExpr = Ghc.ctEvExpr ev +-- +-- tupFstUniq <- Ghc.unsafeTcPluginTcM Ghc.getUniqueM +-- let tupFstName = Ghc.mkSystemVarName tupFstUniq "a" +-- tupFstTy = Ghc.mkTyConApp Ghc.maybeTyCon [Ghc.stringTy] +-- tupFstId = Ghc.mkLocalId tupFstName Ghc.Many tupFstTy +-- +-- tupSndUniq <- Ghc.unsafeTcPluginTcM Ghc.getUniqueM +-- let tupSndName = Ghc.mkSystemVarName tupSndUniq "b" +-- tupSndTy = Ghc.stringTy +-- tupSndId = Ghc.mkLocalId tupSndName Ghc.Many tupSndTy +-- +-- tupUniq <- Ghc.unsafeTcPluginTcM Ghc.getUniqueM +-- let tupName = Ghc.mkSystemVarName tupUniq "c" +-- tupTy = Ghc.mkTupleTy Ghc.Boxed [tupFstTy, tupSndTy] +-- tupId = Ghc.mkLocalId tupName Ghc.Many tupTy +-- +-- let x = case prevExpr of +-- Ghc.Var i -> +-- let n = Ghc.mkClonedInternalName tupUniq $ Ghc.varName i +-- in Ghc.Var $ Ghc.setVarName i n +-- +-- let ip_co = Ghc.unwrapIP (Ghc.exprType prevExpr) +-- castedPrevExpr = Ghc.Cast prevExpr ip_co +-- +-- let mPrevStr = Ghc.mkJustExpr Ghc.stringTy +-- . Ghc.mkTupleSelector [tupFstId, tupSndId] tupSndId tupId +-- $ castedPrevExpr +-- +-- newStr <- Ghc.unsafeTcPluginTcM $ Ghc.mkStringExpr "inserted2" +-- let newTup = Ghc.mkCoreTup [mPrevStr, newStr] +-- +-- Ghc.tcPluginIO $ putStrLn (ppr newTup) +-- Ghc.tcPluginIO $ writeIORef s (Just $ Ghc.EvExpr newTup) +-- --pure $ Just (Ghc.ctEvTerm $ Ghc.cc_ev ct, ct) +-- pure $ Just (Ghc.EvExpr newTup, ct) +-- --ppr (Ghc.ctev_evar $ Ghc.cc_ev ct) +-- +-- xs <- for wanted $ \ct -> do +-- case ct of +-- Ghc.CDictCan{} -> do +-- Ghc.tcPluginIO $ putStrLn $ Ghc.showSDocUnsafe +-- $ Ghc.ppr $ Ghc.cc_ev ct +-- -- Ghc.tcPluginIO $ putStrLn "CDictCan" +-- +-- -- Can easily construct a string, but how can I do an unsafePerformIO +-- -- that generates a random thing? +-- -- mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr +-- +-- -- -- | Parses a string as an identifier, and returns the list of 'Name's that +-- -- -- the identifier can refer to in the current interactive context. +-- -- parseName :: GhcMonad m => String -> m [Name] +-- -- parseName str = withSession $ \hsc_env -> liftIO $ +-- +-- -- -- | Is this a symbol literal. We also look through type synonyms. +-- -- isStrLitTy :: Type -> Maybe FastString +-- +-- -- pushCSVar <- lookupId pushCallStackName +-- -- mkCoreApps (Var pushCSVar) [...] +-- str <- Ghc.unsafeTcPluginTcM $ Ghc.mkStringExpr "inserted" +-- let tuple = Ghc.mkCoreTup [Ghc.mkNothingExpr Ghc.stringTy, str] +-- case ys of +-- [] -> pure (Ghc.EvExpr tuple, ct) +-- [(last, _)] -> do +-- Ghc.tcPluginIO $ putStrLn "........." +-- pure (last, ct) +-- +-- case mLast of +-- Nothing -> do +-- Ghc.tcPluginIO $ putStrLn "NOTHING" +-- pure $ Ghc.TcPluginOk (xs ++ ys) (snd <$> ys) +-- Just _ -> do +-- Ghc.tcPluginIO $ putStrLn "JUST" +-- pure $ Ghc.TcPluginOk xs [] + +-- the winning strategy seems to be to put the givens into both outputs only +-- on the first time, then all other times simply deal with the wanteds. +-- Eventually there will be a round with both a given and a wanted and we can +-- then construct the desired value and use if for the wanted constraint. +-- Therefore we only need to keep track of a boolean state. + +-- data TcPluginResult +-- = TcPluginContradiction [Ct] +-- -- ^ The plugin found a contradiction. +-- -- The returned constraints are removed from the inert set, +-- -- and recorded as insoluble. +-- +-- | TcPluginOk [(EvTerm,Ct)] [Ct] +-- -- ^ The first field is for constraints that were solved. +-- -- These are removed from the inert set, +-- -- and the evidence for them is recorded. +-- -- The second field contains new work, that should be processed by +-- -- the constraint solver. +-- +-- -- An EvTerm is, conceptually, a CoreExpr that implements the constraint. +-- -- Unfortunately, we cannot just do +-- -- type EvTerm = CoreExpr +-- -- Because of staging problems issues around EvTypeable +-- data EvTerm +-- = EvExpr EvExpr +-- +-- | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) +-- +-- | EvFun -- /\as \ds. let binds in v +-- { et_tvs :: [TyVar] +-- , et_given :: [EvVar] +-- , et_binds :: TcEvBinds -- This field is why we need an EvFun +-- -- constructor, and can't just use EvExpr +-- , et_body :: EvVar } +-- +-- deriving Data.Data +-- +-- type EvExpr = CoreExpr + +-- = CDictCan { -- e.g. Num xi +-- cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] +-- +-- cc_class :: Class, +-- cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi +-- +-- cc_pend_sc :: Bool -- See Note [The superclass story] in GHC.Tc.Solver.Canonical +-- -- True <=> (a) cc_class has superclasses +-- -- (b) we have not (yet) added those +-- -- superclasses as Givens +-- } +