    -- ------------------------------------------------------------

    {- |
       Module     : Control.Arrow.ListArrow
       Copyright  : Copyright (C) 2005 Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
       Stability  : experimental
       Portability: portable

       Implementation of pure list arrows

    -}

    -- ------------------------------------------------------------

    module Control.Arrow.ListArrow
        ( LA(..)
        , fromLA
        )
    where

    import           Prelude hiding (id, (.))

    import           Control.Category

    import           Control.Arrow
    import           Control.Arrow.ArrowIf
    import           Control.Arrow.ArrowList
    import           Control.Arrow.ArrowNF
    import           Control.Arrow.ArrowTree
    import           Control.Arrow.ArrowNavigatableTree

    import           Control.DeepSeq

    import           Data.List ( partition )

    -- ------------------------------------------------------------

    -- | pure list arrow data type

    newtype LA a b = LA { runLA :: a -> [b] }

    instance Category LA where
        id                  = LA $ (:[])
        {-# INLINE id #-}
        LA g . LA f         = LA $ concatMap g . f
        {-# INLINE (.) #-}

    instance Arrow LA where
        arr f               = LA $ \ x -> [f x]
        {-# INLINE arr #-}
        first (LA f)        = LA $ \ ~(x1, x2) -> [ (y1, x2) | y1 <- f x1 ]

        -- just for efficiency

        second (LA g)       = LA $ \ ~(x1, x2) -> [ (x1, y2) | y2 <- g x2 ]
        LA f *** LA g       = LA $ \ ~(x1, x2) -> [ (y1, y2) | y1 <- f x1, y2 <- g x2]
        LA f &&& LA g       = LA $ \ x         -> [ (y1, y2) | y1 <- f x , y2 <- g x ]

    instance ArrowZero LA where
        zeroArrow           = LA $ const []
        {-# INLINE zeroArrow #-}

    instance ArrowPlus LA where
        LA f <+> LA g       = LA $ \ x -> f x ++ g x
        {-# INLINE (<+>) #-}

    instance ArrowChoice LA where
        left  (LA f)        = LA $ either (map Left . f) ((:[]) . Right)
        right (LA f)        = LA $ either ((:[]) . Left) (map Right . f)
        LA f +++ LA g       = LA $ either (map Left . f) (map Right . g)
        LA f ||| LA g       = LA $ either f g

    instance ArrowApply LA where
        app                 = LA $ \ (LA f, x) -> f x
        {-# INLINE app #-}

    instance ArrowList LA where
        arrL                = LA
        {-# INLINE arrL #-}
        arr2A f             = LA $ \ ~(x, y) -> runLA (f x) y
        {-# INLINE arr2A #-}
        isA p               = LA $ \ x -> if p x then [x] else []
        {-# INLINE isA #-}
        LA f >>. g          = LA $ g . f
        {-# INLINE (>>.) #-}
        withDefault a d     = a >>. \ x -> if null x then [d] else x

    instance ArrowIf LA where
        ifA (LA p) t e      = LA $ \ x -> runLA ( if null (p x)
                                                  then e
                                                  else t
                                                ) x
        {-# INLINE ifA #-}

        (LA f) `orElse` (LA g)
                            = LA $ \ x -> ( let
                                            res = f x
                                            in
                                            if null res
                                            then g x
                                            else res
                                          )
        {-# INLINE orElse #-}

        spanA p             = LA $ (:[]) . span (not . null . runLA p)

        partitionA  p       = LA $ (:[]) . partition (not . null . runLA p)

    instance ArrowTree LA

    instance ArrowNavigatableTree LA

    instance ArrowNF LA where
        rnfA (LA f)         = LA $ \ x -> let res = f x
                                          in
                                          res `deepseq` res

    instance ArrowWNF LA

    -- ------------------------------------------------------------

    -- | conversion of pure list arrows into other possibly more complex
    -- list arrows

    fromLA          :: ArrowList a => LA b c -> a b c
    fromLA f        =  arrL (runLA f)
    {-# INLINE fromLA #-}

    -- ------------------------------------------------------------