Self optimizing Par Arrow

Par.hs

{-# LANGUAGE Arrows, GADTs #-}

data Par a b where
    Pure :: (a -> b) -> Par a b
    Seq  :: Par a b  -> Par b c -> Par a c
    Par  :: (a -> (a1, a2)) -> Par a1 b1 -> Par a2 b2 -> ((b1, b2) -> b) -> Par a b

instance Category Par where
    id = Pure id

    Pure p . Pure q = Pure (p . q)
    Pure p . Seq f g = Seq f (Pure p . g)
    Pure p . Par l h k r = Par l h k (p . r)

    Seq f g . Pure h = Seq (f . Pure h) g
    Seq f g . Seq h k = Seq (k . h) (g . f)
    Seq f g . Par l h k r = Seq (Par l h k r) (g . f)

    Par l h k r . Pure p = Par (l . p) h k r
    Par l h k r . Seq f g = Seq (g . f) (Par l h k r)
    Par l h k r . Par s f g t =
        let p1f x = fst . l $ t (x, undefined)
            p2f x = snd . l $ t (undefined, x)
            pp1 = h . arr p1f . f
            pp2 = k . arr p2f . g
        in Par s pp1 pp2 r

data Trace
    = TPure
    | Trace :>: Trace
    | Trace :|: Trace
    deriving Show

trace :: Par a b -> Trace
trace (Pure _) = TPure
trace (Seq f g) = trace f :>: trace g
trace (Par _ f g _) = trace f :|: trace g

a1 :: (Arrow arr, Num a) => arr a a
a1 = proc x -> do
    a <- arr (*2) -< x
    b <- arr (+3) -< x
    c <- arr (^2) -< a
    returnA -< a * b + c

main = print $ trace a1