{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module GHC.Debug.Client.Monad.Haxl
  ( Debuggee(..)
  , Request(..)
  , DebugM
  , Env(..)
  ) where

import GHC.Debug.Types
import qualified Data.HashMap.Strict as HM
import System.IO
import Control.Concurrent

import GHC.Debug.Client.BlockCache
import GHC.Debug.Client.Monad.Class

import Haxl.Core hiding (Request, env)
import Data.Typeable

import Data.IORef

data Debuggee = Debuggee { -- Keep track of how many of each request we make
                           Debuggee -> IORef (HashMap CommandId Int)
debuggeeRequestCount :: IORef (HM.HashMap CommandId Int)
                         , Debuggee -> BatchMode
debuggeeBatchMode :: BatchMode
                         }

data BatchMode = Batch | OneByOne deriving (BatchMode -> BatchMode -> Bool
(BatchMode -> BatchMode -> Bool)
-> (BatchMode -> BatchMode -> Bool) -> Eq BatchMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BatchMode -> BatchMode -> Bool
$c/= :: BatchMode -> BatchMode -> Bool
== :: BatchMode -> BatchMode -> Bool
$c== :: BatchMode -> BatchMode -> Bool
Eq, Int -> BatchMode -> ShowS
[BatchMode] -> ShowS
BatchMode -> String
(Int -> BatchMode -> ShowS)
-> (BatchMode -> String)
-> ([BatchMode] -> ShowS)
-> Show BatchMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BatchMode] -> ShowS
$cshowList :: [BatchMode] -> ShowS
show :: BatchMode -> String
$cshow :: BatchMode -> String
showsPrec :: Int -> BatchMode -> ShowS
$cshowsPrec :: Int -> BatchMode -> ShowS
Show)

instance DebugMonad (GenHaxl Debuggee String) where
  type DebugEnv (GenHaxl Debuggee String) = Env Debuggee String
  request :: forall resp.
(Show resp, Typeable resp) =>
Request resp -> GenHaxl Debuggee String resp
request = Request resp -> GenHaxl Debuggee String resp
forall u (r :: * -> *) a w.
(DataSource u r, Request r a) =>
r a -> GenHaxl u w a
dataFetch
  requestBlock :: forall resp.
(Show resp, Typeable resp) =>
BlockCacheRequest resp -> GenHaxl Debuggee String resp
requestBlock = BlockCacheRequest resp -> GenHaxl Debuggee String resp
forall u (r :: * -> *) a w.
(DataSource u r, Request r a) =>
r a -> GenHaxl u w a
dataFetch
  traceMsg :: String -> GenHaxl Debuggee String ()
traceMsg = String -> GenHaxl Debuggee String ()
forall w u. w -> GenHaxl u w ()
tellWrite
  printRequestLog :: DebugEnv (GenHaxl Debuggee String) -> IO ()
printRequestLog = DebugEnv (GenHaxl Debuggee String) -> IO ()
forall u w. Env u w -> IO ()
traceRequestLog
  runDebug :: forall a.
DebugEnv (GenHaxl Debuggee String)
-> GenHaxl Debuggee String a -> IO a
runDebug = DebugEnv (GenHaxl Debuggee String)
-> GenHaxl Debuggee String a -> IO a
forall u w a. Env u w -> GenHaxl u w a -> IO a
runHaxl
  runDebugTrace :: forall a.
DebugEnv (GenHaxl Debuggee String)
-> GenHaxl Debuggee String a -> IO (a, [String])
runDebugTrace = DebugEnv (GenHaxl Debuggee String)
-> GenHaxl Debuggee String a -> IO (a, [String])
forall u w a. Env u w -> GenHaxl u w a -> IO (a, [w])
runHaxlWithWrites
  newEnv :: Mode -> IO (DebugEnv (GenHaxl Debuggee String))
newEnv Mode
args =
    case Mode
args of
      SnapshotMode String
_e -> String -> IO (Env Debuggee String)
forall a. HasCallStack => String -> a
error String
"Loading from snapshot not supported"
      SocketMode Handle
h -> Handle -> IO (Env Debuggee String)
mkEnv Handle
h

  saveCache :: String -> GenHaxl Debuggee String ()
saveCache = String -> String -> GenHaxl Debuggee String ()
forall a. HasCallStack => String -> a
error String
"TODO"
  loadCache :: String -> GenHaxl Debuggee String ()
loadCache = String -> String -> GenHaxl Debuggee String ()
forall a. HasCallStack => String -> a
error String
"TODO"
  unsafeLiftIO :: forall a. IO a -> GenHaxl Debuggee String a
unsafeLiftIO = String -> IO a -> GenHaxl Debuggee String a
forall a. HasCallStack => String -> a
error String
"TODO"

type DebugM = GenHaxl Debuggee String


