Repro for https://github.com/Gabriella439/foldl/issues/194

foldl-repro.cabal

cabal-version:      3.0
name:               foldl-repro
version:            0.1.0.0
-- synopsis:
-- description:
license:            MIT
license-file:       LICENSE
-- author:
-- maintainer:
-- copyright:
build-type:         Simple
extra-doc-files:    CHANGELOG.md
-- extra-source-files:

common warnings
    ghc-options: -Wall

executable foldl-repro
    import:           warnings
    main-is:          Main.hs
    -- other-modules:
    -- other-extensions:
    build-depends:    
       base ^>=4.15.1.0
     , profunctors
     , semigroupoids
     , foldl
    hs-source-dirs:   .
    default-language: Haskell2010

Main.hs

{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE DerivingVia #-}

module Main where

import Control.Foldl (Fold)
import Control.Foldl qualified as Fold
import Data.Function ((&))
import Data.Profunctor
import Data.Semigroup
import Data.Semigroupoid

data Sub = Sub {subSum :: Sum Int}
  deriving stock (Show)

data Result = Result {finalInt :: Int}
  deriving stock (Show)

newtype Event = Event {unEvent :: (Sum Int)}
  deriving stock (Show, Eq, Ord)
  deriving (Num) via (Int)

-- > Fold.fold foldResult [Event 2, Event 4, Event 1, Event 0, Event 1]
-- Result {finalInt = 77}
--
-- THIS SHOULD BE @Result {finalInt = 8}@!!
main :: IO ()
main = print $ Fold.fold foldResult [Event 2, Event 4, Event 1, Event 0, Event 1]

-- | Fold a section into a sub
foldSub :: Fold Event Sub
foldSub = Sub <$> lmap unEvent Fold.mconcat

-- | split into section, then fold each section
foldResult :: Fold Event Result
foldResult =
  foldIntoSections
    &>> Fold.handles traverse (Fold.handles traverse foldSub)
    &>> Fold.foldMap subSum (\s -> s & getSum & Result)

-- | Split into sections, if an event is smaller than the previous one, start a new section.
--
-- > Fold.fold foldIntoSubs [Event 2, Event 4, Event 1, Event 0, Event 1]
--  [ [ Event
--        { unEvent = Sum {getSum = 2}
--        },
--      Event {unEvent = Sum {getSum = 4}}
--    ],
--    [Event {unEvent = Sum {getSum = 1}}],
--    [Event {unEvent = Sum {getSum = 0}}, Event {unEvent = Sum {getSum = 1}}]
--  ]
foldIntoSections :: Fold Event [[Event]]
foldIntoSections = Fold.Fold step [] (reverse . fmap reverse)
  where
    step xs el = case xs & headMay >>= headMay of
      Nothing -> [el] : xs
      Just el' -> case xs of
        [] -> [el] : xs
        (xs' : xss) ->
          if el > el'
            then (el : xs') : xss
            else [el] : xs' : xss

    headMay [] = Nothing
    headMay (x : _) = Just x

(&>>) :: Semigroupoid s => s a b -> s b c -> s a c
(&>>) = flip Data.Semigroupoid.o

-- like >>>
infixr 1 &>>