{-| This module provides efficient and streaming left map-with-accumulator that you can combine
    using 'Applicative' style.

    Import this module qualified to avoid clashing with the Prelude:

>>> import qualified Control.Scanl as SL

    Use 'scan' to apply a 'Fold' to a list (or other 'Traversable' structures) from left to right,
    and 'scanr' to do so from right to left.
-}

{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE TupleSections             #-}

module Control.Scanl (
    -- * Scan Types
      Scan(..)
    , ScanM(..)

    -- * Scanning
    , scan
    , scanM
    , scanr

    , prescan
    , postscan

    -- * Utilities
    -- $utilities
    , purely
    , purely_
    , impurely
    , impurely_
    , generalize
    , simplify
    , hoists
    , arrM
    , premap
    , premapM
    ) where

import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Foldl (Fold(..))
import Control.Foldl.Internal (Pair(..))
import Control.Monad ((<=<))
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Data.Functor.Identity
import Data.Monoid hiding ((<>))
import Data.Profunctor
import Data.Semigroup (Semigroup(..))
import Data.Traversable
import Data.Tuple (swap)
import Prelude hiding ((.), id, scanr)

#if MIN_VERSION_base(4, 7, 0)
import Data.Coerce
#endif

--import qualified Control.Foldl as L

{-| Efficient representation of a left map-with-accumulator that preserves the
    scan's step function and initial accumulator.

    This allows the 'Applicative' instance to assemble derived scans that
    traverse the container only once

    A \''Scan' a b\' processes elements of type __a__ replacing each with a
    value of type __b__.
-}
data Scan a b
  -- | @Scan @ @ step @ @ initial @
  = forall x. Scan (a -> State x b) x

instance Functor (Scan a) where
    fmap f (Scan step begin) = Scan (fmap f . step) begin
    {-# INLINE fmap #-}

instance Applicative (Scan a) where
    pure b    = Scan (\_ -> pure b) ()
    {-# INLINE pure #-}

    (Scan stepL beginL) <*> (Scan stepR beginR) =
        let step a (Pair xL xR) = (bL bR, (Pair xL' xR'))
              where (bL, xL') = runState (stepL a) xL
                    (bR, xR') = runState (stepR a) xR
            begin = Pair beginL beginR
        in  Scan (state . step) begin
    {-# INLINE (<*>) #-}

instance Profunctor Scan where
    lmap = premap
    rmap = fmap

instance Category Scan where
    id = Scan pure ()
    {-# INLINE id #-}
    (Scan s2 b2) . (Scan s1 b1) = Scan (state . step) (Pair b1 b2)
        where step a (Pair xL xR) = (c, Pair xL' xR')
                where (b, xL') = runState (s1 a) xL
                      (c, xR') = runState (s2 b) xR
    {-# INLINE (.) #-}

instance Arrow Scan where
    arr f = Scan (pure . f) ()
    {-# INLINE arr #-}
    first  (Scan step begin) = Scan
      (\(a,b) -> state $ \x -> first (,b) $ runState (step a) x)
      begin
    {-# INLINE first #-}
    second (Scan step begin) = Scan
      (\(b,a) -> state $ \x  -> first (b,) $ runState (step a) x)
      begin
    {-# INLINE second #-}

instance Semigroup b => Semigroup (Scan a b) where
    (<>) = liftA2 (<>)
    {-# INLINE (<>) #-}

instance Monoid b => Monoid (Scan a b) where
    mempty = pure mempty
    {-# INLINE mempty #-}

    mappend = liftA2 mappend
    {-# INLINE mappend #-}

instance Num b => Num (Scan a b) where
    fromInteger = pure . fromInteger
    {-# INLINE fromInteger #-}

    negate = fmap negate
    {-# INLINE negate #-}

    abs = fmap abs
    {-# INLINE abs #-}

    signum = fmap signum
    {-# INLINE signum #-}

    (+) = liftA2 (+)
    {-# INLINE (+) #-}

    (*) = liftA2 (*)
    {-# INLINE (*) #-}

    (-) = liftA2 (-)
    {-# INLINE (-) #-}

instance Fractional b => Fractional (Scan a b) where
    fromRational = pure . fromRational
    {-# INLINE fromRational #-}

    recip = fmap recip
    {-# INLINE recip #-}

    (/) = liftA2 (/)
    {-# INLINE (/) #-}

instance Floating b => Floating (Scan a b) where
    pi = pure pi
    {-# INLINE pi #-}

    exp = fmap exp
    {-# INLINE exp #-}

    sqrt = fmap sqrt
    {-# INLINE sqrt #-}

    log = fmap log
    {-# INLINE log #-}

    sin = fmap sin
    {-# INLINE sin #-}

    tan = fmap tan
    {-# INLINE tan #-}

    cos = fmap cos
    {-# INLINE cos #-}

    asin = fmap asin
    {-# INLINE asin #-}

    atan = fmap atan
    {-# INLINE atan #-}

    acos = fmap acos
    {-# INLINE acos #-}

    sinh = fmap sinh
    {-# INLINE sinh #-}

    tanh = fmap tanh
    {-# INLINE tanh #-}

    cosh = fmap cosh
    {-# INLINE cosh #-}

    asinh = fmap asinh
    {-# INLINE asinh #-}

    atanh = fmap atanh
    {-# INLINE atanh #-}

    acosh = fmap acosh
    {-# INLINE acosh #-}

    (**) = liftA2 (**)
    {-# INLINE (**) #-}

    logBase = liftA2 logBase
    {-# INLINE logBase #-}

{-| Like 'Scan', but monadic.

    A \''ScanM' m a b\' processes elements of type __a__ and
    results in a monadic value of type __m b__.
-}
data ScanM m a b =
  -- | @ScanM @ @ step @ @ initial @ @ extract@
  forall x . ScanM (a -> StateT x m b) (m x)

instance Functor m => Functor (ScanM m a) where
    fmap f (ScanM step begin) = ScanM (fmap f . step) begin
    {-# INLINE fmap #-}

instance Applicative m => Applicative (ScanM m a) where
    pure b    = ScanM (\_ -> StateT $ \() -> pure (b, ())) (pure ())
    {-# INLINE pure #-}

    (ScanM stepL beginL) <*> (ScanM stepR beginR) =
        let step a (Pair xL xR) =
              (\(bL, xL') (bR, xR') -> (bL bR, (Pair xL' xR')))
              <$> runStateT (stepL a) xL
              <*> runStateT (stepR a) xR
            begin = Pair <$> beginL <*> beginR
        in  ScanM (StateT . step) begin
    {-# INLINE (<*>) #-}

instance Functor m => Profunctor (ScanM m) where
    rmap = fmap
    lmap f (ScanM step begin) = ScanM (step . f) begin

instance Monad m => Category (ScanM m) where
    id = ScanM pure (pure ())
    {-# INLINE id #-}
    (ScanM s2 b2) . (ScanM s1 b1) = ScanM (StateT . step) (Pair <$> b1 <*> b2)
        where step a (Pair xL xR) = do
                (b, xL') <- runStateT (s1 a) xL
                (c, xR') <- runStateT (s2 b) xR
                pure (c, Pair xL' xR')
    {-# INLINE (.) #-}

instance Monad m => Arrow (ScanM m) where
    arr f = ScanM (lift . pure . f) (pure ())
    {-# INLINE arr #-}
    first  (ScanM step begin) = ScanM
      (\(a,b) -> StateT $ \x -> first (,b) <$> runStateT (step a) x)
      begin
    {-# INLINE first #-}
    second (ScanM step begin) = ScanM
      (\(b,a) -> StateT $ \x  -> first (b,) <$> runStateT (step a) x)
      begin
    {-# INLINE second #-}

instance (Monad m, Semigroup b) => Semigroup (ScanM m a b) where
    (<>) = liftA2 (<>)
    {-# INLINE (<>) #-}

instance (Monad m, Monoid b) => Monoid (ScanM m a b) where
    mempty = pure mempty
    {-# INLINE mempty #-}

    mappend = liftA2 mappend
    {-# INLINE mappend #-}

instance (Monad m, Num b) => Num (ScanM m a b) where
    fromInteger = pure . fromInteger
    {-# INLINE fromInteger #-}

    negate = fmap negate
    {-# INLINE negate #-}

    abs = fmap abs
    {-# INLINE abs #-}

    signum = fmap signum
    {-# INLINE signum #-}

    (+) = liftA2 (+)
    {-# INLINE (+) #-}

    (*) = liftA2 (*)
    {-# INLINE (*) #-}

    (-) = liftA2 (-)
    {-# INLINE (-) #-}

instance (Monad m, Fractional b) => Fractional (ScanM m a b) where
    fromRational = pure . fromRational
    {-# INLINE fromRational #-}

    recip = fmap recip
    {-# INLINE recip #-}

    (/) = liftA2 (/)
    {-# INLINE (/) #-}

instance (Monad m, Floating b) => Floating (ScanM m a b) where
    pi = pure pi
    {-# INLINE pi #-}

    exp = fmap exp
    {-# INLINE exp #-}

    sqrt = fmap sqrt
    {-# INLINE sqrt #-}

    log = fmap log
    {-# INLINE log #-}

    sin = fmap sin
    {-# INLINE sin #-}

    tan = fmap tan
    {-# INLINE tan #-}

    cos = fmap cos
    {-# INLINE cos #-}

    asin = fmap asin
    {-# INLINE asin #-}

    atan = fmap atan
    {-# INLINE atan #-}

    acos = fmap acos
    {-# INLINE acos #-}

    sinh = fmap sinh
    {-# INLINE sinh #-}

    tanh = fmap tanh
    {-# INLINE tanh #-}

    cosh = fmap cosh
    {-# INLINE cosh #-}

    asinh = fmap asinh
    {-# INLINE asinh #-}

    atanh = fmap atanh
    {-# INLINE atanh #-}

    acosh = fmap acosh
    {-# INLINE acosh #-}

    (**) = liftA2 (**)
    {-# INLINE (**) #-}

    logBase = liftA2 logBase
    {-# INLINE logBase #-}

-- | Apply a strict left 'Scan' to a 'Traversable' container
scan :: Traversable t => Scan a b -> t a -> t b
scan (Scan step begin) as = fst $ runState (traverse step as) begin
{-# INLINE scan #-}

-- | Like 'scan' but start scanning from the right
scanr :: Traversable t => Scan a b -> t a -> t b
scanr (Scan step begin) as =
  fst (runReverseState (traverse (ReverseState #. runState . step) as) begin)
{-# INLINE scanr #-}

-- | Like 'scan' but monadic
scanM :: (Traversable t, Monad m) => ScanM m a b -> t a -> m (t b)
scanM (ScanM step begin) as = fmap fst $ runStateT (traverse step as) =<< begin
{-# INLINE scanM #-}

{-| Convert a `Fold` into a prescan

    \"Prescan\" means that the last element of the scan is not included
-}
prescan :: Fold a b -> Scan a b
prescan (Fold step begin done) = Scan (state . step') begin
  where
    step' a x = (b, x')
      where
        x' = step x a
        b  = done x
{-# INLINE prescan #-}

{-| Convert a `Fold` into a postscan

    \"Postscan\" means that the first element of the scan is not included
-}
postscan :: Fold a b -> Scan a b
postscan (Fold step begin done) = Scan (state . step') begin
  where
    step' a x = (b, x')
      where
        x' = step x a
        b  = done x'
{-# INLINE postscan #-}

arrM :: Monad m => (b -> m c) -> ScanM m b c
arrM f = ScanM (lift . f) (pure ())
{-# INLINE arrM #-}

{- $utilities
-}

-- | Upgrade a scan to accept the 'Scan' type
purely :: (forall x . (a -> State x b) -> x -> r) -> Scan a b -> r
purely f (Scan step begin) = f step begin
{-# INLINABLE purely #-}

-- | Upgrade a more traditional scan to accept the `Scan` type
purely_ :: (forall x . (x -> a -> (x, b)) -> x -> r) -> Scan a b -> r
purely_ f (Scan step begin) = f (\s a -> swap $ runState (step a) s) begin
{-# INLINABLE purely_ #-}

-- | Upgrade a monadic scan to accept the 'ScanM' type
impurely
    :: (forall x . (a -> StateT x m b) -> m x -> r)
    -> ScanM m a b
    -> r
impurely f (ScanM step begin) = f step begin
{-# INLINABLE impurely #-}

-- | Upgrade a more traditional monadic scan to accept the `ScanM` type
impurely_
    :: Monad m
    => (forall x . (x -> a -> m (x, b)) -> m x -> r)
    -> ScanM m a b
    -> r
impurely_ f (ScanM step begin) = f (\s a -> swap <$> runStateT (step a) s) begin

{-| Generalize a `Scan` to a `ScanM`

> generalize (pure r) = pure r
>
> generalize (f <*> x) = generalize f <*> generalize x
-}
generalize :: Monad m => Scan a b -> ScanM m a b
generalize (Scan step begin) = hoists
  (\(Identity c) -> pure c)
  (ScanM step (Identity begin))
{-# INLINABLE generalize #-}

{-| Simplify a pure `ScanM` to a `Scan`

> simplify (pure r) = pure r
>
> simplify (f <*> x) = simplify f <*> simplify x
-}
simplify :: ScanM Identity a b -> Scan a b
simplify (ScanM step (Identity begin)) = Scan step begin
{-# INLINABLE simplify #-}

{- | Shift a 'ScanM' from one monad to another with a morphism such as 'lift' or 'liftIO';
     the effect is the same as 'Control.Monad.Morph.hoist'.
-}
hoists :: (forall x . m x -> n x) -> ScanM m a b -> ScanM n a b
hoists phi (ScanM step begin ) = ScanM
  (\a -> StateT $ phi . runStateT (step a))
  (phi begin)
{-# INLINABLE hoists #-}

{-| @(premap f scaner)@ returns a new 'Scan' where f is applied at each step

> scan (premap f scaner) list = scan scaner (map f list)

> premap id = id
>
> premap (f . g) = premap g . premap f

> premap k (pure r) = pure r
>
> premap k (f <*> x) = premap k f <*> premap k x
-}
premap :: (a -> b) -> Scan b r -> Scan a r
premap f (Scan step begin) = Scan (step . f) begin
{-# INLINABLE premap #-}

{-| @(premapM f scaner)@ returns a new 'ScanM' where f is applied to each input
    element

> premapM return = id
>
> premapM (f <=< g) = premap g . premap f

> premapM k (pure r) = pure r
>
> premapM k (f <*> x) = premapM k f <*> premapM k x
-}
premapM :: Monad m => (a -> m b) -> ScanM m b r -> ScanM m a r
premapM f (ScanM step begin) = ScanM (step <=< lift . f) begin
{-# INLINABLE premapM #-}


-- Internal helpers (not exported)
newtype ReverseState s a = ReverseState
  { runReverseState :: s -> (a, s)
  }

instance Functor (ReverseState s) where
  fmap f (ReverseState m) =
    ReverseState $ \s ->
      let (v, s') = m s
      in (f v, s')
  {-# INLINE fmap #-}

instance Applicative (ReverseState s) where
  pure = ReverseState #. (,)
  {-# INLINE pure #-}

  mf <*> mx =
    ReverseState $ \s ->
      let (f, s2) = runReverseState mf s1
          (x, s1) = runReverseState mx s
      in (f x, s2)
  {-# INLINE (<*>) #-}

#if MIN_VERSION_base(4, 10, 0)
  -- 'liftA2' was moved to the 'Applicative' class in base 4.10.0.0
  liftA2 f mx my =
    ReverseState $ \s ->
      let (x, s2) = runReverseState mx s1
          (y, s1) = runReverseState my s
      in (f x y, s2)
  {-# INLINE liftA2 #-}
#endif


#if MIN_VERSION_base(4, 7, 0)
-- | This is same as normal function composition, except slightly more efficient. The same trick is used in base <http://hackage.haskell.org/package/base-4.11.1.0/docs/src/Data.Functor.Utils.html#%23.> and lens <http://hackage.haskell.org/package/lens-4.17/docs/Control-Lens-Internal-Coerce.html#v:-35-..>
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
(#.) _ = coerce
#else
(#.) :: (b -> c) -> (a -> b) -> (a -> c)
(#.) = (.)
#endif

infixr 9 #.
{-# INLINE (#.) #-}