{-# LANGUAGE DerivingVia #-}
module Otter.Rule where
import Data.Bifunctor (bimap)
import Control.Monad (MonadPlus(..))
import Control.Monad.Fail (MonadFail(..))
import Control.Applicative (Alternative(..), WrappedMonad(..))
newtype Rule a b = Rule { unRule :: Maybe (Either b (a -> Rule a b)) }
deriving (Functor, Applicative) via WrappedMonad (Rule a)
type ProperRule a b = a -> Rule a b
match :: (a -> Maybe b) -> Rule a b
match p = Rule . Just . Right $ Rule . fmap Left . p
apply :: ProperRule a b -> a -> ([b], [ProperRule a b])
apply f = maybe mempty (either ((,[]) . pure) (([],) . pure)) . unRule . f
instance Monad (Rule a) where
return = Rule . Just . Left
(Rule rel) >>= f =
Rule $ rel >>= either (unRule . f) (Just . Right . fmap (>>= f))
instance Alternative (Rule a) where
empty = Rule Nothing
(Rule Nothing) <|> rel = rel
rel <|> _ = rel
instance MonadPlus (Rule a) where
instance MonadFail (Rule a) where
fail _ = Rule Nothing
arrowDimap :: (a -> b) -> (c -> d) -> (b -> c) -> (a -> d)
arrowDimap f g h x = g (h (f x))
relDimap :: (a -> b) -> (c -> d) -> Rule b c -> Rule a d
relDimap f g = Rule . fmap (bimap g (arrowDimap f (relDimap f g))) . unRule