1{-# LANGUAGE ExistentialQuantification, TypeOperators #-} 2 3module LeftFold where 4 5import Control.Applicative 6import Data.List 7import Data.Monoid 8import Data.Strict ((:!:), Pair((:!:))) 9import qualified Data.Strict as S 10import qualified Data.Map.Strict as M 11import Data.Maybe 12 13 14data LeftFold x a = forall s. LeftFold { 15 start :: s, 16 process :: s -> x -> s, 17 finish :: s -> a 18 } 19 -- We keep things pure for as long as possible, to avoid constructing pairs 20 -- in <*> when not needed. Some of the more advanced code below (e.g. 21 -- intervals) is not properly tested with pure LeftFolds. 22 | Pure a 23 24leftFold :: a -> (a -> x -> a) -> LeftFold x a 25leftFold s p = LeftFold s p id 26 27instance Functor (LeftFold x) where 28 fmap f (Pure x) = Pure (f x) 29 fmap f (LeftFold st1 p1 f2) = LeftFold st1 p1 (f . f2) 30 31instance Applicative (LeftFold x) where 32 pure x = Pure x 33 Pure f <*> c = f <$> c 34 LeftFold st1 p1 f1 <*> Pure x = LeftFold st1 p1 (\s -> f1 s x) 35 LeftFold st1 p1 f1 <*> LeftFold st2 p2 f2 = LeftFold { 36 start = st1 :!: st2, 37 process = \(s1 :!: s2) x -> p1 s1 x :!: p2 s2 x, 38 finish = \(s1 :!: s2) -> f1 s1 (f2 s2) 39 } 40 41runLeftFold :: LeftFold x a -> [x] -> a 42runLeftFold (Pure x) _ = x 43runLeftFold (LeftFold st1 p1 f1) xs = f1 $! foldl' p1 st1 xs 44 45monoidFold :: Monoid m => LeftFold m m 46monoidFold = leftFold mempty mappend 47 48mapElems :: LeftFold y a -> (x -> y) -> LeftFold x a 49mapElems (Pure x) _ = (Pure x) 50mapElems (LeftFold s p f) t = LeftFold s (\s x -> p s $! t x) f 51 52filterElems :: (x -> Bool) -> LeftFold x a -> LeftFold x a 53filterElems _ (Pure x) = (Pure x) 54filterElems pred (LeftFold s p f) = LeftFold s (\s x -> if pred x then p s x else s) f 55 56adjoin :: (x -> Bool) -> LeftFold (Bool :!: x) a -> LeftFold x a 57adjoin p f = f `mapElems` (\x -> (p x :!: x)) 58 59 60onSelected :: LeftFold x a -> LeftFold (Bool :!: x) a 61onSelected (Pure x) = Pure x 62onSelected (LeftFold s p f) = LeftFold s (\s (b :!: x) -> if b then p s x else s) f 63 64onJusts :: LeftFold x a -> LeftFold (Maybe x) a 65onJusts (Pure x) = Pure x 66onJusts (LeftFold s p f) = LeftFold s (\s mx -> maybe s (p s) mx) f 67 68onAll :: LeftFold x a -> LeftFold (Bool :!: x) a 69onAll (Pure x) = Pure x 70onAll lf = lf `mapElems` S.snd 71 72runOnGroups :: (x -> x -> Bool) -> LeftFold x y -> LeftFold y z -> LeftFold x z 73runOnGroups eq _ (Pure ox) = Pure ox 74runOnGroups eq (Pure ix) (LeftFold sto po fo) = LeftFold (S.Nothing :!: sto) go finish 75 where go (S.Nothing :!: so) x = (S.Just x :!: so) 76 go (S.Just x' :!: so) x | x' `eq` x = (S.Just x :!: so) 77 | otherwise = (S.Just x :!: po so ix) 78 finish (S.Nothing :!: so) = fo so 79 finish (S.Just _ :!: so) = fo (po so ix) 80runOnGroups eq (LeftFold sti pi fi) (LeftFold sto po fo) = LeftFold (S.Nothing :!: sti :!: sto) go finish 81 where go (S.Nothing :!: si :!: so) x = (S.Just x :!: pi si x :!: so) 82 go (S.Just x' :!: si :!: so) x | x' `eq` x = (S.Just x :!: pi si x :!: so) 83 | otherwise = (S.Just x :!: pi sti x :!: po so (fi si)) 84 finish (S.Nothing :!: si :!: so) = fo so 85 finish (S.Just _ :!: si :!: so) = fo (po so (fi si)) 86 87runOnIntervals :: LeftFold x y -> LeftFold y z -> LeftFold (Bool :!: x) z 88runOnIntervals _ (Pure ox) = (Pure ox) 89runOnIntervals (Pure ix) (LeftFold so po fo) = LeftFold (False :!: S.Nothing) go finish 90 where go (True :!: so) (True :!: x) = (True :!: so) 91 go (True :!: S.Just so) (False :!: x) = (False :!: S.Just (po so ix)) 92 go (True :!: S.Nothing) (False :!: x) = (False :!: S.Just (po so ix)) 93 go (False :!: so) (True :!: x) = (True :!: so) 94 go (False :!: so) (False :!: x) = (False :!: so) 95 finish (False :!: S.Just so) = fo so 96 finish (False :!: S.Nothing) = fo so 97 finish (True :!: S.Just so) = fo (po so ix) 98 finish (True :!: S.Nothing) = fo (po so ix) 99runOnIntervals (LeftFold si pi fi) (LeftFold so po fo) = LeftFold (S.Nothing :!: S.Nothing) go finish 100 where go (S.Just si :!: so) (True :!: x) = (S.Just (pi si x) :!: so) 101 go (S.Just si :!: S.Just so) (False :!: x) = (S.Nothing :!: S.Just (po so $! fi si)) 102 go (S.Just si :!: S.Nothing) (False :!: x) = (S.Nothing :!: S.Just (po so $! fi si)) 103 go (S.Nothing :!: so) (True :!: x) = (S.Just (pi si x) :!: so) 104 go (S.Nothing :!: so) (False :!: x) = (S.Nothing :!: so) 105 finish (S.Nothing :!: S.Just so) = fo so 106 finish (S.Nothing :!: S.Nothing) = fo so 107 finish (S.Just si :!: S.Just so) = fo (po so (fi si)) 108 finish (S.Just si :!: S.Nothing) = fo (po so (fi si)) 109 110multiplex :: Ord k => (a -> k) -> LeftFold a b -> LeftFold a (M.Map k b) 111multiplex key (LeftFold si pi fi) = LeftFold M.empty go finish 112 where go m x = M.alter go' (key x) m 113 where go' mbOld = Just $ pi (fromMaybe si mbOld) x 114 finish = M.map fi 115 116lfLength :: LeftFold x Int 117lfLength = leftFold 0 (\c _ -> c + 1) 118 119lfFirst :: LeftFold x (Maybe x) 120lfFirst = getFirst <$> monoidFold `mapElems` (First . Just) 121 122lfLast :: LeftFold x (Maybe x) 123lfLast = getLast <$> monoidFold `mapElems` (Last . Just) 124 125toList :: LeftFold x [x] 126toList = LeftFold [] (flip (:)) reverse 127 128concatFold :: LeftFold [x] [x] 129concatFold = concat <$> toList 130 131