-- |
-- Copyright: Edward Kmett, Oleg Grenrus
-- License: BSD-3-Clause
--
-- A class of non-empty data structures that can be folded to a summary value.
--
-- @since 4.18.0.0

{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE Trustworthy                #-}
{-# LANGUAGE TypeOperators              #-}

module Data.Foldable1 (
    Foldable1(..),
    foldr1, foldr1',
    foldl1, foldl1',
    intercalate1,
    foldrM1,
    foldlM1,
    foldrMapM1,
    foldlMapM1,
    maximumBy,
    minimumBy,
    ) where
import Data.Foldable      (Foldable, foldlM, foldr)
import Data.List          ([](..), foldl, foldl')
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
import Data.Semigroup
import Data.Tuple (Solo (..))
import Prelude
       (Maybe (..), Monad (..), Ord, Ordering (..), id, seq, ($!), ($), (.),
       (=<<), flip, const, error)

import qualified Data.List.NonEmpty as NE

import Data.Complex (Complex (..))

import Data.Ord (Down (..))

import qualified Data.Monoid as Mon

-- Instances
import Data.Functor.Compose          (Compose (..))
import Data.Functor.Identity         (Identity (..))

import qualified Data.Functor.Product as Functor
import qualified Data.Functor.Sum     as Functor

-- coerce
--import GHC.Internal.Data.Coerce (Coercible, coerce)

-- $setup
-- >>> import Prelude hiding (foldr1, foldl1, head, last, minimum, maximum)

-------------------------------------------------------------------------------
-- Foldable1 type class
-------------------------------------------------------------------------------

-- | Non-empty data structures that can be folded.
--
-- @since 4.18.0.0
class Foldable t => Foldable1 t where
    {-# MINIMAL foldMap1 | foldrMap1 #-}

    -- At some point during design it was possible to define this class using
    -- only 'toNonEmpty'. But it seems a bad idea in general.
    --
    -- So currently we require either foldMap1 or foldrMap1
    --
    -- * foldMap1 defined using foldrMap1
    -- * foldrMap1 defined using foldMap1
    --
    -- One can always define an instance using the following pattern:
    --
    --     toNonEmpty = ...
    --     foldMap f     = foldMap f     . toNonEmpty
    --     foldrMap1 f g = foldrMap1 f g . toNonEmpty

    -- | Given a structure with elements whose type is a 'Semigroup', combine
    -- them via the semigroup's @('<>')@ operator. This fold is
    -- right-associative and lazy in the accumulator. When you need a strict
    -- left-associative fold, use 'foldMap1'' instead, with 'id' as the map.
    --
    -- @since 4.18.0.0
    fold1 :: Semigroup m => t m -> m
    fold1 = foldMap1 id

    -- | Map each element of the structure to a semigroup, and combine the
    -- results with @('<>')@. This fold is right-associative and lazy in the
    -- accumulator. For strict left-associative folds consider 'foldMap1''
    -- instead.
    --
    -- >>> foldMap1 (:[]) (1 :| [2, 3, 4])
    -- [1,2,3,4]
    --
    -- @since 4.18.0.0
    foldMap1 :: Semigroup m => (a -> m) -> t a -> m
    foldMap1 f = foldrMap1 f (\a m -> f a <> m)

    -- | A left-associative variant of 'foldMap1' that is strict in the
    -- accumulator. Use this for strict reduction when partial results are
    -- merged via @('<>')@.
    --
    -- >>> foldMap1' Sum (1 :| [2, 3, 4])
    -- Sum {getSum = 10}
    --
    -- @since 4.18.0.0
    foldMap1' :: Semigroup m => (a -> m) -> t a -> m
    foldMap1' f = foldlMap1' f (\m a -> m <> f a)

    -- | 'NonEmpty' list of elements of a structure, from left to right.
    --
    -- >>> toNonEmpty (Identity 2)
    -- 2 :| []
    --
    -- @since 4.18.0.0
    toNonEmpty :: t a -> NonEmpty a
    toNonEmpty = runNonEmptyDList . foldMap1 singleton

    -- | The largest element of a non-empty structure.
    --
    -- >>> maximum (32 :| [64, 8, 128, 16])
    -- 128
    --
    -- @since 4.18.0.0
    maximum :: Ord a => t a -> a
    maximum = getMax . foldMap1' Max

    -- | The least element of a non-empty structure.
    --
    -- >>> minimum (32 :| [64, 8, 128, 16])
    -- 8
    --
    -- @since 4.18.0.0
    minimum :: Ord a => t a -> a
    minimum = getMin . foldMap1' Min

    -- | The first element of a non-empty structure.
    --
    -- >>> head (1 :| [2, 3, 4])
    -- 1
    --
    -- @since 4.18.0.0
    head :: t a -> a
    head = getFirst . foldMap1 First

    -- | The last element of a non-empty structure.
    --
    -- >>> last (1 :| [2, 3, 4])
    -- 4
    --
    -- @since 4.18.0.0
    last :: t a -> a
    last = getLast . foldMap1 Last

    -- | Right-associative fold of a structure, lazy in the accumulator.
    --
    -- In case of 'NonEmpty' lists, 'foldrMap1', when given a function @f@, a
    -- binary operator @g@, and a list, reduces the list using @g@ from right to
    -- left applying @f@ to the rightmost element:
    --
    -- > foldrMap1 f g (x1 :| [x2, ..., xn1, xn]) == x1 `g` (x2 `g` ... (xn1 `g` (f xn))...)
    --
    -- Note that since the head of the resulting expression is produced by
    -- an application of @g@ to the first element of the list, if @g@ is lazy
    -- in its right argument, 'foldrMap1' can produce a terminating expression
    -- from an unbounded list.
    --
    -- For a general 'Foldable1' structure this should be semantically identical
    -- to:
    --
    -- @foldrMap1 f g = foldrMap1 f g . 'toNonEmpty'@
    --
    -- @since 4.18.0.0
    foldrMap1 :: (a -> b) -> (a -> b -> b) -> t a -> b
    foldrMap1 f g xs =
        appFromMaybe (foldMap1 (FromMaybe . h) xs) Nothing
      where
        h a Nothing  = f a
        h a (Just b) = g a b

    -- | Left-associative fold of a structure but with strict application of the
    -- operator.
    --
    -- This ensures that each step of the fold is forced to Weak Head Normal
    -- Form before being applied, avoiding the collection of thunks that would
    -- otherwise occur. This is often what you want to strictly reduce a
    -- finite structure to a single strict result.
    --
    -- For a general 'Foldable1' structure this should be semantically identical
    -- to:
    --
    -- @foldlMap1' f z = foldlMap1' f z . 'toNonEmpty'@
    --
    -- @since 4.18.0.0
    foldlMap1' :: (a -> b) -> (b -> a -> b) -> t a -> b
    foldlMap1' f g xs =
        foldrMap1 f' g' xs SNothing
      where
        -- f' :: a -> SMaybe b -> b
        f' a SNothing  = f a
        f' a (SJust b) = g b a

        -- g' :: a -> (SMaybe b -> b) -> SMaybe b -> b
        g' a x SNothing  = x $! SJust (f a)
        g' a x (SJust b) = x $! SJust (g b a)

    -- | Left-associative fold of a structure, lazy in the accumulator.  This is
    -- rarely what you want, but can work well for structures with efficient
    -- right-to-left sequencing and an operator that is lazy in its left
    -- argument.
    --
    -- In case of 'NonEmpty' lists, 'foldlMap1', when given a function @f@, a
    -- binary operator @g@, and a list, reduces the list using @g@ from left to
    -- right applying @f@ to the leftmost element:
    --
    -- > foldlMap1 f g (x1 :| [x2, ..., xn]) == (...(((f x1) `g` x2) `g`...) `g` xn
    --
    -- Note that to produce the outermost application of the operator the entire
    -- input list must be traversed. This means that 'foldlMap1' will diverge if
    -- given an infinite list.
    --
    -- If you want an efficient strict left-fold, you probably want to use
    -- 'foldlMap1''  instead of 'foldlMap1'. The reason for this is that the
    -- latter does not force the /inner/ results (e.g. @(f x1) \`g\` x2@ in the
    -- above example) before applying them to the operator (e.g. to
    -- @(\`g\` x3)@). This results in a thunk chain \(O(n)\) elements long,
    -- which then must be evaluated from the outside-in.
    --
    -- For a general 'Foldable1' structure this should be semantically identical
    -- to:
    --
    -- @foldlMap1 f g = foldlMap1 f g . 'toNonEmpty'@
    --
    -- @since 4.18.0.0
    foldlMap1 :: (a -> b) -> (b -> a -> b) -> t a -> b
    foldlMap1 f g xs =
        appFromMaybe (getDual (foldMap1 ((Dual . FromMaybe) . h) xs)) Nothing
      where
        h a Nothing  = f a
        h a (Just b) = g b a

    -- | 'foldrMap1'' is a variant of 'foldrMap1' that performs strict reduction
    -- from right to left, i.e. starting with the right-most element. The input
    -- structure /must/ be finite, otherwise 'foldrMap1'' runs out of space
    -- (/diverges/).
    --
    -- If you want a strict right fold in constant space, you need a structure
    -- that supports faster than \(O(n)\) access to the right-most element.
    --
    -- This method does not run in constant space for structures such as
    -- 'NonEmpty' lists that don't support efficient right-to-left iteration and
    -- so require \(O(n)\) space to perform right-to-left reduction. Use of this
    -- method with such a structure is a hint that the chosen structure may be a
    -- poor fit for the task at hand. If the order in which the elements are
    -- combined is not important, use 'foldlMap1'' instead.
    --
    -- @since 4.18.0.0
    foldrMap1' :: (a -> b) -> (a -> b -> b) -> t a -> b
    foldrMap1' f g xs =
        foldlMap1 f' g' xs SNothing
      where
        f' a SNothing  = f a
        f' a (SJust b) = g a b

        g' bb a SNothing  = bb $! SJust (f a)
        g' bb a (SJust b) = bb $! SJust (g a b)

-------------------------------------------------------------------------------
-- Combinators
-------------------------------------------------------------------------------

-- | A variant of 'foldrMap1' where the rightmost element maps to itself.
--
-- @since 4.18.0.0
foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a
foldr1 = foldrMap1 id
{-# INLINE foldr1 #-}

-- | A variant of 'foldrMap1'' where the rightmost element maps to itself.
--
-- @since 4.18.0.0
foldr1' :: Foldable1 t => (a -> a -> a) -> t a -> a
foldr1' = foldrMap1' id
{-# INLINE foldr1' #-}

-- | A variant of 'foldlMap1' where the leftmost element maps to itself.
--
-- @since 4.18.0.0
foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a
foldl1 = foldlMap1 id
{-# INLINE foldl1 #-}

-- | A variant of 'foldlMap1'' where the leftmost element maps to itself.
--
-- @since 4.18.0.0
foldl1' :: Foldable1 t => (a -> a -> a) -> t a -> a
foldl1' = foldlMap1' id
{-# INLINE foldl1' #-}

-- | Insert an @m@ between each pair of @t m@.
--
-- >>> intercalate1 ", " $ "hello" :| ["how", "are", "you"]
-- "hello, how, are, you"
--
-- >>> intercalate1 ", " $ "hello" :| []
-- "hello"
--
-- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"]
-- "IAmFineYou?"
--
-- @since 4.18.0.0
intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m
intercalate1 = flip intercalateMap1 id

intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m
intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f)

-- | Monadic fold over the elements of a non-empty structure,
-- associating to the right, i.e. from right to left.
--
-- @since 4.18.0.0
foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a
foldrM1 = foldrMapM1 return

-- | Map variant of 'foldrM1'.
--
-- @since 4.18.0.0
foldrMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (a -> b -> m b) -> t a -> m b
foldrMapM1 g f = go . toNonEmpty
  where
    go (e:|es) =
      case es of
        []   -> g e
        x:xs -> f e =<< go (x:|xs)

-- | Monadic fold over the elements of a non-empty structure,
-- associating to the left, i.e. from left to right.
--
-- @since 4.18.0.0
foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a
foldlM1 = foldlMapM1 return

-- | Map variant of 'foldlM1'.
--
-- @since 4.18.0.0
foldlMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (b -> a -> m b) -> t a -> m b
foldlMapM1 g f t = g x >>= \y -> foldlM f y xs
  where x:|xs = toNonEmpty t

-- | The largest element of a non-empty structure with respect to the
-- given comparison function.
--
-- @since 4.18.0.0
maximumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a
maximumBy cmp = foldl1' max'
  where max' x y = case cmp x y of
                        GT -> x
                        _  -> y

-- | The least element of a non-empty structure with respect to the
-- given comparison function.
--
-- @since 4.18.0.0
minimumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a
minimumBy cmp = foldl1' min'
  where min' x y = case cmp x y of
                        GT -> y
                        _  -> x

-------------------------------------------------------------------------------
-- Auxiliary types
-------------------------------------------------------------------------------

-- | Used for default toNonEmpty implementation.
newtype NonEmptyDList a = NEDL { unNEDL :: [a] -> NonEmpty a }

instance Semigroup (NonEmptyDList a) where
  xs <> ys = NEDL (unNEDL xs . NE.toList . unNEDL ys)
  {-# INLINE (<>) #-}

-- | Create dlist with a single element
singleton :: a -> NonEmptyDList a
singleton = NEDL . (:|)

-- | Convert a dlist to a non-empty list
runNonEmptyDList :: NonEmptyDList a -> NonEmpty a
runNonEmptyDList = ($ []) . unNEDL
{-# INLINE runNonEmptyDList #-}

-- | Used for foldrMap1 and foldlMap1 definitions
newtype FromMaybe b = FromMaybe { appFromMaybe :: Maybe b -> b }

instance Semigroup (FromMaybe b) where
    FromMaybe f <> FromMaybe g = FromMaybe (f . Just . g)

-- | Strict maybe, used to implement default foldlMap1' etc.
data SMaybe a = SNothing | SJust !a

-- | Used to implement intercalate1/Map
newtype JoinWith a = JoinWith {joinee :: (a -> a)}

instance Semigroup a => Semigroup (JoinWith a) where
  JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j

-------------------------------------------------------------------------------
-- Instances for misc base types
-------------------------------------------------------------------------------

-- | @since 4.18.0.0
instance Foldable1 NonEmpty where
    foldMap1 f (x :| xs) = go (f x) xs where
        go y [] = y
        go y (z : zs) = y <> go (f z) zs

    foldMap1' f (x :| xs) = foldl' (\m y -> m <> f y) (f x) xs

    toNonEmpty = id

    foldrMap1 g f (x :| xs) = go x xs where
        go y [] = g y
        go y (z : zs) = f y (go z zs)

    foldlMap1  g f (x :| xs) = foldl f (g x) xs
    foldlMap1' g f (x :| xs) = let gx = g x in gx `seq` foldl' f gx xs

    head = NE.head
    last = NE.last

{-
-- | @since 4.18.0.0
instance Foldable1 Down where
    foldMap1 = coerce

-- | @since 4.18.0.0
instance Foldable1 Complex where
    foldMap1 f (x :+ y) = f x <> f y

    toNonEmpty (x :+ y) = x :| y : []

-------------------------------------------------------------------------------
-- Instances for tuples
-------------------------------------------------------------------------------

-- 3+ tuples are not Foldable/Traversable

-- | @since 4.18.0.0
instance Foldable1 Solo where
    foldMap1 f (MkSolo y) = f y
    toNonEmpty (MkSolo x) = x :| []
    minimum (MkSolo x) = x
    maximum (MkSolo x) = x
    head (MkSolo x) = x
    last (MkSolo x) = x

-- | @since 4.18.0.0
instance Foldable1 ((,) a) where
    foldMap1 f (_, y) = f y
    toNonEmpty (_, x) = x :| []
    minimum (_, x) = x
    maximum (_, x) = x
    head (_, x) = x
    last (_, x) = x
-}

-------------------------------------------------------------------------------
-- Monoid / Semigroup instances
-------------------------------------------------------------------------------

{-
-- | @since 4.18.0.0
instance Foldable1 Dual where
    foldMap1 = coerce

-- | @since 4.18.0.0
instance Foldable1 Sum where
    foldMap1 = coerce

-- | @since 4.18.0.0
instance Foldable1 Product where
    foldMap1 = coerce

-- | @since 4.18.0.0
instance Foldable1 Min where
    foldMap1 = coerce

-- | @since 4.18.0.0
instance Foldable1 Max where
    foldMap1 = coerce

-- | @since 4.18.0.0
instance Foldable1 First where
    foldMap1 = coerce

-- | @since 4.18.0.0
instance Foldable1 Last where
    foldMap1 = coerce

-- | @since 4.18.0.0
deriving instance (Foldable1 f) => Foldable1 (Mon.Alt f)

-- | @since 4.18.0.0
deriving instance (Foldable1 f) => Foldable1 (Mon.Ap f)
-}

-------------------------------------------------------------------------------
-- Extra instances
-------------------------------------------------------------------------------

{-
-- | @since 4.18.0.0
instance Foldable1 Identity where
    foldMap1      = coerce

    foldrMap1  g _ = coerce g
    foldrMap1' g _ = coerce g
    foldlMap1  g _ = coerce g
    foldlMap1' g _ = coerce g

    toNonEmpty (Identity x) = x :| []

    last    = coerce
    head    = coerce
    minimum = coerce
    maximum = coerce
-}

-- | It would be enough for either half of a product to be 'Foldable1'.
-- Other could be 'Foldable'.
instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where
    foldMap1 f (Functor.Pair x y)    = foldMap1 f x <> foldMap1 f y
    foldrMap1 g f (Functor.Pair x y) = foldr f (foldrMap1 g f y) x

    head (Functor.Pair x _) = head x
    last (Functor.Pair _ y) = last y

-- | @since 4.18.0.0
instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Sum f g) where
    foldMap1 f (Functor.InL x) = foldMap1 f x
    foldMap1 f (Functor.InR y) = foldMap1 f y

    foldrMap1 g f (Functor.InL x) = foldrMap1 g f x
    foldrMap1 g f (Functor.InR y) = foldrMap1 g f y

    toNonEmpty (Functor.InL x) = toNonEmpty x
    toNonEmpty (Functor.InR y) = toNonEmpty y

    head (Functor.InL x) = head x
    head (Functor.InR y) = head y
    last (Functor.InL x) = last x
    last (Functor.InR y) = last y

    minimum (Functor.InL x) = minimum x
    minimum (Functor.InR y) = minimum y
    maximum (Functor.InL x) = maximum x
    maximum (Functor.InR y) = maximum y

-- | @since 4.18.0.0
instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where
    foldMap1 f = foldMap1 (foldMap1 f) . getCompose

    foldrMap1 f g = foldrMap1 (foldrMap1 f g) (\xs x -> foldr g x xs) . getCompose

    head = head . head . getCompose
    last = last . last . getCompose