Debug.hs 5.15 KB
Newer Older
Tomislav Pree's avatar
Tomislav Pree committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
{-# 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 #-}
Tomislav Pree's avatar
Tomislav Pree committed
15
16
{-# LANGUAGE AllowAmbiguousTypes #-}

Tomislav Pree's avatar
Tomislav Pree committed
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
{-# 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
Tomislav Pree's avatar
Tomislav Pree committed
32
import           Control.Arrow.Fix.Stack as Stack
Tomislav Pree's avatar
Tomislav Pree committed
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
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

53
import           Control.Arrow.State as State
Tomislav Pree's avatar
Tomislav Pree committed
54

55
import           Control.Arrow.Transformer.State
Tomislav Pree's avatar
Tomislav Pree committed
56
57
58
59
60
61
62
63
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)
Tomislav Pree's avatar
Tomislav Pree committed
64
import           Control.Arrow.Transformer.Abstract.Fix.Stack (Stack,StackT)
Tomislav Pree's avatar
Tomislav Pree committed
65
66
67
68

import qualified Data.Text                      as Text
import           Data.Identifiable

Tomislav Pree's avatar
Tomislav Pree committed
69
70
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
Tomislav Pree's avatar
Tomislav Pree committed
71

72
import           Data.Monoidal
Tomislav Pree's avatar
Tomislav Pree committed
73
import           Data.Abstract.MonotoneStore(Store)
Tomislav Pree's avatar
Tomislav Pree committed
74

75
import           Data.Graph.Inductive.Graph(mkGraph, LNode, LEdge, labNodes, labEdges, Graph)
Tomislav Pree's avatar
Tomislav Pree committed
76

77
-- |Typed for websocket connection
Tomislav Pree's avatar
Tomislav Pree committed
78
79
80
81
82
type ClientId = Int
type Client   = (ClientId, WS.Connection)
type State    = [Client]

data DebugState = DebugState {
83
84
85
86
  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
Tomislav Pree's avatar
Tomislav Pree committed
87
88
89
90
91
92
93
94
}

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,
Tomislav Pree's avatar
Tomislav Pree committed
95
            ArrowMetrics a, ArrowStrict, ArrowPrimitive, ArrowCFG a)
Tomislav Pree's avatar
Tomislav Pree committed
96
97
98


class ArrowDebug c where
99
100
101
102
103
  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
Tomislav Pree's avatar
Tomislav Pree committed
104
105
106
107
108
109


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

Tomislav Pree's avatar
Tomislav Pree committed
110

Tomislav Pree's avatar
Tomislav Pree committed
111
112
113
114
115
116
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 -< ()
117
  receiveMessage = DebugT $ proc () -> do
Tomislav Pree's avatar
Tomislav Pree committed
118
119
120
    state <- State.get -< ()
    msg <- liftIO WS.receiveData -< (conn state)
    returnA -< msg
121
  getState = DebugT $ proc () -> do
Tomislav Pree's avatar
Tomislav Pree committed
122
    state <- State.get -< ()
123
124
125
126
127
128
129
130
    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)
Tomislav Pree's avatar
Tomislav Pree committed
131
  {-# INLINE sendMessage #-}
Tomislav Pree's avatar
Tomislav Pree committed
132
  {-# INLINE receiveMessage #-}
133
134
135
  {-# INLINE getState #-}
  {-# INLINE setStep #-}
  {-# INLINE getStep #-}
Tomislav Pree's avatar
Tomislav Pree committed
136
137
138
139

sendResponse :: (DebugState,Text.Text) -> IO ()
sendResponse (debugState,msg)= do
  WS.sendTextData (conn debugState) msg
Tomislav Pree's avatar
Tomislav Pree committed
140