Commit 16c7f920 authored by Tomislav Pree's avatar Tomislav Pree
Browse files

Merge branch 'debug'

parents 9cb8bc8c 8f1db2b3
Pipeline #73245 passed with stages
in 98 minutes and 20 seconds
...@@ -23,6 +23,7 @@ dependencies: ...@@ -23,6 +23,7 @@ dependencies:
- text - text
- union-find - union-find
- unordered-containers - unordered-containers
- aeson
library: library:
ghc-options: ghc-options:
......
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
...@@ -22,6 +23,14 @@ class (Arrow c, Profunctor c) => ArrowControlFlow stmt c | c -> stmt where ...@@ -22,6 +23,14 @@ class (Arrow c, Profunctor c) => ArrowControlFlow stmt c | c -> stmt where
-- For example, @(nextStatement -< e1; nextStatement -< e2)@ adds an CFG edge between @e1@ and @e2@. -- For example, @(nextStatement -< e1; nextStatement -< e2)@ adds an CFG edge between @e1@ and @e2@.
nextStatement :: c x y -> c (Maybe stmt, x) y nextStatement :: c x y -> c (Maybe stmt, x) y
class (Arrow c, Profunctor c) => ArrowCFG graph c | c -> graph where
-- | Get the current control flow graph of the program.
getCFG :: c () graph
default getCFG :: (c ~ t c', ArrowTrans t, ArrowCFG graph c') => c () graph
getCFG = lift' getCFG
{-# INLINE getCFG #-}
-- | Records the trace of the abstract interpreter as an control-flow graph. -- | Records the trace of the abstract interpreter as an control-flow graph.
recordControlFlowGraph :: ArrowControlFlow stmt c => (a -> stmt) -> FixpointCombinator c a b recordControlFlowGraph :: ArrowControlFlow stmt c => (a -> stmt) -> FixpointCombinator c a b
recordControlFlowGraph getStatement f = proc a -> nextStatement f -< (Just (getStatement a),a) recordControlFlowGraph getStatement f = proc a -> nextStatement f -< (Just (getStatement a),a)
...@@ -53,3 +62,9 @@ instance (Applicative f, ArrowControlFlow stmt c) => ArrowControlFlow stmt (Stat ...@@ -53,3 +62,9 @@ instance (Applicative f, ArrowControlFlow stmt c) => ArrowControlFlow stmt (Stat
instance (Monoid w, ArrowControlFlow stmt c) => ArrowControlFlow stmt (WriterT w c) where instance (Monoid w, ArrowControlFlow stmt c) => ArrowControlFlow stmt (WriterT w c) where
nextStatement f = lift (nextStatement (unlift f)) nextStatement f = lift (nextStatement (unlift f))
{-# INLINE nextStatement #-} {-# INLINE nextStatement #-}
instance ArrowCFG graph c => ArrowCFG graph (ConstT r c)
instance ArrowCFG graph c => ArrowCFG graph (ReaderT r c)
instance ArrowCFG graph c => ArrowCFG graph (StateT r c)
instance (ArrowCFG graph c, Monoid r) => ArrowCFG graph (WriterT r c)
instance (ArrowCFG graph c, Applicative r) => ArrowCFG graph (StaticT r c)
...@@ -26,8 +26,9 @@ import Data.Monoidal ...@@ -26,8 +26,9 @@ import Data.Monoidal
import Text.Printf import Text.Printf
type StackPointer = Int 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 class (Arrow c, Profunctor c) => ArrowStack a c | c -> a where
push :: c x y -> c (a, x) (y) push :: c x y -> c (a, x) (y)
...@@ -48,7 +49,7 @@ class (Arrow c, Profunctor c) => ArrowStackDepth c where ...@@ -48,7 +49,7 @@ class (Arrow c, Profunctor c) => ArrowStackDepth c where
{-# INLINE depth #-} {-# 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] elems :: c () [a]
peek :: c () (Maybe a) peek :: c () (Maybe a)
...@@ -57,7 +58,6 @@ class (Arrow c, Profunctor c) => ArrowStackElements a c where ...@@ -57,7 +58,6 @@ class (Arrow c, Profunctor c) => ArrowStackElements a c where
elems = lift' elems elems = lift' elems
peek = lift' peek peek = lift' peek
{-# INLINE elems #-} {-# INLINE elems #-}
{-# INLINE peek #-} {-# INLINE peek #-}
......
...@@ -9,7 +9,7 @@ ...@@ -9,7 +9,7 @@
{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} {-# 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) import Prelude hiding (id,(.),const,head,iterate,lookup)
...@@ -32,13 +32,15 @@ import Data.Profunctor.Unsafe((.#)) ...@@ -32,13 +32,15 @@ import Data.Profunctor.Unsafe((.#))
import Data.Coerce import Data.Coerce
import Data.Order hiding (lub) import Data.Order hiding (lub)
import Control.Arrow.State
newtype FixT c x y = FixT (c x y) newtype FixT c x y = FixT (c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice, deriving (Profunctor,Category,Arrow,ArrowChoice,
ArrowContext ctx, ArrowJoinContext a, ArrowControlFlow a, ArrowContext ctx, ArrowJoinContext a, ArrowControlFlow a,
ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache, ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache,
ArrowStack a,ArrowStackElements a,ArrowStackDepth, ArrowStack a,ArrowStackElements a,ArrowStackDepth,
ArrowComponent a, ArrowInComponent a, ArrowComponent a, ArrowInComponent a,
ArrowMetrics a, ArrowStrict, ArrowPrimitive) ArrowMetrics a, ArrowStrict, ArrowPrimitive, ArrowCFG a)
runFixT :: FixT c x y -> c x y runFixT :: FixT c x y -> c x y
runFixT (FixT f) = f runFixT (FixT f) = f
...@@ -70,3 +72,10 @@ instance (Complete y, Profunctor c, Arrow c) => ArrowComplete y (FixT c) where ...@@ -70,3 +72,10 @@ instance (Complete y, Profunctor c, Arrow c) => ArrowComplete y (FixT c) where
instance (Profunctor c, Arrow c) => ArrowJoin (FixT c) where instance (Profunctor c, Arrow c) => ArrowJoin (FixT c) where
joinSecond lub f (FixT g) = FixT (dimap (\x -> (x, x)) (\(x,y) -> (lub (f x) y)) (second g)) joinSecond lub f (FixT g) = FixT (dimap (\x -> (x, x)) (\(x,y) -> (lub (f x) y)) (second g))
instance ArrowState s c => ArrowState s (FixT c) where
get = lift get
put = lift put
{-# INLINE get #-}
{-# INLINE put #-}
...@@ -49,7 +49,7 @@ import GHC.Exts ...@@ -49,7 +49,7 @@ import GHC.Exts
newtype CacheT cache a b c x y = CacheT { unCacheT :: StateT (cache a b) c x y} newtype CacheT cache a b c x y = CacheT { unCacheT :: StateT (cache a b) c x y}
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStrict,ArrowTrans, deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStrict,ArrowTrans,
ArrowState (cache a b),ArrowControlFlow stmt, ArrowPrimitive) ArrowState (cache a b),ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph)
instance (IsEmpty (cache a b), ArrowRun c) => ArrowRun (CacheT cache a b c) where instance (IsEmpty (cache a b), ArrowRun c) => ArrowRun (CacheT cache a b c) where
type Run (CacheT cache a b c) x y = Run c x (cache a b,y) type Run (CacheT cache a b c) x y = Run c x (cache a b,y)
......
...@@ -29,6 +29,9 @@ import Control.Arrow.Trans ...@@ -29,6 +29,9 @@ import Control.Arrow.Trans
-- import Control.Arrow.Transformer.Writer -- import Control.Arrow.Transformer.Writer
import Control.Arrow.Transformer.State import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Abstract.FiniteEnvStore
import Data.Abstract.MonotoneStore(Store)
import Data.Bits import Data.Bits
import Data.Profunctor import Data.Profunctor
import Data.Identifiable import Data.Identifiable
...@@ -41,7 +44,7 @@ newtype ComponentT component a c x y = ComponentT (StateT (component a) c x y) ...@@ -41,7 +44,7 @@ newtype ComponentT component a c x y = ComponentT (StateT (component a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStrict, deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStrict,
ArrowStackDepth,ArrowStackElements a, ArrowStackDepth,ArrowStackElements a,
ArrowCache a b, ArrowParallelCache a b,ArrowIterateCache a b,ArrowGetCache cache, ArrowCache a b, ArrowParallelCache a b,ArrowIterateCache a b,ArrowGetCache cache,
ArrowContext ctx, ArrowJoinContext u, ArrowControlFlow stmt, ArrowPrimitive) ArrowContext ctx, ArrowJoinContext u, ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph)
runComponentT :: (IsEmpty (comp a), Profunctor c) => ComponentT comp a c x y -> c x y runComponentT :: (IsEmpty (comp a), Profunctor c) => ComponentT comp a c x y -> c x y
runComponentT (ComponentT f) = dimap (\x -> (empty,x)) snd (runStateT f) runComponentT (ComponentT f) = dimap (\x -> (empty,x)) snd (runStateT f)
...@@ -63,11 +66,11 @@ instance (Identifiable a, Profunctor c,ArrowApply c) => ArrowApply (ComponentT c ...@@ -63,11 +66,11 @@ instance (Identifiable a, Profunctor c,ArrowApply c) => ArrowApply (ComponentT c
app = ComponentT (lmap (first coerce) app) app = ComponentT (lmap (first coerce) app)
{-# INLINE app #-} {-# INLINE app #-}
instance ArrowState s c => ArrowState s (ComponentT comp a c) where --instance (Arrow c, Profunctor c) => ArrowState (Store addr val) (EnvStoreT var addr val c) where
get = lift' get -- get = EnvStoreT get
put = lift' put -- put = EnvStoreT put
{-# INLINE get #-} -- {-# INLINE get #-}
{-# INLINE put #-} -- {-# INLINE put #-}
newtype Component a = Component Integer newtype Component a = Component Integer
...@@ -110,6 +113,8 @@ instance (Arrow c, Profunctor c) => ArrowInComponent a (ComponentT Component a c ...@@ -110,6 +113,8 @@ instance (Arrow c, Profunctor c) => ArrowInComponent a (ComponentT Component a c
{-# INLINE inComponent #-} {-# INLINE inComponent #-}
{-# SCC inComponent #-} {-# SCC inComponent #-}
-- Standard Component ---------------------------------------------------------------------------------- -- Standard Component ----------------------------------------------------------------------------------
-- newtype Component a = Component (HashSet a) deriving (Eq,IsEmpty,Monoid,Semigroup) -- newtype Component a = Component (HashSet a) deriving (Eq,IsEmpty,Monoid,Semigroup)
......
...@@ -30,7 +30,7 @@ import Data.Empty ...@@ -30,7 +30,7 @@ import Data.Empty
newtype ContextT ctx c x y = ContextT (ReaderT ctx c x y) newtype ContextT ctx c x y = ContextT (ReaderT ctx c x y)
deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowStrict, deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowStrict,
ArrowLift,ArrowControlFlow stmt, ArrowPrimitive) ArrowLift,ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph)
runContextT :: (IsEmpty ctx, Profunctor c) => ContextT ctx c x y -> c x y runContextT :: (IsEmpty ctx, Profunctor c) => ContextT ctx c x y -> c x y
runContextT (ContextT f) = lmap (empty,) (runReaderT f) runContextT (ContextT f) = lmap (empty,) (runReaderT f)
......
...@@ -23,6 +23,8 @@ import Control.Arrow.Fix.Metrics ...@@ -23,6 +23,8 @@ import Control.Arrow.Fix.Metrics
import Control.Arrow.Fix.Stack (ArrowStackDepth,ArrowStackElements) import Control.Arrow.Fix.Stack (ArrowStackDepth,ArrowStackElements)
import Control.Category import Control.Category
import Control.Arrow.State
import Data.Label import Data.Label
import Data.Coerce import Data.Coerce
import Data.Empty import Data.Empty
...@@ -30,7 +32,7 @@ import Data.Profunctor.Unsafe ...@@ -30,7 +32,7 @@ import Data.Profunctor.Unsafe
import Data.Graph.Inductive (Gr) import Data.Graph.Inductive (Gr)
import qualified Data.Graph.Inductive as G import qualified Data.Graph.Inductive as G
newtype CFG stmt = CFG (Gr stmt ()) newtype CFG stmt = CFG (Gr stmt ()) deriving (Show)
instance IsEmpty (CFG stmt) where instance IsEmpty (CFG stmt) where
empty = CFG G.empty empty = CFG G.empty
...@@ -82,3 +84,7 @@ instance ArrowLift (ControlFlowT stmt c) where ...@@ -82,3 +84,7 @@ instance ArrowLift (ControlFlowT stmt c) where
instance (Profunctor c,ArrowApply c) => ArrowApply (ControlFlowT stmt c) where instance (Profunctor c,ArrowApply c) => ArrowApply (ControlFlowT stmt c) where
app = ControlFlowT (app .# first coerce) app = ControlFlowT (app .# first coerce)
{-# INLINE app #-} {-# INLINE app #-}
instance (Arrow c, Profunctor c) => ArrowCFG (CFG stmt) (ControlFlowT stmt c) where
getCFG = ControlFlowT $ proc () -> get -< ()
{-# INLINE getCFG #-}
...@@ -40,11 +40,14 @@ import Data.Coerce ...@@ -40,11 +40,14 @@ import Data.Coerce
import Text.Printf import Text.Printf
import Control.Arrow.Transformer.Abstract.FiniteEnvStore
import Data.Abstract.MonotoneStore(Store)
newtype MetricsT metric a c x y = MetricsT (StateT (metric a) c x y) newtype MetricsT metric a c x y = MetricsT (StateT (metric a) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLowerBounded z, deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLowerBounded z,
ArrowComponent a,ArrowInComponent a,ArrowControlFlow stmt, ArrowComponent a,ArrowInComponent a,ArrowControlFlow stmt,
ArrowStackDepth,ArrowStackElements a,ArrowContext ctx,ArrowTopLevel, ArrowStackDepth,ArrowStackElements a,ArrowContext ctx,ArrowTopLevel,
ArrowGetCache cache, ArrowPrimitive) ArrowGetCache cache, ArrowPrimitive, ArrowCFG graph)
instance (IsEmpty (metrics a), ArrowRun c) => ArrowRun (MetricsT metrics a c) where instance (IsEmpty (metrics a), ArrowRun c) => ArrowRun (MetricsT metrics a c) where
type Run (MetricsT metrics a c) x y = Run c x (metrics a,y) type Run (MetricsT metrics a c) x y = Run c x (metrics a,y)
...@@ -61,11 +64,17 @@ instance (Profunctor c,ArrowApply c) => ArrowApply (MetricsT metrics a c) where ...@@ -61,11 +64,17 @@ instance (Profunctor c,ArrowApply c) => ArrowApply (MetricsT metrics a c) where
app = MetricsT (app .# first coerce) app = MetricsT (app .# first coerce)
{-# INLINE app #-} {-# INLINE app #-}
instance ArrowState s c => ArrowState s (MetricsT metrics a c) where --instance ArrowState s c => ArrowState s (MetricsT metrics a c) where
get = lift' get -- get = lift' get
put = lift' put -- put = lift' put
{-# INLINE get #-} -- {-# INLINE get #-}
{-# INLINE put #-} -- {-# INLINE put #-}
--instance (Arrow c, Profunctor c) => ArrowState (Store addr val) (EnvStoreT var addr val c) where
-- get = EnvStoreT get
-- put = EnvStoreT put
-- {-# INLINE get #-}
-- {-# INLINE put #-}
-- Basic Metric ---------------------------------------------------------------- -- Basic Metric ----------------------------------------------------------------
newtype Metrics a = Metrics (HashMap a Metric) newtype Metrics a = Metrics (HashMap a Metric)
......
...@@ -43,7 +43,7 @@ newtype StackT stack a c x y = StackT (ReaderT (stack a) c x y) ...@@ -43,7 +43,7 @@ newtype StackT stack a c x y = StackT (ReaderT (stack a) c x y)
ArrowStrict,ArrowTrans, ArrowLowerBounded z, ArrowStrict,ArrowTrans, ArrowLowerBounded z,
ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache, ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache,
ArrowState s,ArrowContext ctx, ArrowJoinContext u, ArrowState s,ArrowContext ctx, ArrowJoinContext u,
ArrowControlFlow stmt, ArrowPrimitive) ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph)
runStackT :: (IsEmpty (stack a), Profunctor c) => StackT stack a c x y -> c x y runStackT :: (IsEmpty (stack a), Profunctor c) => StackT stack a c x y -> c x y
runStackT (StackT f) = lmap (\x -> (empty,x)) (runReaderT f) runStackT (StackT f) = lmap (\x -> (empty,x)) (runReaderT f)
......
...@@ -3,6 +3,7 @@ ...@@ -3,6 +3,7 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.Label where module Data.Label where
import Data.Hashable import Data.Hashable
...@@ -13,12 +14,15 @@ import Control.DeepSeq ...@@ -13,12 +14,15 @@ import Control.DeepSeq
import Text.Printf import Text.Printf
import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics
-- Retrieves label from expression. -- Retrieves label from expression.
class HasLabel x where class HasLabel x where
label :: x -> Label label :: x -> Label
newtype Label = Label { labelVal :: Int } newtype Label = Label { labelVal :: Int }
deriving (Ord,Eq,Hashable,Num,NFData) deriving (Ord,Eq,Hashable,Num,NFData,Generic,ToJSON,FromJSON)
instance Show Label where instance Show Label where
show (Label l) = printf "#%d" l show (Label l) = printf "#%d" l
......
...@@ -26,6 +26,14 @@ dependencies: ...@@ -26,6 +26,14 @@ dependencies:
- text - text
- transformers - transformers
- unordered-containers - unordered-containers
- bytestring
- http-types
- aeson
- safe
- websockets
- wai-websockets
- warp
- wai
data-files: data-files:
- scheme_files/**/*.scm - scheme_files/**/*.scm
......
{-# 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 #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# 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 as 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 (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
import Data.Abstract.MonotoneStore(Store)
import Data.Graph.Inductive.Graph(mkGraph, LNode, LEdge, labNodes, labEdges, Graph)
-- |Typed for websocket connection
type ClientId = Int
type Client = (ClientId, WS.Connection)
type State = [Client]
data DebugState = DebugState {
conn :: WS.Connection, -- |websocket connections
clientId :: ClientId, -- |ID of connected client
stateRef :: Concurrent.MVar State, -- |State reference
step :: Bool -- |Boolean Step Value, required for the step functionality
}
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, ArrowCFG a)
class ArrowDebug c where
sendMessage :: c Text.Text () -- |Sends websocket message
receiveMessage :: c () Text.Text -- |Receives websocket message
getState :: c () DebugState -- |Returns the current debug state
setStep :: c Bool () -- |Set step value, True if StepRequest was received, False after step was executed
getStep :: c () Bool -- |Returns the current step value
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
sendMessage = DebugT $ proc message -> do
state <- State.get -< ()
liftIO sendResponse -< (state,message)
returnA -< ()
receiveMessage = DebugT $ proc () -> do
state <- State.get -< ()
msg <- liftIO WS.receiveData -< (conn state)
returnA -< msg
getState = DebugT $ proc () -> do
state <- State.get -< ()
returnA -< state
setStep = DebugT $ proc message -> do
state <- State.get -< ()
State.put -< (state {step = message})
returnA -< ()
getStep = DebugT $ proc () -> do
state <- State.get -< ()
returnA -< (step state)
{-# INLINE sendMessage #-}
{-# INLINE receiveMessage #-}
{-# INLINE getState #-}
{-# INLINE setStep #-}
{-# INLINE getStep #-}
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 #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC
-fspecialise-aggressively
-flate-specialise
-fsimpl-tick-factor=500
-fno-warn-orphans
-fno-warn-partial-type-signatures
#-}
module Debug.Server.DebugServer where
import Prelude hiding (not,Bounded,fail,(.),exp,read,IO)
import qualified Prelude as P
import Control.Category
import Control.Arrow
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 (ArrowStack,ArrowStackDepth,ArrowStackElements,widenInput,maxDepth,reuseByMetric, StackPointer)
import qualified Control.Arrow.Fix.Stack as Stack