module Text.Regex.TDFA.QuasiQuoter.Internal where
import Prelude
( Either(..)
, String(..)
, fmap
, foldr
, (.)
, (++)
, null
, Char
, snd
, fst
, Maybe(..)
, Bool(..)
, not
, maybe
, either
, error
, Show(..)
, Eq(..)
, Ord(..)
, all
, otherwise
)
import Control.Applicative
( (<|>)
)
import Data.List
( find
, intersect
, nub
, (\\)
)
import qualified Text.Regex.TDFA.Common as TDFA
( CompOption(..)
, ExecOption(..)
)
import Text.Regex.TDFA.Common
( DoPa(..)
, CompOption(CompOption)
, ExecOption(ExecOption)
, GroupIndex(..)
)
import Data.Either
( partitionEithers
)
import Control.Monad
( guard
, Monad(..)
)
import Text.Regex.TDFA.ReadRegex
( parseRegex
)
import Text.Regex.TDFA.Pattern
( Pattern(..)
, PatternSet(..)
, PatternSetCharacterClass(..)
, PatternSetCollatingElement(..)
, PatternSetEquivalenceClass(..)
)
import Text.Regex.TDFA.TDFA
( patternToRegex
)
import Data.Typeable
( Typeable
)
import Data.Data
( Data
)
import Data.Char
( isHexDigit
, chr
)
import Numeric
( readHex
)
data Flag =
CaseSensitive { flagValue :: Bool }
| Multiline { flagValue :: Bool }
| RightAssoc { flagValue :: Bool }
| NewSyntax { flagValue :: Bool }
| LastStarGreedy { flagValue :: Bool }
| CaptureGroups { flagValue :: Bool }
deriving (Show, Eq, Ord)
data Options =
Options { caseSensitive :: Bool
, multiline :: Bool
, rightAssoc :: Bool
, newSyntax :: Bool
, lastStarGreedy :: Bool
, captureGroups :: Bool
}
deriving (Show, Eq, Ord)
deriving instance Typeable PatternSetEquivalenceClass
deriving instance Data PatternSetEquivalenceClass
deriving instance Typeable PatternSetCollatingElement
deriving instance Data PatternSetCollatingElement
deriving instance Typeable PatternSetCharacterClass
deriving instance Data PatternSetCharacterClass
deriving instance Typeable DoPa
deriving instance Data DoPa
deriving instance Typeable PatternSet
deriving instance Data PatternSet
deriving instance Typeable Pattern
deriving instance Data Pattern
deriving instance Typeable CompOption
deriving instance Data CompOption
deriving instance Typeable ExecOption
deriving instance Data ExecOption
unescape :: String -> String
unescape = unescaped
where
delim ('|':'~':']':xs) = Just ("|]", xs)
delim _ = Nothing
control xxs@(d1:d2:d3:d4:xs)
| all isHexDigit ds = Just ([chr v], xs)
| otherwise = Nothing
where ds = [d1,d2,d3,d4]
(v,_):_ = readHex ds
control _ = Nothing
escaped ('\\':xs) = Just ("\\", xs)
escaped ('n' :xs) = Just ("\n", xs)
escaped ('r' :xs) = Just ("\r", xs)
escaped ('t' :xs) = Just ("\t", xs)
escaped ('f' :xs) = Just ("\f", xs)
escaped ('v' :xs) = Just ("\v", xs)
escaped ('x' :xs) = control xs
escaped ('|':'~':']':xs) = Just ("|~]", xs)
escaped _ = Nothing
unescaped ('\\':xs) = case escaped xs of
Just (cs, xs') -> cs ++ unescaped xs'
Nothing -> '\\' : unescaped xs
unescaped xxs@(x:xs) = case delim xxs of
Just (cs, xs') -> cs ++ unescaped xs'
Nothing -> x : unescaped xs
unescaped [] = []
compilePattern :: String -> Either String (Pattern, (GroupIndex, DoPa))
compilePattern = either (Left . show) Right . parseRegex . unescape
defaultOptions :: Options
defaultOptions =
Options { caseSensitive = True
, multiline = True
, rightAssoc = True
, newSyntax = True
, lastStarGreedy = False
, captureGroups = True
}
optionsToTDFAOptions :: Options -> (CompOption, ExecOption)
optionsToTDFAOptions opts =
( CompOption { TDFA.caseSensitive = caseSensitive opts
, TDFA.multiline = multiline opts
, TDFA.rightAssoc = rightAssoc opts
, TDFA.newSyntax = newSyntax opts
, TDFA.lastStarGreedy = lastStarGreedy opts
}
, ExecOption { TDFA.captureGroups = captureGroups opts
}
)
applyFlag :: Flag -> Options -> Options
applyFlag (CaseSensitive v) opts = opts { caseSensitive = v }
applyFlag (Multiline v) opts = opts { multiline = v }
applyFlag (RightAssoc v) opts = opts { rightAssoc = v }
applyFlag (NewSyntax v) opts = opts { newSyntax = v }
applyFlag (LastStarGreedy v) opts = opts { lastStarGreedy = v }
applyFlag (CaptureGroups v) opts = opts { captureGroups = v }
flagsChars :: [(Char, Flag)]
flagsChars =
[ ('C', CaseSensitive True), ('c', CaseSensitive False)
, ('M', Multiline True), ('m', Multiline False)
, ('R', RightAssoc True), ('r', RightAssoc False)
, ('N', NewSyntax True), ('n', NewSyntax False)
, ('A', LastStarGreedy True), ('a', LastStarGreedy False)
, ('G', CaptureGroups True), ('g', CaptureGroups False)
]
charToFlag :: Char -> Maybe Flag
charToFlag c = fmap snd (find ((==c) . fst) flagsChars)
flagToChar :: Flag -> Char
flagToChar f =
case find ((==f) . snd) flagsChars of
Just (c,_) -> c
Nothing -> error ("Missing char for flag: " ++ show f)
negateFlag :: Flag -> Flag
negateFlag f = f { flagValue = not (flagValue f) }
parseFlags :: String -> Either String [Flag]
parseFlags chars = do
let results = fmap (\x -> maybe (Left x) Right (charToFlag x)) chars
(notFlags, flags) = partitionEithers results
extraFlags = flags \\ nub flags
conflictingFlags = intersect flags (fmap negateFlag flags)
guard (null notFlags)
<|> Left ("These are not flags '" ++ notFlags ++ "'")
guard (null extraFlags)
<|> Left ("Duplicate flags '" ++ fmap flagToChar extraFlags ++ "'")
guard (null conflictingFlags)
<|> Left ("Conflicting flags '" ++ fmap flagToChar conflictingFlags
++ "'")
Right flags
switch :: Either a b -> Either b a
switch = either Right Left
flagStringToOptions :: String -> Either String Options
flagStringToOptions = fmap (foldr applyFlag defaultOptions) . parseFlags