path: root/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs

{-
Copyright (C) 2015 Martin Linnemann <theCodingMarlin@googlemail.com>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- |
   Module      : Text.Pandoc.Readers.Odt.Arrows.Utils
   Copyright   : Copyright (C) 2015 Martin Linnemann
   License     : GNU GPL, version 2 or above

   Maintainer  : Martin Linnemann <theCodingMarlin@googlemail.com>
   Stability   : alpha
   Portability : portable

Utility functions for Arrows (Kleisli monads).

Some general notes on notation:

* "^" is meant to stand for a pure function that is lifted into an arrow
based on its usage for that purpose in "Control.Arrow".
* "?" is meant to stand for the usage of a 'FallibleArrow' or a pure function
with an equivalent return value.
* "_" stands for the dropping of a value.
-}

-- We export everything
module Text.Pandoc.Readers.Odt.Arrows.Utils where

import           Control.Arrow
import           Control.Monad                         ( join, MonadPlus(..) )

import qualified Data.Foldable                    as F
import           Data.Monoid

import           Text.Pandoc.Readers.Odt.Generic.Fallible
import           Text.Pandoc.Readers.Odt.Generic.Utils

and2 :: (Arrow a) => a b c -> a b c' -> a b (c,c')
and2 = (&&&)

and3 :: (Arrow a)
     => a b c0->a b c1->a b c2
     -> a b (c0,c1,c2               )
and4 :: (Arrow a)
     => a b c0->a b c1->a b c2->a b c3
     -> a b (c0,c1,c2,c3            )
and5 :: (Arrow a)
     => a b c0->a b c1->a b c2->a b c3->a b c4
     -> a b (c0,c1,c2,c3,c4         )
and6 :: (Arrow a)
     => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5
     -> a b (c0,c1,c2,c3,c4,c5      )
and7 :: (Arrow a)
     => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5->a b c6
     -> a b (c0,c1,c2,c3,c4,c5,c6   )
and8 :: (Arrow a)
     => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5->a b c6->a b c7
     -> a b (c0,c1,c2,c3,c4,c5,c6,c7)

and3 a b c           = (and2 a b          ) &&& c
                       >>^ \((z,y          ) , x) -> (z,y,x          )
and4 a b c d         = (and3 a b c        ) &&& d
                       >>^ \((z,y,x        ) , w) -> (z,y,x,w        )
and5 a b c d e       = (and4 a b c d      ) &&& e
                       >>^ \((z,y,x,w      ) , v) -> (z,y,x,w,v      )
and6 a b c d e f     = (and5 a b c d e    ) &&& f
                       >>^ \((z,y,x,w,v    ) , u) -> (z,y,x,w,v,u    )
and7 a b c d e f g   = (and6 a b c d e f  ) &&& g
                       >>^ \((z,y,x,w,v,u  ) , t) -> (z,y,x,w,v,u,t  )
and8 a b c d e f g h = (and7 a b c d e f g) &&& h
                       >>^ \((z,y,x,w,v,u,t) , s) -> (z,y,x,w,v,u,t,s)

liftA2 :: (Arrow a) => (x -> y -> z) -> a b x -> a b y -> a b z
liftA2 f a b = a &&& b >>^ uncurry f

liftA3 :: (Arrow a) => (z->y->x                -> r)
                    -> a b z->a b y->a b x
                    -> a b r
liftA4 :: (Arrow a) => (z->y->x->w             -> r)
                    -> a b z->a b y->a b x->a b w
                    -> a b r
liftA5 :: (Arrow a) => (z->y->x->w->v          -> r)
                    -> a b z->a b y->a b x->a b w->a b v
                    -> a b r
liftA6 :: (Arrow a) => (z->y->x->w->v->u       -> r)
                    -> a b z->a b y->a b x->a b w->a b v->a b u
                    -> a b r
liftA7 :: (Arrow a) => (z->y->x->w->v->u->t    -> r)
                    -> a b z->a b y->a b x->a b w->a b v->a b u->a b t
                    -> a b r
liftA8 :: (Arrow a) => (z->y->x->w->v->u->t->s -> r)
                    -> a b z->a b y->a b x->a b w->a b v->a b u->a b t->a b s
                    -> a b r

