```{-|
Lax arrows.

In order to get an understanding of what a lax arrow is, consider the following code example:

@
looping :: IO ()
looping = fixIO (\\char -> putChar char >> return \'A\')
@

One might expect that executing @looping@ will result in a capital A being printed but this is
not the case.  The resulting @\'A\'@ will become &#x201C;available&#x201D; not until the action
@putChar char@ has been executed.

In order to explain this, let&#x2019;s think of @IO o@ as being equivalent to @World -> Either
Exception (o,World)@.  The @>>=@ operator could now be defined as follows:

@
io1 >>= io2Gen = \\world -> case io1 world of
Left  exc         -> Left exc
Right (o1,world') -> io2Gen o1 world'
@

This results in the following situation:

* In order to decide whether @looping@ outputs a value or throws an exception, the system has
to decide whether @putChar char >> return \'A\'@ outputs a value or throws an exception.

* In order to decide whether @putChar char >> return \'A\'@ outputs a value or throws an
exception, the system has to decide whether @putChar char@ outputs a value or throws an
exception (because of the way, @>>=@ is implemented).

* In order to decide whether @putChar char@ outputs a value or throws an exception, the system
has to know if there is really a @char@ to output or whether there is none because of an
exception. So it has to decide whether @putChar char >> return \'A\'@ outputs a value or
throws an exception.

So we have a circular dependency resulting in an output value of @_|_@ for @looping@.

The 'LaxArrow' type constructor transforms a given arrow into a new arrow which works mostly
like the base arrow but is &#x201C;a bit less strict&#x201D;.  To be more precise, all parts of
a lax arrow value which are constructed with 'Control.Arrow.arr' are internally moved to the
beginning.  This way, data produced by such parts is available at each point in the arrow when
'Control.Arrow.loop' is used.  For the above example, this would mean that the result @\'A\'@ is
already known before the @putChar@ action is executed and can therefore be used by this action.

Note that relaxation only works for arrows, not directly for monads.  It is unknown whether a
relaxation mechanism for monads exists but it is considered unlikely.  Of course, you can
transform any monad into an arrow by using 'Control.Arrow.Kleisli'.  However, the lax arrow type
is not an instance of 'Control.Arrow.ArrowChoice' nor is it one of 'Control.Arrow.ArrowApply',
and at least the current implementation does not allow it to be an instance of either class.

Further note that the implementation of lax arrows does not use @unsafePerformIO@ nor
@unsafeInterleaveIO@ and is not tied to @IO@ at all.

The lax arrow version of the @looping@ example would be as follows:

@
looping :: IO ()
looping = runKleisli (runLax (loop \$ second \$ impure (Kleisli putChar) >>> arr (const \'A\')))
()
@
-}
module Control.Arrow.Lax (

LaxArrow,
impure,
runLax

) where

-- Prelude
import           Prelude hiding (id, (.))
import qualified Prelude

-- Control
import Control.Category
import Control.Arrow

{-|
A lax arrow.
-}
data LaxArrow base i o = forall impureI impureO.
LaxArrow (Conv i o impureI impureO) (BaseGen base impureI impureO)

type Conv i o impureI impureO = (impureO,i) -> (impureI,o)

type BaseGen base impureI impureO = forall extI extO.
base (impureO,extI) (impureI,extO) -> base extI extO

instance (Arrow base) => Category (LaxArrow base) where

id = arr Prelude.id

LaxArrow conv2 baseGen2 . LaxArrow conv1 baseGen1 = LaxArrow conv' baseGen' where

conv' ~(~(impureO1,impureO2),i) = let

(impureI1,inter) = conv1 (impureO1,i)

(impureI2,o)     = conv2 (impureO2,inter)

in ((impureI1,impureI2),o)

baseGen'                        = baseGen2 . baseGen1 .
(arr leftAssoc >>>) . (>>> arr rightAssoc)

instance (Arrow base) => Arrow (LaxArrow base) where

arr fun = LaxArrow (second fun) ((arr widen >>>) . (>>> arr narrow)) where

widen extI       = ((),extI)

narrow ((),extO) = extO

first (LaxArrow conv baseGen) = LaxArrow (leftAssoc >>> first conv >>> rightAssoc) baseGen

instance (Arrow base) => ArrowLoop (LaxArrow base) where

loop (LaxArrow conv baseGen) = LaxArrow (loop (rightAssoc >>> conv >>> leftAssoc)) baseGen

{-|
Transforms a value of the base arrow type into a lax arrow value.  Pure parts of the
argument are not affected by relaxation, only parts of the lax arrow value which are
constructed with 'Control.Arrow.arr' from the 'LaxArrow' instance of 'Control.Arrow.Arrow'.

@lift@ from the @ArrowTransformer@ class is not used since it is probably supposed to be a
homomorphism but 'impure' is not a homomorphism.  While 'impure' preserves
'Control.Arrow.>>>', it does not preserve 'Control.Arrow.arr', 'Control.Arrow.first' and
'Control.Arrow.loop'. If it would then we would have no relaxation effect at all.
-}
impure :: (ArrowLoop base) => base i o -> LaxArrow base i o
impure base = LaxArrow lazySwap
(loop . (arr lazySwap >>>) . (>>> arr lazySwap) . (>>> first base))

{-|
Converts a lax arrow value into a value of the base arrow type.
-}
runLax :: (Arrow base) => LaxArrow base i o -> base i o
runLax (LaxArrow conv baseGen) = baseGen (arr conv)

leftAssoc :: (val1,(val2,val3)) -> ((val1,val2),val3)
leftAssoc ~(val1,~(val2,val3)) = ((val1,val2),val3)

rightAssoc :: ((val1,val2),val3) -> (val1,(val2,val3))
rightAssoc ~(~(val1,val2),val3) = (val1,(val2,val3))

lazySwap :: (val1,val2) -> (val2,val1)
lazySwap ~(val1,val2) = (val2,val1)
```