Regex.hs

module Regex where

import Control.Applicative
import Data.Profunctor

data Regex c a = Regex (Maybe a) (c -> Regex c a)

instance Functor (Regex c) where
  fmap f (Regex xm xr) = Regex (fmap f xm) (fmap f . xr)

instance Applicative (Regex c) where
  pure a = Regex (Just a) (\_ -> empty)
  Regex fm fr <*> rx = case fm of
    Nothing -> Regex Nothing (\c -> fr c <*> rx)
    Just f -> (f <$> rx) <|> Regex Nothing (\c -> fr c <*> rx)

instance Alternative (Regex c) where
  empty = Regex Nothing (\_ -> empty)
  Regex xm xr <|> Regex ym yr = Regex (xm <|> ym) (\c -> xr c <|> yr c)

(<&>) :: Regex c a -> Regex c b -> Regex c (a, b)
Regex xm xr <&> Regex ym yr = Regex (liftA2 (,) xm ym) (\c -> xr c <&> yr c)

always :: a -> Regex c a
always a = Regex (Just a) (\_ -> always a)

invert :: Regex c a -> Regex c ()
invert (Regex Nothing xr) = Regex (Just ()) (invert . xr)
invert (Regex (Just _) xr) = Regex Nothing (invert . xr)

match :: Regex c a -> [c] -> Maybe a
match (Regex xm _) [] = xm
match (Regex _ xr) (c:cs) = match (xr c) cs

anytoken :: Regex c c
anytoken = Regex Nothing pure

tokenBy :: (c -> Bool) -> Regex c c
tokenBy p = Regex Nothing (\c -> if p c then pure c else empty)

token :: Eq c => c -> Regex c c
token c = tokenBy (== c)

tokens :: Eq c => [c] -> Regex c [c]
tokens = traverse token

instance Profunctor Regex where
  dimap l r (Regex xm xr) = Regex (fmap r xm) (\c -> dimap l r (xr (l c)))

instance Choice Regex where
  left' (Regex xm xr) = Regex (fmap Left xm) go
    where
      go (Left c) = left' (xr c)
      go (Right c) = Regex (Just (Right c)) go