> {-# LANGUAGE CPP, BangPatterns #-}



> module Control.SF.SF where



#if __GLASGOW_HASKELL__ >= 610

> import Control.Category

> import Prelude hiding ((.), id)

#endif



> import Control.Arrow

> import Control.Arrow.ArrowP

> import Control.Arrow.Operations





> newtype SF a b = SF { runSF :: (a -> (b, SF a b)) }



#if __GLASGOW_HASKELL__ >= 610

> instance Category SF where

>   id = SF h where h x = (x, SF h)

>   g . f = SF (h f g)

>     where

>       h f g x =

>         let (y, f') = runSF f x

>             (z, g') = runSF g y

>         in f' `seq` g' `seq` (z, SF (h f' g'))



> instance Arrow SF where

>   arr f = g

>     where g = SF (\x -> (f x, g))

>   first f = SF (g f)

>     where

>       g f (x, z) = f' `seq` ((y, z), SF (g f'))

>         where (y, f') = runSF f x

>   f &&& g = SF (h f g)

>     where

>       h f g x =

>         let (y, f') = runSF f x

>             (z, g') = runSF g x 

>         in ((y, z), SF (h f' g'))

>   f *** g = SF (h f g)

>     where

>       h f g x =

>         let (y, f') = runSF f (fst x)

>             (z, g') = runSF g (snd x) 

>         in ((y, z), SF (h f' g'))

#else

> instance Arrow SF where

>   arr f = g

>     where g = SF (\x -> (f x, g))

>   f >>> g = SF (h f g)

>     where

>       h f g x =

>         let (y, f') = runSF f x

>             (z, g') = runSF g y

>         in (z, SF (h f' g'))

>   first f = SF (g f)

>     where

>       g f (x, z) = ((y, z), SF (g f'))

>         where (y, f') = runSF f x

>   f &&& g = SF (h f g)

>     where

>       h f g x =

>         let (y, f') = runSF f x

>             (z, g') = runSF g x 

>         in ((y, z), SF (h f' g'))

>   f *** g = SF (h f g)

>     where

>       h f g x =

>         let (y, f') = runSF f (fst x)

>             (z, g') = runSF g (snd x) 

>         in ((y, z), SF (h f' g'))

#endif



> instance ArrowLoop SF where

>   loop sf = SF (g sf)

>     where

>       g f x = f' `seq` (y, SF (g f'))

>         where ((y, z), f') = runSF f (x, z)



> instance ArrowChoice SF where

>    left sf = SF (g sf)

>        where 

>          g f x = case x of

>                    Left a -> let (y, f') = runSF f a in f' `seq` (Left y, SF (g f'))

>                    Right b -> (Right b, SF (g f))

> 

> instance ArrowCircuit SF where

>   delay i = SF (f i)

>     where f i x = (i, SF (f x))



> run :: SF a b -> [a] -> [b]

> run _ [] = []

> run (SF f) (x:xs) =

>   let (y, f') = f x 

>   in y `seq` f' `seq` (y : run f' xs)

> 

> unfold :: SF () a -> [a]

> unfold = flip run inp

>   where inp = () : inp

>

> 

> nth :: Int -> SF () a -> a

> nth n (SF f) = x `seq` if n == 0 then x else nth (n - 1) f'

>   where (x, f') = f ()

> 

> nth' :: Int -> (b, ((), b) -> (a, b)) -> a

> nth' !n (i, f) = n `seq` i `seq` f `seq` aux n i

>   where

>     aux !n !i = x `seq` i' `seq` if n == 0 then x else aux (n-1) i'

>       where (x, i') = f ((), i)

>