Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
PLMZ
sturdy
Commits
5616e1e3
Verified
Commit
5616e1e3
authored
Oct 27, 2019
by
Sven Keidel
Browse files
update stratego
parent
e584c808
Pipeline
#17324
failed with stages
in 80 minutes and 24 seconds
Changes
53
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
lib/src/Control/Arrow/Fix/Reuse.hs
View file @
5616e1e3
...
...
@@ -18,6 +18,7 @@ import Control.Arrow.Fix.Cache
import
Data.Abstract.Stable
import
Data.Order
import
Data.Metric
import
Data.Profunctor
import
Data.Monoid
(
First
(
..
))
...
...
@@ -27,11 +28,15 @@ import Text.Printf
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowReuse
a
b
c
where
-- | Reuse cached results at the cost of precision.
reuse
::
(
Monoid
m
)
=>
(
a
->
a
->
Stable
->
b
->
m
)
->
c
(
a
,
Stable
)
m
reuse
::
(
Monoid
m
)
=>
Stable
->
(
a
->
a
->
Stable
->
b
->
m
->
m
)
->
c
a
m
reuseFirst
::
(
ArrowChoice
c
,
ArrowReuse
a
b
c
)
=>
Stable
->
IterationStrategy
c
a
b
reuseFirst
st
f
=
proc
a
->
do
m
<-
reuse
(
\
_
a'
s'
b'
->
First
(
Just
(
a'
,
b'
,
s'
)))
-<
(
a
,
st
)
reuseFirst
::
(
PreOrd
a
,
ArrowChoice
c
,
ArrowReuse
a
b
c
)
=>
Stable
->
IterationStrategy
c
a
b
reuseFirst
s
f
=
proc
a
->
do
m
<-
reuse
s
(
\
a
a'
s'
b'
m
->
case
m
of
First
(
Just
_
)
->
m
First
Nothing
|
a
⊑
a'
->
First
(
Just
(
a'
,
b'
,
s'
))
|
otherwise
->
m
)
-<
a
case
getFirst
m
of
Just
(
_
,
b
,
Stable
)
->
returnA
-<
b
Just
(
a'
,
_
,
Unstable
)
->
f
-<
a'
...
...
@@ -46,17 +51,20 @@ reuseExact f = proc a -> do
_
->
f
-<
a
{-# INLINE reuseExact #-}
reuseByMetric
::
(
Ord
n
,
ArrowChoice
c
,
ArrowReuse
a
b
c
)
=>
Metric
a
n
->
IterationStrategy
c
a
b
reuseByMetric
::
(
PreOrd
a
,
Ord
n
,
ArrowChoice
c
,
ArrowReuse
a
b
c
)
=>
Metric
a
n
->
IterationStrategy
c
a
b
reuseByMetric
metric
=
reuseByMetric_
(
\
s
a
a'
->
Product
s
(
metric
a
a'
))
Unstable
{-# INLINE reuseByMetric #-}
reuseStableByMetric
::
(
Ord
n
,
ArrowChoice
c
,
ArrowReuse
a
b
c
)
=>
Metric
a
n
->
IterationStrategy
c
a
b
reuseStableByMetric
::
(
PreOrd
a
,
Ord
n
,
ArrowChoice
c
,
ArrowReuse
a
b
c
)
=>
Metric
a
n
->
IterationStrategy
c
a
b
reuseStableByMetric
metric
=
reuseByMetric_
(
const
metric
)
Stable
{-# INLINE reuseStableByMetric #-}
reuseByMetric_
::
(
Ord
n
,
ArrowChoice
c
,
ArrowReuse
a
b
c
)
=>
(
Stable
->
Metric
a
n
)
->
Stable
->
IterationStrategy
c
a
b
reuseByMetric_
metric
st
f
=
proc
a
->
do
m
<-
reuse
(
\
a
a'
s'
b'
->
Just
(
Measured
{
input
=
a'
,
output
=
b'
,
stable
=
s'
,
measured
=
metric
s'
a
a'
}))
-<
(
a
,
st
)
reuseByMetric_
::
(
PreOrd
a
,
Ord
n
,
ArrowChoice
c
,
ArrowReuse
a
b
c
)
=>
(
Stable
->
Metric
a
n
)
->
Stable
->
IterationStrategy
c
a
b
reuseByMetric_
metric
s
f
=
proc
a
->
do
m
<-
reuse
s
(
\
a
a'
s'
b'
m
->
if
a
⊑
a'
then
m
<>
Just
(
Measured
{
input
=
a'
,
output
=
b'
,
stable
=
s'
,
measured
=
metric
s'
a
a'
})
else
m
)
-<
a
case
m
of
Just
Measured
{
stable
=
Stable
,
output
=
b
}
->
returnA
-<
b
Just
Measured
{
stable
=
Unstable
,
input
=
a'
}
->
f
-<
a'
...
...
lib/src/Control/Arrow/Order.hs
View file @
5616e1e3
...
...
@@ -52,16 +52,19 @@ joinList empty f = proc (e,(l,s)) -> case l of
[]
->
empty
-<
(
e
,
s
)
[
x
]
->
f
-<
(
e
,(
x
,
s
))
(
x
:
xs
)
->
(
f
-<
(
e
,(
x
,
s
)))
<
⊔
>
(
joinList
empty
f
-<
(
e
,(
xs
,
s
)))
{-# INLINABLE joinList #-}
joinList1
::
(
ArrowChoice
c
,
ArrowLowerBounded
c
,
ArrowComplete
y
c
)
=>
c
(
e
,(
x
,
s
))
y
->
c
(
e
,([
x
],
s
))
y
joinList1
f
=
proc
(
e
,(
l
,
s
))
->
case
l
of
[]
->
bottom
-<
()
[
x
]
->
f
-<
(
e
,(
x
,
s
))
(
x
:
xs
)
->
(
f
-<
(
e
,(
x
,
s
)))
<
⊔
>
(
joinList1
f
-<
(
e
,(
xs
,
s
)))
{-# INLINABLE joinList1 #-}
joinList1'
::
(
ArrowChoice
c
,
ArrowLowerBounded
c
,
ArrowComplete
y
c
)
=>
c
(
x
,
e
)
y
->
c
([
x
],
e
)
y
joinList1'
f
=
proc
(
l
,
e
)
->
case
l
of
[]
->
bottom
-<
()
[
x
]
->
f
-<
(
x
,
e
)
(
x
:
xs
)
->
(
f
-<
(
x
,
e
))
<
⊔
>
(
joinList1'
f
-<
(
xs
,
e
))
{-# INLINABLE joinList1' #-}
lib/src/Control/Arrow/Transformer/Abstract/Environment.hs
View file @
5616e1e3
...
...
@@ -7,6 +7,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
module
Control.Arrow.Transformer.Abstract.Environment
where
import
Prelude
hiding
((
.
),
read
,
Maybe
(
..
))
...
...
@@ -26,6 +27,7 @@ import Control.Arrow.Closure as Cls
import
Control.Arrow.Fix
import
Control.Arrow.Order
import
Data.Abstract.IntersectionSet
(
Set
)
import
Data.Abstract.Maybe
import
qualified
Data.Abstract.StrongMap
as
SM
import
qualified
Data.Abstract.Environment.Flat
as
FM
...
...
@@ -40,7 +42,7 @@ import Data.Coerce
import
GHC.Exts
newtype
EnvT
env
var
val
c
x
y
=
EnvT
(
ReaderT
(
env
var
val
)
c
x
y
)
newtype
EnvT
(
env
::
k1
->
k2
->
*
)
var
val
c
x
y
=
EnvT
(
ReaderT
(
env
var
val
)
c
x
y
)
deriving
(
Profunctor
,
Category
,
Arrow
,
ArrowChoice
,
ArrowTrans
,
ArrowLift
,
ArrowLowerBounded
,
ArrowComplete
z
,
ArrowState
s
,
ArrowFail
e
,
ArrowExcept
e
,
ArrowStore
var'
val'
,
ArrowConst
k
,
ArrowRun
)
...
...
@@ -66,7 +68,7 @@ instance (Identifiable var, UpperBounded val, ArrowChoice c, Profunctor c) => Ar
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance
(
Identifiable
var
,
IsClosure
val
(
FM
.
Env
var
val
)
,
Complete
val
,
ArrowChoice
c
,
Profunctor
c
)
=>
ArrowEnv
var
val
(
EnvT
FM
.
Env
var
val
c
)
where
instance
(
Identifiable
var
,
Traversable
val
,
Complete
(
val
(
Set
var
))
,
ArrowChoice
c
,
Profunctor
c
)
=>
ArrowEnv
var
(
val
(
FM
.
Env
var
val
))
(
EnvT
FM
.
Env
var
val
c
)
where
type
Join
y
(
EnvT
FM
.
Env
var
val
c
)
=
ArrowComplete
y
c
lookup
(
EnvT
f
)
(
EnvT
g
)
=
EnvT
$
proc
(
var
,
x
)
->
do
env
<-
Reader
.
ask
-<
()
...
...
@@ -80,7 +82,7 @@ instance (Identifiable var, IsClosure val (FM.Env var val), Complete val, ArrowC
{-# INLINE lookup #-}
{-# INLINE extend #-}
instance
(
Identifiable
var
,
IsClosure
val
(
FM
.
Env
var
val
)
,
Complete
val
,
ArrowChoice
c
,
Profunctor
c
)
=>
ArrowLetRec
var
val
(
EnvT
FM
.
Env
var
val
c
)
where
instance
(
Identifiable
var
,
Traversable
val
,
Complete
(
val
(
Set
var
))
,
ArrowChoice
c
,
Profunctor
c
)
=>
ArrowLetRec
var
(
val
(
FM
.
Env
var
val
))
(
EnvT
FM
.
Env
var
val
c
)
where
letRec
(
EnvT
f
)
=
EnvT
$
proc
(
ls
,
x
)
->
do
env
<-
Reader
.
ask
-<
()
Reader
.
local
f
-<
(
FM
.
insertRec
ls
env
,
x
)
...
...
lib/src/Control/Arrow/Transformer/Abstract/Fix.hs
View file @
5616e1e3
...
...
@@ -40,6 +40,7 @@ instance ArrowRun c => ArrowRun (FixT a b c) where
type
instance
Fix
(
FixT
_
_
c
)
x
y
=
FixT
x
y
c
instance
(
Profunctor
c
,
ArrowChoice
c
)
=>
ArrowFix
(
FixT
a
b
c
a
b
)
where
fix
f
=
iterationStrategy
(
f
(
fix
f
))
{-# NOINLINE fix #-}
instance
(
Profunctor
c
,
ArrowApply
c
)
=>
ArrowApply
(
FixT
a
b
c
)
where
app
=
FixT
(
app
.#
first
coerce
)
...
...
lib/src/Control/Arrow/Transformer/Abstract/Fix/Cache.hs
View file @
5616e1e3
...
...
@@ -115,10 +115,10 @@ instance (Arrow c, ArrowContext ctx a c) => ArrowContext ctx a (CacheT Cache a b
{-# INLINE localContext #-}
{-# INLINE joinByContext #-}
instance
(
PreOrd
a
,
Arrow
c
,
Profunctor
c
)
=>
ArrowReuse
a
b
(
CacheT
Cache
a
b
c
)
where
reuse
f
=
CacheT
$
proc
(
a
,
s
)
->
do
instance
(
Arrow
c
,
Profunctor
c
)
=>
ArrowReuse
a
b
(
CacheT
Cache
a
b
c
)
where
reuse
s
f
=
CacheT
$
proc
a
->
do
Cache
cache
<-
get
-<
()
returnA
-<
M
.
foldlWithKey'
(
\
m
a'
(
s'
,
b'
)
->
if
s'
⊑
s
&&
a
⊑
a'
then
m
<>
f
a
a'
s'
b'
else
m
)
mempty
cache
returnA
-<
M
.
foldlWithKey'
(
\
m
a'
(
s'
,
b'
)
->
if
s'
⊑
s
then
f
a
a'
s'
b'
m
else
m
)
mempty
cache
{-# INLINE reuse #-}
instance
Identifiable
a
=>
IsList
(
Cache
a
b
)
where
...
...
@@ -154,7 +154,7 @@ instance (Arrow c, ArrowContext ctx a c) => ArrowContext ctx (k,a) (CacheT (Grou
{-# INLINE joinByContext #-}
instance
(
Identifiable
k
,
IsEmpty
(
cache
a
b
),
ArrowApply
c
,
Profunctor
c
,
ArrowReuse
a
b
(
CacheT
cache
a
b
c
))
=>
ArrowReuse
(
k
,
a
)
b
(
CacheT
(
Group
cache
)
(
k
,
a
)
b
c
)
where
reuse
f
=
proc
(
(
k
,
a0
)
,
s
)
->
withCache
(
reuse
(
\
a
a'
->
f
(
k
,
a
)
(
k
,
a'
)))
-<<
(
k
,
(
a0
,
s
)
)
reuse
s
f
=
proc
(
k
,
a0
)
->
withCache
(
reuse
s
(
\
a
a'
->
f
(
k
,
a
)
(
k
,
a'
)))
-<<
(
k
,
a0
)
{-# INLINE reuse #-}
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
...
...
lib/src/Control/Arrow/Transformer/Abstract/Fix/Stack.hs
View file @
5616e1e3
{-# LANGUAGE
GeneralizedNewtypeDeriving
#-}
{-# LANGUAGE
TupleSections
#-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
...
...
@@ -33,8 +33,6 @@ import Data.Order hiding (top)
import
Data.Abstract.Widening
(
Widening
)
import
Data.HashSet
(
HashSet
)
import
qualified
Data.HashSet
as
H
import
Data.Abstract.Stable
import
Data.Foldable
maxSize
::
(
ArrowChoice
c
,
ArrowStack
a
c
)
=>
Int
->
IterationStrategy
c
a
b
->
IterationStrategy
c
a
b
maxSize
limit
strat
f
=
proc
a
->
do
...
...
@@ -65,14 +63,9 @@ instance IsEmpty (Stack a) where
newtype
StackT
stack
a
c
x
y
=
StackT
(
ReaderT
(
stack
a
)
c
x
y
)
deriving
(
Profunctor
,
Category
,
Arrow
,
ArrowChoice
,
ArrowJoin
,
ArrowComplete
z
,
ArrowCache
a
b
,
ArrowState
s
,
ArrowTrans
,
ArrowContext
ctx
a
)
instance
(
PreOrd
a
,
LowerBounded
b
,
ArrowChoice
c
,
ArrowReuse
a
b
c
,
ArrowStack
a
(
StackT
stack
a
c
))
=>
ArrowReuse
a
b
(
StackT
stack
a
c
)
where
reuse
f
=
proc
(
a
,
s
)
->
case
s
of
Unstable
->
do
m0
<-
StackT
(
reuse
f
)
-<
(
a
,
Unstable
)
stack
<-
Stack
.
elems
-<
()
returnA
-<
foldl'
(
\
m
a'
->
if
a
⊑
a'
then
m
<>
f
a
a'
Unstable
bottom
else
m
)
m0
stack
Stable
->
StackT
(
reuse
f
)
-<
(
a
,
Stable
)
instance
(
ArrowReuse
a
b
c
,
ArrowStack
a
(
StackT
stack
a
c
))
=>
ArrowReuse
a
b
(
StackT
stack
a
c
)
where
reuse
s
f
=
StackT
$
reuse
s
f
{-# INLINABLE reuse #-}
instance
(
Identifiable
a
,
Arrow
c
,
Profunctor
c
)
=>
ArrowStack
a
(
StackT
Stack
a
c
)
where
peek
=
lift
$
proc
(
stack
,
()
)
->
returnA
-<
top
stack
...
...
@@ -87,7 +80,7 @@ instance (Identifiable a, Arrow c, Profunctor c) => ArrowStack a (StackT Stack a
{-# INLINE size #-}
runStackT
::
(
IsEmpty
(
stack
a
),
Profunctor
c
)
=>
StackT
stack
a
c
x
y
->
c
x
y
runStackT
(
StackT
f
)
=
lmap
(
\
x
->
(
empty
,
x
)
)
(
runReaderT
f
)
runStackT
(
StackT
f
)
=
lmap
(
empty
,)
(
runReaderT
f
)
{-# INLINE runStackT #-}
instance
(
IsEmpty
(
stack
a
),
ArrowRun
c
)
=>
ArrowRun
(
StackT
stack
a
c
)
where
...
...
lib/src/Control/Arrow/Transformer/Abstract/Fix/Trace.hs
View file @
5616e1e3
...
...
@@ -15,7 +15,7 @@ import Control.Arrow
import
Control.Arrow.Fix
import
Control.Arrow.Fix.Chaotic
import
Control.Arrow.Fix.Reuse
as
Reuse
import
Control.Arrow.Fix.Cache
as
Cache
--
import Control.Arrow.Fix.Cache as Cache
import
Control.Arrow.Fix.Stack
as
Stack
import
Control.Arrow.Fix.Context
as
Context
import
Control.Arrow.State
...
...
@@ -34,6 +34,20 @@ trace showA showB f = proc x -> do
returnA
-<
Debug
.
trace
(
printf
"RETURN
\n
%s
\n
%s
\n\n
"
(
showA
x
)
(
showB
y
))
y
{-# INLINE trace #-}
trace'
::
(
Eq
a
,
ArrowApply
c
)
=>
(
a
->
String
)
->
(
b
->
String
)
->
IterationStrategy
c
a
b
->
IterationStrategy
c
a
b
trace'
showA
showB
strat
f
=
proc
x
->
do
y
<-
strat
(
proc
x'
->
f
-<
Debug
.
trace
(
if
x
==
x'
then
printf
"CALL
\n
%s
\n\n
"
(
showA
x
)
else
printf
"CALL
\n
%s~>
\n
%s
\n\n
"
(
showA
x
)
(
showA
x'
))
x'
)
-<<
x
returnA
-<
Debug
.
trace
(
printf
"RETURN
\n
%s
\n
%s
\n\n
"
(
showA
x
)
(
showB
y
))
y
{-# INLINE trace' #-}
traceCache
::
ArrowState
cache
c
=>
(
cache
->
String
)
->
IterationStrategy
c
a
b
traceCache
showCache
f
=
proc
a
->
do
cache
<-
get
-<
()
f
-<
Debug
.
trace
(
printf
"CACHE %s
\n\n
"
(
showCache
cache
))
a
{-# INLINE traceCache #-}
traceCtx
::
(
ArrowContext
ctx
a'
c
,
ArrowState
cache
c
)
=>
(
a
->
String
)
->
(
b
->
String
)
->
(
ctx
->
String
)
->
(
cache
->
String
)
->
IterationStrategy
c
a
b
traceCtx
showA
showB
showCtx
showCache
f
=
proc
x
->
do
ctx
<-
askContext
-<
()
...
...
@@ -56,26 +70,26 @@ newtype TraceT c x y = TraceT (c x y)
-- m <- Reuse.reuse f -< (a,s)
-- returnA -< Debug.trace (printf "REUSE\nx: %s\n%s\n\n" (show a) (show m)) m
instance
(
Show
a
,
ArrowIterate
a
c
)
=>
ArrowIterate
a
(
TraceT
c
)
where
iterate
=
TraceT
$
proc
(
a
,
b
)
->
iterate
-<
Debug
.
trace
(
printf
"ITERATE
\n\t
x: %s
\n\n
"
(
show
a
))
(
a
,
b
)
instance
(
Show
a
,
Show
b
,
ArrowCache
a
b
c
)
=>
ArrowCache
a
b
(
TraceT
c
)
where
lookup
=
TraceT
$
proc
a
->
do
b
<-
lookup
-<
a
returnA
-<
Debug
.
trace
(
printf
"LOOKUP
\n\t
x: %s
\n\t
y: %s
\n\n
"
(
show
a
)
(
show
b
))
b
update
=
TraceT
$
proc
(
a
,
b
)
->
do
bOld
<-
lookup
-<
a
(
s
,
b'
)
<-
update
-<
(
a
,
b
)
returnA
-<
Debug
.
trace
(
printf
"UPDATE
\n\t
x: %s
\n\t
y: %s -> %s, %s
\n\n
"
(
show
a
)
(
show
bOld
)
(
show
b'
)
(
show
s
))
(
s
,
b'
)
write
=
TraceT
$
proc
(
a
,
b
,
s
)
->
do
write
-<
Debug
.
trace
(
printf
"WRITE
\n\t
x: %s
\n\t
y: %s
\n\t
%s
\n\t\n\n
"
(
show
a
)
(
show
b
)
(
show
s
))
(
a
,
b
,
s
)
setStable
=
TraceT
$
proc
(
s
,
a
)
->
setStable
-<
Debug
.
trace
(
printf
"STABLE
\n\t
x: %s
\n\t
%s
\n\n
"
(
show
a
)
(
show
s
))
(
s
,
a
)
{-# INLINE lookup #-}
{-# INLINE update #-}
{-# INLINE write #-}
{-# INLINE setStable #-}
--
instance (Show a, ArrowIterate a c) => ArrowIterate a (TraceT c) where
--
iterate = TraceT $ proc (a,b) ->
--
iterate -< Debug.trace (printf "ITERATE\n\tx: %s\n\n" (show a)) (a,b)
--
instance (Show a, Show b, ArrowCache a b c) => ArrowCache a b (TraceT c) where
--
lookup = TraceT $ proc a -> do
--
b <- lookup -< a
--
returnA -<
b --
Debug.trace (printf "LOOKUP\n\tx: %s\n\ty: %s\n\n" (show a) (show b)) b
--
update = TraceT $ proc (a,b) -> do
--
bOld <- lookup -< a
--
(s,b') <- update -< (a,b)
--
returnA -< Debug.trace (printf "UPDATE\n\tx: %s\n\ty: %s -> %s, %s\n\n" (show a) (show bOld) (show b') (show s)) (s,b')
--
write = TraceT $ proc (a,b,s) -> do
--
write -<
(a,b,s) --
Debug.trace (printf "WRITE\n\tx: %s\n\ty: %s\n\t%s\n\t\n\n" (show a) (show b) (show s)) (a,b,s)
--
setStable = TraceT $ proc (s,a) ->
--
setStable -< Debug.trace (printf "STABLE\n\tx: %s\n\t%s\n\n" (show a) (show s)) (s,a)
--
{-# INLINE lookup #-}
--
{-# INLINE update #-}
--
{-# INLINE write #-}
--
{-# INLINE setStable #-}
runTraceT
::
TraceT
c
x
y
->
c
x
y
runTraceT
(
TraceT
f
)
=
f
...
...
lib/src/Control/Arrow/Transformer/Concrete/Environment.hs
View file @
5616e1e3
...
...
@@ -68,9 +68,9 @@ instance (ArrowChoice c, Profunctor c) => ArrowClosure expr (Closure expr (HashM
instance
(
Identifiable
var
,
IsClosure
val
(
HashMap
var
val
),
ArrowChoice
c
,
Profunctor
c
)
=>
ArrowLetRec
var
val
(
EnvT
var
val
c
)
where
letRec
(
EnvT
f
)
=
EnvT
$
proc
(
l
s
,
x
)
->
do
letRec
(
EnvT
f
)
=
EnvT
$
proc
(
binding
s
,
x
)
->
do
env
<-
Reader
.
ask
-<
()
let
env'
=
foldr
(
\
(
var
,
val
)
->
M
.
insert
var
(
setEnvironment
env'
val
))
env
l
s
let
env'
=
foldr
(
\
(
var
,
val
)
->
M
.
insert
var
(
setEnvironment
env'
val
))
env
binding
s
Reader
.
local
f
-<
(
env'
,
x
)
instance
(
ArrowApply
c
,
Profunctor
c
)
=>
ArrowApply
(
EnvT
var
val
c
)
where
...
...
lib/src/Control/Arrow/Transformer/Const.hs
View file @
5616e1e3
...
...
@@ -34,7 +34,7 @@ import Data.Coerce
-- | Passes along constant data.
newtype
ConstT
r
c
x
y
=
ConstT
(
StaticT
((
->
)
r
)
c
x
y
)
deriving
(
Category
,
Profunctor
,
Arrow
,
ArrowChoice
,
ArrowLowerBounded
,
ArrowLift
,
ArrowJoin
,
ArrowState
s
,
ArrowReader
r'
,
ArrowWriter
w
,
ArrowState
s
,
ArrowReader
r'
,
ArrowWriter
w
,
ArrowLetRec
var
val
,
ArrowEnv
var
val
,
ArrowClosure
expr
cls
,
ArrowStore
var
val
,
ArrowFail
e
,
ArrowExcept
e
,
ArrowContext
ctx
a
)
...
...
lib/src/Control/Arrow/Transformer/FreeVars.hs
View file @
5616e1e3
...
...
@@ -50,7 +50,7 @@ instance (Identifiable var, ArrowEnv var val c, Profunctor c) => ArrowEnv var va
lookup
(
FreeVarsT
f
)
(
FreeVarsT
g
)
=
FreeVarsT
$
proc
(
var
,
x
)
->
do
tell
-<
H
.
singleton
var
Env
.
lookup
f
g
-<
(
var
,
x
)
extend
(
FreeVarsT
f
)
=
FreeVarsT
$
proc
(
var
,
val
,
x
)
->
do
extend
(
FreeVarsT
f
)
=
FreeVarsT
$
proc
(
var
,
val
,
x
)
->
censor
(
\
(
var
,
_
,
_
)
->
H
.
delete
var
)
(
Env
.
extend
f
)
-<
(
var
,
val
,
x
)
instance
(
Identifiable
var
,
ArrowApply
c
,
Profunctor
c
)
=>
ArrowApply
(
FreeVarsT
var
c
)
where
...
...
lib/src/Control/Arrow/Transformer/NoInline.hs
0 → 100644
View file @
5616e1e3
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module
Control.Arrow.Transformer.NoInline
where
import
Prelude
hiding
(
id
,(
.
),
lookup
,
read
,
fail
)
import
Control.Category
import
Control.Arrow
import
Control.Arrow.Const
import
Control.Arrow.Environment
as
Env
import
Control.Arrow.Closure
as
Cls
import
Control.Arrow.Except
as
Exc
import
Control.Arrow.Fail
import
Control.Arrow.Fix
import
Control.Arrow.Fix.Reuse
as
Reuse
import
Control.Arrow.Fix.Cache
as
Cache
import
Control.Arrow.Fix.Context
as
Context
import
Control.Arrow.Order
import
Control.Arrow.Reader
as
Reader
import
Control.Arrow.State
as
State
import
Control.Arrow.Store
as
Store
import
Control.Arrow.Trans
import
Control.Arrow.Writer
import
Data.Profunctor
import
Data.Profunctor.Unsafe
import
Unsafe.Coerce
newtype
NoInlineT
c
x
y
=
NoInlineT
{
runNoInlineTT
::
c
x
y
}
instance
ArrowRun
c
=>
ArrowRun
(
NoInlineT
c
)
where
type
Run
(
NoInlineT
c
)
x
y
=
Run
c
x
y
instance
ArrowTrans
(
NoInlineT
c
)
where
type
Underlying
(
NoInlineT
c
)
x
y
=
c
x
y
instance
Profunctor
c
=>
Profunctor
(
NoInlineT
c
)
where
dimap
f
g
h
=
lift
$
dimap
f
g
(
unlift
h
)
lmap
f
h
=
lift
$
lmap
f
(
unlift
h
)
rmap
g
h
=
lift
$
rmap
g
(
unlift
h
)
f
.#
_
=
f
`
seq
`
unsafeCoerce
f
_
#.
g
=
g
`
seq
`
unsafeCoerce
g
{-# NOINLINE dimap #-}
{-# NOINLINE lmap #-}
{-# NOINLINE rmap #-}
{-# NOINLINE (.#) #-}
{-# NOINLINE (#.) #-}
-- instance ArrowLift NoInlineT where
-- lift' = lift
-- {-# NOINLINE lift' #-}
instance
Category
c
=>
Category
(
NoInlineT
c
)
where
id
=
lift
id
f
.
g
=
lift
(
unlift
f
.
unlift
g
)
{-# NOINLINE id #-}
{-# NOINLINE (.) #-}
instance
Arrow
c
=>
Arrow
(
NoInlineT
c
)
where
arr
f
=
lift
(
arr
f
)
first
f
=
lift
$
first
(
unlift
f
)
second
f
=
lift
$
second
(
unlift
f
)
f
&&&
g
=
lift
$
unlift
f
&&&
unlift
g
f
***
g
=
lift
$
unlift
f
***
unlift
g
{-# NOINLINE arr #-}
{-# NOINLINE first #-}
{-# NOINLINE second #-}
{-# NOINLINE (&&&) #-}
{-# NOINLINE (***) #-}
instance
(
ArrowChoice
c
)
=>
ArrowChoice
(
NoInlineT
c
)
where
left
f
=
lift
$
left
(
unlift
f
)
right
f
=
lift
$
right
(
unlift
f
)
f
+++
g
=
lift
$
unlift
f
+++
unlift
g
f
|||
g
=
lift
$
unlift
f
|||
unlift
g
{-# NOINLINE left #-}
{-# NOINLINE right #-}
{-# NOINLINE (+++) #-}
{-# NOINLINE (|||) #-}
instance
(
ArrowApply
c
,
Profunctor
c
)
=>
ArrowApply
(
NoInlineT
c
)
where
app
=
lift
$
lmap
(
\
(
f
,
b
)
->
(
unlift
f
,
b
))
app
{-# NOINLINE app #-}
instance
ArrowReader
r
c
=>
ArrowReader
r
(
NoInlineT
c
)
where
ask
=
lift
ask
local
f
=
lift
$
local
(
unlift
f
)
{-# NOINLINE ask #-}
{-# NOINLINE local #-}
instance
ArrowState
s
c
=>
ArrowState
s
(
NoInlineT
c
)
where
get
=
lift
State
.
get
put
=
lift
State
.
put
modify
f
=
lift
(
State
.
modify
(
unlift
f
))
{-# NOINLINE get #-}
{-# NOINLINE put #-}
{-# NOINLINE modify #-}
instance
ArrowWriter
w
c
=>
ArrowWriter
w
(
NoInlineT
c
)
where
tell
=
lift
tell
{-# NOINLINE tell #-}
instance
ArrowFail
e
c
=>
ArrowFail
e
(
NoInlineT
c
)
where
fail
=
lift
fail
{-# NOINLINE fail #-}
instance
ArrowEnv
var
val
c
=>
ArrowEnv
var
val
(
NoInlineT
c
)
where
type
Join
y
(
NoInlineT
c
)
=
Env
.
Join
y
c
lookup
f
g
=
lift
(
Env
.
lookup
(
unlift
f
)
(
unlift
g
))
extend
f
=
lift
(
Env
.
extend
(
unlift
f
))
{-# NOINLINE lookup #-}
{-# NOINLINE extend #-}
instance
ArrowLetRec
var
val
c
=>
ArrowLetRec
var
val
(
NoInlineT
c
)
where
letRec
f
=
lift
(
letRec
(
unlift
f
))
{-# NOINLINE letRec #-}
instance
ArrowClosure
expr
cls
c
=>
ArrowClosure
expr
cls
(
NoInlineT
c
)
where
type
Join
y
(
NoInlineT
c
)
=
Cls
.
Join
y
c
closure
=
lift
Cls
.
closure
apply
f
=
lift
$
Cls
.
apply
(
unlift
f
)
{-# NOINLINE closure #-}
{-# NOINLINE apply #-}
instance
ArrowStore
var
val
c
=>
ArrowStore
var
val
(
NoInlineT
c
)
where
type
Join
y
(
NoInlineT
c
)
=
Store
.
Join
y
c
read
f
g
=
lift
$
Store
.
read
(
unlift
f
)
(
unlift
g
)
write
=
lift
Store
.
write
{-# NOINLINE read #-}
{-# NOINLINE write #-}
type
instance
Fix
(
NoInlineT
c
)
x
y
=
NoInlineT
(
Fix
c
x
y
)
instance
ArrowFix
(
Underlying
(
NoInlineT
c
)
x
y
)
=>
ArrowFix
(
NoInlineT
c
x
y
)
instance
ArrowExcept
e
c
=>
ArrowExcept
e
(
NoInlineT
c
)
where
type
Join
z
(
NoInlineT
c
)
=
Exc
.
Join
z
c
throw
=
lift
throw
try
f
g
h
=
lift
$
try
(
unlift
f
)
(
unlift
g
)
(
unlift
h
)
{-# NOINLINE throw #-}
{-# NOINLINE try #-}
instance
ArrowLowerBounded
c
=>
ArrowLowerBounded
(
NoInlineT
c
)
where
bottom
=
lift
bottom
{-# NOINLINE bottom #-}
instance
ArrowJoin
c
=>
ArrowJoin
(
NoInlineT
c
)
where
joinSecond
lub
f
g
=
lift
$
joinSecond
lub
f
(
unlift
g
)
{-# NOINLINE joinSecond #-}
instance
ArrowComplete
y
c
=>
ArrowComplete
y
(
NoInlineT
c
)
where
f
<
⊔
>
g
=
lift
$
unlift
f
<
⊔
>
unlift
g
{-# NOINLINE (<⊔>) #-}
instance
ArrowConst
x
c
=>
ArrowConst
x
(
NoInlineT
c
)
where
askConst
f
=
lift
(
askConst
(
unlift
.
f
))
{-# NOINLINE askConst #-}
instance
ArrowEffectCommutative
c
=>
ArrowEffectCommutative
(
NoInlineT
c
)
instance
ArrowReuse
a
b
c
=>
ArrowReuse
a
b
(
NoInlineT
c
)
where
reuse
s
f
=
lift
$
reuse
s
f
{-# NOINLINE reuse #-}
instance
ArrowContext
ctx
a
c
=>
ArrowContext
ctx
a
(
NoInlineT
c
)
where
type
Widening
(
NoInlineT
c
)
a
=
Widening
c
a
askContext
=
Context
.
askContext
localContext
f
=
lift
(
localContext
(
unlift
f
))
joinByContext
widen
=
lift
$
joinByContext
widen
{-# NOINLINE askContext #-}
{-# NOINLINE localContext #-}
{-# NOINLINE joinByContext #-}
instance
ArrowCache
a
b
c
=>
ArrowCache
a
b
(
NoInlineT
c
)
where
lookup
=
lift
Cache
.
lookup
write
=
lift
Cache
.
write
update
=
lift
Cache
.
update
setStable
=
lift
Cache
.
setStable
{-# NOINLINE lookup #-}
{-# NOINLINE write #-}
{-# NOINLINE update #-}
{-# NOINLINE setStable #-}
lib/src/Control/Arrow/Transformer/Reader.hs
View file @
5616e1e3
...
...
@@ -157,7 +157,7 @@ instance ArrowConst x c => ArrowConst x (ReaderT r c) where
instance
ArrowEffectCommutative
c
=>
ArrowEffectCommutative
(
ReaderT
r
c
)
instance
ArrowReuse
a
b
c
=>
ArrowReuse
a
b
(
ReaderT
r
c
)
where
reuse
f
=
lift'
$
reuse
f
reuse
s
f
=
lift'
$
reuse
s
f
{-# INLINE reuse #-}
instance
ArrowContext
ctx
a
c
=>
ArrowContext
ctx
a
(
ReaderT
r
c
)
where
...
...
lib/src/Control/Arrow/Transformer/Static.hs
View file @
5616e1e3
...
...
@@ -135,6 +135,11 @@ instance (Applicative f, ArrowClosure expr cls c) => ArrowClosure expr cls (Stat
{-# INLINE apply #-}
{-# SPECIALIZE instance ArrowClosure expr cls c => ArrowClosure expr cls (StaticT ((->) r) c) #-}
instance
(
Applicative
f
,
ArrowLetRec
var
val
c
)
=>
ArrowLetRec
var
val
(
StaticT
f
c
)
where
letRec
(
StaticT
f
)
=
StaticT
$
Env
.
letRec
<$>
f
{-# INLINE letRec #-}
{-# SPECIALIZE instance ArrowLetRec var val c => ArrowLetRec var val (StaticT ((->) r) c) #-}
instance
(
Applicative
f
,
ArrowStore
var
val
c
)
=>
ArrowStore
var
val
(
StaticT
f
c
)
where
type
Join
y
(
StaticT
f
c
)
=
Store
.
Join
y
c
read
(
StaticT
f
)
(
StaticT
g
)
=
StaticT
$
Store
.
read
<$>
f
<*>
g
...
...
lib/src/Control/Arrow/Transformer/Writer.hs
View file @
5616e1e3
...
...
@@ -184,7 +184,7 @@ instance (Monoid w, ArrowStack a c) => ArrowStack a (WriterT w c) where
{-# INLINE size #-}
instance
(
Monoid
w
,
ArrowReuse
a
b
c
)
=>
ArrowReuse
a
b
(
WriterT
w
c
)
where
reuse
f
=
lift'
(
Reuse
.
reuse
f
)
reuse
s
f
=
lift'
(
Reuse
.
reuse
s
f
)
{-# INLINE reuse #-}
instance
(
Monoid
w
,
ArrowContext
ctx
a
c
)
=>
ArrowContext
ctx
a
(
WriterT
w
c
)
where
...
...
lib/src/Data/Abstract/Closure.hs
View file @
5616e1e3
...
...
@@ -26,15 +26,19 @@ newtype Closure expr env = Closure (HashMap expr env)
instance
(
Identifiable
expr
,
PreOrd
env
)
=>
PreOrd
(
Closure
expr
env
)
where
(
⊑
)
=
withCls
$
\
m1
m2
->
M
.
keysSet
m1
⊑
M
.
keysSet
m2
&&
and
(
M
.
intersectionWith
(
⊑
)
m1
m2
)
{-# INLINE (⊑) #-}
instance
(
Identifiable
expr
,
Complete
env
)
=>
Complete
(
Closure
expr
env
)
where
(
⊔
)
=
withCls
$
M
.
unionWith
(
⊔
)
{-# INLINE (⊔) #-}
instance
Foldable
(
Closure
expr
)
where
foldMap
=
foldMapDefault
{-# INLINE foldMap #-}
instance
Traversable
(
Closure
expr
)
where
traverse
f
(
Closure
m
)
=
Closure
<$>
traverse
f
m
{-# INLINE traverse #-}
instance
(
Show
a
,
Show
b
)
=>
Show
(
Closure
a
b
)
where
show
(
Closure
h
)
...
...
@@ -48,15 +52,18 @@ instance (Identifiable expr, Complete env) => IsList (Closure expr env) where
closure
::
Identifiable
expr
=>
expr
->
env
->
Closure
expr
env
closure
expr
env
=
Closure
$
M
.
singleton
expr
env
{-# INLINE closure #-}
apply
::
(
O
.
ArrowComplete
y
c
,
O
.
ArrowLowerBounded
c
,
ArrowChoice
c
)
=>
c
((
expr
,
env
),
x
)
y
->
c
(
Closure
expr
env
,
x
)
y
apply
f
=
lmap
(
first
(
\
(
Closure
m
)
->
M
.
toList
m
))
(
O
.
joinList1'
f
)
{-# INLINE apply #-}
widening
::
Identifiable
expr
=>
Widening
env
->
Widening
(
Closure
expr
env
)
widening
w
=
withCls
$
\
m1
m2
->
(
fold
$
M
.
intersectionWith
(
\
x
y
->
fst
(
w
x
y
))
m1
m2
,
M
.
unionWith
(
\
x
y
->
snd
(
w
x
y
))
m1
m2
)
{-# INLINE widening #-}
withCls
::
Coercible
x
x'
=>
(
HashMap
expr
env
->
x'
)
->
(
Closure
expr
env
->
x
)
withCls
=
coerce
...
...
lib/src/Data/Abstract/Constructor.hs
View file @
5616e1e3
...
...
@@ -33,13 +33,10 @@ instance PreOrd n => PreOrd (Constr n) where
instance
Complete
n
=>
Complete
(
Constr
n
)
where
Constr
m1
⊔
Constr
m2
=
Constr
(
M
.
unionWith
(
IM
.
unionWith
(
zipWith
(
⊔
)))
m1
m2
)