{-|
    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\` (world,x)
    @

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

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

    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 it is 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 arrow input output
             = forall arrowInput arrowOutput.
               LaxArrow ((arrowOutput,input) -> (arrowInput,output))
                        (forall extInput extOutput.
                         arrow (arrowOutput,extInput) (arrowInput,extOutput) ->
                         arrow extInput extOutput)

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

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

            widen extInput = ((),extInput)

            narrow ((),extOutput) = extOutput

        LaxArrow trans1 arrowGen1 >>> LaxArrow trans2 arrowGen2
                = LaxArrow (\(~(~(arrowOutput1,arrowOutput2),input))
                                 -> let

                                        (arrowInput1,intermediate) = trans1 (arrowOutput1,input)

                                        (arrowInput2,output) = trans2 (arrowOutput2,intermediate)

                                    in
                                    ((arrowInput1,arrowInput2),output))
                            (arrowGen2 . arrowGen1 . (pure leftAssoc >>>) . (>>> pure rightAssoc))

        first (LaxArrow trans arrowGen)
                = LaxArrow ((leftAssoc >>>) $ (>>> rightAssoc) $ first $ trans) arrowGen

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

        loop (LaxArrow trans arrowGen)
                = LaxArrow (loop $ (rightAssoc >>>) $ (>>> leftAssoc) $ trans) arrowGen

    {-|
        Transforms a value of the base arrow type into a lax arrow.  Pure parts of the argument
        arrow are not affected by relaxation, only parts of the lax arrow 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 arrow) => arrow input output -> LaxArrow arrow input output
    impure arrow = LaxArrow lazySwap
                            (loop . (pure lazySwap >>>) . (>>> pure lazySwap) . (>>> first arrow))

    {-|
        Converts a lax arrow into a value of the base arrow type.
    -}
    runLax :: (Arrow arrow) => LaxArrow arrow input output -> arrow input output
    runLax (LaxArrow trans arrowGen) = arrowGen (pure trans)

    leftAssoc :: (value1,(value2,value3)) -> ((value1,value2),value3)
    leftAssoc ~(value1,~(value2,value3)) = ((value1,value2),value3)

    rightAssoc :: ((value1,value2),value3) -> (value1,(value2,value3))
    rightAssoc ~(~(value1,value2),value3) = (value1,(value2,value3))

    lazySwap :: (value1,value2) -> (value2,value1)
    lazySwap ~(value1,value2) = (value2,value1)