{- MP:
- In some profiles it seemed that the caching step was causing quite a bit
- of overhead, but still using the cache is about 2-3x faster than without
- a cache. (ie using `doRequest` directly or `uncachedRequest`.
-}

-- | Send a request to a 'Debuggee' paused with 'withPause'.
--request :: (Show resp, Typeable resp) => Request resp -> DebugM resp
--request = dataFetch


instance StateKey Request where
  data State Request = RequestState (MVar Handle)

instance DataSourceName Request where
  dataSourceName :: Proxy Request -> Text
dataSourceName Proxy Request
Proxy = Text
"ghc-debug"

instance ShowP Request where
  showp :: forall a. Request a -> String
showp = Request a -> String
forall a. Show a => a -> String
show

{-
-- | Group together RequestClosures and RequestInfoTables to avoid
-- some context switching.
groupFetches :: MVar Handle -> [([ClosurePtr], ResultVar [RawClosure])] -> [([InfoTablePtr], ResultVar [(StgInfoTableWithPtr, RawInfoTable)])] -> [BlockedFetch Request] -> [BlockedFetch Request] -> IO ()
groupFetches h cs is todo [] = dispatch h cs is (reverse todo)
groupFetches h cs is todo (b@(BlockedFetch r resp) : bs) =
  case r of
    RequestInfoTables is' -> groupFetches h cs ((is', resp):is) todo bs
    RequestClosures cs' -> groupFetches h ((cs', resp):cs) is todo bs
    _ -> groupFetches h cs is (b:todo) bs

dispatch :: MVar Handle
         -> [([ClosurePtr], ResultVar [RawClosure])]
         -> [([InfoTablePtr], ResultVar [(StgInfoTableWithPtr, RawInfoTable)])]
         -> [BlockedFetch Request]
         -> IO ()
dispatch h cs its other = do
  mapM_ do_one other
  -- These can be used to inspect how much batching is happening
--  print ("BATCHED_CLOSURES", length cs, map fst cs)
--  print (length its, map fst its)
  do_many RequestClosures cs
  do_many RequestInfoTables its
  where
    do_one (BlockedFetch req resp) = do
      res <- doRequest h req
      putSuccess resp res

    do_many :: ([a] -> Request [b]) -> [([a], ResultVar [b])] -> IO ()
    do_many _ [] = return ()
    do_many mk_req ms = do
      let req = mk_req (concatMap fst ms)
      results <- doRequest h req
      recordResults results ms



-- | Write the correct number of results to each result var
recordResults :: [a] -> [([b], ResultVar [a])] -> IO ()
recordResults [] [] = return ()
recordResults res ((length -> n, rvar):xs) =
  putSuccess rvar here >> recordResults later xs
  where
    (here, later) = splitAt n res
recordResults _ _ = error ("Impossible recordResults")
-}

_singleFetches :: MVar Handle -> [BlockedFetch Request] -> IO ()
_singleFetches :: MVar Handle -> [BlockedFetch Request] -> IO ()
_singleFetches MVar Handle
h [BlockedFetch Request]
bs = (BlockedFetch Request -> IO ()) -> [BlockedFetch Request] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockedFetch Request -> IO ()
do_one [BlockedFetch Request]
bs
      where
        do_one :: BlockedFetch Request -> IO ()
do_one (BlockedFetch Request a
req ResultVar a
resp) = do
          a
res <- MVar Handle -> Request a -> IO a
forall a. MVar Handle -> Request a -> IO a
doRequest MVar Handle
h Request a
req
          ResultVar a -> a -> IO ()
forall a. ResultVar a -> a -> IO ()
putSuccess ResultVar a
resp a
res

instance DataSource Debuggee Request where
  fetch :: State Request -> Flags -> Debuggee -> PerformFetch Request
fetch (RequestState MVar Handle
h) Flags
_fs Debuggee
u =
    -- Grouping together fetches only shaves off about 0.01s on the simple
    -- benchmark
    ([BlockedFetch Request] -> IO ()) -> PerformFetch Request
forall (req :: * -> *).
([BlockedFetch req] -> IO ()) -> PerformFetch req
SyncFetch (([BlockedFetch Request] -> IO ()) -> PerformFetch Request)
-> ([BlockedFetch Request] -> IO ()) -> PerformFetch Request
forall a b. (a -> b) -> a -> b
$
      case Debuggee -> BatchMode
debuggeeBatchMode Debuggee
u of
        --Batch -> groupFetches h [] [] []
        BatchMode
_ -> MVar Handle -> [BlockedFetch Request] -> IO ()
_singleFetches MVar Handle
h



instance StateKey BlockCacheRequest where
  data State BlockCacheRequest = BCRequestState (IORef BlockCache) (MVar Handle)

instance DataSourceName BlockCacheRequest where
  dataSourceName :: Proxy BlockCacheRequest -> Text
dataSourceName Proxy BlockCacheRequest
Proxy = Text
"block-cache"

