windowed scanl -- by request, untested

MonoidallyAnnotatedEphemeralQueue.hs

-- This is just a reference for how a "proper" monoidally-annotated queue would look.

{-# language PatternSynonyms #-}
{-# language ViewPatterns #-}
{-# language TypeFamilies #-}
{-# language FlexibleContexts #-}

class Monoid (M a) => Measured a where
  type M a :: *
  measure :: a -> M a

data Q a = Q (F a) (M a) [a]

data F a = CONSF (M a) a (F a) | Nil

instance Measured a => Measured (F a) where
  type M (F a) = M a
  measure (CONSF m _ _) = m
  measure _ = mempty

pattern ConsF :: Measured a => a -> F a -> F a
pattern ConsF h t <- CONSF _ h t where
  ConsF h t = CONSF (measure h <> measure t) h t

snocQ :: Measured a => Q a -> a -> Q a
snocQ (Q f m r) a = Q f (m <> measure a) (a:r)

instance Measured a => Measured (Q a) where
  type M (Q a) = M a
  measure (Q f m r) = measure f <> m

rev :: Measured a => F a -> [a] -> F a
rev acc [] = acc
rev acc (x:xs) = rev (ConsF x acc) xs

unconsQ :: Measured a => Q a -> Maybe (a, Q a)
unconsQ (Q Nil _ rs) = case rev Nil rs of
  Nil -> Nothing
  ConsF h t -> Just (h, Q t mempty [])
unconsQ (Q (ConsF h t) m rs) = Just (h, Q t m rs)

pattern ConsQ :: Measured a => a -> Q a -> Q a
pattern ConsQ h t <- (unconsQ -> Just (h, t)) where
  ConsQ a (Q f m r) = Q (ConsF a f) m r

WindowedScanl.hs

-- This version is stripped down to just what is needed for the operation of a windowed scan

data Q a = Q [a] a [a]

measure :: Semigroup a => Q a -> a
measure (Q (h:_) m _) = h <> m
measure (Q [] m _) = m

nil :: Monoid a => Q a
nil = Q [] mempty []

consF :: Monoid a => a -> [a] -> [a]
consF a bs@(b:_) = (a <> b) : bs
consF a [] = [a]

cons :: Monoid a => a -> Q a -> Q a
cons a (Q f m r) = Q (consF a f) m r

snoc :: Monoid a => Q a -> a -> Q a
snoc (Q f m r) a = Q f (m <> a) (a:r)

pop :: Monoid a => Q a -> Q a
pop (Q [] _ rs) = case rev [] rs of
  [] -> nil
  _:as -> Q as mempty []
pop (Q (_:f) m r) = Q f m r

rev :: Monoid a => [a] -> [a] -> [a]
rev acc [] = acc
rev acc (x:xs) = rev (consF x acc) xs

scanlm :: Monoid m => (a -> m) -> [a] -> [m]
scanlm f = scanl (\b a -> b <> f a) mempty

wscanlm :: Monoid m => Int -> (a -> m) -> [a] -> [m]
wscanlm n f as = scanlm f hs ++ go (foldr (\a q -> cons (f a) q) nil hs) ts where
  (hs, ts) = splitAt n as
  go q [] = []
  go q (x:xs) = measure q' : go q' xs where
    q' = pop (snoc q (f x))

-- main = print $ wscanlm 3 Sum [1..10]