Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
PLMZ
sturdy
Commits
c7cc105b
Verified
Commit
c7cc105b
authored
Aug 30, 2019
by
Sven Keidel
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
move to recursion strategies
parent
20d72c90
Pipeline
#15727
failed with stages
in 11 minutes and 29 seconds
Changes
41
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
41 changed files
with
933 additions
and
627 deletions
+933
-627
lib/src/Control/Arrow/Fix.hs
lib/src/Control/Arrow/Fix.hs
+1
-11
lib/src/Control/Arrow/Fix/Cache.hs
lib/src/Control/Arrow/Fix/Cache.hs
+19
-0
lib/src/Control/Arrow/Fix/Chaotic.hs
lib/src/Control/Arrow/Fix/Chaotic.hs
+50
-0
lib/src/Control/Arrow/Fix/Context.hs
lib/src/Control/Arrow/Fix/Context.hs
+26
-0
lib/src/Control/Arrow/Fix/Reuse.hs
lib/src/Control/Arrow/Fix/Reuse.hs
+21
-0
lib/src/Control/Arrow/Fix/Stack.hs
lib/src/Control/Arrow/Fix/Stack.hs
+16
-0
lib/src/Control/Arrow/Fix/Widening.hs
lib/src/Control/Arrow/Fix/Widening.hs
+14
-0
lib/src/Control/Arrow/Store.hs
lib/src/Control/Arrow/Store.hs
+0
-1
lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache.hs
lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache.hs
+60
-0
lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache/Basic.hs
...src/Control/Arrow/Transformer/Abstract/Fix/Cache/Basic.hs
+63
-0
lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache/ContextSensitive.hs
.../Arrow/Transformer/Abstract/Fix/Cache/ContextSensitive.hs
+103
-0
lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache/Group.hs
...src/Control/Arrow/Transformer/Abstract/Fix/Cache/Group.hs
+74
-0
lib/src/Control/Arrow/Transformer/Abstract/Fix/Chaotic.hs
lib/src/Control/Arrow/Transformer/Abstract/Fix/Chaotic.hs
+84
-95
lib/src/Control/Arrow/Transformer/Abstract/Fix/Context.hs
lib/src/Control/Arrow/Transformer/Abstract/Fix/Context.hs
+57
-0
lib/src/Control/Arrow/Transformer/Abstract/Fix/ContextSensitive/Cache.hs
.../Arrow/Transformer/Abstract/Fix/ContextSensitive/Cache.hs
+0
-157
lib/src/Control/Arrow/Transformer/Abstract/Fix/ContextSensitive/CallSite.hs
...row/Transformer/Abstract/Fix/ContextSensitive/CallSite.hs
+0
-65
lib/src/Control/Arrow/Transformer/Abstract/Fix/Parallel.hs
lib/src/Control/Arrow/Transformer/Abstract/Fix/Parallel.hs
+0
-2
lib/src/Control/Arrow/Transformer/Abstract/Fix/Stack.hs
lib/src/Control/Arrow/Transformer/Abstract/Fix/Stack.hs
+89
-0
lib/src/Control/Arrow/Transformer/Abstract/Fix/StackWidening.hs
...c/Control/Arrow/Transformer/Abstract/Fix/StackWidening.hs
+0
-99
lib/src/Control/Arrow/Transformer/Abstract/Fix/Trace.hs
lib/src/Control/Arrow/Transformer/Abstract/Fix/Trace.hs
+19
-11
lib/src/Control/Arrow/Transformer/Abstract/ReachingDefinitions.hs
...Control/Arrow/Transformer/Abstract/ReachingDefinitions.hs
+1
-2
lib/src/Control/Arrow/Transformer/Concrete/ReachingDefinitions.hs
...Control/Arrow/Transformer/Concrete/ReachingDefinitions.hs
+1
-2
lib/src/Control/Arrow/Transformer/Const.hs
lib/src/Control/Arrow/Transformer/Const.hs
+11
-2
lib/src/Control/Arrow/Transformer/ReachingDefinitions.hs
lib/src/Control/Arrow/Transformer/ReachingDefinitions.hs
+14
-14
lib/src/Control/Arrow/Transformer/Reader.hs
lib/src/Control/Arrow/Transformer/Reader.hs
+13
-6
lib/src/Control/Arrow/Transformer/State.hs
lib/src/Control/Arrow/Transformer/State.hs
+17
-1
lib/src/Control/Arrow/Transformer/Static.hs
lib/src/Control/Arrow/Transformer/Static.hs
+8
-0
lib/src/Control/Arrow/Transformer/Writer.hs
lib/src/Control/Arrow/Transformer/Writer.hs
+35
-5
lib/src/Data/Abstract/CallString.hs
lib/src/Data/Abstract/CallString.hs
+13
-25
lib/src/Data/Abstract/Context.hs
lib/src/Data/Abstract/Context.hs
+0
-9
lib/src/Data/Abstract/Context/Insensitive.hs
lib/src/Data/Abstract/Context/Insensitive.hs
+0
-23
lib/src/Data/Label.hs
lib/src/Data/Label.hs
+2
-2
lib/src/Data/Measure.hs
lib/src/Data/Measure.hs
+13
-0
lib/src/Data/Metric.hs
lib/src/Data/Metric.hs
+3
-0
lib/src/Data/OrdMap.hs
lib/src/Data/OrdMap.hs
+2
-3
lib/test/ContextSensitivitySpec.hs
lib/test/ContextSensitivitySpec.hs
+51
-41
lib/test/FixpointSpec.hs
lib/test/FixpointSpec.hs
+29
-31
lib/test/TestPrograms.hs
lib/test/TestPrograms.hs
+6
-1
stack.yaml
stack.yaml
+2
-2
tutorial/src/SturdyStyle/AbstractInterpreter.hs
tutorial/src/SturdyStyle/AbstractInterpreter.hs
+0
-1
tutorial/src/SturdyStyle/GenericInterpreter.hs
tutorial/src/SturdyStyle/GenericInterpreter.hs
+16
-16
No files found.
lib/src/Control/Arrow/Fix.hs
View file @
c7cc105b
...
...
@@ -8,18 +8,15 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module
Control.Arrow.Fix
(
Fix
,
Fix'
,
ArrowFix
(
..
),
IterationStrategy
,
filter
,
trace
)
where
module
Control.Arrow.Fix
(
Fix
,
Fix'
,
ArrowFix
(
..
),
IterationStrategy
,
filter
)
where
import
Prelude
hiding
(
filter
,
pred
)
import
Control.Arrow
import
Control.Arrow.Trans
import
qualified
Debug.Trace
as
Debug
import
Data.Profunctor
import
Data.Lens
(
Prism'
,
getMaybe
,
set
)
import
Text.Printf
-- | Type family that computes the type of the fixpoint.
type
family
Fix
(
c
::
*
->
*
->
*
)
x
y
::
*
->
*
->
*
...
...
@@ -44,10 +41,3 @@ filter :: (Profunctor c, ArrowChoice c, ArrowApply c) => Prism' a a' -> Iteratio
filter
pred
strat
f
=
proc
a
->
case
getMaybe
pred
a
of
Just
a'
->
strat
(
lmap
(
\
x
->
set
pred
x
a
)
f
)
-<<
a'
Nothing
->
f
-<
a
trace
::
(
Show
a
,
Show
b
,
Arrow
c
)
=>
IterationStrategy
c
a
b
->
IterationStrategy
c
a
b
trace
strat
f
=
proc
x
->
do
strat
(
proc
x
->
do
y
<-
f
-<
x
returnA
-<
Debug
.
trace
(
printf
"RETURN
\n
eval(%s)
\n\t
= %s
\n\n
"
(
show
x
)
(
show
y
))
y
)
-<
Debug
.
trace
(
printf
"CALL
\n
%s
\n\n
"
(
show
x
))
x
lib/src/Control/Arrow/Cache.hs
→
lib/src/Control/Arrow/
Fix/
Cache.hs
View file @
c7cc105b
{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module
Control.Arrow.Cache
where
module
Control.Arrow.Fix.Cache
where
import
Control.Arrow
import
Data.Profunctor
import
Data.Abstract.Widening
(
Stable
)
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowRecurse
a
b
c
|
c
->
a
,
c
->
b
where
-- | Decides whether to return a cached result or to recompute.
recurse
::
c
(
a
,
Cached
b
)
y
->
c
a
y
data
Cached
b
=
Compute
|
Cached
(
Stable
,
b
)
deriving
(
Show
,
Eq
)
import
Data.Abstract.Widening
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowCache
a
b
c
|
c
->
a
,
c
->
b
where
-- | Looks up if there is an entry in the cache.
...
...
@@ -27,5 +17,3 @@ class (Arrow c, Profunctor c) => ArrowCache a b c | c -> a, c -> b where
-- | Set a given entry to stable or unstable.
setStable
::
c
(
Stable
,
a
)
()
type
ArrowCacheRecurse
a
b
c
=
(
ArrowCache
a
b
c
,
ArrowRecurse
a
b
c
)
lib/src/Control/Arrow/Fix/Chaotic.hs
0 → 100644
View file @
c7cc105b
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module
Control.Arrow.Fix.Chaotic
where
import
Prelude
hiding
(
head
)
import
Control.Arrow
import
Data.HashSet
(
HashSet
)
import
qualified
Data.HashSet
as
H
import
Data.Identifiable
import
Data.Profunctor
import
Data.Order
import
Text.Printf
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowIterate
a
c
where
-- | Remembers to iterate on an unstable result until it stabilized.
iterate
::
c
(
a
,
b
)
b
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowComponent
a
c
|
c
->
a
where
setComponent
::
c
(
Component
a
,
y
)
y
withComponent
::
c
x
y
->
(
c
(
x
,
y
,
Component
a
)
y
)
->
c
x
y
data
Component
a
=
Component
{
head
::
HashSet
a
,
body
::
HashSet
a
}
deriving
(
Eq
)
instance
Identifiable
a
=>
PreOrd
(
Component
a
)
where
c1
⊑
c2
=
head
c1
⊑
head
c2
&&
body
c1
⊑
body
c2
{-# INLINE (⊑) #-}
instance
Identifiable
a
=>
Complete
(
Component
a
)
where
c1
⊔
c2
=
c1
<>
c2
{-# INLINE (⊔) #-}
instance
Identifiable
a
=>
Semigroup
(
Component
a
)
where
Component
h1
b1
<>
Component
h2
b2
=
Component
{
head
=
h1
<>
h2
,
body
=
b1
<>
b2
}
{-# INLINE (<>) #-}
instance
Identifiable
a
=>
Monoid
(
Component
a
)
where
mempty
=
Component
{
head
=
H
.
empty
,
body
=
H
.
empty
}
mappend
=
(
<>
)
{-# INLINE mempty #-}
{-# INLINE mappend #-}
singleton
::
Identifiable
a
=>
a
->
Component
a
singleton
a
=
Component
{
head
=
H
.
singleton
a
,
body
=
H
.
empty
}
{-# INLINE singleton #-}
instance
Show
a
=>
Show
(
Component
a
)
where
show
(
Component
h
b
)
=
printf
"Component { head = %s, body = %s }"
(
show
(
H
.
toList
h
))
(
show
(
H
.
toList
b
))
lib/src/Control/Arrow/Fix/Context.hs
0 → 100644
View file @
c7cc105b
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
module
Control.Arrow.Fix.Context
where
import
Control.Arrow
import
Control.Arrow.Fix
import
Control.Arrow.State
import
Data.Profunctor
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowContext
ctx
c
|
c
->
ctx
where
askContext
::
c
()
ctx
localContext
::
c
x
y
->
c
(
ctx
,
x
)
y
class
ArrowJoinContext
cache
a
b
c
where
type
Widening
cache
a
::
*
joinContexts'
::
Widening
cache
a
->
IterationStrategy
c
(
cache
a
b
,
a
)
b
joinContexts
::
(
ArrowState
(
cache
a
b
)
c
,
ArrowJoinContext
cache
a
b
c
)
=>
Widening
cache
a
->
IterationStrategy
c
a
b
joinContexts
widen
f
=
proc
a
->
do
cache
<-
get
-<
()
joinContexts'
widen
(
proc
(
cache
,
a
)
->
do
put
-<
cache
f
-<
a
)
-<
(
cache
,
a
)
{-# INLINE joinContexts #-}
lib/src/Control/Arrow/Fix/Reuse.hs
0 → 100644
View file @
c7cc105b
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module
Control.Arrow.Fix.Reuse
where
import
Control.Arrow
import
Control.Arrow.Fix
import
Data.Measure
import
Data.Metric
class
ArrowReuse
a
b
c
where
-- | Reuse cached results at the cost of precision.
reuseStable
::
(
Show
m
,
Monoid
m
)
=>
(
a
->
a
->
b
->
m
)
->
c
a
m
reuseStableByMetric
::
(
Show
b
,
Show
n
,
Ord
n
,
ArrowChoice
c
,
ArrowReuse
a
b
c
)
=>
Metric
a
n
->
IterationStrategy
c
a
b
reuseStableByMetric
metric
f
=
proc
a
->
do
m
<-
reuseStable
(
\
a
a'
b
->
Just
(
Measured
{
measured
=
metric
a
a'
,
argument
=
b
}))
-<
a
case
m
of
Just
n
->
returnA
-<
argument
n
Nothing
->
f
-<
a
{-# INLINE reuseStableByMetric #-}
lib/src/Control/Arrow/Fix/Stack.hs
0 → 100644
View file @
c7cc105b
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module
Control.Arrow.Fix.Stack
where
import
Control.Arrow
import
Data.Profunctor
import
Data.HashSet
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowStack
a
c
|
c
->
a
where
peek
::
c
()
(
Maybe
a
)
size
::
c
()
Int
push
::
c
a
b
->
c
a
b
elem
::
c
a
Bool
elems
::
c
()
(
HashSet
a
)
lib/src/Control/Arrow/Fix/Widening.hs
0 → 100644
View file @
c7cc105b
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module
Control.Arrow.Fix.Widening
where
import
Control.Arrow
import
Data.Profunctor
import
Data.Order
import
Data.Abstract.Widening
(
Stable
,
finite
)
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowWidening
a
c
where
widening
::
c
(
a
,
a
)
(
Stable
,
a
)
instance
Complete
a
=>
ArrowWidening
a
(
->
)
where
widening
(
a
,
a'
)
=
finite
a
a'
lib/src/Control/Arrow/Store.hs
View file @
c7cc105b
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
...
...
lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache.hs
0 → 100644
View file @
c7cc105b
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module
Control.Arrow.Transformer.Abstract.Fix.Cache
where
import
Prelude
hiding
(
pred
,
lookup
,
map
,
head
,
iterate
,(
.
),
truncate
,
elem
)
import
Control.Category
import
Control.Arrow
import
Control.Arrow.Trans
import
Control.Arrow.State
import
Control.Arrow.Fix.Context
as
Context
hiding
(
Widening
)
import
Control.Arrow.Order
(
ArrowJoin
(
..
),
ArrowComplete
(
..
),
ArrowEffectCommutative
)
import
Control.Arrow.Transformer.Const
import
Control.Arrow.Transformer.State
import
Data.Profunctor.Unsafe
import
Data.Empty
import
Data.Order
import
Data.Coerce
import
Data.Abstract.Widening
newtype
CacheT
cache
a
b
c
x
y
=
CacheT
{
unCacheT
::
ConstT
(
Widening
b
)
(
StateT
(
cache
a
b
)
c
)
x
y
}
deriving
(
Profunctor
,
Category
,
Arrow
,
ArrowChoice
,
ArrowTrans
,
ArrowContext
ctx
,
ArrowState
(
cache
a
b
))
runCacheT
::
(
IsEmpty
(
cache
a
b
),
Profunctor
c
)
=>
Widening
b
->
CacheT
cache
a
b
c
x
y
->
c
x
(
cache
a
b
,
y
)
runCacheT
widen
(
CacheT
f
)
=
lmap
(
\
x
->
(
empty
,
x
))
(
runStateT
(
runConstT
widen
f
))
{-# INLINE runCacheT #-}
liftCacheT
::
Arrow
c
=>
CacheT
cache'
a'
b
c
x
y
->
CacheT
cache
a
b
c
(
cache'
a'
b
,
x
)
(
cache'
a'
b
,
y
)
liftCacheT
(
CacheT
f
)
=
CacheT
(
lift
$
\
widen
->
(
withStateT
(
runConstT
widen
f
)))
{-# INLINE liftCacheT #-}
liftCacheT'
::
Arrow
c
=>
CacheT
cache'
a'
b
c
x
y
->
ConstT
(
Widening
b
)
(
StateT
(
cache
a
b
)
c
)
(
cache'
a'
b
,
x
)
(
cache'
a'
b
,
y
)
liftCacheT'
=
coerce
liftCacheT
{-# INLINE liftCacheT' #-}
instance
(
IsEmpty
(
cache
a
b
),
ArrowRun
c
)
=>
ArrowRun
(
CacheT
cache
a
b
c
)
where
type
Run
(
CacheT
cache
a
b
c
)
x
y
=
Widening
b
->
Run
c
x
(
cache
a
b
,
y
)
run
f
widen
=
run
(
runCacheT
widen
f
)
{-# INLINE run #-}
instance
(
Complete
y
,
ArrowEffectCommutative
c
)
=>
ArrowComplete
y
(
CacheT
cache
a
b
c
)
where
CacheT
f
<
⊔
>
CacheT
g
=
CacheT
$
rmap
(
uncurry
(
⊔
))
(
f
&&&
g
)
{-# INLINE (<⊔>) #-}
instance
(
Arrow
c
,
Profunctor
c
)
=>
ArrowJoin
(
CacheT
cache
a
b
c
)
where
joinSecond
(
CacheT
f
)
=
CacheT
(
second
f
)
{-# INLINE joinSecond #-}
instance
(
Profunctor
c
,
ArrowApply
c
)
=>
ArrowApply
(
CacheT
cache
a
b
c
)
where
app
=
CacheT
(
app
.#
first
coerce
)
{-# INLINE app #-}
instance
ArrowEffectCommutative
c
=>
ArrowEffectCommutative
(
CacheT
cache
a
b
c
)
lib/src/Control/Arrow/Transformer/Abstract/Fix/
StackWidening/Cache
.hs
→
lib/src/Control/Arrow/Transformer/Abstract/Fix/
Cache/Basic
.hs
View file @
c7cc105b
...
...
@@ -6,35 +6,26 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module
Control.Arrow.Transformer.Abstract.Fix.
StackWidening.Cache
where
module
Control.Arrow.Transformer.Abstract.Fix.
Cache.Basic
where
import
Prelude
hiding
(
pred
,
lookup
,
map
,
head
,
iterate
,(
.
))
import
Control.Category
import
Control.Arrow
import
Control.Arrow.
Cach
e
import
Control.Arrow.
Const
import
Control.Arrow.
Fix.Reus
e
import
Control.Arrow.
Fix.Cache
import
Control.Arrow.State
import
Control.Arrow.Trans
import
Control.Arrow.Order
(
ArrowJoin
(
..
),
ArrowComplete
(
..
),
ArrowEffectCommutative
)
import
Control.Arrow.Const
import
Control.Arrow.Transformer.Const
import
Control.Arrow.Transformer.State
import
Control.Arrow.Transformer.Abstract.Fix.Cache
import
Data.Order
import
Data.Profunctor
import
Data.Profunctor.Unsafe
((
.#
))
import
Data.Identifiable
import
Data.Coerce
import
Data.Empty
import
Data.Order
import
Data.HashMap.Lazy
(
HashMap
)
import
qualified
Data.HashMap.Lazy
as
M
import
Data.Abstract.Widening
(
Widening
,
Stable
(
..
))
import
Data.Maybe
(
fromMaybe
)
newtype
CacheT
a
b
c
x
y
=
CacheT
(
ConstT
(
Widening
b
)
(
StateT
(
Cache
a
b
)
c
)
x
y
)
deriving
(
Profunctor
,
Category
,
Arrow
,
ArrowChoice
)
import
Data.Abstract.Widening
(
Stable
(
..
))
newtype
Cache
a
b
=
Cache
{
getMap
::
HashMap
a
(
Stable
,
b
)}
instance
(
Show
a
,
Show
b
)
=>
Show
(
Cache
a
b
)
where
...
...
@@ -44,45 +35,29 @@ instance IsEmpty (Cache a b) where
empty
=
Cache
M
.
empty
{-# INLINE empty #-}
instance
(
Identifiable
a
,
LowerBounded
b
,
Arrow
c
,
Profunctor
c
)
=>
ArrowCache
a
b
(
CacheT
a
b
c
)
where
instance
(
Identifiable
a
,
ArrowChoice
c
,
Profunctor
c
)
=>
ArrowCache
a
b
(
CacheT
Cache
a
b
c
)
where
lookup
=
CacheT
$
proc
a
->
do
Cache
cache
<-
get
-<
()
returnA
-<
M
.
lookup
a
cache
update
=
CacheT
$
askConst
$
\
widen
->
proc
(
a
,
b
)
->
do
Cache
cache
<-
get
-<
()
case
M
.
lookup
a
cache
of
Just
(
_
,
b'
)
->
do
let
b''
=
widen
b'
b
put
-<
Cache
(
M
.
insert
a
b''
cache
)
returnA
-<
b''
Nothing
->
do
put
-<
Cache
(
M
.
insert
a
(
Instable
,
b
)
cache
)
returnA
-<
(
Instable
,
b
)
write
=
CacheT
$
modify'
(
\
((
a
,
b
,
s
),
Cache
cache
)
->
(
()
,
Cache
(
M
.
insert
a
(
s
,
b
)
cache
)))
update
=
CacheT
$
askConst
$
\
widen
->
modify'
(
\
((
a
,
b
),
Cache
cache
)
->
let
(
_
,
bOld
)
=
fromMaybe
(
Instable
,
bottom
)
(
M
.
lookup
a
cache
)
bNew
=
widen
bOld
b
in
(
bNew
,
Cache
(
M
.
insert
a
bNew
cache
)))
setStable
=
CacheT
$
modify'
$
\
((
s
,
a
),
Cache
cache
)
->
(
()
,
Cache
(
M
.
adjust
(
first
(
const
s
))
a
cache
))
{-# INLINE lookup #-}
{-# INLINE write #-}
{-# INLINE update #-}
{-# INLINE setStable #-}
runCacheT
::
(
Profunctor
c
)
=>
Widening
b
->
CacheT
a
b
c
x
y
->
c
x
(
Cache
a
b
,
y
)
runCacheT
widen
(
CacheT
f
)
=
lmap
(
\
x
->
(
empty
,
x
))
(
runStateT
(
runConstT
widen
f
))
{-# INLINE runCacheT #-}
instance
(
ArrowRun
c
)
=>
ArrowRun
(
CacheT
a
b
c
)
where
type
Run
(
CacheT
a
b
c
)
x
y
=
Widening
b
->
Run
c
x
(
Cache
a
b
,
y
)
run
f
widen
=
run
(
runCacheT
widen
f
)
{-# INLINE run #-}
instance
(
Profunctor
c
,
ArrowApply
c
)
=>
ArrowApply
(
CacheT
a
b
c
)
where
app
=
CacheT
(
app
.#
first
coerce
)
{-# INLINE app #-}
instance
(
Complete
y
,
ArrowEffectCommutative
c
)
=>
ArrowComplete
y
(
CacheT
a
b
c
)
where
CacheT
f
<
⊔
>
CacheT
g
=
CacheT
$
rmap
(
uncurry
(
⊔
))
(
f
&&&
g
)
{-# INLINE (<⊔>) #-}
instance
(
Arrow
c
,
Profunctor
c
)
=>
ArrowJoin
(
CacheT
a
b
c
)
where
joinSecond
(
CacheT
f
)
=
CacheT
(
second
f
)
{-# INLINE joinSecond #-}
instance
ArrowLift
(
CacheT
a
b
)
where
lift'
f
=
CacheT
(
lift'
(
lift'
f
))
{-# INLINE lift' #-}
instance
ArrowEffectCommutative
c
=>
ArrowEffectCommutative
(
CacheT
a
b
c
)
instance
(
PreOrd
a
,
Arrow
c
,
Profunctor
c
)
=>
ArrowReuse
a
b
(
CacheT
Cache
a
b
c
)
where
reuseStable
f
=
CacheT
$
proc
a
->
do
Cache
cache
<-
get
-<
()
returnA
-<
M
.
foldlWithKey'
(
\
m
a'
(
s
,
b
)
->
if
s
==
Stable
&&
a
⊑
a'
then
m
<>
f
a
a'
b
else
m
)
mempty
cache
{-# INLINE reuseStable #-}
lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache/ContextSensitive.hs
0 → 100644
View file @
c7cc105b
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module
Control.Arrow.Transformer.Abstract.Fix.Cache.ContextSensitive
(
module
Control
.
Arrow
.
Transformer
.
Abstract
.
Fix
.
Cache
,
Cache
)
where
import
Prelude
hiding
(
pred
,
lookup
,
map
,
head
,
iterate
,(
.
),
truncate
,
elem
)
import
Control.Arrow
import
Control.Arrow.Const
import
Control.Arrow.State
import
Control.Arrow.Fix.Cache
as
Cache
import
Control.Arrow.Fix.Context
as
Context
import
Control.Arrow.Fix.Reuse
as
Reuse
import
Control.Arrow.Transformer.Abstract.Fix.Cache
import
Data.Identifiable
import
Data.Profunctor.Unsafe
import
Data.Empty
import
Data.Order
import
Data.Abstract.Widening
as
W
import
Data.Abstract.Widening
(
Stable
(
..
))
import
Data.HashMap.Lazy
(
HashMap
)
import
qualified
Data.HashMap.Lazy
as
M
newtype
Cache
ctx
a
b
=
Cache
(
HashMap
ctx
(
a
,
b
,
Stable
))
deriving
(
Show
)
instance
IsEmpty
(
Cache
ctx
a
b
)
where
empty
=
Cache
M
.
empty
{-# INLINE empty #-}
instance
(
Identifiable
ctx
,
PreOrd
a
,
LowerBounded
b
,
ArrowChoice
c
,
ArrowContext
ctx
c
)
=>
ArrowJoinContext
(
Cache
ctx
)
a
b
c
where
type
Widening
(
Cache
ctx
)
a
=
W
.
Widening
a
joinContexts'
widen
f
=
proc
(
Cache
cache
,
a
)
->
do
ctx
<-
askContext
-<
()
(
f
|||
returnA
)
-<
case
M
.
lookup
ctx
cache
of
-- If there exists a stable cached entry and the actual input is
-- smaller than the cached input, recurse the cached result.
Just
(
a'
,
b
,
s
)
|
a
⊑
a'
->
case
s
of
Stable
->
Right
b
Instable
->
Left
(
Cache
cache
,
a'
)
|
otherwise
->
-- If there exists the actual input is not smaller than the cached
-- input, widen the input and recompute.
let
(
_
,
a''
)
=
widen
a'
a
in
Left
(
Cache
(
M
.
insert
ctx
(
a''
,
b
,
Instable
)
cache
),
a''
)
Nothing
->
Left
(
Cache
(
M
.
insert
ctx
(
a
,
bottom
,
Instable
)
cache
),
a
)
{-# INLINE joinContexts' #-}
instance
(
Identifiable
ctx
,
PreOrd
a
,
Eq
a
,
Complete
b
,
ArrowChoice
c
,
Profunctor
c
,
ArrowContext
ctx
c
)
=>
ArrowCache
a
b
(
CacheT
(
Cache
ctx
)
a
b
c
)
where
lookup
=
CacheT
$
proc
a
->
do
ctx
<-
askContext
-<
()
Cache
cache
<-
get
-<
()
case
M
.
lookup
ctx
cache
of
Just
(
a'
,
b
,
s
)
|
a
⊑
a'
->
returnA
-<
Just
(
s
,
b
)
|
otherwise
->
returnA
-<
Just
(
Instable
,
b
)
Nothing
->
returnA
-<
Nothing
update
=
CacheT
$
askConst
$
\
widening
->
proc
(
a
,
b
)
->
do
ctx
<-
askContext
-<
()
Cache
cache
<-
get
-<
()
case
M
.
lookup
ctx
cache
of
Just
(
a'
,
b'
,
_
)
->
do
let
(
s
,
b''
)
=
widening
b'
b
put
-<
Cache
(
M
.
insert
ctx
(
a'
,
b''
,
if
a
==
a'
then
s
else
Instable
)
cache
)
returnA
-<
(
s
,
b''
)
Nothing
->
do
put
-<
Cache
(
M
.
insert
ctx
(
a
,
b
,
Instable
)
cache
)
returnA
-<
(
Instable
,
b
)
write
=
CacheT
$
proc
(
a
,
b
,
s
)
->
do
ctx
<-
askContext
-<
()
Cache
cache
<-
get
-<
()
case
M
.
lookup
ctx
cache
of
Just
(
a'
,
b'
,
s'
)
->
do
let
b''
=
b
⊔
b'
put
-<
Cache
(
M
.
insert
ctx
(
a'
,
b''
,
if
a
==
a'
then
s
else
s'
)
cache
)
Nothing
->
put
-<
Cache
(
M
.
insert
ctx
(
a
,
b
,
s
)
cache
)
setStable
=
CacheT
$
proc
(
s
,
a
)
->
do
Cache
cache
<-
get
-<
()
ctx
<-
askContext
-<
()
put
-<
Cache
(
M
.
adjust
(
\
(
a'
,
b'
,
s'
)
->
(
a'
,
b'
,
if
a
==
a'
then
s
else
s'
))
ctx
cache
)
{-# INLINE lookup #-}
{-# INLINE update #-}
{-# INLINE write #-}
{-# INLINE setStable #-}
instance
(
PreOrd
a
,
Arrow
c
,
Profunctor
c
)
=>
ArrowReuse
a
b
(
CacheT
(
Cache
ctx
)
a
b
c
)
where
reuseStable
f
=
CacheT
$
proc
a
->
do
Cache
cache
<-
get
-<
()
returnA
-<
M
.
foldl'
(
\
m
(
a'
,
b
,
s
)
->
if
s
==
Stable
&&
a
⊑
a'
then
m
<>
f
a
a'
b
else
m
)
mempty
cache
{-# INLINE reuseStable #-}
lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache/Group.hs
0 → 100644
View file @
c7cc105b
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module
Control.Arrow.Transformer.Abstract.Fix.Cache.Group
where
import
Prelude
hiding
(
pred
,
lookup
,
map
,
head
,
iterate
,(
.
))
import
Control.Arrow
-- import Control.Arrow.Fix.Reuse
import
Control.Arrow.Fix.Context
import
Control.Arrow.Fix.Cache
as
Cache
import
Control.Arrow.State
import
Control.Arrow.Transformer.Abstract.Fix.Cache
import
Control.Arrow.Transformer.Reader
import
Data.Profunctor
import
Data.Identifiable
import
Data.Empty
import
Data.HashMap.Lazy
(
HashMap
)
import
qualified
Data.HashMap.Lazy
as
M
import
Data.Maybe
(
fromMaybe
)
import
Data.Monoidal
data
Group
cache
a
b
where
Groups
::
HashMap
k
(
cache
a
b
)
->
Group
cache
(
k
,
a
)
b
instance
(
Show
k
,
Show
(
cache
a
b
))
=>
Show
(
Group
cache
(
k
,
a
)
b
)
where
show
(
Groups
m
)
=
show
(
M
.
toList
m
)
instance
IsEmpty
(
Group
cache
(
k
,
a
)
b
)
where
empty
=
Groups
empty
{-# INLINE empty #-}
instance
(
Identifiable
k
,
IsEmpty
(
cache
a
b
),
Arrow
c
,
ArrowJoinContext
cache
a
b
(
ReaderT
(
k
,
Group
cache
(
k
,
a
)
b
)
c
))
=>
ArrowJoinContext
(
Group
cache
)
(
k
,
a
)
b
c
where
type
Widening
(
Group
cache
)
(
k
,
a
)
=
Widening
cache
a
joinContexts'
widen
f
=
proc
(
g
,(
k
,
a
))
->
do
let
Groups
groups
=
g
runReaderT
(
joinContexts'
widen
(
ReaderT
(
proc
((
k
,
g
),(
cache
,
a
))
->
do
let
Groups
groups
=
g
f
-<
(
Groups
(
M
.
insert
k
cache
groups
),(
k
,
a
))
)))
-<
((
k
,
g
),(
fromMaybe
empty
(
M
.
lookup
k
groups
),
a
))
{-# INLINE joinContexts' #-}
instance
(
Identifiable
k
,
Arrow
c
,
Profunctor
c
,
ArrowCache
a
b
(
CacheT
cache
a
b
c
),
IsEmpty
(
cache
a
b
))
=>
ArrowCache
(
k
,
a
)
b
(
CacheT
(
Group
cache
)
(
k
,
a
)
b
c
)
where
lookup
=
withCache
Cache
.
lookup
update
=
lmap
assoc2
(
withCache
Cache
.
update
)
write
=
lmap
(
\
((
k
,
a
),
b
,
s
)
->
(
k
,(
a
,
b
,
s
)))
(
withCache
Cache
.
write
)
setStable
=
lmap
shuffle1
(
withCache
Cache
.
setStable
)
{-# INLINE lookup #-}
{-# INLINE update #-}
{-# INLINE write #-}
{-# INLINE setStable #-}
-- instance (PreOrd a, Arrow c, Profunctor c) => ArrowReuse a b (CacheT Cache a b c) where
-- reuseStable f = CacheT $ proc a -> do
-- Cache cache <- get -< ()
-- returnA -< M.foldlWithKey' (\m a' (s,b) -> if s == Stable && a ⊑ a' then m <> f a a' b else m) mempty cache
-- {-# INLINE reuseStable #-}
withCache
::
(
Identifiable
k
,
IsEmpty
(
cache
a
b
),
Arrow
c
,
Profunctor
c
)
=>
CacheT
cache
a
b
c
x
y
->
CacheT
(
Group
cache
)
(
k
,
a
)
b
c
(
k
,
x
)
y
withCache
f
=
CacheT
$
modify
$
proc
((
k
,
x
),
g
)
->
do
let
Groups
groups
=
g
(
cache'
,
y
)
<-
liftCacheT'
f
-<
(
fromMaybe
empty
(
M
.
lookup
k
groups
),
x
)
returnA
-<
(
y
,
Groups
(
M
.
insert
k
cache'
groups
))
{-# INLINE withCache #-}
lib/src/Control/Arrow/Transformer/Abstract/Fix/Chaotic.hs
View file @
c7cc105b
...
...
@@ -11,138 +11,127 @@
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module
Control.Arrow.Transformer.Abstract.Fix.Chaotic
(
ChaoticT
,
runChaoticT
,
iterateOuter
,
iterateInner
)
where
import
Prelude
hiding
(
pred
,
lookup
,
map
,
head
,
iterate
,(
.
),
elem
)
import
Prelude
hiding
(
id
,
pred
,
lookup
,
map
,
head
,
iterate
,(
.
),
elem
)
import
Control.Category
import
Control.Arrow
hiding
(
loop
)
import
Control.Arrow.Fix
import
Control.Arrow.Cache
as
Cache
import
Control.Arrow.Fix.Chaotic