instance ShowP BlockCacheRequest where
  showp :: forall a. BlockCacheRequest a -> String
showp = BlockCacheRequest a -> String
forall a. Show a => a -> String
show


instance DataSource u BlockCacheRequest where
  fetch :: State BlockCacheRequest
-> Flags -> u -> PerformFetch BlockCacheRequest
fetch (BCRequestState IORef BlockCache
ref MVar Handle
h) Flags
_fs u
_u =
    ([BlockedFetch BlockCacheRequest] -> IO ())
-> PerformFetch BlockCacheRequest
forall (req :: * -> *).
([BlockedFetch req] -> IO ()) -> PerformFetch req
SyncFetch ((BlockedFetch BlockCacheRequest -> IO ())
-> [BlockedFetch BlockCacheRequest] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockedFetch BlockCacheRequest -> IO ()
do_one)
    where
      do_one :: BlockedFetch BlockCacheRequest -> IO ()
      do_one :: BlockedFetch BlockCacheRequest -> IO ()
do_one (BlockedFetch BlockCacheRequest a
bcr ResultVar a
resp) = do
        a
res <- (forall a. Request a -> IO a)
-> IORef BlockCache -> BlockCacheRequest a -> IO a
forall resp.
(forall a. Request a -> IO a)
-> IORef BlockCache -> BlockCacheRequest resp -> IO resp
handleBlockReq (MVar Handle -> Request a -> IO a
forall a. MVar Handle -> Request a -> IO a
doRequest MVar Handle
h) IORef BlockCache
ref BlockCacheRequest a
bcr
        ResultVar a -> a -> IO ()
forall a. ResultVar a -> a -> IO ()
putSuccess ResultVar a
resp a
res



mkEnv :: Handle -> IO (Env Debuggee String)
mkEnv :: Handle -> IO (Env Debuggee String)
mkEnv Handle
hdl = do
  IORef (HashMap CommandId Int)
requestMap <- HashMap CommandId Int -> IO (IORef (HashMap CommandId Int))
forall a. a -> IO (IORef a)
newIORef HashMap CommandId Int
forall k v. HashMap k v
HM.empty
  IORef BlockCache
bc <- BlockCache -> IO (IORef BlockCache)
forall a. a -> IO (IORef a)
newIORef BlockCache
emptyBlockCache
  MVar Handle
mhdl <- Handle -> IO (MVar Handle)
forall a. a -> IO (MVar a)
newMVar Handle
hdl
  let ss :: StateStore
ss = State BlockCacheRequest -> StateStore -> StateStore
forall (f :: * -> *).
StateKey f =>
State f -> StateStore -> StateStore
stateSet (IORef BlockCache -> MVar Handle -> State BlockCacheRequest
BCRequestState IORef BlockCache
bc MVar Handle
mhdl) (State Request -> StateStore -> StateStore
forall (f :: * -> *).
StateKey f =>
State f -> StateStore -> StateStore
stateSet (MVar Handle -> State Request
RequestState MVar Handle
mhdl) StateStore
stateEmpty)
  Env Debuggee String
new_env <- StateStore -> Debuggee -> IO (Env Debuggee String)
forall u w. StateStore -> u -> IO (Env u w)
initEnv StateStore
ss (IORef (HashMap CommandId Int) -> BatchMode -> Debuggee
Debuggee IORef (HashMap CommandId Int)
requestMap BatchMode
Batch)
  -- Turn on data fetch stats with report = 3
  let new_flags :: Flags
new_flags = Flags
defaultFlags { report :: Int
report = Int
0 }
  Env Debuggee String -> IO (Env Debuggee String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env Debuggee String -> IO (Env Debuggee String))
-> Env Debuggee String -> IO (Env Debuggee String)
forall a b. (a -> b) -> a -> b
$ Env Debuggee String
new_env { flags :: Flags
Haxl.Core.flags = Flags
new_flags }

-- | Print out the number of request made for each request type
traceRequestLog :: Env u w -> IO ()
traceRequestLog :: forall u w. Env u w -> IO ()
traceRequestLog Env u w
d = do
  Stats
s <- IORef Stats -> IO Stats
forall a. IORef a -> IO a
readIORef (Env u w -> IORef Stats
forall u w. Env u w -> IORef Stats
statsRef Env u w
d)
  String -> IO ()
putStrLn (Stats -> String
ppStats Stats
s)

_traceProfile :: Env u w -> IO ()
_traceProfile :: forall u w. Env u w -> IO ()
_traceProfile Env u w
e = do
  Profile
p <- IORef Profile -> IO Profile
forall a. IORef a -> IO a
readIORef (Env u w -> IORef Profile
forall u w. Env u w -> IORef Profile
profRef Env u w
e)
  HashMap ProfileKey ProfileData -> IO ()
forall a. Show a => a -> IO ()
print (Profile -> HashMap ProfileKey ProfileData
profile Profile
p)