liftA3 fun a b c           = and3 a b c           >>^ uncurry3 fun
liftA4 fun a b c d         = and4 a b c d         >>^ uncurry4 fun
liftA5 fun a b c d e       = and5 a b c d e       >>^ uncurry5 fun
liftA6 fun a b c d e f     = and6 a b c d e f     >>^ uncurry6 fun
liftA7 fun a b c d e f g   = and7 a b c d e f g   >>^ uncurry7 fun
liftA8 fun a b c d e f g h = and8 a b c d e f g h >>^ uncurry8 fun

liftA :: (Arrow a) => (y -> z) -> a b y -> a b z
liftA  fun a = a >>^ fun


-- | Duplicate a value to subsequently feed it into different arrows.
-- Can almost always be replaced with '(&&&)', 'keepingTheValue',
-- or even '(|||)'.
-- Aequivalent to
-- > returnA &&& returnA
duplicate :: (Arrow a) => a b (b,b)
duplicate = arr $ join (,)

-- | Lifts the combination of two values into an arrow.
joinOn :: (Arrow a) => (x -> y -> z) -> a (x,y) z
joinOn = arr.uncurry

-- | Applies a function to the uncurried result-pair of an arrow-application.
-- (The %-symbol was chosen to evoke an association with pairs.)
(>>%) :: (Arrow a) => a x (b,c) -> (b -> c -> d) -> a x d
a >>% f = a >>^ uncurry f

-- | '(>>%)' with its arguments flipped
(%<<) :: (Arrow a) => (b -> c -> d) -> a x (b,c) -> a x d
(%<<) = flip (>>%)

-- | Precomposition with an uncurried function
(%>>) :: (Arrow a) => (b -> c -> d) -> a d r -> a (b,c) r
f %>> a = uncurry f ^>> a

-- | Precomposition with an uncurried function (right to left variant)
(<<%) :: (Arrow a) => a d r -> (b -> c -> d) -> a (b,c) r
(<<%) = flip (%>>)

infixr 2 >>%, %<<, %>>, <<%


-- | Duplicate a value and apply an arrow to the second instance.
-- Aequivalent to
-- > \a -> duplicate >>> second a
-- or
-- > \a -> returnA &&& a
keepingTheValue :: (Arrow a) => a b c -> a b (b,c)
keepingTheValue a = returnA &&& a

-- | Duplicate a value and apply an arrow to the first instance.
-- Aequivalent to
-- > \a -> duplicate >>> first a
-- or
-- > \a -> a &&& returnA
keepingTheValue' :: (Arrow a) => a b c -> a b (c,b)
keepingTheValue' a = a &&& returnA

-- | 'bind' from the "Maybe"-Monad lifted into an 'ArrowChoice'.
-- Actually, it's the more complex '(>=>)', because 'bind' alone does not
-- combine as nicely in arrow form.
-- The current implementation is not the most efficient one, because it can
-- not return directly if a 'Nothing' is encountered. That in turn follows
-- from the type system, as 'Nothing' has an "invisible" type parameter that
-- can not be dropped early.
--
-- Also, there probably is a way to generalize this to other monads
-- or applicatives, but I'm leaving that as an exercise to the reader.
-- I have a feeling there is a new Arrow-typeclass to be found that is less
-- restrictive than 'ArrowApply'. If it is already out there,
-- I have not seen it yet. ('ArrowPlus' for example is not general enough.)
(>>>=) :: (ArrowChoice a) => a x (Maybe b) -> a b (Maybe c) -> a x (Maybe c)
a1 >>>= a2 = a1 >>> maybeToChoice >>> right a2 >>> choiceToMaybe >>^ join

infixr 2 >>>=

-- | 'mplus' Lifted into an arrow. No 'ArrowPlus' required.
-- (But still different from a true bind)
(>++<) :: (Arrow a, MonadPlus m) => a x (m b) -> a x (m b) -> a x (m b)
(>++<) = liftA2 mplus

-- | Left-compose with a pure function
leftLift :: (ArrowChoice a) => (l -> l') -> a (Either l r) (Either l' r)
leftLift = left.arr

-- | Right-compose with a pure function
rightLift :: (ArrowChoice a) => (r -> r') -> a (Either l r) (Either l r')
rightLift = right.arr


