mirror of
https://github.com/aaronallen8455/graph-trace.git
synced 2024-09-11 09:05:34 +03:00
good progress
This commit is contained in:
parent
d70b442577
commit
4b280fd824
@ -25,6 +25,7 @@ library
|
||||
, ghc
|
||||
, containers
|
||||
, syb
|
||||
, template-haskell
|
||||
hs-source-dirs: src
|
||||
|
||||
executable exe
|
||||
|
25
Main.hs
25
Main.hs
@ -1,21 +1,34 @@
|
||||
{-# OPTIONS_GHC -fplugin=Debug #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import GHC.Stack
|
||||
|
||||
main :: IO ()
|
||||
import Debug
|
||||
|
||||
main :: Debug "main" => IO ()
|
||||
main = do
|
||||
let ?_debug_ip = (Nothing, "test")
|
||||
--let ?_debug_ip = "insert"
|
||||
test
|
||||
|
||||
-- test :: (?_debug_ip :: (Maybe String, String)) => IO ()
|
||||
-- test = test2
|
||||
|
||||
test :: (?_debug_ip :: (Maybe String, String)) => IO ()
|
||||
test = print (?_debug_ip :: (Maybe String, String))
|
||||
trace :: (?_debug_ip :: String) => IO ()
|
||||
trace = putStrLn ?_debug_ip
|
||||
|
||||
test :: Debug "blah" => IO ()
|
||||
test = do
|
||||
trace
|
||||
trace
|
||||
another
|
||||
|
||||
another :: Debug "another2" => IO ()
|
||||
another = trace
|
||||
|
||||
-- test :: (?x :: String) => IO ()
|
||||
-- test = print ?x
|
||||
|
||||
blah :: ()
|
||||
blah = unsafePerformIO $ putStrLn "test"
|
||||
st :: Debug "..." => IO ()
|
||||
st = putStrLn "..."
|
||||
|
11
Test.hs
11
Test.hs
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
@ -9,9 +10,9 @@ 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
|
||||
test :: Debug "yo" => String
|
||||
test = let ?x = newIP in
|
||||
do ?x
|
||||
where
|
||||
newIP = ?x <> "test"
|
||||
|
||||
|
410
src/Debug.hs
410
src/Debug.hs
@ -1,13 +1,23 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Debug where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Foldable
|
||||
import Data.Traversable
|
||||
import Data.IORef
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import GHC.TypeLits (Symbol)
|
||||
import qualified Language.Haskell.TH as TH
|
||||
|
||||
import qualified GHC.Builtin.Names as Ghc
|
||||
import qualified GHC.Builtin.Types as Ghc
|
||||
@ -16,15 +26,25 @@ 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.Bag as Ghc
|
||||
import qualified GHC.Data.FastString as Ghc
|
||||
import qualified GHC.Driver.Finder as Ghc
|
||||
import qualified GHC.Driver.Plugins as Ghc hiding (TcPlugin)
|
||||
import qualified GHC.Driver.Types as Ghc
|
||||
import qualified GHC.Hs.Binds as Ghc
|
||||
import qualified GHC.Hs.Decls 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.Hs.Type as Ghc
|
||||
import qualified GHC.Iface.Env as Ghc
|
||||
import qualified GHC.Rename.Expr as Ghc
|
||||
import qualified GHC.Tc.Plugin as Ghc hiding (lookupOrig, findImportedModule, getTopEnv)
|
||||
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.Tc.Types.Origin as Ghc
|
||||
import qualified GHC.Tc.Utils.Monad as Ghc
|
||||
import qualified GHC.ThToHs 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)
|
||||
@ -32,32 +52,254 @@ 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.Unit.Module.Name as Ghc
|
||||
import qualified GHC.Utils.Outputable as Ghc
|
||||
|
||||
import Data.Generics (everywhereM, mkM)
|
||||
--type family DebugKey (key :: Symbol) :: Constraint
|
||||
type Debug (key :: Symbol) = (?_debug_ip :: String) -- (DebugKey key, ?_debug_ip :: String)
|
||||
|
||||
plugin :: Ghc.Plugin
|
||||
plugin =
|
||||
Ghc.defaultPlugin
|
||||
{ Ghc.pluginRecompile = Ghc.purePlugin
|
||||
, Ghc.tcPlugin = \_ -> Just tcPlugin
|
||||
, Ghc.typeCheckResultAction = const typeCheckResultAction
|
||||
-- , Ghc.typeCheckResultAction = const typeCheckResultAction
|
||||
, Ghc.renamedResultAction = const renamedResultAction
|
||||
}
|
||||
|
||||
typeCheckResultAction :: Ghc.ModSummary -> Ghc.TcGblEnv -> Ghc.TcM Ghc.TcGblEnv
|
||||
typeCheckResultAction _modSummary tcGblEnv = do
|
||||
x <- mkM test `everywhereM` Ghc.tcg_binds tcGblEnv
|
||||
pure tcGblEnv
|
||||
renamedResultAction :: Ghc.TcGblEnv -> Ghc.HsGroup Ghc.GhcRn
|
||||
-> Ghc.TcM (Ghc.TcGblEnv, Ghc.HsGroup Ghc.GhcRn)
|
||||
renamedResultAction tcGblEnv
|
||||
hsGroup@Ghc.HsGroup
|
||||
{ Ghc.hs_valds =
|
||||
Ghc.XValBindsLR (Ghc.NValBinds binds sigs)
|
||||
}
|
||||
= do
|
||||
hscEnv <- Ghc.getTopEnv
|
||||
|
||||
test :: Ghc.LHsExpr Ghc.GhcTc -> Ghc.TcM ( Ghc.LHsExpr Ghc.GhcTc )
|
||||
test = undefined
|
||||
Ghc.Found _ debugModule <- liftIO $
|
||||
Ghc.findImportedModule hscEnv (Ghc.mkModuleName "Debug") Nothing
|
||||
|
||||
debugPredName <- Ghc.lookupOrig debugModule (Ghc.mkClsOcc "Debug")
|
||||
|
||||
let keyMap = M.fromList
|
||||
$ concatMap (sigUsesDebugPred debugPredName) (Ghc.unLoc <$> sigs)
|
||||
binds' <-
|
||||
(traverse . traverse . traverse . traverse)
|
||||
(modifyBinding keyMap)
|
||||
binds
|
||||
pure (tcGblEnv, hsGroup { Ghc.hs_valds = Ghc.XValBindsLR $ Ghc.NValBinds binds' sigs })
|
||||
renamedResultAction tcGblEnv group = pure (tcGblEnv, group)
|
||||
|
||||
-- | If a sig contains the Debug constraint, get the name of the corresponding
|
||||
-- binding.
|
||||
--
|
||||
-- Are there ever more than one name in the TypeSig? yes:
|
||||
-- one, two :: Debug x => ...
|
||||
sigUsesDebugPred :: Ghc.Name -> Ghc.Sig Ghc.GhcRn -> [(Ghc.Name, String)]
|
||||
sigUsesDebugPred debugPredName
|
||||
(Ghc.TypeSig _ lNames (Ghc.HsWC _ (Ghc.HsIB _
|
||||
(Ghc.L _ (Ghc.HsQualTy _ (Ghc.L _ ctx) _))))) = concat $ do
|
||||
key <- listToMaybe
|
||||
$ mapMaybe (checkForDebugPred debugPredName) (Ghc.unLoc <$> ctx)
|
||||
Just $ zip (Ghc.unLoc <$> lNames) (repeat key)
|
||||
sigUsesDebugPred _ _ = []
|
||||
|
||||
-- TODO need to recurse through HsValBinds. Use syb for this?
|
||||
checkForDebugPred :: Ghc.Name -> Ghc.HsType Ghc.GhcRn -> Maybe String
|
||||
checkForDebugPred debugPredName
|
||||
(Ghc.HsAppTy _ (Ghc.L _ (Ghc.HsTyVar _ _ (Ghc.L _ name))) (Ghc.L _ (Ghc.HsTyLit _ (Ghc.HsStrTy _ key))))
|
||||
-- TODO pass in Debug name
|
||||
| name == debugPredName = Just $ Ghc.unpackFS key
|
||||
checkForDebugPred n (Ghc.HsForAllTy _ _ (Ghc.L _ ty)) = checkForDebugPred n ty
|
||||
checkForDebugPred n (Ghc.HsParTy _ (Ghc.L _ ty)) = checkForDebugPred n ty
|
||||
checkForDebugPred _ _ = Nothing
|
||||
-- need a case for nested QualTy?
|
||||
|
||||
modifyBinding
|
||||
:: M.Map Ghc.Name String
|
||||
-> Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn
|
||||
-> Ghc.TcM (Ghc.HsBindLR Ghc.GhcRn Ghc.GhcRn)
|
||||
modifyBinding keyMap
|
||||
bnd@(Ghc.FunBind _ (Ghc.L _ name) mg@(Ghc.MG _ alts _) _)
|
||||
| Just key <- M.lookup name keyMap
|
||||
= do
|
||||
newAlts <- (traverse . traverse . traverse) (modifyMatch key) alts
|
||||
pure bnd{Ghc.fun_matches = mg{ Ghc.mg_alts = newAlts }}
|
||||
modifyBinding _ bnd = pure bnd
|
||||
|
||||
-- Oops, IP don't play well with where clauses... will not be able to debug from
|
||||
-- inside a where bound function.
|
||||
-- Solution: can iterate through the where bound functions and recursively
|
||||
-- insert the alteration. Doesn't work because we are going to be doing
|
||||
-- unsafe IO and the random identifier that gets produced must be the same
|
||||
-- across all things within that scope.
|
||||
-- Solution: We insert two pieces of code: 1) a where clause where the new
|
||||
-- identifier is bound and 2) the let statements to bind the IP to that new val,
|
||||
-- this way the val is shared across all scopes.
|
||||
--
|
||||
-- The new plan:
|
||||
-- For each FunBind that has a Debug constraint, add a where clause that binds
|
||||
-- a 'newIP' variable which makes the new debug key from the old one.
|
||||
-- In all function bodies, add a let binding that binds the IP to this new
|
||||
-- value. This will probably entail tracking the name of the where bound var.
|
||||
|
||||
-- | Add a where bind for the new value of the IP, then add let bindings to the
|
||||
-- front of each GRHS to set the new value of the IP in that scope.
|
||||
modifyMatch
|
||||
:: String
|
||||
-> Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
|
||||
-> Ghc.TcM (Ghc.Match Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn))
|
||||
modifyMatch key
|
||||
m@Ghc.Match
|
||||
{ Ghc.m_grhss =
|
||||
grhs@Ghc.GRHSs
|
||||
{ Ghc.grhssGRHSs = grhss
|
||||
, Ghc.grhssLocalBinds = Ghc.L whereLoc whereBinds
|
||||
}
|
||||
} = do
|
||||
uniq <- Ghc.getUniqueM
|
||||
let whereBindName = Ghc.mkSystemVarName uniq "new_debug_ip"
|
||||
|
||||
whereBindExpr <- mkWhereBind key
|
||||
|
||||
let bind = Ghc.FunBind
|
||||
{ Ghc.fun_ext = mempty
|
||||
, Ghc.fun_id = Ghc.noLoc whereBindName
|
||||
, Ghc.fun_matches =
|
||||
Ghc.MG
|
||||
{ Ghc.mg_ext = Ghc.NoExtField
|
||||
, Ghc.mg_alts = Ghc.noLoc
|
||||
[Ghc.noLoc Ghc.Match
|
||||
{ Ghc.m_ext = Ghc.NoExtField
|
||||
, Ghc.m_ctxt = Ghc.FunRhs
|
||||
{ Ghc.mc_fun = Ghc.noLoc whereBindName
|
||||
, Ghc.mc_fixity = Ghc.Prefix
|
||||
, Ghc.mc_strictness = Ghc.NoSrcStrict
|
||||
}
|
||||
, Ghc.m_pats = []
|
||||
, Ghc.m_grhss = Ghc.GRHSs
|
||||
{ Ghc.grhssExt = Ghc.NoExtField
|
||||
, Ghc.grhssGRHSs =
|
||||
[ Ghc.noLoc $ Ghc.GRHS
|
||||
Ghc.NoExtField
|
||||
[]
|
||||
whereBindExpr
|
||||
]
|
||||
, Ghc.grhssLocalBinds = Ghc.noLoc $
|
||||
Ghc.EmptyLocalBinds Ghc.NoExtField
|
||||
}
|
||||
}
|
||||
]
|
||||
, Ghc.mg_origin = Ghc.Generated
|
||||
}
|
||||
, Ghc.fun_tick = []
|
||||
}
|
||||
|
||||
wrappedBind =
|
||||
(Ghc.NonRecursive, Ghc.unitBag (Ghc.noLoc bind))
|
||||
|
||||
whereBinds' =
|
||||
case whereBinds of
|
||||
Ghc.EmptyLocalBinds x ->
|
||||
Ghc.HsValBinds Ghc.NoExtField
|
||||
(Ghc.XValBindsLR (Ghc.NValBinds [wrappedBind] []))
|
||||
|
||||
Ghc.HsValBinds x (Ghc.XValBindsLR (Ghc.NValBinds binds sigs)) ->
|
||||
let otherBinds = updateDebugIPInBinds whereBindName <$> binds
|
||||
|
||||
in Ghc.HsValBinds x
|
||||
(Ghc.XValBindsLR
|
||||
(Ghc.NValBinds (wrappedBind : otherBinds) sigs
|
||||
)
|
||||
)
|
||||
|
||||
_ -> whereBinds
|
||||
|
||||
grhss' = fmap (updateDebugIPInGRHS whereBindName) <$> grhss
|
||||
|
||||
pure m { Ghc.m_grhss =
|
||||
grhs
|
||||
{ Ghc.grhssGRHSs = grhss'
|
||||
, Ghc.grhssLocalBinds = Ghc.L whereLoc whereBinds'
|
||||
} }
|
||||
|
||||
-- | Produce the contents of the where binding that contains the new debug IP
|
||||
-- value, generated by creating a new ID and pairing it with the old one.
|
||||
mkWhereBind :: String -> Ghc.TcM (Ghc.LHsExpr Ghc.GhcRn)
|
||||
mkWhereBind key = do
|
||||
-- TODO This is where the new ID will be generated and paired with the old ID
|
||||
Right exprPs
|
||||
<- fmap (Ghc.convertToHsExpr Ghc.Generated Ghc.noSrcSpan)
|
||||
. liftIO
|
||||
$ TH.runQ [| ?_debug_ip <> key |]
|
||||
|
||||
(exprRn, _) <- Ghc.rnLExpr exprPs
|
||||
|
||||
pure exprRn
|
||||
|
||||
-- TODO can use syb for this?
|
||||
updateDebugIPInBinds
|
||||
:: Ghc.Name
|
||||
-> (Ghc.RecFlag, Ghc.LHsBinds Ghc.GhcRn)
|
||||
-> (Ghc.RecFlag, Ghc.LHsBinds Ghc.GhcRn)
|
||||
updateDebugIPInBinds varName (rec, binds)
|
||||
= (rec, fmap updateBind <$> binds)
|
||||
where
|
||||
updateBind b@Ghc.FunBind{ Ghc.fun_matches = m@Ghc.MG{ Ghc.mg_alts = alts } }
|
||||
= b { Ghc.fun_matches =
|
||||
m { Ghc.mg_alts = (fmap . fmap . fmap) updateMatch alts }
|
||||
}
|
||||
updateBind b = b
|
||||
updateMatch m@Ghc.Match{Ghc.m_grhss = g@Ghc.GRHSs{Ghc.grhssGRHSs = grhss}}
|
||||
= m{Ghc.m_grhss =
|
||||
g{Ghc.grhssGRHSs = fmap (updateDebugIPInGRHS varName) <$> grhss }
|
||||
}
|
||||
|
||||
updateDebugIPInGRHS
|
||||
:: Ghc.Name
|
||||
-> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
|
||||
-> Ghc.GRHS Ghc.GhcRn (Ghc.LHsExpr Ghc.GhcRn)
|
||||
updateDebugIPInGRHS varName (Ghc.GRHS x guards body)
|
||||
= Ghc.GRHS x guards (updateDebugIPInExpr varName body)
|
||||
|
||||
-- | Given the name of the variable to assign to the debug IP, create a let
|
||||
-- expression that updates the IP in that scope.
|
||||
updateDebugIPInExpr
|
||||
:: Ghc.Name
|
||||
-> Ghc.LHsExpr Ghc.GhcRn
|
||||
-> Ghc.LHsExpr Ghc.GhcRn
|
||||
updateDebugIPInExpr varName
|
||||
= Ghc.noLoc
|
||||
. Ghc.HsLet Ghc.NoExtField
|
||||
( Ghc.noLoc $ Ghc.HsIPBinds
|
||||
Ghc.NoExtField
|
||||
( Ghc.IPBinds Ghc.NoExtField
|
||||
[ Ghc.noLoc $ Ghc.IPBind
|
||||
Ghc.NoExtField
|
||||
(Left . Ghc.noLoc $ Ghc.HsIPName "_debug_ip")
|
||||
(Ghc.noLoc $ Ghc.HsVar
|
||||
Ghc.NoExtField
|
||||
(Ghc.noLoc varName)
|
||||
)
|
||||
]
|
||||
)
|
||||
)
|
||||
|
||||
-- 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.tcPluginInit = pure () -- Ghc.tcPluginIO $ newIORef False
|
||||
, Ghc.tcPluginStop = \_ -> pure ()
|
||||
, Ghc.tcPluginSolve = tcPluginSolver
|
||||
, Ghc.tcPluginSolve = const tcPluginSolver
|
||||
}
|
||||
|
||||
ppr :: Ghc.Outputable a => a -> String
|
||||
@ -80,72 +322,88 @@ isDebuggerIpCt ct@Ghc.CDictCan{}
|
||||
-- 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
|
||||
tcPluginSolver :: Ghc.TcPluginSolver
|
||||
tcPluginSolver given derived wanted = do
|
||||
--Ghc.tcPluginIO . putStrLn $ ppr (wanted, given, derived)
|
||||
case filter isDebuggerIpCt wanted of
|
||||
[w]
|
||||
| Ghc.IPOccOrigin _ <- Ghc.ctl_origin . Ghc.ctev_loc $ Ghc.cc_ev w
|
||||
-> do
|
||||
--Ghc.tcPluginIO . putStrLn . ppr $ Ghc.ctl_origin . Ghc.ctev_loc $ Ghc.cc_ev w
|
||||
pure $ Ghc.TcPluginOk [] []
|
||||
| otherwise
|
||||
-> do
|
||||
--Ghc.tcPluginIO . putStrLn . ppr $ Ghc.ctl_origin . Ghc.ctev_loc $ Ghc.cc_ev w
|
||||
str <- Ghc.unsafeTcPluginTcM $ Ghc.mkStringExpr "inserted"
|
||||
pure $ Ghc.TcPluginOk [(Ghc.EvExpr str, w)] []
|
||||
_ -> pure $ Ghc.TcPluginOk [] []
|
||||
|
||||
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 [] []
|
||||
-- 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
|
||||
|
Loading…
Reference in New Issue
Block a user