{-|
    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 “available” not until the action
    @putChar char@ has been executed.

    In order to explain this, let’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 “a bit less strict”.  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)