{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
module BNFC.Regex ( nullable, simpReg ) where
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup(..))
#endif
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.List as List
import BNFC.Abs
nullable :: Reg -> Bool
nullable :: Reg -> Bool
nullable = \case
RSeq Reg
r1 Reg
r2 -> Reg -> Bool
nullable Reg
r1 Bool -> Bool -> Bool
&& Reg -> Bool
nullable Reg
r2
RAlt Reg
r1 Reg
r2 -> Reg -> Bool
nullable Reg
r1 Bool -> Bool -> Bool
|| Reg -> Bool
nullable Reg
r2
RMinus Reg
r1 Reg
r2 -> Reg -> Bool
nullable Reg
r1 Bool -> Bool -> Bool
&& Bool -> Bool
not (Reg -> Bool
nullable Reg
r2)
RStar Reg
_ -> Bool
True
RPlus Reg
r1 -> Reg -> Bool
nullable Reg
r1
ROpt Reg
_ -> Bool
True
Reg
REps -> Bool
True
RChar Char
_ -> Bool
False
RAlts String
_ -> Bool
False
RSeqs String
s -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s
Reg
RDigit -> Bool
False
Reg
RLetter -> Bool
False
Reg
RUpper -> Bool
False
Reg
RLower -> Bool
False
Reg
RAny -> Bool
False
simpReg :: Reg -> Reg
simpReg :: Reg -> Reg
simpReg = Reg -> Reg
rloop
where
rloop :: Reg -> Reg
rloop = forall a. ToReg a => a -> Reg
rx forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reg -> RC
loop
loop :: Reg -> RC
loop :: Reg -> RC
loop = \case
RStar Reg
r -> Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ Reg -> Reg
rStar forall a b. (a -> b) -> a -> b
$ Reg -> Reg
rloop Reg
r
RPlus Reg
r -> Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ Reg -> Reg
rPlus forall a b. (a -> b) -> a -> b
$ Reg -> Reg
rloop Reg
r
ROpt Reg
r -> Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ Reg -> Reg
rOpt forall a b. (a -> b) -> a -> b
$ Reg -> Reg
rloop Reg
r
Reg
REps -> Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ Reg
REps
RSeqs [] -> Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ Reg
REps
RSeqs s :: String
s@(Char
_:Char
_:String
_) -> Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ String -> Reg
RSeqs String
s
RSeq Reg
r1 Reg
r2 -> Reg -> RC
loop Reg
r1 RC -> RC -> RC
`rcSeq` Reg -> RC
loop Reg
r2
RAlt Reg
r1 Reg
r2 -> Reg -> RC
loop Reg
r1 RC -> RC -> RC
`rcAlt` Reg -> RC
loop Reg
r2
RMinus Reg
r1 Reg
r2 -> Reg -> RC
loop Reg
r1 RC -> RC -> RC
`rcMinus` Reg -> RC
loop Reg
r2
RSeqs [Char
c] -> CharClass -> RC
CC forall a b. (a -> b) -> a -> b
$ Char -> CharClass
cChar Char
c
RChar Char
c -> CharClass -> RC
CC forall a b. (a -> b) -> a -> b
$ Char -> CharClass
cChar Char
c
RAlts String
s -> CharClass -> RC
CC forall a b. (a -> b) -> a -> b
$ String -> CharClass
cAlts String
s
Reg
RDigit -> CharClass -> RC
CC forall a b. (a -> b) -> a -> b
$ CharClass
cDigit
Reg
RLetter -> CharClass -> RC
CC forall a b. (a -> b) -> a -> b
$ CharClass
cLetter
Reg
RUpper -> CharClass -> RC
CC forall a b. (a -> b) -> a -> b
$ CharClass
cUpper
Reg
RLower -> CharClass -> RC
CC forall a b. (a -> b) -> a -> b
$ CharClass
cLower
Reg
RAny -> CharClass -> RC
CC forall a b. (a -> b) -> a -> b
$ CharClass
cAny
data CharClass = CMinus { CharClass -> CharClassUnion
_ccYes, CharClass -> CharClassUnion
_ccNo :: CharClassUnion }
deriving (CharClass -> CharClass -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CharClass -> CharClass -> Bool
$c/= :: CharClass -> CharClass -> Bool
== :: CharClass -> CharClass -> Bool
$c== :: CharClass -> CharClass -> Bool
Eq, Eq CharClass
CharClass -> CharClass -> Bool
CharClass -> CharClass -> Ordering
CharClass -> CharClass -> CharClass
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CharClass -> CharClass -> CharClass
$cmin :: CharClass -> CharClass -> CharClass
max :: CharClass -> CharClass -> CharClass
$cmax :: CharClass -> CharClass -> CharClass
>= :: CharClass -> CharClass -> Bool
$c>= :: CharClass -> CharClass -> Bool
> :: CharClass -> CharClass -> Bool
$c> :: CharClass -> CharClass -> Bool
<= :: CharClass -> CharClass -> Bool
$c<= :: CharClass -> CharClass -> Bool
< :: CharClass -> CharClass -> Bool
$c< :: CharClass -> CharClass -> Bool
compare :: CharClass -> CharClass -> Ordering
$ccompare :: CharClass -> CharClass -> Ordering
Ord, Int -> CharClass -> ShowS
[CharClass] -> ShowS
CharClass -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CharClass] -> ShowS
$cshowList :: [CharClass] -> ShowS
show :: CharClass -> String
$cshow :: CharClass -> String
showsPrec :: Int -> CharClass -> ShowS
$cshowsPrec :: Int -> CharClass -> ShowS
Show)
data CharClassUnion
= CAny
| CAlt (Set CharClassAtom)
deriving (CharClassUnion -> CharClassUnion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CharClassUnion -> CharClassUnion -> Bool
$c/= :: CharClassUnion -> CharClassUnion -> Bool
== :: CharClassUnion -> CharClassUnion -> Bool
$c== :: CharClassUnion -> CharClassUnion -> Bool
Eq, Eq CharClassUnion
CharClassUnion -> CharClassUnion -> Bool
CharClassUnion -> CharClassUnion -> Ordering
CharClassUnion -> CharClassUnion -> CharClassUnion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CharClassUnion -> CharClassUnion -> CharClassUnion
$cmin :: CharClassUnion -> CharClassUnion -> CharClassUnion
max :: CharClassUnion -> CharClassUnion -> CharClassUnion
$cmax :: CharClassUnion -> CharClassUnion -> CharClassUnion
>= :: CharClassUnion -> CharClassUnion -> Bool
$c>= :: CharClassUnion -> CharClassUnion -> Bool
> :: CharClassUnion -> CharClassUnion -> Bool
$c> :: CharClassUnion -> CharClassUnion -> Bool
<= :: CharClassUnion -> CharClassUnion -> Bool
$c<= :: CharClassUnion -> CharClassUnion -> Bool
< :: CharClassUnion -> CharClassUnion -> Bool
$c< :: CharClassUnion -> CharClassUnion -> Bool
compare :: CharClassUnion -> CharClassUnion -> Ordering
$ccompare :: CharClassUnion -> CharClassUnion -> Ordering
Ord, Int -> CharClassUnion -> ShowS
[CharClassUnion] -> ShowS
CharClassUnion -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CharClassUnion] -> ShowS
$cshowList :: [CharClassUnion] -> ShowS
show :: CharClassUnion -> String
$cshow :: CharClassUnion -> String
showsPrec :: Int -> CharClassUnion -> ShowS
$cshowsPrec :: Int -> CharClassUnion -> ShowS
Show)
data CharClassAtom
= CChar Char
| CDigit
| CLower
| CUpper
deriving (CharClassAtom -> CharClassAtom -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CharClassAtom -> CharClassAtom -> Bool
$c/= :: CharClassAtom -> CharClassAtom -> Bool
== :: CharClassAtom -> CharClassAtom -> Bool
$c== :: CharClassAtom -> CharClassAtom -> Bool
Eq, Eq CharClassAtom
CharClassAtom -> CharClassAtom -> Bool
CharClassAtom -> CharClassAtom -> Ordering
CharClassAtom -> CharClassAtom -> CharClassAtom
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CharClassAtom -> CharClassAtom -> CharClassAtom
$cmin :: CharClassAtom -> CharClassAtom -> CharClassAtom
max :: CharClassAtom -> CharClassAtom -> CharClassAtom
$cmax :: CharClassAtom -> CharClassAtom -> CharClassAtom
>= :: CharClassAtom -> CharClassAtom -> Bool
$c>= :: CharClassAtom -> CharClassAtom -> Bool
> :: CharClassAtom -> CharClassAtom -> Bool
$c> :: CharClassAtom -> CharClassAtom -> Bool
<= :: CharClassAtom -> CharClassAtom -> Bool
$c<= :: CharClassAtom -> CharClassAtom -> Bool
< :: CharClassAtom -> CharClassAtom -> Bool
$c< :: CharClassAtom -> CharClassAtom -> Bool
compare :: CharClassAtom -> CharClassAtom -> Ordering
$ccompare :: CharClassAtom -> CharClassAtom -> Ordering
Ord, Int -> CharClassAtom -> ShowS
[CharClassAtom] -> ShowS
CharClassAtom -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CharClassAtom] -> ShowS
$cshowList :: [CharClassAtom] -> ShowS
show :: CharClassAtom -> String
$cshow :: CharClassAtom -> String
showsPrec :: Int -> CharClassAtom -> ShowS
$cshowsPrec :: Int -> CharClassAtom -> ShowS
Show)
data RC
= Rx Reg
| CC CharClass
rSeq :: Reg -> Reg -> Reg
rSeq :: Reg -> Reg -> Reg
rSeq = forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a b. (a -> b) -> a -> b
$ \case
(RAlts String
"", Reg
_ ) -> String -> Reg
RAlts String
""
(Reg
_ , RAlts String
"") -> String -> Reg
RAlts String
""
(Reg
REps , Reg
r ) -> Reg
r
(RSeqs String
"", Reg
r ) -> Reg
r
(Reg
r , Reg
REps ) -> Reg
r
(Reg
r , RSeqs String
"") -> Reg
r
(RStar Reg
r1, RStar Reg
r2) | Reg
r1 forall a. Eq a => a -> a -> Bool
== Reg
r2 -> Reg -> Reg
rStar Reg
r1
(RPlus Reg
r1, RStar Reg
r2) | Reg
r1 forall a. Eq a => a -> a -> Bool
== Reg
r2 -> Reg -> Reg
rPlus Reg
r1
(RStar Reg
r1, RPlus Reg
r2) | Reg
r1 forall a. Eq a => a -> a -> Bool
== Reg
r2 -> Reg -> Reg
rPlus Reg
r1
(Reg
r1 , RStar Reg
r2) | Reg
r1 forall a. Eq a => a -> a -> Bool
== Reg
r2 -> Reg -> Reg
rPlus Reg
r1
(RStar Reg
r1, Reg
r2 ) | Reg
r1 forall a. Eq a => a -> a -> Bool
== Reg
r2 -> Reg -> Reg
rPlus Reg
r1
(RSeqs String
s1, RSeqs String
s2) -> String -> Reg
RSeqs forall a b. (a -> b) -> a -> b
$ String
s1 forall a. [a] -> [a] -> [a]
++ String
s2
(RChar Char
c1, RSeqs String
s2) -> String -> Reg
RSeqs forall a b. (a -> b) -> a -> b
$ Char
c1 forall a. a -> [a] -> [a]
: String
s2
(RSeqs String
s1, RChar Char
c2) -> String -> Reg
RSeqs forall a b. (a -> b) -> a -> b
$ String
s1 forall a. [a] -> [a] -> [a]
++ [Char
c2]
(RChar Char
c1, RChar Char
c2) -> String -> Reg
RSeqs [ Char
c1, Char
c2 ]
(Reg
r1 , RSeq Reg
r2 Reg
r3) -> (Reg
r1 Reg -> Reg -> Reg
`rSeq` Reg
r2) Reg -> Reg -> Reg
`rSeq` Reg
r3
(Reg
r1 , Reg
r2 ) -> Reg
r1 Reg -> Reg -> Reg
`RSeq` Reg
r2
rAlt :: Reg -> Reg -> Reg
rAlt :: Reg -> Reg -> Reg
rAlt = forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a b. (a -> b) -> a -> b
$ \case
(RAlts String
"", Reg
r ) -> Reg
r
(Reg
r , RAlts String
"") -> Reg
r
(RAlts String
s1, RAlts String
s2) -> String -> Reg
RAlts forall a b. (a -> b) -> a -> b
$ String
s1 forall a. [a] -> [a] -> [a]
++ String
s2
(RChar Char
c1, RAlts String
s2) -> String -> Reg
RAlts forall a b. (a -> b) -> a -> b
$ Char
c1 forall a. a -> [a] -> [a]
: String
s2
(RAlts String
s1, RChar Char
c2) -> String -> Reg
RAlts forall a b. (a -> b) -> a -> b
$ String
s1 forall a. [a] -> [a] -> [a]
++ [Char
c2]
(RChar Char
c1, RChar Char
c2) -> String -> Reg
RAlts [ Char
c1, Char
c2 ]
(Reg
r1 , RAlt Reg
r2 Reg
r3) -> (Reg
r1 Reg -> Reg -> Reg
`rAlt` Reg
r2) Reg -> Reg -> Reg
`rAlt` Reg
r3
(Reg
r1, Reg
r2)
| Reg
r1 forall a. Eq a => a -> a -> Bool
== Reg
r2 -> Reg
r1
| Bool
otherwise -> Reg
r1 Reg -> Reg -> Reg
`RAlt` Reg
r2
rMinus :: Reg -> Reg -> Reg
rMinus :: Reg -> Reg -> Reg
rMinus = forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a b. (a -> b) -> a -> b
$ \case
(RAlts String
"", Reg
_ ) -> String -> Reg
RAlts String
""
(Reg
r , RAlts String
"") -> Reg
r
(RAlts String
s1, RAlts String
s2) -> case String
s1 forall a. Eq a => [a] -> [a] -> [a]
List.\\ String
s2 of
[Char
c] -> Char -> Reg
RChar Char
c
String
s -> String -> Reg
RAlts String
s
(Reg
r1, Reg
r2)
| Reg
r1 forall a. Eq a => a -> a -> Bool
== Reg
r2 -> String -> Reg
RAlts String
""
| Bool
otherwise -> Reg
r1 Reg -> Reg -> Reg
`RMinus` Reg
r2
rStar :: Reg -> Reg
rStar :: Reg -> Reg
rStar = \case
Reg
REps -> Reg
REps
RSeqs String
"" -> Reg
REps
RAlts String
"" -> Reg
REps
ROpt Reg
r -> Reg -> Reg
RStar Reg
r
RStar Reg
r -> Reg -> Reg
RStar Reg
r
RPlus Reg
r -> Reg -> Reg
RStar Reg
r
Reg
r -> Reg -> Reg
RStar Reg
r
rPlus :: Reg -> Reg
rPlus :: Reg -> Reg
rPlus = \case
Reg
REps -> Reg
REps
RSeqs String
"" -> Reg
REps
RAlts String
"" -> String -> Reg
RAlts String
""
ROpt Reg
r -> Reg -> Reg
RStar Reg
r
RStar Reg
r -> Reg -> Reg
RStar Reg
r
RPlus Reg
r -> Reg -> Reg
RPlus Reg
r
Reg
r -> Reg -> Reg
RPlus Reg
r
rOpt :: Reg -> Reg
rOpt :: Reg -> Reg
rOpt = \case
Reg
REps -> Reg
REps
RSeqs String
"" -> Reg
REps
RAlts String
"" -> Reg
REps
RStar Reg
r -> Reg -> Reg
RStar Reg
r
RPlus Reg
r -> Reg -> Reg
RStar Reg
r
ROpt Reg
r -> Reg -> Reg
ROpt Reg
r
Reg
r -> Reg -> Reg
ROpt Reg
r
rcSeq :: RC -> RC -> RC
rcSeq :: RC -> RC -> RC
rcSeq = forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a b. (a -> b) -> a -> b
$ \case
(Rx Reg
REps , RC
r ) -> RC
r
(Rx (RSeqs String
""), RC
r ) -> RC
r
(RC
r , Rx Reg
REps ) -> RC
r
(RC
r , Rx (RSeqs String
"")) -> RC
r
(RC
r1 , RC
r2 ) -> Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ forall a. ToReg a => a -> Reg
rx RC
r1 Reg -> Reg -> Reg
`rSeq` forall a. ToReg a => a -> Reg
rx RC
r2
rcAlt :: RC -> RC -> RC
rcAlt :: RC -> RC -> RC
rcAlt = forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a b. (a -> b) -> a -> b
$ \case
(Rx (RAlts String
""), RC
r) -> RC
r
(RC
r, Rx (RAlts String
"")) -> RC
r
(CC CharClass
c1, CC CharClass
c2) -> CharClass
c1 CharClass -> CharClass -> RC
`cAlt` CharClass
c2
(RC
c1 , RC
c2 ) -> Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ forall a. ToReg a => a -> Reg
rx RC
c1 Reg -> Reg -> Reg
`rAlt` forall a. ToReg a => a -> Reg
rx RC
c2
rcMinus :: RC -> RC -> RC
rcMinus :: RC -> RC -> RC
rcMinus = forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a b. (a -> b) -> a -> b
$ \case
(RC
r , Rx (RAlts String
"")) -> RC
r
(CC CharClass
c1, CC CharClass
c2 ) -> CharClass
c1 CharClass -> CharClass -> RC
`cMinus` CharClass
c2
(RC
c1 , RC
c2 ) -> Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ forall a. ToReg a => a -> Reg
rx RC
c1 Reg -> Reg -> Reg
`rMinus` forall a. ToReg a => a -> Reg
rx RC
c2
class ToReg a where
rx :: a -> Reg
instance ToReg RC where
rx :: RC -> Reg
rx (Rx Reg
r) = Reg
r
rx (CC CharClass
c) = forall a. ToReg a => a -> Reg
rx CharClass
c
instance ToReg CharClass where
rx :: CharClass -> Reg
rx (CMinus CharClassUnion
p CharClassUnion
m)
| CharClassUnion
m forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = forall a. ToReg a => a -> Reg
rx CharClassUnion
p
| CharClassUnion
p forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = String -> Reg
RAlts String
""
| Bool
otherwise = forall a. ToReg a => a -> Reg
rx CharClassUnion
p Reg -> Reg -> Reg
`RMinus` forall a. ToReg a => a -> Reg
rx CharClassUnion
m
instance ToReg CharClassUnion where
rx :: CharClassUnion -> Reg
rx CharClassUnion
CAny = Reg
RAny
rx (CAlt Set CharClassAtom
cs) = case [Reg]
rs of
[] -> String -> Reg
RAlts String
""
[Reg
r] -> Reg
r
[Reg]
rs -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Reg -> Reg -> Reg
RAlt [Reg]
rs
where
start :: St
start = Bool -> Bool -> Bool -> String -> St
St Bool
False Bool
False Bool
False String
""
step :: St -> CharClassAtom -> St
step St
st = \case
CChar Char
c -> St
st { stAlts :: String
stAlts = Char
c forall a. a -> [a] -> [a]
: St -> String
stAlts St
st }
CharClassAtom
CDigit -> St
st { stDigit :: Bool
stDigit = Bool
True }
CharClassAtom
CLower -> St
st { stLower :: Bool
stLower = Bool
True }
CharClassAtom
CUpper -> St
st { stUpper :: Bool
stUpper = Bool
True }
(St Bool
digit Bool
upper Bool
lower String
alts) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl St -> CharClassAtom -> St
step St
start forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toDescList Set CharClassAtom
cs
rs :: [Reg]
rs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ Char -> Reg
RChar Char
c | [Char
c] <- [String
alts] ]
, [ String -> Reg
RAlts String
alts | (Char
_:Char
_:String
_) <- [String
alts] ]
, [ Reg
RDigit | Bool
digit ]
, [ Reg
RLetter | Bool
upper Bool -> Bool -> Bool
&& Bool
lower ]
, [ Reg
RUpper | Bool
upper Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
lower ]
, [ Reg
RLower | Bool
lower Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
upper ]
]
data St = St { St -> Bool
stDigit, St -> Bool
stUpper, St -> Bool
stLower :: Bool, St -> String
stAlts :: String }
cAlt :: CharClass -> CharClass -> RC
cAlt :: CharClass -> CharClass -> RC
cAlt c1 :: CharClass
c1@(CMinus CharClassUnion
p1 CharClassUnion
m1) c2 :: CharClass
c2@(CMinus CharClassUnion
p2 CharClassUnion
m2)
| CharClass
c1 forall a. Eq a => a -> a -> Bool
== CharClass
cAny Bool -> Bool -> Bool
|| CharClass
c2 forall a. Eq a => a -> a -> Bool
== CharClass
cAny = CharClass -> RC
CC CharClass
cAny
| CharClassUnion
p1 CharClassUnion -> CharClassUnion -> Either CharClass CharClassUnion
`ccuMinus` CharClassUnion
m2 forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right CharClassUnion
p1,
CharClassUnion
p2 CharClassUnion -> CharClassUnion -> Either CharClass CharClassUnion
`ccuMinus` CharClassUnion
m1 forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right CharClassUnion
p2 = CharClass -> RC
CC forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id CharClassUnion -> CharClass
ccu forall a b. (a -> b) -> a -> b
$ (CharClassUnion
p1 forall a. Semigroup a => a -> a -> a
<> CharClassUnion
p2) CharClassUnion -> CharClassUnion -> Either CharClass CharClassUnion
`ccuMinus` (CharClassUnion
m1 forall a. Semigroup a => a -> a -> a
<> CharClassUnion
m2)
| Bool
otherwise = Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ forall a. ToReg a => a -> Reg
rx CharClass
c1 Reg -> Reg -> Reg
`RAlt` forall a. ToReg a => a -> Reg
rx CharClass
c2
cMinus :: CharClass -> CharClass -> RC
cMinus :: CharClass -> CharClass -> RC
cMinus c1 :: CharClass
c1@(CMinus CharClassUnion
p1 CharClassUnion
m1) c2 :: CharClass
c2@(CMinus CharClassUnion
p2 CharClassUnion
m2)
| CharClassUnion
p2 forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = CharClass -> RC
CC CharClass
c1
| CharClassUnion
p1 CharClassUnion -> CharClassUnion -> Either CharClass CharClassUnion
`ccuMinus` CharClassUnion
m2 forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right CharClassUnion
p1 = CharClass -> RC
CC forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id CharClassUnion -> CharClass
ccu forall a b. (a -> b) -> a -> b
$ CharClassUnion
p1 CharClassUnion -> CharClassUnion -> Either CharClass CharClassUnion
`ccuMinus` (CharClassUnion
m1 forall a. Semigroup a => a -> a -> a
<> CharClassUnion
p2)
| Bool
otherwise = Reg -> RC
Rx forall a b. (a -> b) -> a -> b
$ forall a. ToReg a => a -> Reg
rx CharClass
c1 Reg -> Reg -> Reg
`RMinus` forall a. ToReg a => a -> Reg
rx CharClass
c2
cChar :: Char -> CharClass
cChar :: Char -> CharClass
cChar Char
c = String -> CharClass
cAlts [Char
c]
cAlts :: String -> CharClass
cAlts :: String -> CharClass
cAlts String
cs = CharClassUnion -> CharClass
ccu forall a b. (a -> b) -> a -> b
$ Set CharClassAtom -> CharClassUnion
CAlt forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> CharClassAtom
CChar String
cs
cDigit, cLower, cUpper, cLetter, cAny :: CharClass
cDigit :: CharClass
cDigit = CharClassAtom -> CharClass
cAtom CharClassAtom
CDigit
cLower :: CharClass
cLower = CharClassAtom -> CharClass
cAtom CharClassAtom
CLower
cUpper :: CharClass
cUpper = CharClassAtom -> CharClass
cAtom CharClassAtom
CUpper
cLetter :: CharClass
cLetter = CharClassUnion -> CharClass
ccu forall a b. (a -> b) -> a -> b
$ Set CharClassAtom -> CharClassUnion
CAlt forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [ CharClassAtom
CLower, CharClassAtom
CUpper ]
cAny :: CharClass
cAny = CharClassUnion -> CharClass
ccu CharClassUnion
CAny
cAtom :: CharClassAtom -> CharClass
cAtom :: CharClassAtom -> CharClass
cAtom = CharClassUnion -> CharClass
ccu forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set CharClassAtom -> CharClassUnion
CAlt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Set a
Set.singleton
ccu :: CharClassUnion -> CharClass
ccu :: CharClassUnion -> CharClass
ccu = (CharClassUnion -> CharClassUnion -> CharClass
`CMinus` forall a. Monoid a => a
mempty)
ccuMinus :: CharClassUnion -> CharClassUnion -> Either CharClass CharClassUnion
ccuMinus :: CharClassUnion -> CharClassUnion -> Either CharClass CharClassUnion
ccuMinus = forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a b. (a -> b) -> a -> b
$ \case
(CharClassUnion
_ , CharClassUnion
CAny) -> forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty
(c1 :: CharClassUnion
c1@CharClassUnion
CAny, CharClassUnion
c2 )
| CharClassUnion
c2 forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ CharClassUnion
c1
| Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ CharClassUnion
c1 CharClassUnion -> CharClassUnion -> CharClass
`CMinus` CharClassUnion
c2
(CAlt Set CharClassAtom
cs1, CAlt Set CharClassAtom
cs2)
| forall a. Set a -> Bool
Set.null Set CharClassAtom
cs1' Bool -> Bool -> Bool
||
forall a. Set a -> Bool
Set.null Set CharClassAtom
cs2' -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Set CharClassAtom -> CharClassUnion
CAlt Set CharClassAtom
cs1'
| Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Set CharClassAtom -> CharClassUnion
CAlt Set CharClassAtom
cs1' CharClassUnion -> CharClassUnion -> CharClass
`CMinus` Set CharClassAtom -> CharClassUnion
CAlt Set CharClassAtom
cs2'
where
cs1' :: Set CharClassAtom
cs1' = Set CharClassAtom
cs1 forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set CharClassAtom
cs2
cs2' :: Set CharClassAtom
cs2' = Set CharClassAtom
cs2 forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set CharClassAtom
cs1
instance Semigroup CharClassUnion where
CharClassUnion
CAny <> :: CharClassUnion -> CharClassUnion -> CharClassUnion
<> CharClassUnion
_ = CharClassUnion
CAny
CharClassUnion
_ <> CharClassUnion
CAny = CharClassUnion
CAny
CAlt Set CharClassAtom
cs <> CAlt Set CharClassAtom
cs' = Set CharClassAtom -> CharClassUnion
CAlt (Set CharClassAtom
cs forall a. Semigroup a => a -> a -> a
<> Set CharClassAtom
cs')
instance Monoid CharClassUnion where
mempty :: CharClassUnion
mempty = Set CharClassAtom -> CharClassUnion
CAlt forall a. Set a
Set.empty
mappend :: CharClassUnion -> CharClassUnion -> CharClassUnion
mappend = forall a. Semigroup a => a -> a -> a
(<>)