ControlFlow.hs 3.43 KB
Newer Older
1
{-# LANGUAGE Arrows #-}
2
3
4
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5
{-# LANGUAGE MultiParamTypeClasses #-}
6
{-# LANGUAGE TypeFamilies #-}
7
{-# LANGUAGE UnboxedTuples #-}
8
{-# LANGUAGE UndecidableInstances #-}
9
10
module Control.Arrow.Transformer.Abstract.Fix.ControlFlow where

11
import           Prelude hiding(pred,(.))
Tobias Leon Hombücher's avatar
Tobias Leon Hombücher committed
12

13
import           Control.Arrow
14
import           Control.Arrow.Primitive
15
16
import           Control.Arrow.Trans
import           Control.Arrow.Transformer.State
Sven Keidel's avatar
Sven Keidel committed
17
18
19
20
import           Control.Arrow.Transformer.Reader
import           Control.Arrow.Fix.Chaotic as Chaotic
import           Control.Arrow.Fix.Cache as Cache
import           Control.Arrow.Fix.Context (ArrowContext,ArrowJoinContext)
21
import           Control.Arrow.Fix.ControlFlow
Sven Keidel's avatar
Sven Keidel committed
22
23
import           Control.Arrow.Fix.Metrics
import           Control.Arrow.Fix.Stack (ArrowStackDepth,ArrowStackElements)
24
25
import           Control.Category

Tomislav Pree's avatar
Tomislav Pree committed
26
27
import           Control.Arrow.State

28
29
30
31
32
33
34
import           Data.Label
import           Data.Coerce
import           Data.Empty
import           Data.Profunctor.Unsafe
import           Data.Graph.Inductive (Gr)
import qualified Data.Graph.Inductive as G

Tomislav Pree's avatar
Tomislav Pree committed
35
newtype CFG stmt = CFG (Gr stmt ()) deriving (Show)
36
37

instance IsEmpty (CFG stmt) where
Sven Keidel's avatar
Sven Keidel committed
38
  empty = CFG G.empty
39

Tomislav Pree's avatar
Tomislav Pree committed
40
newtype ControlFlowT stmt c x y = ControlFlowT (StateT (CFG stmt) (ReaderT (Maybe stmt) c) x y) 
Sven Keidel's avatar
Sven Keidel committed
41
  deriving (
42
43
44
45
46
      Profunctor, Category, Arrow, ArrowChoice, ArrowContext ctx,
      ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b,
      ArrowJoinContext u, ArrowStackDepth, ArrowStackElements a,
      ArrowMetrics a, ArrowComponent a, ArrowInComponent a,
      ArrowPrimitive
Sven Keidel's avatar
Sven Keidel committed
47
    )
48

Tomislav Pree's avatar
Tomislav Pree committed
49
instance (HasLabel stmt, Arrow c, Profunctor c) => ArrowControlFlow stmt (ControlFlowT stmt c)  where
Sven Keidel's avatar
Sven Keidel committed
50
51
  nextStatement f = lift $ proc (predecessor, (cfg, (nextStmt, x))) ->
    unlift f -< (nextStmt, (addEdge predecessor nextStmt cfg, x))
52
    where
Sven Keidel's avatar
Sven Keidel committed
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
      addEdge :: HasLabel stmt => Maybe stmt -> Maybe stmt -> CFG stmt -> CFG stmt
      addEdge pred next (CFG graph) = CFG $ case (pred,next) of
        (Just pred', Just next') -> insEdge pred' next' graph
        _ -> graph

      insEdge :: HasLabel stmt => stmt -> stmt -> Gr stmt () -> Gr stmt ()
      insEdge pred next gr
        | G.hasEdge gr (lp,ln) = gr
        | otherwise            = G.insEdge (lp, ln, ()) $ insNode pred $ insNode next gr
        where
          lp = labelVal $ label pred
          ln = labelVal $ label next

      insNode :: HasLabel stmt => stmt -> Gr stmt () -> Gr stmt ()
      insNode stmt gr = case G.lab gr (labelVal (label stmt)) of
        Just _ -> gr
        Nothing -> G.insNode (labelVal $ label stmt, stmt) gr
  {-# INLINE nextStatement #-}
71
72

instance (ArrowRun c) => ArrowRun (ControlFlowT stmt c) where
Sven Keidel's avatar
Sven Keidel committed
73
74
  type Run (ControlFlowT stmt c) x y = Run c x (CFG stmt,y)
  run f = run (lmap (\x ->(Nothing,(empty,x))) (unlift f))
75
76
  {-# INLINE run #-}

77
instance ArrowTrans (ControlFlowT stmt) where
78
79
80
  lift' = ControlFlowT . lift' . lift'
  {-# INLINE lift' #-}

81
instance ArrowLift (ControlFlowT stmt c) where
Sven Keidel's avatar
Sven Keidel committed
82
  type Underlying (ControlFlowT stmt c) x y = c (Maybe stmt, (CFG stmt,x)) (CFG stmt,y)
83
84
85
86

instance (Profunctor c,ArrowApply c) => ArrowApply (ControlFlowT stmt c) where
  app = ControlFlowT (app .# first coerce)
  {-# INLINE app #-}
Tomislav Pree's avatar
Tomislav Pree committed
87
88
89
90

instance (Arrow c, Profunctor c) => ArrowCFG (CFG stmt) (ControlFlowT stmt c) where
  getCFG = ControlFlowT $ proc () -> get -< ()
  {-# INLINE getCFG #-}