module System.Process.Quick.TdfaToSbvRegex (parse, match) where

import Data.SBV.RegExp
import System.Process.Quick.Prelude
import Text.Regex.TDFA.Pattern
import Text.Regex.TDFA.ReadRegex

parse :: String -> RegExp
parse :: String -> RegExp
parse String
rxp =
  case String -> Either ParseError (Pattern, (GroupIndex, DoPa))
parseRegex (String -> Either ParseError (Pattern, (GroupIndex, DoPa)))
-> String -> Either ParseError (Pattern, (GroupIndex, DoPa))
forall a b. (a -> b) -> a -> b
$ String -> String
adaptAnchors String
rxp of
    Right (Pattern
p, (GroupIndex, DoPa)
_) -> Pattern -> RegExp
tdfa2SbvRegex Pattern
p
    Left ParseError
e -> Text -> RegExp
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> RegExp) -> Text -> RegExp
forall a b. (a -> b) -> a -> b
$ Text
"Failed to parse pattern " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall b a. (Show a, IsString b) => a -> b
show String
rxp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as TDFA due: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
forall b a. (Show a, IsString b) => a -> b
show ParseError
e

adaptAnchors :: String -> String
adaptAnchors :: String -> String
adaptAnchors [] = String
".*"
adaptAnchors String
rx = String -> String
tailAnchor (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
headAnchor String
rx
  where
    headAnchor :: String -> String
headAnchor String
x =  if String
"^" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x then String
x else String
".*" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x
    tailAnchor :: String -> String
tailAnchor String
x =  if String
"$" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
x then String
x else String
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".*"

tdfa2SbvRegex :: Pattern -> RegExp
tdfa2SbvRegex :: Pattern -> RegExp
tdfa2SbvRegex = \case
  Pattern
PEmpty -> String -> RegExp
Literal String
""
  PGroup Maybe GroupIndex
_ Pattern
p -> Pattern -> RegExp
tdfa2SbvRegex Pattern
p -- ??
  POr [Pattern]
ps -> [RegExp] -> RegExp
Union ([RegExp] -> RegExp) -> [RegExp] -> RegExp
forall a b. (a -> b) -> a -> b
$ (Pattern -> RegExp) -> [Pattern] -> [RegExp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pattern -> RegExp
tdfa2SbvRegex [Pattern]
ps
  PConcat [Pattern]
ps -> [RegExp] -> RegExp
Conc ([RegExp] -> RegExp) -> [RegExp] -> RegExp
forall a b. (a -> b) -> a -> b
$ (Pattern -> RegExp) -> [Pattern] -> [RegExp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pattern -> RegExp
tdfa2SbvRegex [Pattern]
ps
  PQuest Pattern
p -> RegExp -> RegExp
Opt (RegExp -> RegExp) -> RegExp -> RegExp
forall a b. (a -> b) -> a -> b
$ Pattern -> RegExp
tdfa2SbvRegex Pattern
p
  PPlus Pattern
p -> RegExp -> RegExp
KPlus (RegExp -> RegExp) -> RegExp -> RegExp
forall a b. (a -> b) -> a -> b
$ Pattern -> RegExp
tdfa2SbvRegex Pattern
p
  PStar Bool
_ Pattern
p -> RegExp -> RegExp
KStar (RegExp -> RegExp) -> RegExp -> RegExp
forall a b. (a -> b) -> a -> b
$ Pattern -> RegExp
tdfa2SbvRegex Pattern
p
  PBound GroupIndex
n Maybe GroupIndex
Nothing Pattern
p -> GroupIndex -> RegExp -> RegExp
Power GroupIndex
n (RegExp -> RegExp) -> RegExp -> RegExp
forall a b. (a -> b) -> a -> b
$ Pattern -> RegExp
tdfa2SbvRegex Pattern
p
  PBound GroupIndex
n (Just GroupIndex
m) Pattern
p -> GroupIndex -> GroupIndex -> RegExp -> RegExp
Loop GroupIndex
n GroupIndex
m (RegExp -> RegExp) -> RegExp -> RegExp
forall a b. (a -> b) -> a -> b
$ Pattern -> RegExp
tdfa2SbvRegex Pattern
p
  PCarat DoPa
_ -> String -> RegExp
Literal String
"" -- store in state monad as global flag
  PDollar DoPa
_ -> String -> RegExp
Literal String
"" -- store in state monad as global flag
  PDot DoPa
_ -> RegExp
AllChar
  PAny DoPa
_ PatternSet
ps -> PatternSet -> RegExp
patternSetToRegex PatternSet
ps
  PAnyNot DoPa
_ PatternSet
ps -> RegExp -> RegExp -> RegExp
Inter RegExp
AllChar (RegExp -> RegExp) -> (RegExp -> RegExp) -> RegExp -> RegExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegExp -> RegExp
Comp (RegExp -> RegExp) -> RegExp -> RegExp
forall a b. (a -> b) -> a -> b
$ PatternSet -> RegExp
patternSetToRegex PatternSet
ps
  PEscape DoPa
_ Char
c -> String -> RegExp
Literal [Char
c]
  PChar DoPa
_ Char
c -> String -> RegExp
Literal [Char
c]
  PNonCapture Pattern
p -> Pattern -> RegExp
tdfa2SbvRegex Pattern
p -- ??
  PNonEmpty Pattern
p -> Pattern -> RegExp
tdfa2SbvRegex Pattern
p -- ??

patternSetToRegex :: PatternSet -> RegExp
patternSetToRegex :: PatternSet -> RegExp
patternSetToRegex = \case
  PatternSet Maybe (Set Char)
ps Maybe (Set PatternSetCharacterClass)
Nothing Maybe (Set PatternSetCollatingElement)
Nothing Maybe (Set PatternSetEquivalenceClass)
Nothing ->
    [RegExp] -> RegExp
Union ([RegExp] -> Maybe [RegExp] -> [RegExp]
forall a. a -> Maybe a -> a
fromMaybe [] (Set Char -> [RegExp]
charSetToRegex (Set Char -> [RegExp]) -> Maybe (Set Char) -> Maybe [RegExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Set Char)
ps))
  PatternSet Maybe (Set Char)
_ Maybe (Set PatternSetCharacterClass)
a Maybe (Set PatternSetCollatingElement)
b Maybe (Set PatternSetEquivalenceClass)
c ->
    Text -> RegExp
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> RegExp) -> Text -> RegExp
forall a b. (a -> b) -> a -> b
$ Text
"Not supported:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe (Set PatternSetCharacterClass) -> Text
forall b a. (Show a, IsString b) => a -> b
show Maybe (Set PatternSetCharacterClass)
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe (Set PatternSetCollatingElement) -> Text
forall b a. (Show a, IsString b) => a -> b
show Maybe (Set PatternSetCollatingElement)
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe (Set PatternSetEquivalenceClass) -> Text
forall b a. (Show a, IsString b) => a -> b
show Maybe (Set PatternSetEquivalenceClass)
c

charSetToRegex :: Set Char -> [RegExp]
charSetToRegex :: Set Char -> [RegExp]
charSetToRegex = (Char -> RegExp) -> String -> [RegExp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> RegExp
Literal (String -> RegExp) -> (Char -> String) -> Char -> RegExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
:[])) (String -> [RegExp])
-> (Set Char -> String) -> Set Char -> [RegExp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> String
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList