{-# LANGUAGE        StandaloneDeriving #-}
{-# LANGUAGE        FlexibleInstances  #-}
{-# LANGUAGE        OverloadedStrings  #-}
{-# LANGUAGE        OverloadedLists    #-}
{-# LANGUAGE        TypeFamilies       #-}
{-# LANGUAGE        Trustworthy        #-}
{-# OPTIONS_HADDOCK not-home           #-}

{-|
Module      : Zozo
Description : Brzozowski derivatives
Copyright   : (c) Nicklas Botö, 2020
License     : GPL-3
Maintainer  : git@nicbot.xyz
Stability   : experimental

Library for constructing, exploring, and visualizing regular expressions and their
@NFA@ form. Focusing heavily on the Brzozowski derivative
but also Thompson's construction (eventually).
-}

module Zozo
    (
        -- * Language definition
      Regex(..)
    ,

        -- * Regex constructors
      (<|>)
    , (<^>)
    , (***)
    , neg
    , (\\)
    ,

        -- ** Specialized constructors
      r
    , some
    , many
    , mayb
    , alphabet
    , unit
    , nu
    ,

        -- * Derivatives
      derive
    , (^-)

        -- * Evaluation
    , rreduce
    , eval
    , printMatching
    , match
    , (?)
    ,

        -- * Regex sets
      alpha
    , numeric
    , int
    , alphaNum
    , space
    , spaces
    , whiteSpace
    , ascii
    ,

        -- ** Set combinators
      between
    , sepBy
    , (?>)
    , (<?)
    )
where

import qualified Data.Set                      as S
import           Data.String
import           GHC.Exts                       ( IsList
                                                , Item
                                                , toList
                                                , fromList
                                                )

-- *  Language definition

-- | A simple regex lang
data Regex
        -- | The empty set
        = Nil
        -- | The empty string, \( \epsilon \)
        | Eps
        -- | A symbol as a singleton set
        | Sym   Char
        -- | Union of language sets
        -- \[ \Lambda \vee \Gamma \hspace{10pt} \Lambda,\Gamma \subseteq \Sigma^* \]
        | Union Regex Regex
        -- | Intercept of language sets
        -- \[ \Lambda \wedge \Gamma \hspace{10pt} \Lambda,\Gamma \subseteq \Sigma^* \]
        | Inter Regex Regex
        -- | Complement of language sets
        -- \[ \neg \Gamma \hspace{10pt} \Gamma \subseteq \Sigma^* \]
        | Comp  Regex
        -- | All possible concatenations
        | Conc  Regex Regex
        -- | [Kleene star operator](https://en.wikipedia.org/wiki/Kleene_star)
        | Star  Regex

instance Show Regex where
    show :: Regex -> String
show r :: Regex
r = '^' Char -> ShowS
forall a. a -> [a] -> [a]
: Regex -> String
sw Regex
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ "$"
      where
        sw :: Regex -> String
sw x :: Regex
x | Regex
x Regex -> Regex -> Bool
forall a. Eq a => a -> a -> Bool
== Regex
ascii = "."
        sw Nil              = "∅"
        sw Eps              = "ε"
        sw (Sym c :: Char
c) | [Char
Item String
c] String -> Regex -> Bool
? Regex
spec = "\\" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
Item String
c]
                   | Bool
otherwise  = [Char
Item String
c]
        sw (Union r1 :: Regex
r1 r2 :: Regex
r2) = '(' Char -> ShowS
forall a. a -> [a] -> [a]
: Regex -> String
sw Regex
r1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ "|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Regex -> String
sw Regex
r2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
        sw (Inter r1 :: Regex
r1 r2 :: Regex
r2) = '(' Char -> ShowS
forall a. a -> [a] -> [a]
: Regex -> String
sw Regex
r1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ "^" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Regex -> String
sw Regex
r2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
        sw (Conc  r1 :: Regex
r1 r2 :: Regex
r2) = Regex -> String
sw Regex
r1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ Regex -> String
sw Regex
r2
        sw (Comp r :: Regex
r     ) = "~(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Regex -> String
sw Regex
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
        sw (Star r :: Regex
r     ) = '(' Char -> ShowS
forall a. a -> [a] -> [a]
: Regex -> String
sw Regex
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")*"
        spec :: Regex
spec = [".", "(", ")", "|", "^", "~", "*", "\\"]

instance Semigroup Regex where
    <> :: Regex -> Regex -> Regex
(<>) = Regex -> Regex -> Regex
(***)

instance Monoid Regex where
    mempty :: Regex
mempty = Regex
Eps

deriving instance Eq Regex

-- | For use with @OverloadedStrings@
instance IsString Regex where
    fromString :: String -> Regex
fromString = String -> Regex
r

-- | For use with @OverloadedLists@
instance IsList Regex where
    type (Item Regex) = String
    toList :: Regex -> [Item Regex]
toList   = Set String -> [String]
forall a. Set a -> [a]
S.toList (Set String -> [String])
-> (Regex -> Set String) -> Regex -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> Set String
eval
    fromList :: [Item Regex] -> Regex
fromList = (String -> Regex -> Regex) -> Regex -> [String] -> Regex
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Regex -> Regex -> Regex
(<|>) (Regex -> Regex -> Regex)
-> (String -> Regex) -> String -> Regex -> Regex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Regex
r) Regex
Nil

-- Looks nicer...
instance {-# OVERLAPPING #-} Show (S.Set String) where
        show :: Set String -> String
show s :: Set String
s = "{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ShowS
forall a. [a] -> [a]
tail ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
init ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. Show a => a -> String
show) (Set String -> [String]
forall a. Set a -> [a]
S.toList Set String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "}"

-- * Regex constructors

-- | Synonym for the @Union@ constructor
infixl 6 <|>
(<|>) :: Regex -> Regex -> Regex
x :: Regex
x   <|> :: Regex -> Regex -> Regex
<|> Nil = Regex
x
Nil <|> y :: Regex
y   = Regex
y
x :: Regex
x <|> y :: Regex
y | Regex
x Regex -> Regex -> Bool
forall a. Eq a => a -> a -> Bool
== Regex
y    = Regex
x
        | Bool
otherwise = Regex -> Regex -> Regex
Union Regex
x Regex
y

-- | Synonym for the @Inter@ constructor
infixl 6 <^>
(<^>) :: Regex -> Regex -> Regex
Nil <^> :: Regex -> Regex -> Regex
<^> _   = Regex
Nil
_   <^> Nil = Regex
Nil
x :: Regex
x <^> y :: Regex
y | Regex
x Regex -> Regex -> Bool
forall a. Eq a => a -> a -> Bool
== Regex
y    = Regex
x
        | Bool
otherwise = Regex -> Regex -> Regex
Inter Regex
x Regex
y

-- | Synonym for the @Conc@ constructor
infixl 6 ***
(***) :: Regex -> Regex -> Regex
x :: Regex
x   *** :: Regex -> Regex -> Regex
*** Eps = Regex
x
Eps *** y :: Regex
y   = Regex
y
_   *** Nil = Regex
Nil
Nil *** _   = Regex
Nil
x :: Regex
x   *** y :: Regex
y   = Regex -> Regex -> Regex
Conc Regex
x Regex
y

-- | Synonym for the @Comp@ constructor
neg :: Regex -> Regex
neg :: Regex -> Regex
neg = Regex -> Regex
Comp

-- | Language set difference
-- \[ \Lambda \backslash \Gamma \hspace{10pt} \Lambda,\Gamma \subseteq \Sigma^* \]
infixl 6 \\
(\\) :: Regex -> Regex -> Regex
r1 :: Regex
r1 \\ :: Regex -> Regex -> Regex
\\ r2 :: Regex
r2 = Regex
r1 Regex -> Regex -> Regex
<^> Regex -> Regex
neg Regex
r2

-- ** Specialized constructors

-- | Treat string as concatenation of symbol regexes
--
-- @
--  r"foo" = Sym \'f\' *** Sym \'o\' *** Sym \'o\'
-- @
r :: String -> Regex
r :: String -> Regex
r = (Char -> Regex) -> String -> Regex
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> Regex
Sym

-- | Synonym for @Star@ constructor
-- That is, zero or more.
--
-- @
--  ^r*$
-- @
some :: Regex -> Regex
some :: Regex -> Regex
some = Regex -> Regex
Star

-- | One or more
--
-- @
--  ^r+$
-- @
many :: Regex -> Regex
many :: Regex -> Regex
many r :: Regex
r = Regex -> Regex
some Regex
r Regex -> Regex -> Regex
*** Regex
r

-- | Zero or one
--
-- @
--  ^r?$
-- @
mayb :: Regex -> Regex
mayb :: Regex -> Regex
mayb = Regex -> Regex -> Regex
(<|>) ""

-- | Fold string over language union
--
-- @
--  numericChar = alphabet ['0'..'9']
-- @
alphabet :: String -> Regex
alphabet :: String -> Regex
alphabet = (Regex -> Regex -> Regex) -> [Regex] -> Regex
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Regex -> Regex -> Regex
(<|>) ([Regex] -> Regex) -> (String -> [Regex]) -> String -> Regex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Regex) -> String -> [Regex]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Regex
Sym

-- | \[
-- \mathbb{1}_x = \begin{cases}
--          \epsilon \quad & x = \top \\
--          \varnothing \quad & \text{otherwise} \\
--         \end{cases}
-- \]
unit :: Bool -> Regex
unit :: Bool -> Regex
unit True  = Regex
Eps
unit False = Regex
Nil

-- | Set membership
mem :: Regex -> Regex -> Bool
mem :: Regex -> Regex -> Bool
mem _ Eps           = Bool
False
mem e :: Regex
e Nil           = Regex
e Regex -> Regex -> Bool
forall a. Eq a => a -> a -> Bool
== Regex
Eps
mem e :: Regex
e (Sym c :: Char
c      ) = Regex
e Regex -> Regex -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Regex
Sym Char
c
mem e :: Regex
e (Union r1 :: Regex
r1 r2 :: Regex
r2) = Regex -> Regex -> Bool
mem Regex
e Regex
r1 Bool -> Bool -> Bool
|| Regex -> Regex -> Bool
mem Regex
e Regex
r2
mem e :: Regex
e (Inter r1 :: Regex
r1 r2 :: Regex
r2) = Regex -> Regex -> Bool
mem Regex
e Regex
r1 Bool -> Bool -> Bool
&& Regex -> Regex -> Bool
mem Regex
e Regex
r2
mem e :: Regex
e (Conc  r1 :: Regex
r1 r2 :: Regex
r2) = Bool
forall a. HasCallStack => a
undefined
mem e :: Regex
e (Comp r :: Regex
r     ) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Regex -> Regex -> Bool
mem Regex
e Regex
r
mem e :: Regex
e (Star r :: Regex
r     ) = Bool
forall a. HasCallStack => a
undefined

-- | Auxiliary function to derive where
-- \[
-- \nu(R) = \begin{cases}
--          \epsilon \quad & \epsilon \in R\\
--          \varnothing \quad & \text{otherwise} \\
--          \end{cases}
-- \]
-- Equivalent to
--
-- @
--  unit . (Eps `mem`)
-- @
nu :: Regex -> Regex
nu :: Regex -> Regex
nu (Sym c :: Char
c)       = Regex
Nil
nu Eps           = Regex
Eps
nu Nil           = Regex
Nil
nu (Star r :: Regex
r     ) = Regex
Eps
nu (Conc  r1 :: Regex
r1 r2 :: Regex
r2) = Regex -> Regex
nu Regex
r1 Regex -> Regex -> Regex
<^> Regex -> Regex
nu Regex
r2
nu (Inter r1 :: Regex
r1 r2 :: Regex
r2) = Regex -> Regex
nu Regex
r1 Regex -> Regex -> Regex
<^> Regex -> Regex
nu Regex
r2
nu (Union r1 :: Regex
r1 r2 :: Regex
r2) = Regex -> Regex
nu Regex
r1 Regex -> Regex -> Regex
<|> Regex -> Regex
nu Regex
r2
nu (Comp r :: Regex
r     ) = Bool -> Regex
unit (Regex -> Regex
nu Regex
r Regex -> Regex -> Bool
forall a. Eq a => a -> a -> Bool
== Regex
Nil)

-- * Derivatives

-- | Defining the (Brzozowski) derivative of a language \(L\) 
-- with respect to the string \(u \in \Sigma^*\) to be
-- \[
--      u^{-1} L = \left\{ v : uv \in L \right\}
-- \]
derive :: String -> Regex -> Regex
derive :: String -> Regex -> Regex
derive s :: String
s r :: Regex
r = (Char -> Regex -> Regex) -> Regex -> String -> Regex
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> Regex -> Regex
deriveSym Regex
r (ShowS
forall a. [a] -> [a]
reverse String
s)

-- | Derivative for individual symbols, to fold over
deriveSym :: Char -> Regex -> Regex
deriveSym :: Char -> Regex -> Regex
deriveSym _ Eps           = Regex
Nil
deriveSym _ Nil           = Regex
Nil
deriveSym d :: Char
d (Sym  c :: Char
c     ) = Bool -> Regex
unit (Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c)
deriveSym d :: Char
d (Star r :: Regex
r     ) = Char -> Regex -> Regex
deriveSym Char
d Regex
r Regex -> Regex -> Regex
*** Regex -> Regex
Star Regex
r
deriveSym d :: Char
d (Comp r1 :: Regex
r1    ) = Regex -> Regex
Comp (Regex -> Regex) -> Regex -> Regex
forall a b. (a -> b) -> a -> b
$ Char -> Regex -> Regex
deriveSym Char
d Regex
r1
deriveSym d :: Char
d (Union r1 :: Regex
r1 r2 :: Regex
r2) = Char -> Regex -> Regex
deriveSym Char
d Regex
r1 Regex -> Regex -> Regex
<|> Char -> Regex -> Regex
deriveSym Char
d Regex
r2
deriveSym d :: Char
d (Inter r1 :: Regex
r1 r2 :: Regex
r2) = Char -> Regex -> Regex
deriveSym Char
d Regex
r1 Regex -> Regex -> Regex
<^> Char -> Regex -> Regex
deriveSym Char
d Regex
r2
deriveSym d :: Char
d (Conc r1 :: Regex
r1 r2 :: Regex
r2) =
    (Char -> Regex -> Regex
deriveSym Char
d Regex
r1 Regex -> Regex -> Regex
*** Regex
r2) Regex -> Regex -> Regex
<|> (Regex -> Regex
nu Regex
r1 Regex -> Regex -> Regex
*** Char -> Regex -> Regex
deriveSym Char
d Regex
r2)

-- | Infix @derive@ with regex symbol input
infixl 5 ^-
(^-) :: String -> Regex -> Regex
^- :: String -> Regex -> Regex
(^-) = String -> Regex -> Regex
derive

-- * Evaluation and reduction

-- | Continue reducing a regex
rreduce :: String -> Regex -> Regex
rreduce :: String -> Regex -> Regex
rreduce s :: String
s = (Regex -> Bool) -> (Regex -> Regex) -> Regex -> Regex
forall a. (a -> Bool) -> (a -> a) -> a -> a
until Regex -> Bool
normal (String
s String -> Regex -> Regex
^-) where normal :: Regex -> Bool
normal x :: Regex
x = String -> Regex -> Regex
derive String
s Regex
x Regex -> Regex -> Bool
forall a. Eq a => a -> a -> Bool
== Regex
x

-- | Evaluate regex to a set of strings
eval :: Regex -> S.Set String
eval :: Regex -> Set String
eval Nil           = Set String
forall a. Set a
S.empty
eval Eps           = String -> Set String
forall a. a -> Set a
S.singleton ""
eval (Sym  c :: Char
c     ) = String -> Set String
forall a. a -> Set a
S.singleton [Char
Item String
c]
eval (Star r :: Regex
r     ) = String -> Set String
forall a. a -> Set a
S.singleton (String -> Set String) -> String -> Set String
forall a b. (a -> b) -> a -> b
$ Set String -> String
forall a. Show a => a -> String
show (Regex -> Set String
eval Regex
r) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "*"
eval (Union r1 :: Regex
r1 r2 :: Regex
r2) = Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
S.union (Regex -> Set String
eval Regex
r1) (Regex -> Set String
eval Regex
r2)
eval (Inter r1 :: Regex
r1 r2 :: Regex
r2) = Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
S.intersection (Regex -> Set String
eval Regex
r1) (Regex -> Set String
eval Regex
r2)
eval (Conc r1 :: Regex
r1 r2 :: Regex
r2) =
    ((String, String) -> String) -> Set (String, String) -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map ((String -> ShowS) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> ShowS
forall a. Semigroup a => a -> a -> a
(<>)) (Set (String, String) -> Set String)
-> Set (String, String) -> Set String
forall a b. (a -> b) -> a -> b
$ Set String -> Set String -> Set (String, String)
forall a b. Set a -> Set b -> Set (a, b)
S.cartesianProduct (Regex -> Set String
eval Regex
r1) (Regex -> Set String
eval Regex
r2)
{-# INLINE eval #-}

-- | Print all strings that match a regex.
-- Note that this does not print the full list when
-- the number of matches is infinite.
--
-- >>> printMatching $ some "a"
-- {"a"}*
-- 
-- and not
--
-- @
--  
--  a
--  aa
--  aaa
--  ...
-- @
--
-- If you want to such matches, please use the derivative '(^-)'
-- or the match function '(?)'
printMatching :: Regex -> IO ()
printMatching :: Regex -> IO ()
printMatching = (String -> IO ()) -> Set String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn (Set String -> IO ()) -> (Regex -> Set String) -> Regex -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> Set String
eval

-- | Check if regex matches.
-- Essentially checking if the derivative with respect to a string
-- contains the empty string, \(\epsilon\).
match :: String -> Regex -> Bool
match :: String -> Regex -> Bool
match s :: String
s r :: Regex
r = Regex -> Regex
nu (String
s String -> Regex -> Regex
^- Regex
r) Regex -> Regex -> Bool
forall a. Eq a => a -> a -> Bool
== Regex
Eps

-- TODO maybe change this symbol
infixl 5 ?
(?) :: String -> Regex -> Bool
? :: String -> Regex -> Bool
(?) = String -> Regex -> Bool
match
-- ^ Infix synonym for @match@ 

-- * Regex sets

-- | Alphabetic characters
alpha :: Regex
alpha :: Regex
alpha = String -> Regex
alphabet (String -> Regex) -> String -> Regex
forall a b. (a -> b) -> a -> b
$ [Item String
'a' .. Item String
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Item String
'A' .. Item String
'Z']

-- | Numeric characters
numeric :: Regex
numeric :: Regex
numeric = String -> Regex
alphabet [Item String
'0' .. Item String
'9']

-- | Positive or negative integer
int :: Regex
int :: Regex
int = "-" Regex -> Regex -> Regex
?> Regex -> Regex
many Regex
numeric

-- | Alpha-numeric characters
alphaNum :: Regex
alphaNum :: Regex
alphaNum = Regex
alpha Regex -> Regex -> Regex
<|> Regex
numeric

-- | Single space character
space :: Regex
space :: Regex
space = " "

-- | One or more spaces
spaces :: Regex
spaces :: Regex
spaces = Regex -> Regex
many Regex
space

-- | Any whitespace character 
whiteSpace :: Regex
whiteSpace :: Regex
whiteSpace = [" ", "\n", "\t"]

-- | Any ASCII character
ascii :: Regex
ascii :: Regex
ascii = String -> Regex
alphabet [Item String
'\NUL' .. Item String
'\127']

-- ** Set combinators

-- I will use <> in place of *** from hereon

-- | Regex inside delimiters
--
-- >>> "'a'" ? ascii `between` "'"
-- True
between :: Regex -> Regex -> Regex
between :: Regex -> Regex -> Regex
between c :: Regex
c d :: Regex
d = Regex
d Regex -> Regex -> Regex
forall a. Semigroup a => a -> a -> a
<> (Regex
c Regex -> Regex -> Regex
\\ Regex
d) Regex -> Regex -> Regex
forall a. Semigroup a => a -> a -> a
<> Regex
d

-- | One or more regexes seperated by another regex
--
-- @
--  list :: Regex
--  list = "[" <> int \`sepBy\` "," <> "]"
-- @
sepBy :: Regex -> Regex -> Regex
sepBy :: Regex -> Regex -> Regex
sepBy c :: Regex
c d :: Regex
d = Regex
c Regex -> Regex -> Regex
forall a. Semigroup a => a -> a -> a
<> Regex -> Regex
some (Regex
d Regex -> Regex -> Regex
forall a. Semigroup a => a -> a -> a
<> Regex
c)

-- | Alternating concat
--
-- @
--  "'" ?> "a" = "'a" \<|\> "a"
-- @
(?>) :: Regex -> Regex -> Regex
?> :: Regex -> Regex -> Regex
(?>) p :: Regex
p = (Regex -> Regex
mayb Regex
p Regex -> Regex -> Regex
forall a. Semigroup a => a -> a -> a
<>)

-- | Suffix variant of '(?>)'
(<?) :: Regex -> Regex -> Regex
<? :: Regex -> Regex -> Regex
(<?) r :: Regex
r p :: Regex
p = Regex
r Regex -> Regex -> Regex
forall a. Semigroup a => a -> a -> a
<> Regex -> Regex
mayb Regex
p