Fold like thing with termination

Fold.hs

-- The idea is to compose fold like things that can terminate. This is primarily so I can 
-- make a Alternative instance that returns the first finished fold.
-- I copied much of this from foldl and folds but unlike those libraries you cannot call the `extractor` until the 
-- fold is finished.

data StepState = Running | Finished
  deriving (Eq, Show, Ord, Read, Generic)

anyFinished :: StepState -> StepState -> StepState
anyFinished x y = case (x, y) of
  (Running, a) -> a
  (a, Running) -> a
  (Finished, Finished) -> Finished

anyRunning :: StepState -> StepState -> StepState
anyRunning x y = case (x, y) of
  (Finished, a) -> a
  (a, Finished) -> a
  (Running, Running)  -> Running

data FoldStep e r = forall s. FoldStep
  { internalState :: s
  , update :: s -> e -> (StepState, s)
  , extractor :: s -> r
  }

instance Functor (FoldStep e) where
  fmap f (FoldStep a b e) = FoldStep
    { internalState = a
    , update = b
    , extractor = f . e
    }

instance Applicative (FoldStep e) where
  pure x = FoldStep () (const $ const (Finished, ())) (const x)
  FoldStep fState fUpdate fExtractor <*> FoldStep xState xUpdate xExtractor = FoldStep
    { internalState = Pair fState xState
    , update = \(Pair newFState newXState) e ->
        let (fRunning, fNextState) = fUpdate newFState e
            (xRunning, xNextState) = xUpdate newXState e
        in (anyRunning fRunning xRunning, Pair fNextState xNextState)
    , extractor = \(Pair newFState newXState) ->
        fExtractor newFState $ xExtractor newXState
    }

instance Alternative (FoldStep e) where
  empty = FoldStep () (\_ _ -> (Running, ())) (\_ -> undefined)
  FoldStep xState xUpdate xExtractor <|> FoldStep yState yUpdate yExtractor = FoldStep
    { internalState = Pair (Running, xState) (Running, yState)
    , update = \(Pair (_, newXState) (_, newYState)) e ->
        let (xRunning, xNextState) = xUpdate newXState e
            (yRunning, yNextState) = yUpdate newYState e
        in (anyFinished xRunning yRunning, Pair (xRunning, xNextState) (yRunning, yNextState))
    , extractor = \(Pair (xRunning, newXState) (yRunning, newYState)) -> case (xRunning, yRunning) of
        (Finished, _) -> xExtractor newXState
        (_, Finished) -> yExtractor newYState
        _ -> error "tried to extract from an unfinished fold"
    }