Match.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ApplicativeDo #-}

module Descript.BasicInj.Process.Reduce.Match
  ( Match (..)
  , MatchT (..)
  , emptyMatch
  , matchAgain
  , matchAgainF
  , mapLeftover
  , bimapMatch
  ) where

import Data.Semigroup

-- | The result of successfully matching an input value (or other
-- expression - whatever @a@ is) on a regular value.
data Match a
  = Match
  { matched :: a -- ^ Part of the value the input matched/consumed.
  , leftover :: a -- ^ Part of the value the input didn't match/consume.
  } deriving (Functor)

-- | Turns 'Match' (and 'MatchA') into a transformer.
newtype MatchT u a = MatchT{ runMatchT :: u (Match a) } deriving (Functor)

instance Applicative Match where
  pure x
    = Match
    { matched = x
    , leftover = x
    }
  f <*> x
    = Match
    { matched = matched f $ matched x
    , leftover = leftover f $ leftover x
    }

instance (Applicative u) => Applicative (MatchT u) where
  pure = MatchT . pure . pure
  MatchT f <*> MatchT x = MatchT $ (<*>) <$> f <*> x

-- | A 'Match' with no 'matched' and the given value as 'leftover'.
-- A match with an empty input.
emptyMatch :: (Monoid a) => a -> Match a
emptyMatch x
  = Match
  { matched = mempty
  , leftover = x
  }

-- | Applies the matching function on the old 'leftover', returns a
-- 'Match' with the old and new 'matched' combined and the new 'leftover'.
matchAgain :: (Semigroup a) => (a -> Match a) -> Match a -> Match a
matchAgain f old
  = Match
  { matched = matched old <> matched new
  , leftover = leftover new
  }
  where new = f $ leftover old

-- | 'matchAgain' with a side effect.
matchAgainF :: (Semigroup a, Functor w) => (a -> w (Match a)) -> Match a -> w (Match a)
matchAgainF f old = do
  new <- f $ leftover old
  pure Match
    { matched = matched old <> matched new
    , leftover = leftover new
    }

-- | Transforms the 'leftover'.
mapLeftover :: (a -> a) -> Match a -> Match a
mapLeftover f x
  = Match
  { matched = matched x
  , leftover = f $ leftover x
  }

-- | Transforms 'matched' with the first function and 'leftover' with
-- the second.
bimapMatch :: (a -> b) -> (a -> b) -> Match a -> Match b
bimapMatch fMatched fLeftover x
  = Match
  { matched = fMatched $ matched x
  , leftover = fLeftover $ leftover x
  }