Debug.hs 3.91 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
{-# 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.Cache
import           Control.Arrow.Fix.ControlFlow
import           Control.Arrow.Fix.Context
import           Control.Arrow.Fix.Metrics
Tomislav Pree's avatar
Tomislav Pree committed
30
import           Control.Arrow.Fix.Stack as Stack
Tomislav Pree's avatar
Tomislav Pree committed
31
32
33
34
35
36
37
38
39
40
import           Control.Arrow.Trans
import           Control.Arrow.IO

import           Data.Profunctor


import qualified Network.WebSockets             as WS

import qualified Control.Concurrent             as Concurrent

41
import           Control.Arrow.State as State
Tomislav Pree's avatar
Tomislav Pree committed
42

43
import           Control.Arrow.Transformer.State
Tomislav Pree's avatar
Tomislav Pree committed
44
45
import           Prelude hiding (lookup,read,fail,Bounded(..))

46
import           Control.Arrow.Fix.SCC
Tomislav Pree's avatar
Tomislav Pree committed
47
48
49
50
import           Control.Arrow.Transformer.Abstract.Fix

import qualified Data.Text                      as Text

51
-- |Typed for websocket connection
Tomislav Pree's avatar
Tomislav Pree committed
52
53
54
55
56
type ClientId = Int
type Client   = (ClientId, WS.Connection)
type State    = [Client]

data DebugState = DebugState {
57
58
59
60
  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
61
62
63
64
}

newtype DebugT c x y = DebugT (StateT DebugState c x y)
  deriving (Profunctor,Category,Arrow,ArrowChoice,
65
            ArrowContext ctx a', ArrowCallSite lab, ArrowControlFlow a,
Tomislav Pree's avatar
Tomislav Pree committed
66
            ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache,
67
            ArrowStack a,ArrowStackElements a,ArrowStackDepth, ArrowSCC a,
Tomislav Pree's avatar
Tomislav Pree committed
68
            ArrowMetrics a, ArrowStrict, ArrowPrimitive, ArrowCFG a)
Tomislav Pree's avatar
Tomislav Pree committed
69
70
71


class ArrowDebug c where
72
73
74
75
76
  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
77
78
79
80
81
82


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
83

Tomislav Pree's avatar
Tomislav Pree committed
84
85
86
87
88
89
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 -< ()
90
  receiveMessage = DebugT $ proc () -> do
Tomislav Pree's avatar
Tomislav Pree committed
91
92
93
    state <- State.get -< ()
    msg <- liftIO WS.receiveData -< (conn state)
    returnA -< msg
94
  getState = DebugT $ proc () -> do
Tomislav Pree's avatar
Tomislav Pree committed
95
    state <- State.get -< ()
96
97
98
99
100
101
102
103
    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
104
  {-# INLINE sendMessage #-}
Tomislav Pree's avatar
Tomislav Pree committed
105
  {-# INLINE receiveMessage #-}
106
107
108
  {-# INLINE getState #-}
  {-# INLINE setStep #-}
  {-# INLINE getStep #-}
Tomislav Pree's avatar
Tomislav Pree committed
109
110
111
112

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