regexlogic.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module Main where

import Data.String
import Data.Monoid hiding (Alt)
import Control.Applicative
import Control.Monad.Logic

data Regex = Empty              -- The empty string
           | Lit Char           -- Character literals
           | Concat Regex Regex -- Concatenation of two regexs
           | Alt    Regex Regex -- Choice between two regexs
           | Kleene Regex       -- The Kleene star
           deriving Show

instance Monoid Regex where
  mempty        = Empty
  a `mappend` b = Concat a b

instance IsString Regex where fromString x = mconcat $ map Lit x

produceAll' :: Applicative f => (f String -> f String -> f String) -> Regex -> f String
produceAll' _x Empty          = pure ""
produceAll' _x (Lit s)        = pure [s]
produceAll'  x (Alt r1 r2)    = produceAll' x r1 `x` produceAll' x r2
produceAll'  x (Concat r1 r2) = (<|>) <$> produceAll' x r1 <*> produceAll' x r2
produceAll'  x (Kleene r)     = produceAll' x $ foldr (Alt . mconcat . flip replicate r) Empty [0..]

produceAll :: MonadLogic f => Regex -> f String
produceAll = produceAll' interleave

main :: IO ()
main = do
  print $ take                 14 $ produceAll' (<|>) (Alt (Kleene (Lit 'a')) (Lit 'b'))
  print $ observeMany          14 $ produceAll        (Alt (Kleene (Lit 'a')) (Lit 'b'))
  mapM_ putStrLn $ observeMany 14 $ produceAll $ (Kleene (Alt "snuggy" "buggy")) <> "bug"