Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
8f5834c6
Commit
8f5834c6
authored
Nov 06, 2007
by
Ross Paterson
Browse files
adapt tests to new Category superclass of Arrow
parent
5acd938f
Changes
4
Hide whitespace changes
Inline
Side-by-side
testsuite/tests/ghc-regress/arrows/should_run/arrowrun002.hs
View file @
8f5834c6
...
...
@@ -5,7 +5,9 @@
module
Main
where
import
Control.Arrow
import
Control.Category
import
Data.Complex
import
Prelude
hiding
(
id
,
(
.
))
infixr
4
:&:
...
...
@@ -53,9 +55,12 @@ apply (f :&: fs) (Succ t) = Succ (apply fs t)
-- Having defined apply, we can forget about powertrees and do all our
-- programming with Hom's. Firstly, Hom is an arrow:
instance
Category
Hom
where
id
=
id
:&:
id
(
f
:&:
fs
)
.
(
g
:&:
gs
)
=
(
f
.
g
)
:&:
(
fs
.
gs
)
instance
Arrow
Hom
where
arr
f
=
f
:&:
arr
(
f
***
f
)
(
f
:&:
fs
)
>>>
(
g
:&:
gs
)
=
(
g
.
f
)
:&:
(
fs
>>>
gs
)
first
(
f
:&:
fs
)
=
first
f
:&:
(
arr
transpose
>>>
first
fs
>>>
arr
transpose
)
...
...
testsuite/tests/ghc-regress/arrows/should_run/arrowrun003.hs
View file @
8f5834c6
...
...
@@ -3,6 +3,8 @@
module
Main
(
main
)
where
import
Control.Arrow
import
Control.Category
import
Prelude
hiding
(
id
,
(
.
))
class
ArrowLoop
a
=>
ArrowCircuit
a
where
delay
::
b
->
a
b
b
...
...
@@ -23,9 +25,12 @@ unzipStream abs = (fmap fst abs, fmap snd abs)
newtype
StreamMap
a
b
=
StreamMap
(
Stream
a
->
Stream
b
)
unStreamMap
(
StreamMap
f
)
=
f
instance
Category
StreamMap
where
id
=
StreamMap
id
StreamMap
f
.
StreamMap
g
=
StreamMap
(
f
.
g
)
instance
Arrow
StreamMap
where
arr
f
=
StreamMap
(
fmap
f
)
StreamMap
f
>>>
StreamMap
g
=
StreamMap
(
g
.
f
)
first
(
StreamMap
f
)
=
StreamMap
(
uncurry
zipStream
.
first
f
.
unzipStream
)
...
...
@@ -50,12 +55,15 @@ runStreamMap (StreamMap f) as =
data
Auto
a
b
=
Auto
(
a
->
(
b
,
Auto
a
b
))
instance
Category
Auto
where
id
=
Auto
$
\
a
->
(
a
,
id
)
Auto
f
.
Auto
g
=
Auto
$
\
b
->
let
(
c
,
g'
)
=
g
b
(
d
,
f'
)
=
f
c
in
(
d
,
f'
.
g'
)
instance
Arrow
Auto
where
arr
f
=
Auto
$
\
a
->
(
f
a
,
arr
f
)
Auto
f
>>>
Auto
g
=
Auto
$
\
b
->
let
(
c
,
f'
)
=
f
b
(
d
,
g'
)
=
g
c
in
(
d
,
f'
>>>
g'
)
first
(
Auto
f
)
=
Auto
$
\
(
b
,
d
)
->
let
(
c
,
f'
)
=
f
b
in
((
c
,
d
),
first
f'
)
instance
ArrowLoop
Auto
where
...
...
testsuite/tests/ghc-regress/arrows/should_run/arrowrun004.hs
View file @
8f5834c6
...
...
@@ -6,7 +6,9 @@
module
Main
(
main
)
where
import
Control.Arrow
import
Control.Category
import
Data.Char
import
Prelude
hiding
(
id
,
(
.
))
-- Parsers
...
...
@@ -19,10 +21,13 @@ data Sym s = Sym { token :: s, value :: String }
newtype
BTParser
s
a
b
=
BTParser
(
a
->
[
Sym
s
]
->
[(
b
,
[
Sym
s
])])
instance
Category
(
BTParser
s
)
where
id
=
BTParser
$
\
a
ss
->
[(
a
,
ss
)]
BTParser
f
.
BTParser
g
=
BTParser
$
\
b
ss
->
[(
d
,
ss''
)
|
(
c
,
ss'
)
<-
g
b
ss
,
(
d
,
ss''
)
<-
f
c
ss'
]
instance
Arrow
(
BTParser
s
)
where
arr
f
=
BTParser
$
\
a
ss
->
[(
f
a
,
ss
)]
BTParser
f
>>>
BTParser
g
=
BTParser
$
\
b
ss
->
[(
d
,
ss''
)
|
(
c
,
ss'
)
<-
f
b
ss
,
(
d
,
ss''
)
<-
g
c
ss'
]
first
(
BTParser
f
)
=
BTParser
$
\
(
b
,
d
)
ss
->
[((
c
,
d
),
ss'
)
|
(
c
,
ss'
)
<-
f
b
ss
]
...
...
testsuite/tests/ghc-regress/gadt/arrow.hs
View file @
8f5834c6
...
...
@@ -2,6 +2,8 @@
module
Opt
where
import
Control.Arrow
import
Control.Category
import
Prelude
hiding
(
id
,
(
.
))
data
Opt
arr
a
b
where
Lift
::
arr
a
b
->
Opt
arr
a
b
...
...
@@ -11,10 +13,12 @@ runOpt :: Arrow arr => Opt arr a b -> arr a b
runOpt
(
Lift
f
)
=
f
runOpt
(
First
f
)
=
first
(
runOpt
f
)
instance
Arrow
arr
=>
Category
(
Opt
arr
)
where
id
=
Lift
id
First
f
.
First
g
=
First
(
f
.
g
)
f
.
g
=
Lift
(
runOpt
f
.
runOpt
g
)
instance
Arrow
arr
=>
Arrow
(
Opt
arr
)
where
arr
=
Lift
.
arr
First
f
>>>
First
g
=
First
(
f
>>>
g
)
f
>>>
g
=
Lift
(
runOpt
f
>>>
runOpt
g
)
first
=
First
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment