Commit 8f5834c6 authored by Ross Paterson's avatar Ross Paterson
Browse files

adapt tests to new Category superclass of Arrow

parent 5acd938f
......@@ -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)
......
......@@ -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
......
......@@ -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]
......
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment