Справедлив ли мой инстанс класса ArrowApply?

{-# LANGUAGE Arrows #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE InstanceSigs #-}
module CircuitTrans where
import Control.Arrow
import Control.Arrow.Operations
import Control.Arrow.Transformer.Stream ( ArrowAddStream(liftStream) )
import Control.Arrow.Transformer ( ArrowTransformer(..) )
import Control.Category ( Category(..) )
import Prelude hiding (id, (.))
import Control.Applicative
 
 
 
newtype CircuitT a b c = CircuitT {runCircuitT :: a b (CircuitT a b c, c)}
 
instance (Arrow a) => Functor (CircuitT a b) where
    fmap f (CircuitT c) = CircuitT $ (fmap f *** f) ^<< c
 
instance (Arrow a) => Applicative (CircuitT a b) where
    pure = arr . const
    cf <*> ca = uncurry ($) ^<< (cf &&& ca)
 
instance (ArrowPlus a) => Alternative (CircuitT a b) where
    empty = zeroArrow
    (<|>) = (<+>) 
 
instance (ArrowApply a) => Monad (CircuitT a b) where
    ab >>= fbac = (ab >>^ fbac) &&& id >>> app
 
instance (Arrow a) => Category (CircuitT a) where
    id = CircuitT $ id >>^ (id,)
    CircuitT bc . CircuitT ab = CircuitT $ proc a -> do
        (ab', b) <- ab -< a
        (bc', c) <- bc -< b
        returnA -< (bc' . ab', c)
 
instance (Arrow a) => Arrow (CircuitT a) where
    arr f = CircuitT $ (arr f,) ^<< arr f
    first (CircuitT bc) = CircuitT $ proc (b, d) -> do
        (x, c) <- bc -< b
        returnA -< (first x, (c, d))
 
 
instance (ArrowChoice a) => ArrowChoice (CircuitT a) where
    left c@(CircuitT bc) = CircuitT $ ((left *** Left) ^<< bc) ||| arr ((left c,) . Right)
    -- left c@(CircuitT bc) = CircuitT $ proc ebd -> do
    --     ans <- (case ebd of
    --         Left b -> (left *** Left) ^<< bc -< b
    --         Right d -> arr (left c,) -< Right d)
    --     returnA -< ans
    -- Так тоже можно 
 
instance (ArrowApply a) => ArrowApply (CircuitT a) where
    -- app = CircuitT $ ((app,) <<< snd) ^<< app <<^ first runCircuitT
    -- Так тоже можно
    app :: CircuitT a (CircuitT a b c, b) c
    app = CircuitT $ proc (CircuitT abc, b) -> do
        c <- app -< (abc, b)
        returnA -< (app, snd c)
 
instance (ArrowLoop a) => ArrowLoop (CircuitT a) where
    loop (CircuitT a) = CircuitT $ proc b -> do
        rec
            (circ, (c, d)) <- a -< (b, d)
        returnA -< (loop circ, c) 
 
instance (ArrowZero a) => ArrowZero (CircuitT a) where
    zeroArrow = CircuitT zeroArrow 
 
instance (ArrowPlus a) => ArrowPlus (CircuitT a) where
    CircuitT a1 <+> CircuitT a2 = CircuitT $ a1 <+> a2
 
instance (Arrow a, Arrow (CircuitT a)) => ArrowTransformer CircuitT a where
    lift a = CircuitT $ a >>^ (lift a,) 
 
instance (ArrowPlus a) => Semigroup (CircuitT a b c) where
    (<>) = (<+>)
 
instance (ArrowPlus a) => Monoid (CircuitT a b c) where
    mempty = zeroArrow 
 
instance ArrowError r a => ArrowError r (CircuitT a) where
    raise = CircuitT raise
--     tryInUnless (CircuitT aeb) (CircuitT aebc) (CircuitT aerc) = CircuitT $ proc e -> do
--         (aeb', b) <- aeb -< e
--         (aebc', x) <- aebc -< (e, b)
--         (aeerc, y) <- aerc -< (e, r)
--         returnA -< undefined 
 
instance ArrowWriter w a => ArrowWriter w (CircuitT a) where
    write = lift write
    newWriter aeb = aeb >>^ (,mempty)
 
instance ArrowState w a => ArrowState w (CircuitT a) where
    fetch = lift fetch
    store = lift store
 
instance ArrowReader w a => ArrowReader w (CircuitT a) where
    readState = lift readState
    -- newReader = CircuitT . (first newReader ^<<) . newReader . runCircuitT
    -- Так тоже можно
    newReader (CircuitT aeb) = CircuitT $ proc ew -> do
        (cir, b) <- newReader aeb -< ew
        returnA -< (newReader cir, b)
 
instance ArrowLoop a => ArrowCircuit (CircuitT a) where
    delay b = CircuitT . arr $ (, b) . delay
 
instance (ArrowLoop a, ArrowApply a) => ArrowAddStream (CircuitT a) a where
    liftStream = lift
--     elimStream = runAutomaton
 
-- runAutomaton :: (ArrowLoop a, ArrowApply a) => CircuitT a (e,b) c -> a (e,Stream b) (Stream c)
-- runAutomaton (CircuitT f) =
--     arr (\(e, Cons x xs) -> ((e, x), (e, xs))) >>>
--     first f >>>
--     arr (\((y, c), (e, xs)) -> (y, (runAutomaton c, (e, xs)))) >>>
--     second app >>>
--     arr (uncurry Cons)