Commit ba531861 authored by Tomislav Pree's avatar Tomislav Pree
Browse files

add debugger logic

parent c995774b
......@@ -23,6 +23,7 @@ dependencies:
- text
- union-find
- unordered-containers
- aeson
library:
ghc-options:
......
......@@ -26,8 +26,9 @@ import Data.Monoidal
import Text.Printf
type StackPointer = Int
data RecurrentCall = RecurrentCall StackPointer | NoLoop
data RecurrentCall = RecurrentCall StackPointer | NoLoop deriving (Show)
class (Arrow c, Profunctor c) => ArrowStack a c | c -> a where
push :: c x y -> c (a, x) (y)
......@@ -48,7 +49,7 @@ class (Arrow c, Profunctor c) => ArrowStackDepth c where
{-# INLINE depth #-}
class (Arrow c, Profunctor c) => ArrowStackElements a c where
class (Arrow c, Profunctor c) => ArrowStackElements a c | c -> a where
elems :: c () [a]
peek :: c () (Maybe a)
......@@ -57,7 +58,6 @@ class (Arrow c, Profunctor c) => ArrowStackElements a c where
elems = lift' elems
peek = lift' peek
{-# INLINE elems #-}
{-# INLINE peek #-}
......@@ -127,6 +127,15 @@ instance ArrowStack a c => ArrowStack a (ReaderT r c) where
instance ArrowStackDepth c => ArrowStackDepth (ReaderT r c)
instance ArrowStackElements a c => ArrowStackElements a (ReaderT r c)
---------------DEBUGT
--instance ArrowStack a c => ArrowStack a (DebugT c) where
-- push f = lift $ lmap shuffle1 (push (unlift f))
-- {-# INLINE push #-}
--instance ArrowStackDepth c => ArrowStackDepth (DebugT c)
--instance ArrowStackElements a c => ArrowStackElements a (DebugT c)
---------------
instance ArrowStack a c => ArrowStack a (StateT s c) where
push f = lift $ lmap shuffle1 (push (unlift f))
{-# INLINE push #-}
......
......@@ -3,6 +3,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.Label where
import Data.Hashable
......@@ -13,12 +14,15 @@ import Control.DeepSeq
import Text.Printf
import Data.Text.Prettyprint.Doc
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics
-- Retrieves label from expression.
class HasLabel x where
label :: x -> Label
newtype Label = Label { labelVal :: Int }
deriving (Ord,Eq,Hashable,Num,NFData)
deriving (Ord,Eq,Hashable,Num,NFData,Generic,ToJSON,FromJSON)
instance Show Label where
show (Label l) = printf "#%d" l
......
......@@ -12,6 +12,8 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
......@@ -27,7 +29,7 @@ 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.Fix.Stack as Stack
import Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..))
import Control.Arrow.Trans
import Control.Arrow.IO
......@@ -65,12 +67,15 @@ 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 Control.Arrow.Transformer.Abstract.Fix.Stack (Stack,StackT)
import qualified Data.Text as Text
import Data.Identifiable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.Monoidal
......@@ -106,19 +111,20 @@ class ArrowDebug c where
addBreakpoints :: c Breakpoints ()
isBreakpoint :: c Expr Bool
sendMessage :: c Text.Text ()
receiveMessage :: c () Text.Text
sendStack :: 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
......@@ -132,10 +138,21 @@ instance (Arrow c, Profunctor c, ArrowIO c) => ArrowDebug (DebugT c) where
state <- State.get -< ()
liftIO sendResponse -< (state,message)
returnA -< ()
receiveMessage = DebugT $ proc message -> do
state <- State.get -< ()
msg <- liftIO WS.receiveData -< (conn state)
returnA -< msg
sendStack = DebugT $ proc message-> do
state <- State.get -< ()
--stack <- Stack.elems -< ()
returnA-< ()
{-# INLINE addBreakpoints #-}
{-# INLINE isBreakpoint #-}
{-# INLINE sendMessage #-}
{-# INLINE receiveMessage #-}
{-# INLINE sendStack #-}
sendResponse :: (DebugState,Text.Text) -> IO ()
sendResponse (debugState,msg)= do
WS.sendTextData (conn debugState) msg
......@@ -5,6 +5,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Syntax where
import Data.Text (Text)
......@@ -19,7 +20,9 @@ import Control.Monad.State
import Control.DeepSeq
import GHC.Generics
import Data.Aeson (ToJSON, FromJSON)
-- Literals of Scheme
data Literal
= Int Int
| Float Double
......@@ -31,6 +34,8 @@ data Literal
| Quote Literal
-- | DottedList [Literal] Literal
deriving (Eq,Generic,NFData)
instance ToJSON Literal
instance FromJSON Literal
data Op1
-- | Check operations
......@@ -69,6 +74,8 @@ data Op1
-- | Error -- (error z)
| Random -- (random z)
deriving (Eq,Generic,NFData)
instance ToJSON Op1
instance FromJSON Op1
data Op2
-- | Equivalence predicates
......@@ -80,6 +87,8 @@ data Op2
-- | String operations
| StringRef -- (string-ref z1 z2)
deriving (Eq,Generic,NFData)
instance ToJSON Op2
instance FromJSON Op2
data OpVar
-- | Numerical operations
......@@ -99,6 +108,8 @@ data OpVar
| StringAppend -- (string-append z1 z2 z3 ...)
-- | List operations
deriving (Eq,Generic,NFData)
instance ToJSON OpVar
instance FromJSON OpVar
-- | Expressions of Scheme. Each expression has a label, with which the
......@@ -128,6 +139,9 @@ data Expr
| Error String Label
deriving (Generic,NFData)
instance ToJSON Expr
instance FromJSON Expr
instance Eq Expr where
e1 == e2 = label e1 == label e2
......
......@@ -33,7 +33,9 @@ import Control.Arrow.Environment as Env
import qualified Control.Arrow.Fix as Fix
import Control.Arrow.Fix.Chaotic(IterationStrategy,chaotic,innermost',outermost')
import qualified Control.Arrow.Fix.Context as Ctx
import Control.Arrow.Fix.Stack as Stack
--import Control.Arrow.Fix.Stack as Stack
import Control.Arrow.Fix.Stack (ArrowStack,ArrowStackDepth,ArrowStackElements,widenInput,maxDepth,reuseByMetric)
import qualified Control.Arrow.Fix.Stack as Stack
import Control.Arrow.IO
import qualified Control.Arrow.Trans as Trans
import Control.Arrow.Transformer.IO
......@@ -43,7 +45,7 @@ import Control.Arrow.Transformer.Abstract.LogError
import Control.Arrow.Transformer.Abstract.Fix
import Control.Arrow.Transformer.Abstract.Fix.Component as Comp
import Control.Arrow.Transformer.Abstract.Fix.Context
import Control.Arrow.Transformer.Abstract.Fix.Stack as Stack
import Control.Arrow.Transformer.Abstract.Fix.Stack --as Stack
import Control.Arrow.Transformer.Abstract.Fix.Cache.Immutable as Cache
import Control.Arrow.Transformer.Abstract.Fix.Metrics as Metric
import Control.Arrow.Transformer.Abstract.Fix.ControlFlow
......@@ -57,7 +59,7 @@ import qualified Data.Abstract.Widening as W
import Data.Abstract.Terminating(Terminating)
import TypedAnalysis
import Syntax (LExpr,Expr(App))
import Syntax (LExpr,Expr(App),Literal)
import GenericInterpreter as Generic
--import Control.Arrow.Transformer.Debug(DebugT)
......@@ -94,6 +96,8 @@ import qualified Data.ByteString as B
import Control.Arrow.Transformer.Debug(DebugState(..), DebugT, ArrowDebug, sendMessage)
import Control.Arrow.Transformer.State
import Control.Arrow.Fix.ControlFlow
type InterpT c x y =
(ValueT Val
......@@ -104,7 +108,7 @@ type InterpT c x y =
(DebugT
(MetricsT Metric.Monotone In
(ComponentT Comp.Component In
(StackT Stack.Stack In
(StackT Stack In
(CacheT Cache.Monotone In Out
(ContextT Ctx
(ControlFlowT Expr
......@@ -158,15 +162,6 @@ 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
-- }
data Message
= ReachedBreakpoint {breakpoint :: Expr, env :: Env}
......@@ -181,37 +176,17 @@ data Message
data TestMessage
= InitializeDebuggerRequest {path :: String}
| InitializeDebuggerResponse {code :: Text}
| ContinueRequest {bps :: [Text], start :: Bool}
| InitializeDebuggerResponse {code :: [Expr]}
| ContinueRequest {bps :: [Int], start :: Bool}
| ContinueResponse {debugInfo :: Text}
| RefreshRequest
| RefreshResponse {success :: Bool}
deriving (Show, Eq, Generic)
instance ToJSON TestMessage where
-- toJSON (InitializeDebuggerRequest operation path) = object ["operation" .= operation, "path" .= path]
-- toJSON (InitializeDebuggerResponse operation code) = object ["operation" .= operation, "code" .= code]
-- toJSON (ContinueRequest operation bps start) = object ["operation" .= operation, "bps" .= bps, "start" .= start]
-- toJSON (ContinueResponse operation debugInfo) = object ["operation" .= operation, "debugInfo" .= debugInfo]
-- toJSON (RefreshRequest operation) = object ["operation" .= operation]
-- toJSON (RefreshResponse operation success) = object ["operation" .= operation, "success" .= success]
instance FromJSON TestMessage where
-- parseJSON v = parseInitializeDebuggerRequest v
-- <> parseInitializeDebuggerResponse v
-- <> parseContinueRequest v
-- <> parseContinueResponse v
-- <> parseRefreshRequest v
-- <> parseRefreshResponse v
-- where
-- parseInitializeDebuggerRequest = withObject "InitializeDebuggerRequest" $ \obj -> InitializeDebuggerRequest <$> obj .: "operation" <*> obj .: "path"
-- parseInitializeDebuggerResponse = withObject "InitializeDebuggerResponse" $ \obj -> InitializeDebuggerResponse <$> obj .: "operation" <*> obj .: "code"
-- parseContinueRequest = withObject "ContinueRequest" $ \obj -> ContinueRequest <$> obj .: "operation" <*> obj .: "bps" <*> obj .: "start"
-- parseContinueResponse = withObject "ContinueResponse" $ \obj -> ContinueResponse <$> obj .: "operation" <*> obj.: "debugInfo"
-- parseRefreshRequest = withObject "RefreshRequest" $ \obj -> RefreshRequest <$> obj .: "operation"
-- parseRefreshResponse = withObject "RefreshResponse" $ \obj -> RefreshResponse <$> obj .: "operation" <*> obj .: "success"
instance ToJSON TestMessage
instance FromJSON TestMessage
......@@ -222,79 +197,8 @@ changeExpressions debugState expressions = debugState { expressionList = express
changeDebugPhase :: DebugState -> Int -> DebugState
changeDebugPhase debugState debugPhase = debugState { debugPhase = debugPhase }
{--
-- | Main entry point for the debugger
startDebugger :: [LExpr] -> P.IO ()
startDebugger expr = do
_setupDebugState -- TODO: Implement
let ?sensitivity = 0
let ?debugState = _debugState -- TODO: Implement
evalDebug expr
-- socket <- createSocket -< 1234
-- loop
-- where
-- loop = do
-- msg <- Client.receive -< ()
-- case msg of
-- StartProgram file breakpoints -> do
-- prog <- loadSchemeFile file
-- let ?sensitivity = 0
-- let debugState = DebugState socket breakpoints
-- evalDebug debugState prog
-- loop
-- _ ->
-- closeSocket socket
evalDebug :: (?sensitivity::Int, ?debugState::DebugState) => [LExpr] -> P.IO ()
evalDebug expr =
let ?cacheWidening = (storeErrWidening, W.finite) in
let ?fixpointAlgorithm = transform $
Fix.fixpointAlgorithm $
debug .
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)))
return ()
where
e0 = generate (sequence expr)
-- | Send message to debugging client
send :: (?debugState :: DebugState) => Message -> P.IO ()
send = _send -- TODO: Implement
-- | Receive message from debugging client
receive :: (?debugState :: DebugState) => () -> P.IO Message
receive = _receive -- TODO: Implement
-- | Debugging combinator
debug :: (?debugState :: DebugState,
ArrowChoice c, ArrowIO c, ArrowStackElements In c)
=> Fix.FixpointCombinator c ((Store,Errors),(Env,[Expr]))
((Store,Errors), Terminating Val)
debug f = proc input@((store,errors),(env,exprs)) -> do
case exprs of
expr:_ | expr `P.elem` breakpoints ?debugState -> do
-- We reached a breakpoint
liftIO send -< ReachedBreakpoint expr env
loop -< input
f -< input
_ ->
f -< input
where
loop = proc input@((store,errors),(env,expr)) -> do
msg <- liftIO receive -< ()
case msg of
Continue ->
returnA -< ()
GetStackRequest -> do
stack <- Stack.elems -< ()
liftIO send -< GetStackResponse stack
loop -< input
-}
refreshDebugState :: DebugState -> DebugState
refreshDebugState debugState = debugState { breakpoints = [], expressionList = []}
......@@ -343,41 +247,46 @@ disconnectClient clientId stateRef = Concurrent.modifyMVar_ stateRef $ \state ->
listen :: DebugState -> P.IO ()
listen debugState = do
print (clientId debugState)
msg <- WS.receiveData (conn debugState)
let dec = Maybe.fromJust (decode'' msg) :: TestMessage
print "JETZT KOMMT PRINT DEC "
print (dec)
-- print (operation dec)
-- case dec of
-- InitializeDebuggerResponse { code = c } -> ... c ...
-- let op = operation dec
-- case op of
-- "InitializeDebuggerRequest" -> do
-- let expressions = Parser.loadSchemeFile (path dec)
-- -- TODO richtige Expressions an den Client senden, wie kann man die expr. zum string casten?
-- let object = InitializeDebuggerResponse "InitializeDebuggerResponse" "BLA CODE"
-- print object
-- let encodedObject = encode object
-- let textObject = Data.Text.Encoding.decodeUtf8 (toStrict1 encodedObject)
case dec of
InitializeDebuggerRequest { path = p } -> do
expressions <- Parser.loadSchemeFile (path dec)
ulEx <- Parser.loadSchemeFile' (path dec)
print ulEx
--let object = InitializeDebuggerResponse ([generate expressions])
let object = InitializeDebuggerResponse ([ulEx])
print object
let encodedObject = encode object
let textObject = Data.Text.Encoding.decodeUtf8 (toStrict1 encodedObject)
let changedDebugState = changeExpressions debugState [expressions]
sendResponse changedDebugState textObject
ContinueRequest {bps = b, start = s} -> do --hier b und s benutzen
sendResponse debugState "bla"
--eval debug aufrufen
let ?sensitivity = 0
let ?debugState = debugState
let bla = expressionList debugState
expressions <- Parser.loadSchemeFile ("test_factorial.scm")
-- sendResponse debugState textObject
-- --debugPhase auf 1 setzen
evalDebug ([expressions])
RefreshRequest -> do
let object = RefreshResponse True
print object
let encodedObject = encode object
let textObject = Data.Text.Encoding.decodeUtf8 (toStrict1 encodedObject)
sendResponse debugState textObject
-- "ContinueRequest" -> do
-- sendResponse debugState "bla"
-- --checken ob debug phase auf 1 ist
-- --evalDebug aufrufen
-- let ?sensitivity = 0
-- let ?debugState = debugState
-- evalDebug (expressionList debugState)
-- "RefreshRequest" -> do
-- --debug state neu initialisieren und listen aufrufen
-- sendResponse debugState "REFRESHHHH"
let debugStateRefreshed = refreshDebugState debugState
Exception.finally
(listen debugStateRefreshed)
(disconnectClient (clientId debugStateRefreshed) (stateRef debugStateRefreshed))
listen debugState
......@@ -395,7 +304,6 @@ sendResponse debugState msg = do
evalDebug :: (?sensitivity::Int, ?debugState::DebugState) => [LExpr] -> P.IO ()
evalDebug expr =
let ?cacheWidening = (storeErrWidening, W.finite) in
......@@ -408,38 +316,50 @@ evalDebug expr =
return ()
where
e0 = generate (sequence expr)
{-# INLINE evalDebug #-}
-- | Debugging combinator
debug :: (?debugState :: DebugState,
ArrowChoice c, ArrowIO c, ArrowStackElements In c, ArrowDebug c)
ArrowChoice c, ArrowIO c, ArrowDebug c, ArrowStack In c, ArrowStackDepth c, ArrowStackElements In c, ArrowControlFlow stmt 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
sendMessage -< (Text.pack "DEBUG COMBINATOR")
stackDepth <- Stack.depth -< ()
stackElems <- Stack.elems -< ()
--liftIO print -< "stackDepth"
--liftIO print -< stackDepth
liftIO print -< "stackElems"
liftIO print -< stackElems
liftIO print -< "exprs"
liftIO print -< exprs
{--
case exprs of
expr:_ | expr `P.elem` breakpoints ?debugState -> do
-- We reached a breakpoint
liftIO send -< ReachedBreakpoint expr env
loop -< input
f -< input
_ ->
f -< input
where
loop = proc input@((store,errors),(env,expr)) -> do
msg <- liftIO receive -< ()
case msg of
Continue ->
returnA -< ()
GetStackRequest -> do
stack <- Stack.elems -< ()
liftIO send -< GetStackResponse stack
loop -< input
-}
--case exprs of
-- expr:_ | isBreakpoint expr -> do
-- -- Breakpoint reached
-- stack <- Stack.elems -< ()
--
-- sendMessage -< ContinueResponse stack input --cfg
-- loop -< input
-- f -< input
-- _ ->
-- f -< input
--where
-- loop = proc input@((store,errors),(env,expr)) -> do
-- msg <- receiveMessage -< ()
-- dec <- Maybe.fromJust (decode'' msg) :: TestMessage
-- liftIO print -< (dec)
-- case dec of
-- ContinueRequest ->
-- returnA -< ()
-- _ -> do
-- loop -< input
f -< (input)
{-# INLINE debug #-}
--------------------- Helper Functions ----------------------------
......@@ -448,6 +368,7 @@ decode'' :: FromJSON a => Text.Text -> Maybe a
decode'' = decode . toLazyByteString . Data.Text.Encoding.encodeUtf8Builder
toStrict1 :: BL.ByteString -> B.ByteString
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