( ^+++  ) :: (ArrowChoice a) => (b -> c) ->  a b' c'   -> a (Either b b') (Either c c')
(  +++^ ) :: (ArrowChoice a) =>  a b c   -> (b' -> c') -> a (Either b b') (Either c c')
( ^+++^ ) :: (ArrowChoice a) => (b -> c) -> (b' -> c') -> a (Either b b') (Either c c')

l ^+++  r  = leftLift l >>> right r
l  +++^ r  = left     l >>> rightLift r
l ^+++^ r  = leftLift l >>> rightLift r

infixr 2 ^+++, +++^, ^+++^

( ^|||  ) :: (ArrowChoice a) => (b -> d) ->  a c d   -> a (Either b c) d
(  |||^ ) :: (ArrowChoice a) =>  a b d   -> (c -> d) -> a (Either b c) d
( ^|||^ ) :: (ArrowChoice a) => (b -> d) -> (c -> d) -> a (Either b c) d

l ^|||  r  = arr l |||     r
l  |||^ r  =     l ||| arr r
l ^|||^ r  = arr l ||| arr r

infixr 2 ^||| ,  |||^, ^|||^

( ^&&&  ) :: (Arrow a) => (b -> c) ->  a b c'   -> a b (c,c')
(  &&&^ ) :: (Arrow a) =>  a b c   -> (b -> c') -> a b (c,c')
( ^&&&^ ) :: (Arrow a) => (b -> c) -> (b -> c') -> a b (c,c')

l ^&&&  r = arr l &&&     r
l  &&&^ r =     l &&& arr r
l ^&&&^ r = arr l &&& arr r

infixr 3 ^&&&, &&&^, ^&&&^

( ^***  ) :: (Arrow a) => (b -> c) ->  a b' c'   -> a (b,b') (c,c')
(  ***^ ) :: (Arrow a) =>  a b c   -> (b' -> c') -> a (b,b') (c,c')
( ^***^ ) :: (Arrow a) => (b -> c) -> (b' -> c') -> a (b,b') (c,c')

l ^***  r = arr l ***     r
l  ***^ r =     l *** arr r
l ^***^ r = arr l *** arr r

infixr 3 ^***, ***^, ^***^

-- | A version of
--
-- >>> \p -> arr (\x -> if p x the  Right x else Left x)
--
-- but with p being an arrow
choose :: (ArrowChoice a) => a b Bool -> a b (Either b b)
choose checkValue = keepingTheValue checkValue >>^ select
  where select (x,True  ) = Right x
        select (x,False ) = Left  x

-- | Converts @Right a@ into @Just a@ and @Left _@ into @Nothing@.
choiceToMaybe :: (ArrowChoice a) => a (Either l r) (Maybe r)
choiceToMaybe = arr eitherToMaybe

-- | Converts @Nothing@ into @Left ()@ and @Just a@ into @Right a@.
maybeToChoice :: (ArrowChoice a) => a (Maybe b) (Fallible b)
maybeToChoice = arr maybeToEither

-- | Lifts a constant value into an arrow
returnV :: (Arrow a) => c -> a x c
returnV = arr.const

-- | 'returnA' dropping everything
returnA_ :: (Arrow a) => a _b ()
returnA_  = returnV ()

-- | Wrapper for an arrow that can be evaluated im parallel. All
-- Arrows can be evaluated in parallel, as long as they return a
-- monoid.
newtype ParallelArrow a b c = CoEval { evalParallelArrow :: a b c }
  deriving (Eq, Ord, Show)

instance (Arrow a, Monoid m) => Monoid (ParallelArrow a b m) where
  mempty = CoEval $ returnV mempty
  (CoEval a) `mappend` (CoEval ~b) = CoEval $ a &&& b >>% mappend

-- | Evaluates a collection of arrows in a parallel fashion.
--
-- This is in essence a fold of '(&&&)' over the collection,
-- so the actual execution order and parallelity depends on the
-- implementation of '(&&&)' in the arrow in question.
-- The default implementation of '(&&&)' for example keeps the
-- order as given in the collection.
--
-- This function can be seen as a generalization of
-- 'Control.Applicative.sequenceA' to arrows or as an alternative to
-- a fold with 'Control.Applicative.WrappedArrow', which
-- substitutes the monoid with function application.
--
coEval :: (Arrow a, F.Foldable f, Monoid m) => f (a b m) -> a b m
coEval = evalParallelArrow . (F.foldMap CoEval)

