Stack.hs 4.43 KB
Newer Older
1
{-# LANGUAGE GADTs #-}
2
{-# LANGUAGE DataKinds #-}
Sven Keidel's avatar
Sven Keidel committed
3
{-# LANGUAGE TupleSections #-}
Sven Keidel's avatar
Sven Keidel committed
4
5
6
7
8
9
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
10
{-# LANGUAGE UnboxedTuples #-}
Sven Keidel's avatar
Sven Keidel committed
11
{-# LANGUAGE UndecidableInstances #-}
Sven Keidel's avatar
Sven Keidel committed
12
module Control.Arrow.Transformer.Abstract.Fix.Stack(StackT,Stack) where
Sven Keidel's avatar
Sven Keidel committed
13

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

16
17
import           Control.Category
import           Control.Arrow hiding (loop)
18
import           Control.Arrow.Primitive
19
import           Control.Arrow.Strict
20
21
import           Control.Arrow.Fix.ControlFlow as ControlFlow
import           Control.Arrow.Fix.Cache as Cache
Sven Keidel's avatar
Sven Keidel committed
22
import           Control.Arrow.Fix.Stack (ArrowStack,ArrowStackDepth,ArrowStackElements,StackPointer,RecurrentCall(..))
Sven Keidel's avatar
Sven Keidel committed
23
import qualified Control.Arrow.Fix.Stack as Stack
24
25
26
import           Control.Arrow.Fix.Context (ArrowContext,ArrowJoinContext)
import           Control.Arrow.State
import           Control.Arrow.Trans
27
import           Control.Arrow.Order (ArrowLowerBounded)
Sven Keidel's avatar
Sven Keidel committed
28

29
import           Control.Arrow.Transformer.Reader
Sven Keidel's avatar
Sven Keidel committed
30

31
32
33
34
import           Data.Profunctor
import           Data.Profunctor.Unsafe ((.#))
import           Data.Coerce
import           Data.Empty
35
36
37
import           Data.Identifiable
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
Sven Keidel's avatar
Sven Keidel committed
38
39
import           Data.List(sortBy)
import           Data.Ord(comparing)
Sven Keidel's avatar
Sven Keidel committed
40
41

newtype StackT stack a c x y = StackT (ReaderT (stack a) c x y)
42
  deriving (Profunctor,Category,Arrow,ArrowChoice,
43
            ArrowStrict,ArrowTrans, ArrowLowerBounded z,
Sven Keidel's avatar
Sven Keidel committed
44
            ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache,
45
            ArrowState s,ArrowContext ctx, ArrowJoinContext u,
Tomislav Pree's avatar
Tomislav Pree committed
46
            ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph)
Sven Keidel's avatar
Sven Keidel committed
47

48
runStackT :: (IsEmpty (stack a), Profunctor c) => StackT stack a c x y -> c x y
Sven Keidel's avatar
Sven Keidel committed
49
runStackT (StackT f) = lmap (\x -> (empty,x)) (runReaderT f)
50
51
{-# INLINE runStackT #-}

52
instance Profunctor c => ArrowLift (StackT stack a c) where
53
54
  type Underlying (StackT stack a c) x y = c (stack a, x) y

55
56
57
58
59
60
61
62
63
instance (IsEmpty (stack a), ArrowRun c) => ArrowRun (StackT stack a c) where
  type Run (StackT stack a c) x y = Run c x y
  run f = run (runStackT f)
  {-# INLINE run #-}

instance (Profunctor c,ArrowApply c) => ArrowApply (StackT stack a c) where
  app = StackT (app .# first coerce)
  {-# INLINE app #-}

64
65
instance ArrowCache a b c => ArrowCache a b (StackT stack a c) where
  type Widening (StackT stack a c) = Widening c
66
67

-- Standard Stack -----------------------------------------------------------------------
Sven Keidel's avatar
Sven Keidel committed
68
data Stack a = Stack
Sven Keidel's avatar
Sven Keidel committed
69
70
  { elems :: HashMap a StackPointer
  , depth :: Int
Sven Keidel's avatar
Sven Keidel committed
71
72
73
  }

instance IsEmpty (Stack a) where
Sven Keidel's avatar
Sven Keidel committed
74
  empty = Stack { elems = empty, depth = 0 }
Sven Keidel's avatar
Sven Keidel committed
75
76
  {-# INLINE empty #-}

77
instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a c) where
78
  push f = lift $ proc (st,(a,x)) -> do
Sven Keidel's avatar
Sven Keidel committed
79
    let st' = st { elems = M.insert a (depth st) (elems st)
80
                 , depth = depth st + 1
81
                 }
Sven Keidel's avatar
Sven Keidel committed
82
    unlift f -< (st', x)
Sven Keidel's avatar
Sven Keidel committed
83
84
85
  elem = lift $ arr $ \(st,a) -> case M.lookup a (elems st) of
    Just callDepth -> RecurrentCall (depth st - callDepth)
    Nothing -> NoLoop
86
87
  {-# INLINE push #-}
  {-# INLINE elem #-}
88
89
  {-# SCC push #-}
  {-# SCC elem #-}
90
91
92
93
94

instance (Arrow c, Profunctor c) => ArrowStackDepth (StackT Stack a c) where
  depth = lift $ proc (st,()) -> returnA -< depth st
  {-# INLINE depth #-}

Sven Keidel's avatar
Sven Keidel committed
95
instance (Arrow c, Profunctor c) => ArrowStackElements a (StackT Stack a c) where
Sven Keidel's avatar
Sven Keidel committed
96
97
98
99
100
101
  peek = proc () -> do
    l <- Stack.elems -< ()
    returnA -< case l of
      [] -> Nothing
      (x:_) -> Just x
  elems = lift $ arr $ \(st, ()) -> fst <$> sortBy (comparing snd) (M.toList (elems st))
Sven Keidel's avatar
Sven Keidel committed
102
  {-# INLINE peek #-}
103
  {-# INLINE elems #-}
Sven Keidel's avatar
Sven Keidel committed
104

105
-- Stack with a monotone component ------------------------------------------------------
Sven Keidel's avatar
Sven Keidel committed
106
107
108
109
110
111
112
113
114
115
116
117
118
119
-- data Monotone b where
--   Monotone :: HashMap b a -> Monotone (a,b)

-- instance IsEmpty (Monotone (a,b)) where
--   empty = Monotone empty
--   {-# INLINE empty #-}

-- instance (PreOrd a, Identifiable b, Profunctor c, Arrow c) => ArrowStack (a,b) (StackT Monotone (a,b) c) where
--   push f = lift $ lmap (\(Monotone m, ((a, b), x)) -> (Monotone (M.insert b a m), x)) (unlift f)
--   elem = lift $ arr $ \(Monotone m, (a,b)) -> Just a ⊑ M.lookup b m
--   {-# INLINE elem #-}
--   {-# INLINE push #-}
--   {-# SCC elem #-}
--   {-# SCC push #-}