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
db4e0fb4
Unverified
Commit
db4e0fb4
authored
Feb 01, 2019
by
Sven Keidel
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
inline all typeclass methods and implement Profunctor arrows
parent
11c79d36
Changes
52
Hide whitespace changes
Inline
Side-by-side
Showing
52 changed files
with
1127 additions
and
527 deletions
+1127
-527
lib/package.yaml
lib/package.yaml
+2
-1
lib/src/Control/Arrow/Abstract/Join.hs
lib/src/Control/Arrow/Abstract/Join.hs
+4
-2
lib/src/Control/Arrow/Abstract/Terminating.hs
lib/src/Control/Arrow/Abstract/Terminating.hs
+9
-0
lib/src/Control/Arrow/Alloc.hs
lib/src/Control/Arrow/Alloc.hs
+2
-1
lib/src/Control/Arrow/Conditional.hs
lib/src/Control/Arrow/Conditional.hs
+2
-1
lib/src/Control/Arrow/Const.hs
lib/src/Control/Arrow/Const.hs
+2
-1
lib/src/Control/Arrow/Deduplicate.hs
lib/src/Control/Arrow/Deduplicate.hs
+2
-1
lib/src/Control/Arrow/Environment.hs
lib/src/Control/Arrow/Environment.hs
+6
-2
lib/src/Control/Arrow/Except.hs
lib/src/Control/Arrow/Except.hs
+8
-1
lib/src/Control/Arrow/Fail.hs
lib/src/Control/Arrow/Fail.hs
+3
-1
lib/src/Control/Arrow/Fix.hs
lib/src/Control/Arrow/Fix.hs
+2
-1
lib/src/Control/Arrow/Random.hs
lib/src/Control/Arrow/Random.hs
+2
-1
lib/src/Control/Arrow/Reader.hs
lib/src/Control/Arrow/Reader.hs
+2
-1
lib/src/Control/Arrow/State.hs
lib/src/Control/Arrow/State.hs
+4
-1
lib/src/Control/Arrow/Store.hs
lib/src/Control/Arrow/Store.hs
+3
-1
lib/src/Control/Arrow/Trans.hs
lib/src/Control/Arrow/Trans.hs
+4
-3
lib/src/Control/Arrow/Transformer/Abstract/BoundedEnvironment.hs
.../Control/Arrow/Transformer/Abstract/BoundedEnvironment.hs
+21
-13
lib/src/Control/Arrow/Transformer/Abstract/Completion.hs
lib/src/Control/Arrow/Transformer/Abstract/Completion.hs
+55
-15
lib/src/Control/Arrow/Transformer/Abstract/Contour.hs
lib/src/Control/Arrow/Transformer/Abstract/Contour.hs
+18
-19
lib/src/Control/Arrow/Transformer/Abstract/Environment.hs
lib/src/Control/Arrow/Transformer/Abstract/Environment.hs
+18
-17
lib/src/Control/Arrow/Transformer/Abstract/Except.hs
lib/src/Control/Arrow/Transformer/Abstract/Except.hs
+77
-41
lib/src/Control/Arrow/Transformer/Abstract/Failure.hs
lib/src/Control/Arrow/Transformer/Abstract/Failure.hs
+60
-19
lib/src/Control/Arrow/Transformer/Abstract/Fixpoint.hs
lib/src/Control/Arrow/Transformer/Abstract/Fixpoint.hs
+89
-94
lib/src/Control/Arrow/Transformer/Abstract/Powerset.hs
lib/src/Control/Arrow/Transformer/Abstract/Powerset.hs
+42
-13
lib/src/Control/Arrow/Transformer/Abstract/ReachingDefinitions.hs
...Control/Arrow/Transformer/Abstract/ReachingDefinitions.hs
+23
-26
lib/src/Control/Arrow/Transformer/Abstract/Stack.hs
lib/src/Control/Arrow/Transformer/Abstract/Stack.hs
+15
-3
lib/src/Control/Arrow/Transformer/Abstract/Store.hs
lib/src/Control/Arrow/Transformer/Abstract/Store.hs
+13
-12
lib/src/Control/Arrow/Transformer/Abstract/Terminating.hs
lib/src/Control/Arrow/Transformer/Abstract/Terminating.hs
+107
-0
lib/src/Control/Arrow/Transformer/Concrete/Environment.hs
lib/src/Control/Arrow/Transformer/Concrete/Environment.hs
+7
-13
lib/src/Control/Arrow/Transformer/Concrete/Except.hs
lib/src/Control/Arrow/Transformer/Concrete/Except.hs
+11
-5
lib/src/Control/Arrow/Transformer/Concrete/Failure.hs
lib/src/Control/Arrow/Transformer/Concrete/Failure.hs
+11
-5
lib/src/Control/Arrow/Transformer/Concrete/Fixpoint.hs
lib/src/Control/Arrow/Transformer/Concrete/Fixpoint.hs
+3
-2
lib/src/Control/Arrow/Transformer/Concrete/Random.hs
lib/src/Control/Arrow/Transformer/Concrete/Random.hs
+8
-14
lib/src/Control/Arrow/Transformer/Concrete/Store.hs
lib/src/Control/Arrow/Transformer/Concrete/Store.hs
+5
-11
lib/src/Control/Arrow/Transformer/Concrete/Trace.hs
lib/src/Control/Arrow/Transformer/Concrete/Trace.hs
+4
-6
lib/src/Control/Arrow/Transformer/Const.hs
lib/src/Control/Arrow/Transformer/Const.hs
+17
-25
lib/src/Control/Arrow/Transformer/Cont.hs
lib/src/Control/Arrow/Transformer/Cont.hs
+35
-4
lib/src/Control/Arrow/Transformer/Reader.hs
lib/src/Control/Arrow/Transformer/Reader.hs
+78
-23
lib/src/Control/Arrow/Transformer/State.hs
lib/src/Control/Arrow/Transformer/State.hs
+80
-25
lib/src/Control/Arrow/Transformer/Static.hs
lib/src/Control/Arrow/Transformer/Static.hs
+50
-13
lib/src/Control/Arrow/Transformer/Writer.hs
lib/src/Control/Arrow/Transformer/Writer.hs
+61
-17
lib/src/Control/Arrow/Utils.hs
lib/src/Control/Arrow/Utils.hs
+6
-0
lib/src/Control/Arrow/Writer.hs
lib/src/Control/Arrow/Writer.hs
+2
-1
lib/src/Data/Abstract/Error.hs
lib/src/Data/Abstract/Error.hs
+18
-11
lib/src/Data/Abstract/Failure.hs
lib/src/Data/Abstract/Failure.hs
+73
-39
lib/src/Data/Abstract/Terminating.hs
lib/src/Data/Abstract/Terminating.hs
+7
-4
lib/src/Data/Monoidal.hs
lib/src/Data/Monoidal.hs
+15
-12
stratego/package.yaml
stratego/package.yaml
+13
-0
stratego/src/ConcreteSemantics.hs
stratego/src/ConcreteSemantics.hs
+2
-1
stratego/src/GrammarSemantics.hs
stratego/src/GrammarSemantics.hs
+2
-0
stratego/src/SortSemantics.hs
stratego/src/SortSemantics.hs
+22
-5
stratego/src/WildcardSemantics.hs
stratego/src/WildcardSemantics.hs
+2
-0
No files found.
lib/package.yaml
View file @
db4e0fb4
...
@@ -15,6 +15,7 @@ dependencies:
...
@@ -15,6 +15,7 @@ dependencies:
-
text
-
text
-
unordered-containers
-
unordered-containers
-
deepseq
-
deepseq
-
profunctors
flags
:
flags
:
trace
:
trace
:
...
@@ -23,7 +24,7 @@ flags:
...
@@ -23,7 +24,7 @@ flags:
manual
:
True
manual
:
True
library
:
library
:
ghc-options
:
-Wall
ghc-options
:
-Wall
-O2
source-dirs
:
source-dirs
:
-
src
-
src
when
:
when
:
...
...
lib/src/Control/Arrow/Abstract/Join.hs
View file @
db4e0fb4
...
@@ -6,8 +6,9 @@ import Prelude hiding ((.))
...
@@ -6,8 +6,9 @@ import Prelude hiding ((.))
import
Control.Arrow
import
Control.Arrow
import
Control.Arrow.Utils
import
Control.Arrow.Utils
import
Data.Order
(
Complete
(
..
))
import
Data.Order
(
Complete
(
..
))
import
Data.Profunctor
class
Arrow
c
=>
ArrowJoin
c
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowJoin
c
where
-- | Join two arrow computation with the provided upper bound operator.
-- | Join two arrow computation with the provided upper bound operator.
--
--
-- Laws:
-- Laws:
...
@@ -18,10 +19,11 @@ class Arrow c => ArrowJoin c where
...
@@ -18,10 +19,11 @@ class Arrow c => ArrowJoin c where
joinWith'
::
ArrowJoin
c
=>
(
y
->
y
->
y
)
->
c
x
y
->
c
x'
y
->
c
(
x
,
x'
)
y
joinWith'
::
ArrowJoin
c
=>
(
y
->
y
->
y
)
->
c
x
y
->
c
x'
y
->
c
(
x
,
x'
)
y
joinWith'
lub
f
g
=
joinWith
lub
(
f
<<<
pi1
)
(
g
<<<
pi2
)
joinWith'
lub
f
g
=
joinWith
lub
(
f
<<<
pi1
)
(
g
<<<
pi2
)
{-# INLINE joinWith' #-}
(
<
⊔
>
)
::
(
ArrowJoin
c
,
Complete
y
)
=>
c
x
y
->
c
x
y
->
c
x
y
(
<
⊔
>
)
::
(
ArrowJoin
c
,
Complete
y
)
=>
c
x
y
->
c
x
y
->
c
x
y
(
<
⊔
>
)
=
joinWith
(
⊔
)
(
<
⊔
>
)
=
joinWith
(
⊔
)
{-# INLINE (<⊔>) #-}
-- | Joins a list of arguments. Use it with idiom brackets:
-- | Joins a list of arguments. Use it with idiom brackets:
-- @
-- @
...
...
lib/src/Control/Arrow/Abstract/Terminating.hs
0 → 100644
View file @
db4e0fb4
module
Control.Arrow.Abstract.Terminating
where
import
Control.Arrow
import
Data.Abstract.Terminating
import
Data.Profunctor
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowTerminating
c
where
throwTerminating
::
c
(
Terminating
x
)
x
catchTerminating
::
c
x
y
->
c
x
(
Terminating
y
)
lib/src/Control/Arrow/Alloc.hs
View file @
db4e0fb4
...
@@ -3,8 +3,9 @@
...
@@ -3,8 +3,9 @@
module
Control.Arrow.Alloc
where
module
Control.Arrow.Alloc
where
import
Control.Arrow
import
Control.Arrow
import
Data.Profunctor
-- | Arrow-based interface for allocating addresses.
-- | Arrow-based interface for allocating addresses.
class
Arrow
c
=>
ArrowAlloc
x
y
c
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowAlloc
x
y
c
where
-- | Allocates a new address.
-- | Allocates a new address.
alloc
::
c
x
y
alloc
::
c
x
y
lib/src/Control/Arrow/Conditional.hs
View file @
db4e0fb4
...
@@ -6,9 +6,10 @@ module Control.Arrow.Conditional where
...
@@ -6,9 +6,10 @@ module Control.Arrow.Conditional where
import
Control.Arrow
import
Control.Arrow
import
GHC.Exts
(
Constraint
)
import
GHC.Exts
(
Constraint
)
import
Data.Profunctor
-- | Arrow based interface to implement conditionals.
-- | Arrow based interface to implement conditionals.
class
Arrow
c
=>
ArrowCond
v
c
|
c
->
v
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowCond
v
c
|
c
->
v
where
-- | Type class constraint used by the abstract instances to join arrow computations.
-- | Type class constraint used by the abstract instances to join arrow computations.
type
family
Join
(
c
::
*
->
*
->
*
)
x
y
::
Constraint
type
family
Join
(
c
::
*
->
*
->
*
)
x
y
::
Constraint
...
...
lib/src/Control/Arrow/Const.hs
View file @
db4e0fb4
...
@@ -3,9 +3,10 @@
...
@@ -3,9 +3,10 @@
module
Control.Arrow.Const
where
module
Control.Arrow.Const
where
import
Control.Arrow
import
Control.Arrow
import
Data.Profunctor
-- | Arrow-based interface that gives access to a constant value.
-- | Arrow-based interface that gives access to a constant value.
class
Arrow
c
=>
ArrowConst
r
c
|
c
->
r
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowConst
r
c
|
c
->
r
where
-- | Retrieve the constant value.
-- | Retrieve the constant value.
askConst
::
c
()
r
askConst
::
c
()
r
lib/src/Control/Arrow/Deduplicate.hs
View file @
db4e0fb4
...
@@ -3,11 +3,12 @@
...
@@ -3,11 +3,12 @@
module
Control.Arrow.Deduplicate
where
module
Control.Arrow.Deduplicate
where
import
Control.Arrow
import
Control.Arrow
import
Data.Profunctor
-- | Arrow-based interface to deduplicate the result /set/ of a computation.
-- | Arrow-based interface to deduplicate the result /set/ of a computation.
-- This is required by the 'Control.Arrow.Transformer.Abstract.Powerset.PowT'
-- This is required by the 'Control.Arrow.Transformer.Abstract.Powerset.PowT'
-- arrow transformer.
-- arrow transformer.
class
Arrow
c
=>
ArrowDeduplicate
x
y
c
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowDeduplicate
x
y
c
where
dedup
::
c
x
y
->
c
x
y
dedup
::
c
x
y
->
c
x
y
instance
ArrowDeduplicate
x
y
(
->
)
where
instance
ArrowDeduplicate
x
y
(
->
)
where
...
...
lib/src/Control/Arrow/Environment.hs
View file @
db4e0fb4
...
@@ -15,6 +15,7 @@ import Control.Arrow.Fail
...
@@ -15,6 +15,7 @@ import Control.Arrow.Fail
import
Control.Arrow.Utils
import
Control.Arrow.Utils
import
Data.String
import
Data.String
import
Data.Profunctor
import
Text.Printf
import
Text.Printf
...
@@ -22,7 +23,7 @@ import GHC.Exts (Constraint)
...
@@ -22,7 +23,7 @@ import GHC.Exts (Constraint)
-- | Arrow-based interface for interacting with environments.
-- | Arrow-based interface for interacting with environments.
class
Arrow
c
=>
ArrowEnv
var
val
env
c
|
c
->
var
,
c
->
val
,
c
->
env
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowEnv
var
val
env
c
|
c
->
var
,
c
->
val
,
c
->
env
where
-- | Type class constraint used by the abstract instances to join arrow computations.
-- | Type class constraint used by the abstract instances to join arrow computations.
type
family
Join
(
c
::
*
->
*
->
*
)
x
y
::
Constraint
type
family
Join
(
c
::
*
->
*
->
*
)
x
y
::
Constraint
...
@@ -44,6 +45,7 @@ class Arrow c => ArrowEnv var val env c | c -> var, c -> val, c -> env where
...
@@ -44,6 +45,7 @@ class Arrow c => ArrowEnv var val env c | c -> var, c -> val, c -> env where
-- | Simpler version of environment lookup.
-- | Simpler version of environment lookup.
lookup'
::
(
Join
c
((
val
,
var
),
var
)
val
,
Show
var
,
IsString
e
,
ArrowFail
e
c
,
ArrowEnv
var
val
env
c
)
=>
c
var
val
lookup'
::
(
Join
c
((
val
,
var
),
var
)
val
,
Show
var
,
IsString
e
,
ArrowFail
e
c
,
ArrowEnv
var
val
env
c
)
=>
c
var
val
lookup'
=
lookup''
id
lookup'
=
lookup''
id
{-# INLINE lookup' #-}
lookup''
::
(
Join
c
((
val
,
var
),
var
)
y
,
Show
var
,
IsString
e
,
ArrowFail
e
c
,
ArrowEnv
var
val
env
c
)
=>
c
val
y
->
c
var
y
lookup''
::
(
Join
c
((
val
,
var
),
var
)
y
,
Show
var
,
IsString
e
,
ArrowFail
e
c
,
ArrowEnv
var
val
env
c
)
=>
c
val
y
->
c
var
y
lookup''
f
=
proc
var
->
lookup''
f
=
proc
var
->
...
@@ -51,7 +53,7 @@ lookup'' f = proc var ->
...
@@ -51,7 +53,7 @@ lookup'' f = proc var ->
(
proc
(
val
,
_
)
->
f
-<
val
)
(
proc
(
val
,
_
)
->
f
-<
val
)
(
proc
var
->
fail
-<
fromString
$
printf
"Variable %s not bound"
(
show
var
))
(
proc
var
->
fail
-<
fromString
$
printf
"Variable %s not bound"
(
show
var
))
-<
(
var
,
var
)
-<
(
var
,
var
)
{-# INLINE lookup'' #-}
-- | Run a computation in an extended environment.
-- | Run a computation in an extended environment.
extendEnv'
::
ArrowEnv
var
val
env
c
=>
c
a
b
->
c
(
var
,
val
,
a
)
b
extendEnv'
::
ArrowEnv
var
val
env
c
=>
c
a
b
->
c
(
var
,
val
,
a
)
b
...
@@ -59,7 +61,9 @@ extendEnv' f = proc (x,y,a) -> do
...
@@ -59,7 +61,9 @@ extendEnv' f = proc (x,y,a) -> do
env
<-
getEnv
-<
()
env
<-
getEnv
-<
()
env'
<-
extendEnv
-<
(
x
,
y
,
env
)
env'
<-
extendEnv
-<
(
x
,
y
,
env
)
localEnv
f
-<
(
env'
,
a
)
localEnv
f
-<
(
env'
,
a
)
{-# INLINE extendEnv' #-}
-- | Add a list of bindings to the given environment.
-- | Add a list of bindings to the given environment.
bindings
::
(
ArrowChoice
c
,
ArrowEnv
var
val
env
c
)
=>
c
([(
var
,
val
)],
env
)
env
bindings
::
(
ArrowChoice
c
,
ArrowEnv
var
val
env
c
)
=>
c
([(
var
,
val
)],
env
)
env
bindings
=
fold
((
\
(
env
,(
x
,
y
))
->
(
x
,
y
,
env
))
^>>
extendEnv
)
bindings
=
fold
((
\
(
env
,(
x
,
y
))
->
(
x
,
y
,
env
))
^>>
extendEnv
)
{-# INLINE bindings #-}
lib/src/Control/Arrow/Except.hs
View file @
db4e0fb4
...
@@ -14,9 +14,10 @@ import Control.Arrow
...
@@ -14,9 +14,10 @@ import Control.Arrow
import
Control.Arrow.Utils
import
Control.Arrow.Utils
import
GHC.Exts
(
Constraint
)
import
GHC.Exts
(
Constraint
)
import
Data.Profunctor
-- | Arrow-based interface for exception handling.
-- | Arrow-based interface for exception handling.
class
Arrow
c
=>
ArrowExcept
e
c
|
c
->
e
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowExcept
e
c
|
c
->
e
where
-- | Type class constraint used by the abstract instances to join arrow computations.
-- | Type class constraint used by the abstract instances to join arrow computations.
type
family
Join
(
c
::
*
->
*
->
*
)
x
y
::
Constraint
type
family
Join
(
c
::
*
->
*
->
*
)
x
y
::
Constraint
...
@@ -33,19 +34,23 @@ class Arrow c => ArrowExcept e c | c -> e where
...
@@ -33,19 +34,23 @@ class Arrow c => ArrowExcept e c | c -> e where
-- | Simpler version of 'throw'.
-- | Simpler version of 'throw'.
throw'
::
ArrowExcept
()
c
=>
c
a
b
throw'
::
ArrowExcept
()
c
=>
c
a
b
throw'
=
proc
_
->
throw
-<
()
throw'
=
proc
_
->
throw
-<
()
{-# INLINE throw' #-}
-- | Simpler version of 'catch'.
-- | Simpler version of 'catch'.
catch'
::
(
Join
c
(
x
,(
x
,
e
))
y
,
ArrowExcept
e
c
)
=>
c
x
y
->
c
e
y
->
c
x
y
catch'
::
(
Join
c
(
x
,(
x
,
e
))
y
,
ArrowExcept
e
c
)
=>
c
x
y
->
c
e
y
->
c
x
y
catch'
f
g
=
catch
f
(
pi2
>>>
g
)
catch'
f
g
=
catch
f
(
pi2
>>>
g
)
{-# INLINE catch' #-}
-- | @'try' f g h@ executes @f@, if it succeeds the result is passed to
-- | @'try' f g h@ executes @f@, if it succeeds the result is passed to
-- @g@, if it fails the original input is passed to @h@.
-- @g@, if it fails the original input is passed to @h@.
try
::
(
Join
c
(
x
,(
x
,
e
))
z
,
ArrowExcept
e
c
)
=>
c
x
y
->
c
y
z
->
c
x
z
->
c
x
z
try
::
(
Join
c
(
x
,(
x
,
e
))
z
,
ArrowExcept
e
c
)
=>
c
x
y
->
c
y
z
->
c
x
z
->
c
x
z
try
f
g
h
=
catch
(
f
>>>
g
)
(
pi1
>>>
h
)
try
f
g
h
=
catch
(
f
>>>
g
)
(
pi1
>>>
h
)
{-# INLINE try #-}
-- | Picks the first computation that does not throw an exception.
-- | Picks the first computation that does not throw an exception.
(
<+>
)
::
(
Join
c
(
x
,(
x
,
e
))
y
,
ArrowExcept
e
c
)
=>
c
x
y
->
c
x
y
->
c
x
y
(
<+>
)
::
(
Join
c
(
x
,(
x
,
e
))
y
,
ArrowExcept
e
c
)
=>
c
x
y
->
c
x
y
->
c
x
y
f
<+>
g
=
catch
f
(
pi1
>>>
g
)
f
<+>
g
=
catch
f
(
pi1
>>>
g
)
{-# INLINE (<+>) #-}
-- | @'tryFirst' f g -< l@ executes @f@ on elements of @l@ until one of them does not throw an exception.
-- | @'tryFirst' f g -< l@ executes @f@ on elements of @l@ until one of them does not throw an exception.
-- In case @f@ throws an exception for all elements of @l@, @g@ is executed.
-- In case @f@ throws an exception for all elements of @l@, @g@ is executed.
...
@@ -53,7 +58,9 @@ tryFirst :: (Join c ((x,[x]),((x,[x]),e)) y, ArrowChoice c, ArrowExcept e c) =>
...
@@ -53,7 +58,9 @@ tryFirst :: (Join c ((x,[x]),((x,[x]),e)) y, ArrowChoice c, ArrowExcept e c) =>
tryFirst
f
g
=
proc
l
->
case
l
of
tryFirst
f
g
=
proc
l
->
case
l
of
[]
->
g
-<
()
[]
->
g
-<
()
a
:
as
->
try
(
f
.
pi1
)
id
(
tryFirst
f
g
.
pi2
)
-<
(
a
,
as
)
a
:
as
->
try
(
f
.
pi1
)
id
(
tryFirst
f
g
.
pi2
)
-<
(
a
,
as
)
{-# INLINE tryFirst #-}
-- | A computation that always succeeds
-- | A computation that always succeeds
success
::
ArrowExcept
e
c
=>
c
a
a
success
::
ArrowExcept
e
c
=>
c
a
a
success
=
id
success
=
id
{-# INLINE success #-}
lib/src/Control/Arrow/Fail.hs
View file @
db4e0fb4
...
@@ -10,9 +10,10 @@ import Prelude hiding (fail)
...
@@ -10,9 +10,10 @@ import Prelude hiding (fail)
import
Control.Arrow
import
Control.Arrow
import
Control.Monad.Except
(
MonadError
)
import
Control.Monad.Except
(
MonadError
)
import
qualified
Control.Monad.Except
as
M
import
qualified
Control.Monad.Except
as
M
import
Data.Profunctor
-- | Arrow-based interface for computations that can fail.
-- | Arrow-based interface for computations that can fail.
class
Arrow
c
=>
ArrowFail
e
c
|
c
->
e
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowFail
e
c
|
c
->
e
where
-- | Causes the computation to fail. In contrast to
-- | Causes the computation to fail. In contrast to
-- 'Control.Arrow.Except.ArrowExcept', this failure cannot be recovered from.
-- 'Control.Arrow.Except.ArrowExcept', this failure cannot be recovered from.
...
@@ -24,3 +25,4 @@ instance MonadError e m => ArrowFail e (Kleisli m) where
...
@@ -24,3 +25,4 @@ instance MonadError e m => ArrowFail e (Kleisli m) where
-- | Simpler version of 'fail'.
-- | Simpler version of 'fail'.
fail'
::
ArrowFail
()
c
=>
c
a
b
fail'
::
ArrowFail
()
c
=>
c
a
b
fail'
=
arr
(
const
()
)
>>>
fail
fail'
=
arr
(
const
()
)
>>>
fail
{-# INLINE fail' #-}
lib/src/Control/Arrow/Fix.hs
View file @
db4e0fb4
...
@@ -9,9 +9,10 @@ module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix) where
...
@@ -9,9 +9,10 @@ module Control.Arrow.Fix(ArrowFix(..),Fix,liftFix) where
import
Control.Arrow
import
Control.Arrow
import
Control.Arrow.Trans
import
Control.Arrow.Trans
import
Data.Profunctor
-- | Arrow-based interface for describing fixpoint computations.
-- | Arrow-based interface for describing fixpoint computations.
class
Arrow
c
=>
ArrowFix
x
y
c
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowFix
x
y
c
where
-- | Computes the fixpoint of an arrow computation.
-- | Computes the fixpoint of an arrow computation.
fix
::
(
c
x
y
->
c
x
y
)
->
c
x
y
fix
::
(
c
x
y
->
c
x
y
)
->
c
x
y
...
...
lib/src/Control/Arrow/Random.hs
View file @
db4e0fb4
...
@@ -2,6 +2,7 @@
...
@@ -2,6 +2,7 @@
module
Control.Arrow.Random
where
module
Control.Arrow.Random
where
import
Control.Arrow
import
Control.Arrow
import
Data.Profunctor
class
Arrow
c
=>
ArrowRand
v
c
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowRand
v
c
where
random
::
c
()
v
random
::
c
()
v
lib/src/Control/Arrow/Reader.hs
View file @
db4e0fb4
...
@@ -7,9 +7,10 @@ module Control.Arrow.Reader where
...
@@ -7,9 +7,10 @@ module Control.Arrow.Reader where
import
Control.Arrow
import
Control.Arrow
import
Control.Monad.Reader
(
MonadReader
)
import
Control.Monad.Reader
(
MonadReader
)
import
qualified
Control.Monad.Reader
as
M
import
qualified
Control.Monad.Reader
as
M
import
Data.Profunctor
-- | Arrow-based interface for read-only values.
-- | Arrow-based interface for read-only values.
class
Arrow
c
=>
ArrowReader
r
c
|
c
->
r
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowReader
r
c
|
c
->
r
where
-- | Retrieves the current read-only value.
-- | Retrieves the current read-only value.
ask
::
c
()
r
ask
::
c
()
r
-- | Runs a computation with a new value.
-- | Runs a computation with a new value.
...
...
lib/src/Control/Arrow/State.hs
View file @
db4e0fb4
...
@@ -12,9 +12,10 @@ import Control.Arrow
...
@@ -12,9 +12,10 @@ import Control.Arrow
import
Control.Arrow.Utils
import
Control.Arrow.Utils
import
Control.Monad.State
(
MonadState
)
import
Control.Monad.State
(
MonadState
)
import
qualified
Control.Monad.State
as
M
import
qualified
Control.Monad.State
as
M
import
Data.Profunctor
-- | Arrow-based interface to describe stateful computations.
-- | Arrow-based interface to describe stateful computations.
class
Arrow
c
=>
ArrowState
s
c
|
c
->
s
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowState
s
c
|
c
->
s
where
-- | Retrieves the current state.
-- | Retrieves the current state.
get
::
c
()
s
get
::
c
()
s
-- | Sets the current state.
-- | Sets the current state.
...
@@ -23,10 +24,12 @@ class Arrow c => ArrowState s c | c -> s where
...
@@ -23,10 +24,12 @@ class Arrow c => ArrowState s c | c -> s where
-- | run computation that modifies the current state.
-- | run computation that modifies the current state.
modify
::
ArrowState
s
c
=>
c
(
x
,
s
)
s
->
c
x
()
modify
::
ArrowState
s
c
=>
c
(
x
,
s
)
s
->
c
x
()
modify
f
=
put
<<<
f
<<<
(
id
&&&
const
get
)
modify
f
=
put
<<<
f
<<<
(
id
&&&
const
get
)
{-# INLINE modify #-}
-- | run computation that modifies the current state.
-- | run computation that modifies the current state.
modify'
::
ArrowState
s
c
=>
c
(
s
,
x
)
s
->
c
x
()
modify'
::
ArrowState
s
c
=>
c
(
s
,
x
)
s
->
c
x
()
modify'
f
=
put
<<<
f
<<<
(
const
get
&&&
id
)
modify'
f
=
put
<<<
f
<<<
(
const
get
&&&
id
)
{-# INLINE modify' #-}
instance
MonadState
s
m
=>
ArrowState
s
(
Kleisli
m
)
where
instance
MonadState
s
m
=>
ArrowState
s
(
Kleisli
m
)
where
get
=
Kleisli
(
P
.
const
M
.
get
)
get
=
Kleisli
(
P
.
const
M
.
get
)
...
...
lib/src/Control/Arrow/Store.hs
View file @
db4e0fb4
...
@@ -12,12 +12,13 @@ import Control.Arrow
...
@@ -12,12 +12,13 @@ import Control.Arrow
import
Control.Arrow.Fail
import
Control.Arrow.Fail
import
Text.Printf
import
Text.Printf
import
Data.String
import
Data.String
import
Data.Profunctor
import
GHC.Exts
(
Constraint
)
import
GHC.Exts
(
Constraint
)
-- | Arrow-based interface to describe computations that read from a store.
-- | Arrow-based interface to describe computations that read from a store.
-- The parameter `y` needs to be exposed, because abstract instances
-- The parameter `y` needs to be exposed, because abstract instances
-- may need to join on `y`.
-- may need to join on `y`.
class
Arrow
c
=>
ArrowStore
var
val
c
|
c
->
var
,
c
->
val
where
class
(
Arrow
c
,
Profunctor
c
)
=>
ArrowStore
var
val
c
|
c
->
var
,
c
->
val
where
type
family
Join
(
c
::
*
->
*
->
*
)
x
y
::
Constraint
type
family
Join
(
c
::
*
->
*
->
*
)
x
y
::
Constraint
-- | Reads a value from the store. Fails if the binding is not in the current store.
-- | Reads a value from the store. Fails if the binding is not in the current store.
...
@@ -32,3 +33,4 @@ read' = proc var ->
...
@@ -32,3 +33,4 @@ read' = proc var ->
read
(
proc
(
val
,
_
)
->
returnA
-<
val
)
read
(
proc
(
val
,
_
)
->
returnA
-<
val
)
(
proc
var
->
fail
-<
fromString
$
printf
"variable %s not bound"
(
show
var
))
(
proc
var
->
fail
-<
fromString
$
printf
"variable %s not bound"
(
show
var
))
-<
(
var
,
var
)
-<
(
var
,
var
)
{-# INLINE read' #-}
lib/src/Control/Arrow/Trans.hs
View file @
db4e0fb4
...
@@ -2,16 +2,17 @@
...
@@ -2,16 +2,17 @@
module
Control.Arrow.Trans
where
module
Control.Arrow.Trans
where
import
Control.Arrow
import
Control.Arrow
import
Data.Profunctor
class
ArrowLift
t
where
class
ArrowLift
t
where
lift'
::
Arrow
c
=>
c
x
y
->
t
c
x
y
lift'
::
(
Arrow
c
,
Profunctor
c
)
=>
c
x
y
->
t
c
x
y
-- | Lifts an inner computation into an arrow transformer and vice versa.
-- | Lifts an inner computation into an arrow transformer and vice versa.
class
ArrowTrans
t
where
class
ArrowTrans
t
where
type
Dom
t
x
y
::
*
type
Dom
t
x
y
::
*
type
Cod
t
x
y
::
*
type
Cod
t
x
y
::
*
lift
::
Arrow
c
=>
c
(
Dom
t
x
y
)
(
Cod
t
x
y
)
->
t
c
x
y
lift
::
(
Arrow
c
,
Profunctor
c
)
=>
c
(
Dom
t
x
y
)
(
Cod
t
x
y
)
->
t
c
x
y
unlift
::
Arrow
c
=>
t
c
x
y
->
c
(
Dom
t
x
y
)
(
Cod
t
x
y
)
unlift
::
(
Arrow
c
,
Profunctor
c
)
=>
t
c
x
y
->
c
(
Dom
t
x
y
)
(
Cod
t
x
y
)
type
family
Rep
c
x
y
type
family
Rep
c
x
y
lib/src/Control/Arrow/Transformer/Abstract/BoundedEnvironment.hs
View file @
db4e0fb4
...
@@ -31,6 +31,12 @@ import Data.Identifiable
...
@@ -31,6 +31,12 @@ import Data.Identifiable
import
Data.Abstract.FiniteMap
(
Map
)
import
Data.Abstract.FiniteMap
(
Map
)
import
qualified
Data.Abstract.FiniteMap
as
M
import
qualified
Data.Abstract.FiniteMap
as
M
import
Data.Abstract.Maybe
(
Maybe
(
..
))
import
Data.Abstract.Maybe
(
Maybe
(
..
))
import
Data.Profunctor
-- | Abstract domain for environments in which concrete environments
-- are approximated by a mapping from variables to addresses and a
-- mapping from addresses to values. The number of allocated addresses
-- allows to tune the precision and performance of the analysis.
-- | Abstract domain for environments in which concrete environments
-- | Abstract domain for environments in which concrete environments
-- are approximated by a mapping from variables to addresses and a
-- are approximated by a mapping from variables to addresses and a
...
@@ -40,10 +46,10 @@ import Data.Abstract.Maybe(Maybe(..))
...
@@ -40,10 +46,10 @@ import Data.Abstract.Maybe(Maybe(..))
-- Furthermore, closures and environments are defined mutually
-- Furthermore, closures and environments are defined mutually
-- recursively. By only allowing a finite number of addresses, the
-- recursively. By only allowing a finite number of addresses, the
-- abstract domain of closures and environments becomes finite.
-- abstract domain of closures and environments becomes finite.
newtype
EnvT
var
addr
val
c
x
y
=
newtype
EnvT
var
addr
val
c
x
y
=
EnvT
(
ConstT
(
c
(
var
,
val
,
Map
var
addr
val
)
addr
)
(
ReaderT
(
Map
var
addr
val
)
c
)
x
y
)
EnvT
(
ConstT
(
c
(
var
,
val
,
Map
var
addr
val
)
addr
)
(
ReaderT
(
Map
var
addr
val
)
c
)
x
y
)
deriving
(
Profunctor
,
Category
,
Arrow
,
ArrowChoice
,
ArrowState
s
,
ArrowFail
e
,
ArrowExcept
e
,
ArrowJoin
)
runEnvT
::
(
Show
var
,
Identifiable
var
,
Identifiable
addr
,
Complete
val
,
ArrowChoice
c
)
runEnvT
::
(
Show
var
,
Identifiable
var
,
Identifiable
addr
,
Complete
val
,
ArrowChoice
c
,
Profunctor
c
)
=>
c
(
var
,
val
,
Map
var
addr
val
)
addr
->
EnvT
var
addr
val
c
x
y
->
c
([(
var
,
val
)],
x
)
y
=>
c
(
var
,
val
,
Map
var
addr
val
)
addr
->
EnvT
var
addr
val
c
x
y
->
c
([(
var
,
val
)],
x
)
y
runEnvT
alloc
f
=
runEnvT
alloc
f
=
let
EnvT
f'
=
proc
(
bs
,
x
)
->
do
let
EnvT
f'
=
proc
(
bs
,
x
)
->
do
...
@@ -51,6 +57,7 @@ runEnvT alloc f =
...
@@ -51,6 +57,7 @@ runEnvT alloc f =
env'
<-
bindings
-<
(
bs
,
env
)
env'
<-
bindings
-<
(
bs
,
env
)
localEnv
f
-<
(
env'
,
x
)
localEnv
f
-<
(
env'
,
x
)
in
(
const
(
M
.
empty
)
&&&
id
)
^>>
runReaderT
(
runConstT
alloc
f'
)
in
(
const
(
M
.
empty
)
&&&
id
)
^>>
runReaderT
(
runConstT
alloc
f'
)
{-# INLINE runEnvT #-}
instance
ArrowTrans
(
EnvT
var
addr
val
)
where
instance
ArrowTrans
(
EnvT
var
addr
val
)
where
type
Dom
(
EnvT
var
addr
val
)
x
y
=
Dom
(
ReaderT
(
Map
var
addr
val
))
x
y
type
Dom
(
EnvT
var
addr
val
)
x
y
=
Dom
(
ReaderT
(
Map
var
addr
val
))
x
y
...
@@ -60,8 +67,9 @@ instance ArrowTrans (EnvT var addr val) where
...
@@ -60,8 +67,9 @@ instance ArrowTrans (EnvT var addr val) where
instance
ArrowLift
(
EnvT
var
addr
val
)
where
instance
ArrowLift
(
EnvT
var
addr
val
)
where
lift'
f
=
EnvT
(
lift'
(
lift'
f
))
lift'
f
=
EnvT
(
lift'
(
lift'
f
))
{-# INLINE lift' #-}
instance
(
Identifiable
var
,
Identifiable
addr
,
Complete
val
,
ArrowChoice
c
)
=>
instance
(
Identifiable
var
,
Identifiable
addr
,
Complete
val
,
ArrowChoice
c
,
Profunctor
c
)
=>
ArrowEnv
var
val
(
Map
var
addr
val
)
(
EnvT
var
addr
val
c
)
where
ArrowEnv
var
val
(
Map
var
addr
val
)
(
EnvT
var
addr
val
c
)
where
type
Join
(
EnvT
var
addr
val
c
)
x
y
=
Complete
(
c
(
Map
var
addr
val
,
x
)
y
)
type
Join
(
EnvT
var
addr
val
c
)
x
y
=
Complete
(
c
(
Map
var
addr
val
,
x
)
y
)
lookup
(
EnvT
f
)
(
EnvT
g
)
=
EnvT
$
proc
(
var
,
x
)
->
do
lookup
(
EnvT
f
)
(
EnvT
g
)
=
EnvT
$
proc
(
var
,
x
)
->
do
...
@@ -70,27 +78,27 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c) =>
...
@@ -70,27 +78,27 @@ instance (Identifiable var, Identifiable addr, Complete val, ArrowChoice c) =>
Just
val
->
f
-<
(
val
,
x
)
Just
val
->
f
-<
(
val
,
x
)
JustNothing
val
->
joined
f
g
-<
((
val
,
x
),
x
)
JustNothing
val
->
joined
f
g
-<
((
val
,
x
),
x
)
Nothing
->
g
-<
x
Nothing
->
g
-<
x
{-# INLINE lookup #-}
getEnv
=
EnvT
ask
getEnv
=
EnvT
ask
{-# INLINE getEnv #-}
extendEnv
=
EnvT
$
ConstT
$
StaticT
$
\
alloc
->
lift'
$
M
.
insertBy
alloc
extendEnv
=
EnvT
$
ConstT
$
StaticT
$
\
alloc
->
lift'
$
M
.
insertBy
alloc
{-# INLINE extendEnv #-}
localEnv
(
EnvT
f
)
=
EnvT
$
local
f
localEnv
(
EnvT
f
)
=
EnvT
$
local
f
{-# INLINE localEnv #-}
instance
ArrowReader
r
c
=>
ArrowReader
r
(
EnvT
var
addr
val
c
)
where
instance
ArrowReader
r
c
=>
ArrowReader
r
(
EnvT
var
addr
val
c
)
where
ask
=
lift'
ask
ask
=
lift'
ask
{-# INLINE ask #-}
local
(
EnvT
(
ConstT
(
StaticT
f
)))
=
local
(
EnvT
(
ConstT
(
StaticT
f
)))
=
EnvT
$
ConstT
$
StaticT
$
\
alloc
->
ReaderT
$
(
\
(
env
,(
r
,
x
))
->
(
r
,(
env
,
x
)))
^>>
local
(
runReaderT
(
f
alloc
))
EnvT
$
ConstT
$
StaticT
$
\
alloc
->
ReaderT
$
(
\
(
env
,(
r
,
x
))
->
(
r
,(
env
,
x
)))
^>>
local
(
runReaderT
(
f
alloc
))
{-# INLINE local #-}
instance
ArrowApply
c
=>
ArrowApply
(
EnvT
var
addr
val
c
)
where
instance
(
ArrowApply
c
,
Profunctor
c
)
=>
ArrowApply
(
EnvT
var
addr
val
c
)
where