-- | Defines Left as failure, Right as success
type FallibleArrow a input failure success = a input (Either failure success)

type ReFallibleArrow a failure success success'
     = FallibleArrow a (Either failure success) failure success'

-- | Wrapper for fallible arrows. Fallible arrows are all arrows that return
-- an Either value where left is a faliure and right is a success value.
newtype AlternativeArrow a input failure success
  = TryArrow { evalAlternativeArrow :: FallibleArrow a input failure success }


instance (ArrowChoice a, Monoid failure)
         => Monoid (AlternativeArrow a input failure success) where
  mempty = TryArrow $ returnV $ Left mempty
  (TryArrow a) `mappend` (TryArrow b)
         = TryArrow $ a &&& b
                      >>^ \(a',~b')
                          -> ( (\a'' -> left (mappend a'') b') ||| Right )
                               a'

-- | Evaluates a collection of fallible arrows, trying each one in succession.
-- Left values are interpreted as failures, right values as successes.
--
-- The evaluation is stopped once an arrow succeeds.
-- Up to that point, all failures are collected in the failure-monoid.
-- Note that '()' is a monoid, and thus can serve as a failure-collector if
-- you are uninterested in the exact failures.
--
-- This is in essence a fold of '(&&&)' over the collection, enhanced with a
-- little bit of repackaging, so the actual execution order depends on the
-- implementation of '(&&&)' in the arrow in question.
-- The default implementation of '(&&&)' for example keeps the
-- order as given in the collection.
--
tryArrows         :: (ArrowChoice a, F.Foldable f, Monoid failure)
                  => f (FallibleArrow a b failure success)
                  ->    FallibleArrow a b failure success
tryArrows         = evalAlternativeArrow . (F.foldMap TryArrow)

--
liftSuccess       :: (ArrowChoice a)
                  => (success -> success')
                  -> ReFallibleArrow a failure success success'
liftSuccess       = rightLift

--
liftAsSuccess     :: (ArrowChoice a)
                  => a x success
                  -> FallibleArrow a x failure success
liftAsSuccess a   = a >>^ Right

--
asFallibleArrow   :: (ArrowChoice a)
                  => a x success
                  -> FallibleArrow a x failure success
asFallibleArrow a = a >>^ Right

-- | Raises an error into a 'ReFallibleArrow' if the arrow is already in
-- "error mode"
liftError         :: (ArrowChoice a, Monoid failure)
                  => failure
                  -> ReFallibleArrow a failure success success
liftError e       = leftLift (e <>)

-- | Raises an error into a 'FallibleArrow', droping both the arrow input
-- and any previously stored error value.
_raiseA           :: (ArrowChoice a)
                  => failure
                  -> FallibleArrow a x failure success
_raiseA e         = returnV (Left e)

-- | Raises an empty error into a 'FallibleArrow', droping both the arrow input
-- and any previously stored error value.
_raiseAEmpty      :: (ArrowChoice a, Monoid failure)
                  => FallibleArrow a x failure success
_raiseAEmpty      = _raiseA mempty

-- | Raises an error into a 'ReFallibleArrow', possibly appending the new error
-- to an existing one
raiseA            :: (ArrowChoice a, Monoid failure)
                  => failure
                  -> ReFallibleArrow a failure success success
raiseA e          = arr $ Left.(either (<> e) (const e))

-- | Raises an empty error into a 'ReFallibleArrow'. If there already is an
-- error, nothing changes.
-- (Note that this function is only aequivalent to @raiseA mempty@ iff the
-- failure monoid follows the monoid laws.)
raiseAEmpty       :: (ArrowChoice a, Monoid failure)
                  => ReFallibleArrow a failure success success
raiseAEmpty       = arr (fromRight (const mempty) >>> Left)


-- | Execute the second arrow if the first succeeds
(>>?) :: (ArrowChoice a)
            => FallibleArrow a x       failure success
            -> FallibleArrow a success failure success'
            -> FallibleArrow a x       failure success'
a >>? b = a >>> Left ^||| b

-- | Execute the lifted second arrow if the first succeeds
(>>?^) :: (ArrowChoice a)
            => FallibleArrow a x       failure success
            -> (success                     -> success')
            -> FallibleArrow a x       failure success'
a >>?^ f = a >>^ Left ^|||^ Right . f

-- | Execute the lifted second arrow if the first succeeds
(>>?^?) :: (ArrowChoice a)
            => FallibleArrow a x       failure success
            -> (success      -> Either failure success')
            -> FallibleArrow a x       failure success'
a >>?^? b = a >>> Left ^|||^ b

-- | Execute the second arrow if the lifted first arrow succeeds
(^>>?) :: (ArrowChoice a)
            => (x            -> Either failure success)
            -> FallibleArrow a success failure success'
            -> FallibleArrow a x       failure success'
a ^>>? b = a ^>> Left ^||| b

-- | Execute the lifted second arrow if the lifted first arrow succeeds
(^>>?^) :: (ArrowChoice a)
            => (x            -> Either failure success)
            -> (success                     -> success')
            -> FallibleArrow a x       failure success'
a ^>>?^ f = arr $ a >>> right f

-- | Execute the lifted second arrow if the lifted first arrow succeeds
(^>>?^?) :: (ArrowChoice a)
            => (x            -> Either failure success)
            -> (success      -> Either failure success')
            -> FallibleArrow a x       failure success'
a ^>>?^? f = a ^>> Left ^|||^ f

-- | Execute the second, non-fallible arrow if the first arrow succeeds
(>>?!) :: (ArrowChoice a)
            => FallibleArrow a x       failure success
            ->               a success         success'
            -> FallibleArrow a x       failure success'
a >>?! f = a >>> right f

---
(>>?%) :: (ArrowChoice a)
          => FallibleArrow a x f (b,b')
          -> (b -> b' -> c)
          -> FallibleArrow a x f c
a >>?% f = a >>?^ (uncurry f)

---
(^>>?%) :: (ArrowChoice a)
          => (x -> Either f (b,b'))
          -> (b -> b' -> c)
          -> FallibleArrow a x f c
a ^>>?% f = arr a >>?^ (uncurry f)

---
(>>?%?) :: (ArrowChoice a)
           => FallibleArrow a x f (b,b')
           -> (b -> b' -> (Either f c))
           -> FallibleArrow a x f c
a >>?%? f = a >>?^? (uncurry f)

infixr 1  >>?,  >>?^,  >>?^?
infixr 1 ^>>?, ^>>?^, ^>>?^?, >>?!
infixr 1 >>?%, ^>>?%, >>?%?

-- | Keep values that are Right, replace Left values by a constant.
ifFailedUse :: (ArrowChoice a) => v -> a (Either f v) v
ifFailedUse v = arr $ either (const v) id

-- | '(&&)' lifted into an arrow
(<&&>) :: (Arrow a) => a x Bool -> a x Bool -> a x Bool
(<&&>) = liftA2 (&&)

-- | '(||)' lifted into an arrow
(<||>) :: (Arrow a) => a x Bool -> a x Bool -> a x Bool
(<||>) = liftA2 (||)

-- | An equivalent of '(&&)' in a fallible arrow
(>&&<) :: (ArrowChoice a, Monoid f) => FallibleArrow a x f s
                                    -> FallibleArrow a x f s'
                                    -> FallibleArrow a x f (s,s')
(>&&<) = liftA2 chooseMin

-- | An equivalent of '(||)' in some forms of fallible arrows
(>||<) :: (ArrowChoice a, Monoid f, Monoid s) => FallibleArrow a x f s
                                              -> FallibleArrow a x f s
                                              -> FallibleArrow a x f s
(>||<) = liftA2 chooseMax

-- | An arrow version of a short-circuit (<|>)
ifFailedDo :: (ArrowChoice a)
           => FallibleArrow a x f y
           -> FallibleArrow a x f y
           -> FallibleArrow a x f y
ifFailedDo a b = keepingTheValue a >>> repackage ^>> (b |||^ Right)
  where repackage (x , Left  _) = Left  x
        repackage (_ , Right y) = Right y

infixr 4 <&&>, <||>, >&&<, >||<
infixr 1 `ifFailedDo`