Component.hs 7.03 KB
Newer Older
1
{-# LANGUAGE Arrows #-}
2
{-# LANGUAGE DataKinds #-}
Sven Keidel's avatar
Sven Keidel committed
3
{-# LANGUAGE FlexibleContexts #-}
4
5
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
Sven Keidel's avatar
Sven Keidel committed
6
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7
{-# LANGUAGE MultiParamTypeClasses #-}
8
{-# LANGUAGE RankNTypes #-}
Sven Keidel's avatar
Sven Keidel committed
9
{-# LANGUAGE TypeFamilies #-}
10
{-# LANGUAGE UnboxedTuples #-}
11
{-# LANGUAGE UndecidableInstances #-}
12
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
Sven Keidel's avatar
Sven Keidel committed
13
module Control.Arrow.Transformer.Abstract.Fix.Component(ComponentT,runComponentT,Component) where
Sven Keidel's avatar
Sven Keidel committed
14

Sven Keidel's avatar
Sven Keidel committed
15
import           Prelude hiding (id,pred,lookup,map,head,iterate,(.),elem)
Sven Keidel's avatar
Sven Keidel committed
16
17

import           Control.Category
18
import           Control.Arrow hiding (loop)
19
import           Control.Arrow.Primitive
20
import           Control.Arrow.Strict
Sven Keidel's avatar
Sven Keidel committed
21
22
import           Control.Arrow.Fix.Chaotic
import           Control.Arrow.Fix.Cache as Cache
23
import           Control.Arrow.Fix.ControlFlow
Sven Keidel's avatar
Sven Keidel committed
24
25
26
import           Control.Arrow.Fix.Stack as Stack
import           Control.Arrow.Fix.Context as Context
import           Control.Arrow.State
Sven Keidel's avatar
Sven Keidel committed
27
import           Control.Arrow.Trans
28

29
30
-- import           Control.Arrow.Transformer.Writer
import           Control.Arrow.Transformer.State
Sven Keidel's avatar
Sven Keidel committed
31

Tomislav Pree's avatar
Tomislav Pree committed
32
33
34
import           Control.Arrow.Transformer.Abstract.FiniteEnvStore 
import           Data.Abstract.MonotoneStore(Store)

Sven Keidel's avatar
Sven Keidel committed
35
import           Data.Bits
Sven Keidel's avatar
Sven Keidel committed
36
import           Data.Profunctor
Sven Keidel's avatar
Sven Keidel committed
37
38
import           Data.Identifiable
import           Data.Coerce
39
import           Data.Empty
Sven Keidel's avatar
Sven Keidel committed
40
41

import           Text.Printf
42

43
newtype ComponentT component a c x y = ComponentT (StateT (component a) c x y)
44
  deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowStrict,
45
            ArrowStackDepth,ArrowStackElements a,
Sven Keidel's avatar
Sven Keidel committed
46
            ArrowCache a b, ArrowParallelCache a b,ArrowIterateCache a b,ArrowGetCache cache,
Tomislav Pree's avatar
Tomislav Pree committed
47
            ArrowContext ctx, ArrowJoinContext u, ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph)
Sven Keidel's avatar
Sven Keidel committed
48

49
runComponentT :: (IsEmpty (comp a), Profunctor c) => ComponentT comp a c x y -> c x y
Sven Keidel's avatar
Sven Keidel committed
50
runComponentT (ComponentT f) = dimap (\x -> (empty,x)) snd (runStateT f)
51
{-# INLINE runComponentT #-}
52

53
instance ArrowLift (ComponentT comp a c) where
54
55
  type Underlying (ComponentT comp a c) x y = c (comp a,x) (comp a,y)

56
instance ArrowTrans (ComponentT comp a) where
57
58
59
60
61
  lift' f = ComponentT (lift' f)
  {-# INLINE lift' #-}

instance (IsEmpty (comp a), ArrowRun c) => ArrowRun (ComponentT comp a c) where
  type Run (ComponentT comp a c) x y = Run c x y
62
  run f = run (runComponentT f)
63
64
  {-# INLINE run #-}

65
instance (Identifiable a, Profunctor c,ArrowApply c) => ArrowApply (ComponentT comp a c) where
66
  app = ComponentT (lmap (first coerce) app)
67
  {-# INLINE app #-}
Sven Keidel's avatar
Sven Keidel committed
68

Tomislav Pree's avatar
Tomislav Pree committed
69
70
71
72
73
--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 #-}
74

Sven Keidel's avatar
Sven Keidel committed
75
76
77
78
newtype Component a = Component Integer

instance Show (Component a) where
  show (Component comp) = printf "%b" comp
79

Sven Keidel's avatar
Sven Keidel committed
80
81
82
83
84
85
86
87
88
89
90
91
92
instance IsEmpty (Component a) where
  empty = mempty

instance Semigroup (Component a) where
  Component c1 <> Component c2 = Component (c1 .|. c2)
instance Monoid (Component a) where
  mempty = Component 0
  mappend = (<>)

instance (Arrow c, Profunctor c) => ArrowComponent a (ComponentT Component a c) where
  addToComponent = lift $ arr $ \(Component comp,(_,pointer)) ->
    let comp' = (shiftL (1 :: Integer) pointer .|. comp)
    in (Component comp', ())
93
  {-# INLINE addToComponent #-}
94
  {-# SCC addToComponent #-}
95

96
97
98
instance (Identifiable a, ArrowStack a c) => ArrowStack a (ComponentT Component a c) where
  push f = lift $ proc (comp,(a,x)) -> do
    (comp',y) <- push (lmap (\x -> (mempty,x)) (unlift f)) -< (a,x)
Sven Keidel's avatar
Sven Keidel committed
99
100
101
    returnA -< (comp <> pop comp', y)
    where
      pop (Component comp) = Component (shiftR comp 1)
102
  {-# INLINE push #-}
103
  {-# SCC push #-}
104

Sven Keidel's avatar
Sven Keidel committed
105
106
107
108
109
110
111
112
instance (Arrow c, Profunctor c) => ArrowInComponent a (ComponentT Component a c) where
  inComponent f = lift $ dimap (second snd) (\(comp, y) -> (comp,(isInComponent comp,y))) (unlift f)
    where
      isInComponent (Component comp)
        | comp == 0      = Empty
        | comp == 1      = Head Outermost
        | testBit comp 0 = Head Inner
        | otherwise      = Body
113
  {-# INLINE inComponent #-}
114
  {-# SCC inComponent #-}
115

Tomislav Pree's avatar
Tomislav Pree committed
116
117


Sven Keidel's avatar
Sven Keidel committed
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
-- Standard Component ----------------------------------------------------------------------------------
-- newtype Component a = Component (HashSet a) deriving (Eq,IsEmpty,Monoid,Semigroup)

-- instance (Identifiable a, Arrow c, Profunctor c) => ArrowComponent a (ComponentT Component a c) where
--   addToComponent = lift $ arr $ \(Component c,a) -> (Component (H.insert a c),())
--   removeFromComponent = lift $ arr $ \(Component c,a) -> (Component (H.delete a c),())
--   {-# INLINE addToComponent #-}
--   {-# INLINE removeFromComponent #-}
--   {-# SCC addToComponent #-}
--   {-# SCC removeFromComponent #-}

-- instance (Identifiable a, Arrow c, Profunctor c) => ArrowInComponent a (ComponentT Component a c) where
--   inComponent = lift $ arr $ \(Component c,a) ->
--     let comp | H.null c = Empty
--              | H.singleton a == c = Head Outermost
--              | H.member a c = Head Inner
--              | otherwise = Body
--     in (Component c,comp)
--   {-# INLINE inComponent #-}
--   {-# SCC inComponent #-}

-- instance (Identifiable a, ArrowStack a c) => ArrowStack a (ComponentT Component a c) where
--   push f = lift $ proc (comp,(a,x)) -> do
--     (comp',y) <- push (lmap (\x -> (mempty,x)) (unlift f)) -< (a,x)
--     returnA -< (comp <> comp', y)
--   {-# INLINE push #-}
--   {-# SCC push #-}

-- -- Component with a mononone part ------------------------------------------------------------------
-- data Monotone b where
--   Monotone :: HashMap b a -> Monotone (a,b)

-- instance IsEmpty (Monotone (a,b)) where
--   empty = Monotone empty

-- instance Identifiable b => Semigroup (Monotone (a,b)) where
--   Monotone m1 <> Monotone m2 = Monotone (M.union m2 m1)

-- instance Identifiable b => Monoid (Monotone (a,b)) where
--   mempty = empty
--   mappend = (<>)

-- instance (PreOrd a, Identifiable b, Arrow c, Profunctor c) => ArrowComponent (a,b) (ComponentT Monotone (a,b) c) where
--   addToComponent      = lift $ arr $ \(Monotone m,(a,b)) -> (Monotone (M.insert b a m), ())
--   removeFromComponent = lift $ arr $ \(Monotone m,(a,b)) ->
--     (Monotone (M.update (\a' -> if a' ⊑ a then Nothing else Just a') b m), ())
--   {-# INLINE addToComponent #-}
--   {-# INLINE removeFromComponent #-}
--   {-# SCC addToComponent #-}
--   {-# SCC removeFromComponent #-}

-- instance (PreOrd a, Identifiable b, Profunctor c, Arrow c) => ArrowInComponent (a,b) (ComponentT Monotone (a,b) c) where
--   inComponent = lift $ arr $ \(Monotone m,(a,b)) ->
--     let comp | M.null m              = Empty
--              | Just a ⊑ M.lookup b m = Head $ if M.size m == 1 then Outermost else Inner
--              | otherwise             = Body
--     in (Monotone m,comp)
--   {-# INLINE inComponent #-}
--   {-# SCC inComponent #-}

-- instance (ArrowStack a c) => ArrowStack a (ComponentT Monotone a c) where
--   push f = lift $ proc (comp,(a,x)) -> push (unlift f) -< (a,(comp,x))
--   {-# INLINE push #-}
--   {-# SCC push #-}