{-|
    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 that is
    not the case.  The resulting @\'A\'@ will become “available” not until the
    @return@ action has being executed which is after the execution of @putChar char@.  If one
    thinks of a value of type @IO a@ as being a function of type @World -> (a,World)@ then return is
    defined as follows:

    @
    return x = \\world -> world \`seq\` (x,world)
    @

    However, to make @looping@ work, @return@ would have to be defined as follows:

    @
    return x = \\world -> (x,world)
    @

    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.pure' 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
    'System.IO.Unsafe.unsafePerformIO' nor 'System.IO.Unsafe.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) >>> pure (const \'A\')))
                         ()
    @
-}
module Control.Arrow.Lax (
    LaxArrow,
    impure,
    runLax
) where

    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) => Arrow (LaxArrow base) where

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

            widen extI       = ((),extI)

            narrow ((),extO) = extO

        LaxArrow conv1 baseGen1 >>> LaxArrow conv2 baseGen2 = 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 .
                                              (pure leftAssoc >>>) . (>>> pure rightAssoc)

        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 @pure@ 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 @(>>>)@, it does
        not preserve @pure@, @first@ and @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 . (pure lazySwap >>>) . (>>> pure 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 (pure 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)