{-# OPTIONS_GHC -fglasgow-exts #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Arrow.Transformer.Static
-- Copyright   :  (c) Ross Paterson 2003
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  ross@soi.city.ac.uk
-- Stability   :  experimental
-- Portability :  non-portable (multi-parameter type classes)
--
-- Arrow transformer adding static information.

module Control.Arrow.Transformer.Static(
		StaticArrow, StaticMonadArrow,
		wrapA, unwrapA, wrapM, unwrapM,
		module Control.Arrow.Operations,
		module Control.Arrow.Transformer,
		module Control.Sequence
	) where

import Control.Arrow
import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer
import Control.Monad
import Control.Sequence

-- | An arrow type that augments the underlying arrow with static information.

newtype StaticArrow f a b c = SA (f (a b c))

instance (Arrow a, Sequence f) => ArrowTransformer (StaticArrow f) a where
	lift f = SA (lift0 f)

instance (Arrow a, Sequence f) => Arrow (StaticArrow f a) where
	arr f = SA (lift0 (arr f))
	SA f >>> SA g = SA (lift2 (>>>) f g)
	first (SA f) = SA (lift1 first f)

-- The following promotions follow directly from the arrow transformer.

instance (ArrowZero a, Sequence f) => ArrowZero (StaticArrow f a) where
	zeroArrow = lift zeroArrow

instance (ArrowCircuit a, Sequence f) => ArrowCircuit (StaticArrow f a) where
	delay x = lift (delay x)

instance (ArrowError ex a, Sequence f) => ArrowError ex (StaticArrow f a) where
	raise = lift raise
	handle (SA f) (SA h) = SA (lift2 handle f h)
	tryInUnless (SA f) (SA s) (SA h) = SA (lift3 tryInUnless f s h)

instance (ArrowReader r a, Sequence f) => ArrowReader r (StaticArrow f a) where
	readState = lift readState
	newReader (SA f) = SA (lift1 newReader f)

instance (ArrowState s a, Sequence f) => ArrowState s (StaticArrow f a) where
	fetch = lift fetch
	store = lift store

instance (ArrowWriter w a, Sequence f) => ArrowWriter w (StaticArrow f a) where
	write = lift write
	newWriter (SA f) = SA (lift1 newWriter f)

-- Classes that are preserved.

instance (ArrowChoice a, Sequence f) => ArrowChoice (StaticArrow f a) where
	left (SA f) = SA (lift1 left f)

-- ArrowApply is generally not preserved.

instance (ArrowLoop a, Sequence f) => ArrowLoop (StaticArrow f a) where
	loop (SA f) = SA (lift1 loop f)

instance (ArrowPlus a, Sequence f) => ArrowPlus (StaticArrow f a) where
	SA f <+> SA g = SA (lift2 (<+>) f g)

-- promotions

instance (ArrowAddStream a a', Sequence f) =>
		ArrowAddStream (StaticArrow f a) (StaticArrow f a') where
	liftStream (SA f) = SA (lift1 liftStream f)
	elimStream (SA f) = SA (lift1 elimStream f)

instance (ArrowAddState s a a', Sequence f) =>
		ArrowAddState s (StaticArrow f a) (StaticArrow f a') where
	liftState (SA f) = SA (lift1 liftState f)
	elimState (SA f) = SA (lift1 elimState f)

instance (ArrowAddReader r a a', Sequence f) =>
		ArrowAddReader r (StaticArrow f a) (StaticArrow f a') where
	liftReader (SA f) = SA (lift1 liftReader f)
	elimReader (SA f) = SA (lift1 elimReader f)

instance (ArrowAddWriter w a a', Sequence f) =>
		ArrowAddWriter w (StaticArrow f a) (StaticArrow f a') where
	liftWriter (SA f) = SA (lift1 liftWriter f)
	elimWriter (SA f) = SA (lift1 elimWriter f)

instance (ArrowAddError ex a a', Sequence f) =>
		ArrowAddError ex (StaticArrow f a) (StaticArrow f a') where
	liftError (SA f) = SA (lift1 liftError f)
	elimError (SA f) (SA h) = SA (lift2 elimError f h)

-- | A special case.

type StaticArrowArrow a s = StaticArrow (ArrowSequence a s)

wrapA :: (Arrow a, Arrow a') => a s (a' b c) -> StaticArrowArrow a s a' b c
wrapA x = SA (ArrowSequence x)

unwrapA :: (Arrow a, Arrow a') => StaticArrowArrow a s a' b c -> a s (a' b c)
unwrapA (SA (ArrowSequence x)) = x

-- | A special case is monads applied to the whole arrow, in contrast to
-- 'Kleisli' arrows, in which the monad is applied to the output.

type StaticMonadArrow m = StaticArrow (MonadSequence m)

wrapM :: (Monad m, Arrow a) => m (a b c) -> StaticMonadArrow m a b c
wrapM x = SA (MonadSequence x)

unwrapM :: (Monad m, Arrow a) => StaticMonadArrow m a b c -> m (a b c)
unwrapM (SA (MonadSequence x)) = x
