Commit 240fc93a authored by Tomislav Pree's avatar Tomislav Pree
Browse files

embed debug combinator

parent c6c91d18
Pipeline #64878 failed with stages
in 30 minutes and 43 seconds
......@@ -9,7 +9,7 @@
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Control.Arrow.Transformer.Abstract.Fix(FixT,runFixT) where
module Control.Arrow.Transformer.Abstract.Fix(FixT(..),runFixT) where
import Prelude hiding (id,(.),const,head,iterate,lookup)
......
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Control.Arrow.Transformer.Debug where
import Control.Category
import Control.Arrow hiding (loop)
import Control.Arrow.Primitive
import Control.Arrow.Strict
import Control.Arrow.Fix
import Control.Arrow.Fix.Cache
import Control.Arrow.Fix.Chaotic
import Control.Arrow.Fix.ControlFlow
import Control.Arrow.Fix.Context
import Control.Arrow.Fix.Metrics
import Control.Arrow.Fix.Stack
import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..))
import Control.Arrow.Trans
import Control.Arrow.IO
import Data.Profunctor
import Data.Profunctor.Unsafe((.#))
import Data.Coerce
import Data.Order hiding (lub)
import Syntax (LExpr,Expr(App))
import qualified Network.HTTP.Types as Http
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WebSockets as WS
import qualified Network.WebSockets as WS
import qualified Safe
import qualified Control.Concurrent as Concurrent
import Control.Arrow.State as State
import Control.Arrow.Transformer.State
import Prelude hiding (lookup,read,fail,Bounded(..))
import Control.Arrow.Fix.Parallel (parallel,adi)
import Control.Arrow.Transformer.Abstract.Terminating
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Metrics
import Control.Arrow.Transformer.Abstract.Fix.Component
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable hiding (Widening)
import Control.Arrow.Transformer.Abstract.Fix.Stack
import qualified Data.Text as Text
import Data.Identifiable
type ClientId = Int
type Client = (ClientId, WS.Connection)
type State = [Client]
type Socket = () -- Placeholder
type Breakpoints = [Expr] -- Placeholder
--type StackElems = [In] -- Placeholder
data DebugState = DebugState {
breakpoints :: Breakpoints,
conn :: WS.Connection,
clientId :: ClientId,
stateRef :: Concurrent.MVar State,
expressionList :: [LExpr],
debugPhase :: Int
}
newtype DebugT c x y = DebugT (StateT DebugState c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,
ArrowContext ctx, ArrowJoinContext a, ArrowControlFlow a,
ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache,
ArrowStack a,ArrowStackElements a,ArrowStackDepth,
ArrowComponent a, ArrowInComponent a,
ArrowMetrics a, ArrowStrict, ArrowPrimitive)
class ArrowDebug c where
addBreakpoints :: c Breakpoints ()
isBreakpoint :: c Expr Bool
sendMessage :: c Text.Text ()
--instance ArrowRun (DebugT c) where
-- type Run (DebugT c) x y = c x y
--
--instance ArrowRun c => ArrowRun (DebugT c) where type Run (DebugT c) x y = Run c x y
instance (Profunctor c, Arrow c, ArrowRun c) => ArrowRun (DebugT c) where
type Run (DebugT c) x y = Run c (DebugState,x) (DebugState,y)
run (DebugT (StateT f)) = run f
deriving instance ArrowDebug c => ArrowDebug (FixT c)
instance (Arrow c, Profunctor c, ArrowIO c) => ArrowDebug (DebugT c) where
addBreakpoints = DebugT $ proc bps -> do
state <- State.get -< ()
State.put -< state { breakpoints = bps ++ breakpoints state }
returnA -< ()
isBreakpoint = DebugT $ proc expr -> do
state <- State.get -< ()
returnA -< expr `Prelude.elem` (breakpoints state)
sendMessage = DebugT $ proc message -> do
state <- State.get -< ()
liftIO sendResponse -< (state,message)
returnA -< ()
{-# INLINE addBreakpoints #-}
{-# INLINE isBreakpoint #-}
{-# INLINE sendMessage #-}
sendResponse :: (DebugState,Text.Text) -> IO ()
sendResponse (debugState,msg)= do
WS.sendTextData (conn debugState) msg
{-# LANGUAGE Arrows #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImplicitParams #-}
......@@ -58,6 +60,8 @@ import TypedAnalysis
import Syntax (LExpr,Expr(App))
import GenericInterpreter as Generic
--import Control.Arrow.Transformer.Debug(DebugT)
--imports for debugger
import qualified Control.Concurrent as Concurrent
......@@ -88,21 +92,25 @@ import Parser
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as B
import Control.Arrow.Transformer.Debug(DebugT, ArrowDebug, sendMessage)
import Control.Arrow.Transformer.State
type InterpT c x y =
(ValueT Val
(TerminatingT
(LogErrorT Text
(EnvStoreT Text Addr Val
(FixT
(FixT
(DebugT
(MetricsT Metric.Monotone In
(ComponentT Comp.Component In
(StackT Stack.Stack In
(CacheT Cache.Monotone In Out
(ContextT Ctx
(ControlFlowT Expr
c))))))))))) x y
c)))))))))))) x y
{--
evalChaotic :: (?sensitivity :: Int) => IterationStrategy _ In Out -> [(Text,Addr)] -> [LExpr] -> (CFG Expr, (Metric.Monotone In, Out'))
evalChaotic iterationStrat env0 e =
let ?cacheWidening = (storeErrWidening, W.finite) in
......@@ -118,7 +126,9 @@ evalChaotic iterationStrat env0 e =
where
e0 = generate (sequence e)
{-# INLINE evalChaotic #-}
-}
{--
evalInner :: Eval
evalInner = evalChaotic innermost'
......@@ -133,7 +143,7 @@ evalOuter' exprs = let (metrics,(cfg,res)) = evalOuter [] exprs in (metrics,(cfg
eval' :: (?sensitivity :: Int) => [(Text,Addr)] -> [LExpr] -> (Errors,Terminating Val)
eval' env exprs = snd $ snd $ snd $ evalInner env exprs
-}
--------------------------------------------------
......@@ -178,6 +188,7 @@ data TestMessage
| RefreshResponse {operation :: Text, success :: Bool}
deriving (Show, Eq)
instance ToJSON TestMessage where
toJSON (InitializeDebuggerRequest operation path) = object ["operation" .= operation, "path" .= path]
toJSON (InitializeDebuggerResponse operation code) = object ["operation" .= operation, "code" .= code]
......@@ -206,12 +217,10 @@ instance FromJSON TestMessage where
changeExpressions :: DebugState -> [LExpr] -> DebugState
changeExpressions debugState expressions = DebugState (breakpoints debugState) (conn debugState) (clientId debugState) (stateRef debugState) expressions (debugPhase debugState)
changeExpressions debugState expressions = debugState { expressionList = expressions }
changeDebugPhase :: DebugState -> Int -> DebugState
changeDebugPhase debugState debugPhase = DebugState (breakpoints debugState) (conn debugState) (clientId debugState) (stateRef debugState) (expressionList debugState) debugPhase
changeDebugPhase debugState debugPhase = debugState { debugPhase = debugPhase }
{--
......@@ -293,7 +302,7 @@ startServer :: P.IO ()
startServer = do
putStrLn "hello world"
state <- Concurrent.newMVar []
Warp.run 3000 $ WS.websocketsOr
Warp.run 3001 $ WS.websocketsOr
WS.defaultConnectionOptions
(wsApp state)
httpApp
......@@ -392,7 +401,7 @@ evalDebug expr =
--debug . --TODO
Ctx.recordCallsite ?sensitivity (\(_,(_,exprs)) -> case exprs of App _ _ l:_ -> Just l; _ -> Nothing) .
Fix.filter' isFunctionBody (chaotic innermost') in
do _ <- Trans.run (extend' (Generic.runFixed :: InterpT IO [Expr] Val)) (empty,(empty,([],e0)))
do _ <- Trans.run (extend' (Generic.runFixed :: InterpT IO [Expr] Val)) (empty,(empty,(empty,e0)))
return ()
where
e0 = generate (sequence expr)
......@@ -400,10 +409,15 @@ evalDebug expr =
-- | Debugging combinator
debug :: (?debugState :: DebugState,
ArrowChoice c, ArrowIO c, ArrowStackElements In c)
ArrowChoice c, ArrowIO c, ArrowStackElements In c, ArrowDebug c)
=> Fix.FixpointCombinator c ((Store,Errors),(Env,[Expr]))
((Store,Errors), Terminating Val)
debug f = proc input@((store,errors),(env,exprs)) -> do
sendMessage -< (Text.pack "BLA")
f -< input
{--
case exprs of
expr:_ | expr `P.elem` breakpoints ?debugState -> do
-- We reached a breakpoint
......@@ -422,7 +436,7 @@ debug f = proc input@((store,errors),(env,exprs)) -> do
stack <- Stack.elems -< ()
liftIO send -< GetStackResponse stack
loop -< input
-}
--------------------- Helper Functions ----------------------------
......@@ -437,3 +451,6 @@ toStrict1 = B.concat . BL.toChunks
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment