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

Sven Keidel's avatar
Sven Keidel committed
10
import Prelude hiding (elem)
Sven Keidel's avatar
Sven Keidel committed
11
import Control.Arrow
Sven Keidel's avatar
Sven Keidel committed
12
13
import Control.Arrow.Fix
import Control.Arrow.Trans
14
15
16
17
18
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
Sven Keidel's avatar
Sven Keidel committed
19
20

import Data.Profunctor
Sven Keidel's avatar
Sven Keidel committed
21
22
23
24
import Data.Order
import Data.Metric
import Data.Abstract.Widening
import Data.Maybe
25
import Data.Monoidal
Sven Keidel's avatar
Sven Keidel committed
26
27

import Text.Printf
Sven Keidel's avatar
Sven Keidel committed
28

Tomislav Pree's avatar
Tomislav Pree committed
29

Sven Keidel's avatar
Sven Keidel committed
30
type StackPointer = Int
Tomislav Pree's avatar
Tomislav Pree committed
31
data RecurrentCall = RecurrentCall StackPointer | NoLoop deriving (Show)
Sven Keidel's avatar
Sven Keidel committed
32

Sven Keidel's avatar
Sven Keidel committed
33
class (Arrow c, Profunctor c) => ArrowStack a c | c -> a where
Sven Keidel's avatar
Sven Keidel committed
34
35
  push :: c x y -> c (a, x) (y)
  elem :: c a RecurrentCall
36

37
  default elem :: (c ~ t c', ArrowTrans t, ArrowStack a c') => c a RecurrentCall
38
39
40
  elem = lift' elem
  {-# INLINE elem #-}

Sven Keidel's avatar
Sven Keidel committed
41
42
push' :: ArrowStack a c => c a b -> c a b
push' f = lmap (\a -> (a,a)) (push f)
Sven Keidel's avatar
Sven Keidel committed
43
{-# INLINE push' #-}
Sven Keidel's avatar
Sven Keidel committed
44

45
46
class (Arrow c, Profunctor c) => ArrowStackDepth c where
  depth :: c () Int
47
  default depth :: (c ~ t c', ArrowTrans t, ArrowStackDepth c') => c () Int
48
49
50
51
  depth = lift' depth
  {-# INLINE depth #-}


Tomislav Pree's avatar
Tomislav Pree committed
52
class (Arrow c, Profunctor c) => ArrowStackElements a c | c -> a where
Sven Keidel's avatar
Sven Keidel committed
53
  elems :: c () [a]
Sven Keidel's avatar
Sven Keidel committed
54
  peek :: c () (Maybe a)
Sven Keidel's avatar
Sven Keidel committed
55

56
57
  default elems :: (c ~ t c', ArrowTrans t, ArrowStackElements a c') => c () [a]
  default peek :: (c ~ t c', ArrowTrans t, ArrowStackElements a c') => c () (Maybe a)
Sven Keidel's avatar
Sven Keidel committed
58
59
60
61
62
63

  elems = lift' elems
  peek = lift' peek
  {-# INLINE elems #-}
  {-# INLINE peek #-}

64
class (Arrow c, Profunctor c) => ArrowTopLevel c where
65
  topLevel :: FixpointCombinator c a b -> FixpointCombinator c a b -> FixpointCombinator c a b
66

67
  default topLevel :: (Underlying c a b ~ c' a' b', ArrowLift c, ArrowTopLevel c') => FixpointCombinator c a b -> FixpointCombinator c a b -> FixpointCombinator c a b
68
69
  topLevel stratTop stratLower f = lift $ topLevel (unlift1 stratTop) (unlift1 stratLower) (unlift f)
  {-# INLINE topLevel #-}
70

71
72
73
maxDepth :: (ArrowChoice c, ArrowStackDepth c) => Int -> FixpointCombinator c a b -> FixpointCombinator c a b
maxDepth limit strat f = proc a -> do
  n <- depth -< ()
Sven Keidel's avatar
Sven Keidel committed
74
75
76
  if n < limit
  then f -< a
  else strat f -< a
77
{-# INLINABLE maxDepth #-}
Sven Keidel's avatar
Sven Keidel committed
78

79
widenInput :: (Complete a, ArrowStackElements a c) => Widening a -> FixpointCombinator c a b
Sven Keidel's avatar
Sven Keidel committed
80
81
82
83
widenInput widen f = proc a -> do
  m <- peek -< ()
  f -< case m of
    Nothing -> a
84
    Just x  -> snd $ x `widen` (x  a)
Sven Keidel's avatar
Sven Keidel committed
85
86
{-# INLINE widenInput #-}

87
reuse :: (ArrowChoice c, ArrowStackElements a c) => (a -> [a] -> Maybe a) -> FixpointCombinator c a b
Sven Keidel's avatar
Sven Keidel committed
88
89
90
91
92
reuse select f = proc a -> do
  xs <- elems -< ()
  f -< fromMaybe a (select a xs)
{-# INLINE reuse #-}

93
reuseFirst :: (PreOrd a, ArrowChoice c, ArrowStackElements a c) => FixpointCombinator c a b
Sven Keidel's avatar
Sven Keidel committed
94
95
96
97
98
99
100
101
reuseFirst = reuse find
  where
    find a (x:xs)
      | a  x     = Just x
      | otherwise = find a xs
    find _ []     = Nothing
{-# INLINE reuseFirst #-}

102
reuseByMetric :: (PreOrd a, Ord n, ArrowChoice c, ArrowStackElements a c) => Metric a n -> FixpointCombinator c a b
Sven Keidel's avatar
Sven Keidel committed
103
104
reuseByMetric metric = reuse find
  where
105
    find a xs = element <$> foldMap (\a' -> if a  a' then Just (Measured a' (metric a a')) else Nothing) xs
Sven Keidel's avatar
Sven Keidel committed
106
107
{-# INLINE reuseByMetric #-}

108
data Measured a n = Measured { element :: a, measured :: n }
Sven Keidel's avatar
Sven Keidel committed
109
110

instance (Show a, Show n) => Show (Measured a n) where
111
  show m = printf "%s@%s" (show (element m)) (show (measured m))
Sven Keidel's avatar
Sven Keidel committed
112
113
114
115
116
117

instance Ord n => Semigroup (Measured a n) where
  m1 <> m2
    | measured m1 <= measured m2 = m1
    | otherwise                  = m2
  {-# INLINE (<>) #-}
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

------------- Instances --------------
instance ArrowStack a c => ArrowStack a (ConstT r c) where
  push f = lift $ \r -> push (unlift f r)
  {-# INLINE push #-}

instance ArrowStack a c => ArrowStack a (ReaderT r c) where
  push f = lift $ lmap shuffle1 (push (unlift f))
  {-# INLINE push #-}
instance ArrowStackDepth c => ArrowStackDepth (ReaderT r c)
instance ArrowStackElements a c => ArrowStackElements a (ReaderT r c)

instance ArrowStack a c => ArrowStack a (StateT s c) where
  push f = lift $ lmap shuffle1 (push (unlift f))
  {-# INLINE push #-}
instance ArrowStackDepth c => ArrowStackDepth (StateT s c)
instance ArrowStackElements a c => ArrowStackElements a (StateT s c)

instance ArrowTopLevel c => ArrowTopLevel (StateT s c)

instance (Applicative f, ArrowStack a c) => ArrowStack a (StaticT f c) where
  push (StaticT f) = StaticT $ push <$> f
  {-# INLINE push #-}
  {-# SPECIALIZE instance ArrowStack a c => ArrowStack a (StaticT ((->) r) c) #-}

instance (Monoid w, ArrowStack a c) => ArrowStack a (WriterT w c) where
  push f = lift $ push (unlift f)
  {-# INLINE push #-}

instance (Monoid w, ArrowStackElements a c) => ArrowStackElements a (WriterT w c)
instance (Monoid w, ArrowStackDepth c) => ArrowStackDepth (WriterT w c)