ControlFlow.hs 3.06 KB
Newer Older
Sven Keidel's avatar
Sven Keidel committed
1
{-# LANGUAGE DefaultSignatures #-}
2
{-# LANGUAGE Arrows #-}
3
{-# LANGUAGE FlexibleInstances #-}
4
{-# LANGUAGE FunctionalDependencies #-}
5
6
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
7
8
9
10
module Control.Arrow.Fix.ControlFlow where

import Control.Arrow
import Control.Arrow.Fix
11
12
13
14
15
16
17
import Control.Arrow.Trans
import Control.Arrow.Transformer.Const
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Writer

18
import Data.Profunctor
19
import Data.Monoidal
20
21
22
23

class (Arrow c, Profunctor c) => ArrowControlFlow stmt c | c -> stmt where
  -- | Adds a control-flow edge between the previously evaluated statement and the next statement.
  -- For example, @(nextStatement -< e1; nextStatement -< e2)@ adds an CFG edge between @e1@ and @e2@.
Sven Keidel's avatar
Sven Keidel committed
24
  nextStatement :: c x y -> c (Maybe stmt, x) y
25

Sven Keidel's avatar
Sven Keidel committed
26
27
28
29
30
31
32
33
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 #-}

34
35
-- | Records the trace of the abstract interpreter as an control-flow graph.
recordControlFlowGraph :: ArrowControlFlow stmt c => (a -> stmt) -> FixpointCombinator c a b
Sven Keidel's avatar
Sven Keidel committed
36
recordControlFlowGraph getStatement f = proc a -> nextStatement f -< (Just (getStatement a),a)
37
{-# INLINE recordControlFlowGraph #-}
38
39
40

-- | Records the trace of the abstract interpreter as an control-flow graph.
recordControlFlowGraph' :: (ArrowChoice c, ArrowControlFlow stmt c) => (a -> Maybe stmt) -> FixpointCombinator c a b
Sven Keidel's avatar
Sven Keidel committed
41
recordControlFlowGraph' getStatement f = proc a -> nextStatement f -< (getStatement a,a)
42
{-# INLINE recordControlFlowGraph' #-}
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

------------- Instances --------------
instance ArrowControlFlow stmt c => ArrowControlFlow stmt (ConstT r c) where
  nextStatement f = lift $ \r -> nextStatement (unlift f r)
  {-# INLINE nextStatement #-}

instance ArrowControlFlow stmt c => ArrowControlFlow stmt (ReaderT r c) where
  nextStatement f = lift $ lmap shuffle1 (nextStatement (unlift f))
  {-# INLINE nextStatement #-}

instance ArrowControlFlow stmt c => ArrowControlFlow stmt (StateT s c) where
  nextStatement f = lift $ lmap shuffle1 (nextStatement (unlift f))
  {-# INLINE nextStatement #-}

instance (Applicative f, ArrowControlFlow stmt c) => ArrowControlFlow stmt (StaticT f c) where
  nextStatement (StaticT f) = StaticT $ nextStatement <$> f
  {-# INLINE nextStatement #-}
  {-# SPECIALIZE instance ArrowControlFlow stmt c => ArrowControlFlow stmt (StaticT ((->) r) c) #-}

instance (Monoid w, ArrowControlFlow stmt c) => ArrowControlFlow stmt (WriterT w c) where
  nextStatement f = lift (nextStatement (unlift f))
  {-# INLINE nextStatement #-}
Sven Keidel's avatar
Sven Keidel committed
65
66
67

instance ArrowCFG graph c => ArrowCFG graph (ConstT r c)
instance ArrowCFG graph c => ArrowCFG graph (ReaderT r c)
Tomislav Pree's avatar
Tomislav Pree committed
68
69
70
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)