content: -- ------------------------------------------------------------
  
  {- |
     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 #-}
  
  -- ------------------------------------------------------------
  
  