{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
-- ------------------------------------------------------------
{- |
Copyright : Copyright (C) 2014 - Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt <uwe@fh-wedel.de>
Stability : stable
Portability: portable
W3C XML Schema Regular Expression Matcher
Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>
-}
-- ------------------------------------------------------------
module Text.Regex.XMLSchema.Generic.Regex
( GenRegex
, mkZero
, mkZero'
, mkUnit
, mkSym
, mkSym1
, mkSymRng
, mkWord
, mkDot
, mkStar
, mkAll
, mkAlt
, mkElse
, mkSeq
, mkSeqs
, mkRep
, mkRng
, mkOpt
, mkDiff
, mkIsect
, mkExor
, mkInterleave
, mkCompl
, mkBr
, mkBr'
, isZero
, errRegex
, nullable
, nullable'
, delta1
, delta
, firstChars
, matchWithRegex
, matchWithRegex'
, splitWithRegex
, splitWithRegex'
, splitWithRegexCS
, splitWithRegexCS'
)
where
import Data.List (intercalate)
import Data.Monoid ((<>))
import Data.Set.CharSet
import Data.String (IsString(..))
import Text.Regex.XMLSchema.Generic.StringLike
{-
import Debug.Trace (traceShow)
trc :: Show a => String -> a -> a
trc msg x = traceShow (msg, x) x
-- -}
-- ------------------------------------------------------------
data GenRegex s
= Zero s
| Unit
| Sym CharSet
| Dot
| Star (GenRegex s)
| Alt (GenRegex s) (GenRegex s)
| Else (GenRegex s) (GenRegex s)
| Seq (GenRegex s) (GenRegex s)
| Rep Int (GenRegex s) -- 1 or more repetitions
| Rng Int Int (GenRegex s) -- n..m repetitions
| Diff (GenRegex s) (GenRegex s) -- r1 - r2
| Isec (GenRegex s) (GenRegex s) -- r1 n r2
| Exor (GenRegex s) (GenRegex s) -- r1 xor r2
| Intl (GenRegex s) (GenRegex s) -- r1 interleavedWith r2
| Br (Label s) (GenRegex s) -- (...) not yet parsed
| Obr (Label s) s !Int (GenRegex s) -- currently parsed (...)
| Cbr [(Label s, s)] (GenRegex s) -- already completely parsed (...)
deriving (Eq, Ord {-, Show -})
type Label s
= Maybe s -- we need one special label for the whole expression
-- see splitWithRegex
type SubexResults s
= [(Label s, s)]
type Nullable s
= (Bool, SubexResults s)
-- ------------------------------------------------------------
{- just for documentation
class Inv a where
inv :: a -> Bool
instance Inv (GenRegex s) where
inv (Zero _) = True
inv Unit = True
inv (Sym p) = not (nulCS p) && not (fullCS p)
inv Dot = True
inv (Star e) = inv e
inv (Alt e1 e2) = inv e1 &&
inv e2
inv (Seq e1 e2) = inv e1 &&
inv e2
inv (Rep i e) = i > 0 && inv e
inv (Rng i j e) = (i < j || (i == j && i > 1)) &&
inv e
inv (Diff e1 e2) = inv e1 &&
inv e2
inv (Isec e1 e2) = inv e1 &&
inv e2
inv (Exor e1 e2) = inv e1 &&
inv e2
-}
-- ------------------------------------------------------------
--
-- smart constructors
-- | construct the r.e. for the empty set.
-- An (error-) message may be attached
mkZero :: s -> GenRegex s
mkZero = Zero
{-# INLINE mkZero #-}
mkZero' :: (StringLike s) =>
String -> GenRegex s
mkZero' = Zero . fromString
{-# INLINE mkZero' #-}
-- | construct the r.e. for the set containing the empty word
mkUnit :: GenRegex s
mkUnit = Unit
{-# INLINE mkUnit #-}
-- | construct the r.e. for a set of chars
mkSym :: (StringLike s) =>
CharSet -> GenRegex s
mkSym s
| nullCS s = mkZero' "empty char range"
| fullCS s = mkDot
| otherwise = Sym s
{-# INLINE mkSym #-}
-- | construct an r.e. for a single char set
mkSym1 :: (StringLike s) =>
Char -> GenRegex s
mkSym1 = mkSym . singleCS
{-# INLINE mkSym1 #-}
-- | construct an r.e. for an intervall of chars
mkSymRng :: (StringLike s) =>
Char -> Char -> GenRegex s
mkSymRng c1 c2 = mkSym $ rangeCS c1 c2
{-# INLINE mkSymRng #-}
-- | mkSym generaized for strings
mkWord :: (StringLike s) =>
[Char] -> GenRegex s
mkWord = mkSeqs . map mkSym1
-- | construct an r.e. for the set of all Unicode chars
mkDot :: GenRegex s
mkDot = Dot
{-# INLINE mkDot #-}
-- | construct an r.e. for the set of all Unicode words
mkAll :: (StringLike s) =>
GenRegex s
mkAll = mkStar mkDot
{-# INLINE mkAll #-}
-- | construct r.e. for r*
mkStar :: (StringLike s) =>
GenRegex s -> GenRegex s
mkStar (Zero _) = mkUnit -- {}* == ()
mkStar e@Unit = e -- ()* == ()
mkStar e@(Star _e1) = e -- (r*)* == r*
mkStar (Rep 1 e1) = mkStar e1 -- (r+)* == r*
mkStar (Rep i e1)
| i == 1
||
nullable e1 = mkStar e1 -- (r{i,})* == r* when i == 1 or nullable r
mkStar e@(Rng _ _ e1)
| nullable e = mkStar e1 -- (r{i,j})* == r* when i == 0 or nullable r
mkStar e@(Alt _ _) = Star (rmStar e) -- (a*|b)* == (a|b)*
{- this is wrong, not generally applicable
mkStar (Br l r s) = mkBr0 l (mkStar r) s -- ({l}r)* == ({l}r*) because we want the longest match as result for the subexpression
-}
mkStar e = Star e
rmStar :: (StringLike s) =>
GenRegex s -> GenRegex s
rmStar (Alt e1 e2) = mkAlt (rmStar e1) (rmStar e2)
rmStar (Star e1) = rmStar e1
rmStar (Rep 1 e1) = rmStar e1
rmStar e1 = e1
-- | construct the r.e for r1|r2
mkAlt :: (StringLike s) =>
GenRegex s -> GenRegex s -> GenRegex s
mkAlt e1 (Zero _) = e1 -- e1 u {} = e1
mkAlt (Zero _) e2 = e2 -- {} u e2 = e2
mkAlt (Sym p1) (Sym p2) = mkSym $ p1 `unionCS` p2 -- melting of predicates
mkAlt e1 e2@(Sym _) = mkAlt e2 e1 -- symmetry: predicates always first
mkAlt e1@(Sym _) (Alt e2@(Sym _) e3) = mkAlt (mkAlt e1 e2) e3 -- prepare melting of predicates
mkAlt (Sym _) e2@Dot = e2 -- c|. = . for a c's
mkAlt e1@(Star Dot) _e2 = e1 -- A* u e1 = A*
mkAlt _e1 e2@(Star Dot) = e2 -- e1 u A* = A*
mkAlt (Alt e1 e2) e3 = mkAlt e1 (mkAlt e2 e3) -- associativity
mkAlt e1 e2
| e1 == e2 = e1
| otherwise = Alt e1 e2
-- | construct the r.e. for r1{|}r2 (r1 orElse r2).
--
-- This represents the same r.e. as r1|r2, but when
-- collecting the results of subexpressions in (...) and r1 succeeds, the
-- subexpressions of r2 are discarded, so r1 matches are prioritized
--
-- example
--
-- > splitSubex "({1}x)|({2}.)" "x" = ([("1","x"),("2","x")], "")
-- >
-- > splitSubex "({1}x){|}({2}.)" "x" = ([("1","x")], "")
mkElse :: (StringLike s) =>
GenRegex s -> GenRegex s -> GenRegex s
mkElse e1 (Zero _) = e1 -- e1 u {} = e1
mkElse (Zero _) e2 = e2 -- {} u e2 = e2
mkElse (Sym p1) (Sym p2) = mkSym $ p1 `unionCS` p2 -- melting of predicates
-- no symmetry allowed
mkElse e1@(Sym _) (Else e2@(Sym _) e3) = mkElse (mkElse e1 e2) e3 -- prepare melting of predicates
mkElse (Sym _) e2@Dot = e2 -- c|. = . for a c's
mkElse e1@(Star Dot) _e2 = e1 -- A* u e1 = A*
mkElse _e1 e2@(Star Dot) = e2 -- e1 u A* = A*
mkElse (Else e1 e2) e3 = mkElse e1 (mkElse e2 e3) -- associativity
mkElse e1 e2
| e1 == e2 = e1
| otherwise = Else e1 e2
-- | Construct the sequence r.e. r1.r2
mkSeq :: GenRegex s -> GenRegex s -> GenRegex s
mkSeq e1@(Zero _) _e2 = e1
mkSeq _e1 e2@(Zero _) = e2
mkSeq Unit e2 = e2
mkSeq (Cbr ss1 e1) e2 = mkCbr ss1 (mkSeq e1 e2) -- move finished submatches upwards
mkSeq e1 Unit = e1
mkSeq (Seq e1 e2) e3 = mkSeq e1 (mkSeq e2 e3)
mkSeq e1 e2 = Seq e1 e2
-- | mkSeq extened to lists
mkSeqs :: [GenRegex s] -> GenRegex s
mkSeqs = foldr mkSeq mkUnit
-- | Construct repetition r{i,}
mkRep :: (StringLike s) =>
Int -> GenRegex s -> GenRegex s
mkRep 0 e = mkStar e
mkRep _ e@(Zero _) = e
mkRep _ e
| nullable e = mkStar e
mkRep i (Rep j e) = mkRep (i * j) e
mkRep i e = Rep i e
-- | Construct range r{i,j}
mkRng :: (StringLike s) =>
Int -> Int -> GenRegex s -> GenRegex s
mkRng 0 0 _e = mkUnit
mkRng 1 1 e = e
mkRng lb ub _e
| lb > ub = mkZero' $
"illegal range " ++
show lb ++ ".." ++ show ub
mkRng _l _u e@(Zero _) = e
mkRng _l _u e@Unit = e
mkRng lb ub e = Rng lb ub e
-- | Construct option r?
mkOpt :: (StringLike s) =>
GenRegex s -> GenRegex s
mkOpt = mkRng 0 1
{-# INLINE mkOpt #-}
-- | Construct difference r.e.: r1 {\\} r2
--
-- example
--
-- > match "[a-z]+{\\}bush" "obama" = True
-- > match "[a-z]+{\\}bush" "clinton" = True
-- > match "[a-z]+{\\}bush" "bush" = False -- not important any more
mkDiff :: (StringLike s) =>
GenRegex s -> GenRegex s -> GenRegex s
mkDiff e1@(Zero _) _e2 = e1 -- {} - r2 = {}
mkDiff e1 (Zero _) = e1 -- r1 - {} = r1
mkDiff _e1 (Star Dot) = mkZero' "empty set in difference expr" -- r1 - .* = {}
mkDiff Dot (Sym p) = mkSym $ compCS p -- . - s = ~s
mkDiff (Sym _) Dot = mkZero' "empty set in difference expr" -- x - . = {}
mkDiff (Sym p1) (Sym p2) = mkSym $ p1 `diffCS` p2 -- set diff
mkDiff e1 e2
| e1 == e2 = mkZero' "empty set in difference expr" -- r1 - r1 = {}
| otherwise = Diff e1 e2
-- | Construct the Complement of an r.e.: whole set of words - r
mkCompl :: (StringLike s) =>
GenRegex s -> GenRegex s
mkCompl (Zero _) = mkAll
mkCompl (Star Dot) = mkZero' "empty set in compl expr"
mkCompl e = mkDiff (mkStar mkDot) e
-- | Construct r.e. for intersection: r1 {&} r2
--
-- example
--
-- > match ".*a.*{&}.*b.*" "-a-b-" = True
-- > match ".*a.*{&}.*b.*" "-b-a-" = True
-- > match ".*a.*{&}.*b.*" "-a-a-" = False
-- > match ".*a.*{&}.*b.*" "---b-" = False
mkIsect :: (StringLike s) =>
GenRegex s -> GenRegex s -> GenRegex s
mkIsect e1@(Zero _) _e2 = e1 -- {} n r2 = {}
mkIsect _e1 e2@(Zero _) = e2 -- r1 n {} = {}
mkIsect e1@(Unit) e2 -- () n r2 = () if nullable r2
| nullable e2 = e1 -- () n r2 = {} if not nullable r2
| otherwise = mkZero' "intersection empty"
mkIsect e1 e2@(Unit) = mkIsect e2 e1 -- symmetric version of las 2 laws
mkIsect (Sym p1) (Sym p2) = mkSym $ p1 `intersectCS` p2 -- intersect sets
mkIsect e1@(Sym _) Dot = e1 -- x n . = x
mkIsect Dot e2@(Sym _) = e2 -- . n x = x
mkIsect (Star Dot) e2 = e2 -- .* n r2 = r2
mkIsect e1 (Star Dot) = e1 -- r1 n .* = r1
mkIsect e1 e2
| e1 == e2 = e1 -- r1 n r1 = r1
| otherwise = Isec e1 e2
-- | Construct r.e. for exclusive or: r1 {^} r2
--
-- example
--
-- > match "[a-c]+{^}[c-d]+" "abc" = True
-- > match "[a-c]+{^}[c-d]+" "acdc" = False
-- > match "[a-c]+{^}[c-d]+" "ccc" = False
-- > match "[a-c]+{^}[c-d]+" "cdc" = True
mkExor :: (StringLike s) =>
GenRegex s -> GenRegex s -> GenRegex s
mkExor (Zero _) e2 = e2
mkExor e1 (Zero _) = e1
mkExor (Star Dot) _e2 = mkZero' "empty set in exor expr"
mkExor _e1 (Star Dot) = mkZero' "empty set in exor expr"
mkExor (Sym p1) (Sym p2) = mkSym $ p1 `exorCS` p2
mkExor (Sym p1) Dot = mkSym $ compCS p1
mkExor Dot (Sym p2) = mkSym $ compCS p2
mkExor e1 e2
| e1 == e2 = mkZero' "empty set in exor expr" -- r1 xor r1 = {}
| otherwise = Exor e1 e2
mkInterleave :: GenRegex s -> GenRegex s -> GenRegex s
mkInterleave e1@(Zero _) _ = e1
mkInterleave _ e2@(Zero _) = e2
mkInterleave (Unit) e2 = e2
mkInterleave e1 (Unit) = e1
mkInterleave e1 e2 = Intl e1 e2
-- | Construct a labeled subexpression: ({label}r)
mkBr :: s -> GenRegex s -> GenRegex s
mkBr l e = Br (Just l) e
mkBr' :: StringLike s =>
String -> GenRegex s -> GenRegex s
mkBr' l e = Br (Just $ fromString l) e
mkBrN :: GenRegex s -> GenRegex s
mkBrN e = Br Nothing e
mkObr :: StringLike s =>
Label s -> s -> Int -> GenRegex s -> GenRegex s
mkObr _ _ _ e@(Zero _) = e
mkObr l s n Unit = mkCbr [(l, takeS n s)] mkUnit
mkObr l s n e = Obr l s n e
mkCbr :: SubexResults s -> GenRegex s -> GenRegex s
mkCbr _ e@(Zero _) = e -- dead end, throw away subexpr matches
mkCbr ss (Cbr ss1 e) = mkCbr (ss <> ss1) e -- join inner and this subexpr match
mkCbr ss e = Cbr ss e
-- ------------------------------------------------------------
instance (StringLike s) => Show (GenRegex s) where
show (Zero e) = "{" ++ toString e ++ "}"
show Unit = "()"
show (Sym p)
| p == compCS (stringCS "\n\r")
= "."
| null (tail cs) &&
rng1 (head cs)
= escRng . head $ cs
| otherwise = "[" ++ concat cs' ++ "]"
where
rng1 (x,y) = x == y
cs = p -- charRngs . chars $ p
cs' = map escRng p
escRng (x, y)
| x == y = esc x
| succ x == y
= esc x ++ esc y
| otherwise
= esc x ++ "-" ++ esc y
esc x
| x `elem` "\\-[]{}()*+?.^"
= '\\':x:""
| x >= ' ' && x <= '~'
= x:""
| otherwise
= "&#" ++ show (fromEnum x) ++ ";"
show Dot = "\\a"
show (Star Dot) = "\\A"
show (Star e) = "(" ++ show e ++ "*)"
show (Alt e1 e2) = "(" ++ show e1 ++ "|" ++ show e2 ++ ")"
show (Else e1 e2) = "(" ++ show e1 ++ "{|}" ++ show e2 ++ ")"
show (Seq e1 e2) = "(" ++ show e1 ++ show e2 ++ ")"
show (Rep 1 e) = "(" ++ show e ++ "+)"
show (Rep i e) = "(" ++ show e ++ "{" ++ show i ++ ",})"
show (Rng 0 1 e) = "(" ++ show e ++ "?)"
show (Rng i j e) = "(" ++ show e ++ "{" ++ show i ++ "," ++ show j ++ "})"
show (Diff e1 e2) = "(" ++ show e1 ++ "{\\}" ++ show e2 ++ ")"
show (Isec e1 e2) = "(" ++ show e1 ++ "{&}" ++ show e2 ++ ")"
show (Exor e1 e2) = "(" ++ show e1 ++ "{^}" ++ show e2 ++ ")"
show (Intl e1 e2) = "(" ++ show e1 ++ "{:}" ++ show e2 ++ ")"
show (Br l e) = "({" ++ showL l ++ "}" ++ show e ++ ")"
show (Obr l s n e) = "({" ++ showL l ++ "=" ++ toString (takeS n s) ++ "}" ++ show e ++ ")"
show (Cbr ss e) = "([" ++ intercalate "," (map (\ (l, s) -> showL l ++ "=" ++ toString s) ss) ++ "]"
++ show e ++
")"
showL :: Show s => Label s -> String
showL = rmq . maybe "" show
where
rmq ('\"':xs) = init xs
rmq xs = xs
-- ------------------------------------------------------------
isZero :: GenRegex s -> Bool
isZero (Zero _) = True
isZero _ = False
{-# INLINE isZero #-}
errRegex :: (StringLike s) =>
GenRegex s -> s
errRegex (Zero e) = e
errRegex _ = emptyS
-- ------------------------------------------------------------
nullable :: (StringLike s) =>
GenRegex s -> Bool
nullable = fst . nullable'
{-# INLINE nullable #-}
nullable' :: (StringLike s) =>
GenRegex s -> Nullable s
nullable' (Zero _) = (False, [])
nullable' Unit = (True, [])
nullable' Dot = (False, [])
nullable' (Sym _x) = (False, [])
nullable' (Star _e) = (True, [])
nullable' (Rep _i e) = nullable' e
nullable' (Rng i _ e) = (i == 0, []) `unionN` nullable' e
nullable' (Seq e1 e2) = nullable' e1 `isectN` nullable' e2
nullable' (Alt e1 e2) = nullable' e1 `unionN` nullable' e2
nullable' (Else e1 e2) = nullable' e1 `orElseN` nullable' e2
nullable' (Isec e1 e2) = nullable' e1 `isectN` nullable' e2
nullable' (Diff e1 e2) = nullable' e1 `diffN` nullable' e2
nullable' (Exor e1 e2) = nullable' e1 `exorN` nullable' e2
nullable' (Intl e1 e2) = nullable' e1 `isectN` nullable' e2
nullable' (Br l e) = (True, [(l, emptyS )]) `isectN` nullable' e
nullable' (Obr l s n e) = (True, [(l, takeS n s)]) `isectN` nullable' e
nullable' (Cbr ss e) = (True, ss) `isectN` nullable' e
isectN :: Nullable s -> Nullable s -> Nullable s
isectN (True, ws1) (True, ws2) = (True, ws1 ++ ws2)
isectN _ _ = (False, [])
unionN :: Nullable s -> Nullable s -> Nullable s
unionN (False, _) (False, _) = (False, [])
unionN (_, ws1) (_, ws2) = (True, ws1 ++ ws2)
orElseN :: Nullable s -> Nullable s -> Nullable s
orElseN e1@(True, _ws1) _ = e1
orElseN _ e2 = e2
diffN :: Nullable s -> Nullable s -> Nullable s
diffN n1 (False, _) = n1
diffN _ _ = (False, [])
exorN :: Nullable s -> Nullable s -> Nullable s
exorN n1@(True, _) (False, _) = n1
exorN (False, _) n2@(True, _) = n2
exorN _ _ = (False, [])
-- ------------------------------------------------------------
-- | FIRST for regular expressions
--
-- this is only an approximation, the real set of char may be smaller,
-- when the expression contains intersection, set difference or exor operators
firstChars :: (StringLike s) =>
GenRegex s -> CharSet
firstChars (Zero _) = emptyCS
firstChars Unit = emptyCS
firstChars (Sym p) = p
firstChars Dot = allCS
firstChars (Star e1) = firstChars e1
firstChars (Alt e1 e2) = firstChars e1 `unionCS` firstChars e2
firstChars (Else e1 e2) = firstChars e1 `unionCS` firstChars e2
firstChars (Seq e1 e2)
| nullable e1 = firstChars e1 `unionCS` firstChars e2
| otherwise = firstChars e1
firstChars (Rep _i e) = firstChars e
firstChars (Rng _i _j e) = firstChars e
firstChars (Diff e1 _e2) = firstChars e1 -- this is an approximation
firstChars (Isec e1 e2) = firstChars e1 `intersectCS` firstChars e2 -- this is an approximation
firstChars (Exor e1 e2) = firstChars e1 `unionCS` firstChars e2 -- this is an approximation
firstChars (Intl e1 e2) = firstChars e1 `unionCS` firstChars e2
firstChars (Br _l e) = firstChars e
firstChars (Obr _l _s _n e) = firstChars e
firstChars (Cbr _ss e) = firstChars e
-- ------------------------------------------------------------
delta1 :: (StringLike s) => Char -> s -> GenRegex s -> GenRegex s
delta1 c inp e0
= d' e0
where
d' e@(Zero _) = e
d' Unit = mkZero' $
"unexpected char " ++ show c
d' (Sym p)
| c `elemCS` p = mkUnit
| otherwise = mkZero' $
"unexpected char " ++ show c
d' Dot = mkUnit
d' e@(Star Dot) = e
d' e@(Star e1) = mkSeq (d' e1) e
d' (Alt e1 e2) = mkAlt (d' e1) (d' e2)
d' (Else e1 e2) = mkElse (d' e1) (d' e2)
d' (Seq e1@(Obr l s n e1') e2)
| nu = mkAlt (mkSeq (d' e1) e2)
(mkCbr ((l, takeS n s) : ws) (d' e2))
where
(nu, ws) = nullable' e1'
d' (Seq e1 e2)
| nullable e1 = mkAlt (mkSeq (d' e1) e2)
(d' e2)
| otherwise = mkSeq (d' e1) e2
d' (Rep i e) = mkSeq (d' e) (mkRep (i-1) e)
d' (Rng i j e) = mkSeq (d' e) (mkRng ((i-1) `max` 0) (j-1) e)
d' (Diff e1 e2) = mkDiff (d' e1) (d' e2)
d' (Isec e1 e2) = mkIsect (d' e1) (d' e2)
d' (Exor e1 e2) = mkExor (d' e1) (d' e2)
d' (Intl e1 e2) = mkAlt (mkInterleave (d' e1) e2 )
(mkInterleave e1 (d' e2))
d' (Br l e) = d' (mkObr l inp 0 e) -- a subex parse starts
d' (Obr l s n e) = mkObr l s (n + 1) (d' e) -- a subex parse cont.
d' (Cbr ss e) = mkCbr ss (d' e) -- the results of a subex parse
-- ------------------------------------------------------------
delta :: (StringLike s) => s -> GenRegex s -> GenRegex s
delta inp@(uncons -> Just (c, inp')) e0
= d' e0
where
d' e@(Zero _) = e -- don't process whole input, parse has failed
d' e@(Star Dot) = e -- don't process input, derivative does not change
d' e = delta inp' ( -- trc "delta1=" $
delta1 c inp e)
delta _empty e
= e
matchWithRegex :: (StringLike s) =>
GenRegex s -> s -> Bool
matchWithRegex e s
= nullable $ delta s e
matchWithRegex' :: (StringLike s) =>
GenRegex s -> s -> Maybe (SubexResults s)
matchWithRegex' e s
= (\ (r, l) -> if r then Just l else Nothing) . nullable' $ delta s e
-- ------------------------------------------------------------
-- | This function wraps the whole regex in a subexpression before starting
-- the parse. This is done for getting access to
-- the whole parsed string. Therfore we need one special label, this label
-- is the Nothing value, all explicit labels are Just labels.
splitWithRegex :: (StringLike s) =>
GenRegex s -> s -> Maybe (SubexResults s, s)
splitWithRegex re inp
= do
(re', rest) <- splitWithRegex' (mkBrN re) inp
return ( snd . nullable' $ re', rest)
splitWithRegexCS :: (StringLike s) =>
GenRegex s -> CharSet -> s -> Maybe (SubexResults s, s)
splitWithRegexCS re cs inp
= do
(re', rest) <- splitWithRegexCS' (mkBrN re) cs inp
return ( snd . nullable' $ re', rest)
-- ----------------------------------------
--
-- | The main scanner function
{- linear recursive function, can lead to stack overflow
splitWithRegex' :: Eq l => GenRegex s -> String -> Maybe (GenRegex s, String)
splitWithRegex' re ""
| nullable re = Just (re, "")
| otherwise = Nothing
splitWithRegex' re inp@(c : inp')
| isZero re = Nothing
| otherwise = evalRes . splitWithRegex' (delta1 re c) $ inp'
where
evalRes Nothing
| nullable re = Just (re, inp)
| otherwise = Nothing
evalRes res = res
-}
-- tail recursive version of above function
splitWithRegex' :: (StringLike s) =>
GenRegex s -> s -> Maybe (GenRegex s, s)
splitWithRegex' re inp
= splitWithRegex''
( if nullable re
then Just (re, inp) -- first possible result: empty prefix
else Nothing -- empty prefix not a result
) re inp
splitWithRegex'' :: (StringLike s) =>
Maybe (GenRegex s, s) -> GenRegex s -> s -> Maybe (GenRegex s, s)
splitWithRegex'' lastRes re inp@(uncons -> Just (c, inp'))
| isZero re = lastRes
| otherwise = splitWithRegex'' nextRes re' $ inp'
where
re' = delta1 c inp re
nextRes
| nullable re' = Just (re', inp')
| otherwise = lastRes
splitWithRegex'' lastRes _re _empty
= lastRes
-- ----------------------------------------
--
-- | speedup version for splitWithRegex'
--
-- This function checks whether the input starts with a char from FIRST re.
-- If this is not the case, the split fails. The FIRST set can be computed once
-- for a whole tokenizer and reused by every call of split
splitWithRegexCS' :: (StringLike s) =>
GenRegex s -> CharSet -> s -> Maybe (GenRegex s, s)
splitWithRegexCS' re cs inp@(uncons -> Just (c, _inp'))
| c `elemCS` cs = splitWithRegex' re inp
splitWithRegexCS' re _cs inp
| nullable re = Just (re, inp)
| otherwise = Nothing
-- ------------------------------------------------------------