{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Text.Regex.Pcre2.TH where
import Control.Applicative (Alternative(..))
import Control.Monad (forM)
import Control.Monad.State.Strict (evalStateT)
import Data.IORef
import qualified Data.IntMap.Strict as IM
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as Map
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Foreign as Text
import Data.Type.Bool (If)
import Data.Type.Equality (type (==))
import Foreign
import Foreign.C (CUInt)
import GHC.TypeLits hiding (Text)
import qualified GHC.TypeLits as TypeLits
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax (liftData)
import Lens.Micro
import Lens.Micro.Extras (view)
import System.IO.Unsafe (unsafePerformIO)
import Text.Regex.Pcre2.Foreign
import Text.Regex.Pcre2.Internal
newtype Captures (info :: CapturesInfo) = Captures (NonEmpty Text)
deriving (Show )
type CapturesInfo = (Nat, [(Symbol, Nat)])
type family CaptNum (i :: k) (info :: CapturesInfo) :: Nat where
CaptNum (num :: Nat) '(hi, _) = If (num `CmpNat` hi == 'GT)
(TypeError (TypeLits.Text "No capture numbered " :<>: ShowType num))
num
CaptNum (name :: Symbol) '(_, '(name, num) ': _) = num
CaptNum (name :: Symbol) '(hi, _ ': kvs) = CaptNum name '(hi, kvs)
CaptNum (name :: Symbol) _ = TypeError
(TypeLits.Text "No capture named " :<>: ShowType name)
CaptNum _ _ = TypeError
(TypeLits.Text "Capture index must be a number (Nat) or name (Symbol)")
capture :: forall i info num. (CaptNum i info ~ num, KnownNat num) =>
Captures info -> Text
capture :: Captures info -> Text
capture = Getting Text (Captures info) Text -> Captures info -> Text
forall a s. Getting a s a -> s -> a
view (Getting Text (Captures info) Text -> Captures info -> Text)
-> Getting Text (Captures info) Text -> Captures info -> Text
forall a b. (a -> b) -> a -> b
$ forall k (i :: k) (info :: CapturesInfo) (num :: Nat).
(CaptNum i info ~ num, KnownNat num) =>
Lens' (Captures info) Text
forall (info :: CapturesInfo) (num :: Nat).
(CaptNum i info ~ num, KnownNat num) =>
Lens' (Captures info) Text
_capture @i
_capture :: forall i info num. (CaptNum i info ~ num, KnownNat num) =>
Lens' (Captures info) Text
_capture :: Lens' (Captures info) Text
_capture = (NonEmpty Text -> f (NonEmpty Text))
-> Captures info -> f (Captures info)
forall (f :: * -> *) (info :: CapturesInfo) (info :: CapturesInfo).
Functor f =>
(NonEmpty Text -> f (NonEmpty Text))
-> Captures info -> f (Captures info)
_Captures ((NonEmpty Text -> f (NonEmpty Text))
-> Captures info -> f (Captures info))
-> ((Text -> f Text) -> NonEmpty Text -> f (NonEmpty Text))
-> (Text -> f Text)
-> Captures info
-> f (Captures info)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Traversal (NonEmpty Text) (NonEmpty Text) Text Text
-> Lens (NonEmpty Text) (NonEmpty Text) Text Text
forall s t a. HasCallStack => Traversal s t a a -> Lens s t a a
singular (Index (NonEmpty Text)
-> Traversal' (NonEmpty Text) (IxValue (NonEmpty Text))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Index (NonEmpty Text)
-> Traversal' (NonEmpty Text) (IxValue (NonEmpty Text)))
-> Index (NonEmpty Text)
-> Traversal' (NonEmpty Text) (IxValue (NonEmpty Text))
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy num -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal @num Proxy num
forall k (t :: k). Proxy t
Proxy) where
_Captures :: (NonEmpty Text -> f (NonEmpty Text))
-> Captures info -> f (Captures info)
_Captures NonEmpty Text -> f (NonEmpty Text)
f (Captures NonEmpty Text
cs) = NonEmpty Text -> Captures info
forall (info :: CapturesInfo). NonEmpty Text -> Captures info
Captures (NonEmpty Text -> Captures info)
-> f (NonEmpty Text) -> f (Captures info)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Text -> f (NonEmpty Text)
f NonEmpty Text
cs
globalMatcherCache :: IORef (Map Text Matcher)
globalMatcherCache :: IORef (Map Text Matcher)
globalMatcherCache = IO (IORef (Map Text Matcher)) -> IORef (Map Text Matcher)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map Text Matcher)) -> IORef (Map Text Matcher))
-> IO (IORef (Map Text Matcher)) -> IORef (Map Text Matcher)
forall a b. (a -> b) -> a -> b
$ Map Text Matcher -> IO (IORef (Map Text Matcher))
forall a. a -> IO (IORef a)
newIORef Map Text Matcher
forall k a. Map k a
Map.empty
{-# NOINLINE globalMatcherCache #-}
memoMatcher :: Text -> Matcher
memoMatcher :: Text -> Matcher
memoMatcher Text
patt = IO Matcher -> Matcher
forall a. IO a -> a
unsafePerformIO (IO Matcher -> Matcher) -> IO Matcher -> Matcher
forall a b. (a -> b) -> a -> b
$ do
Map Text Matcher
cache <- IORef (Map Text Matcher) -> IO (Map Text Matcher)
forall a. IORef a -> IO a
readIORef IORef (Map Text Matcher)
globalMatcherCache
case Text -> Map Text Matcher -> Maybe Matcher
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
patt Map Text Matcher
cache of
Just Matcher
matcher -> Matcher -> IO Matcher
forall (m :: * -> *) a. Monad m => a -> m a
return Matcher
matcher
Maybe Matcher
Nothing -> IORef (Map Text Matcher)
-> (Map Text Matcher -> (Map Text Matcher, Matcher)) -> IO Matcher
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Text Matcher)
globalMatcherCache ((Map Text Matcher -> (Map Text Matcher, Matcher)) -> IO Matcher)
-> (Map Text Matcher -> (Map Text Matcher, Matcher)) -> IO Matcher
forall a b. (a -> b) -> a -> b
$ \Map Text Matcher
cache ->
let matcher :: Matcher
matcher = Option -> Text -> Matcher
pureUserMatcher Option
forall a. Monoid a => a
mempty Text
patt
in (Text -> Matcher -> Map Text Matcher -> Map Text Matcher
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
patt Matcher
matcher Map Text Matcher
cache, Matcher
matcher)
predictCaptureNames :: Option -> Text -> IO [Maybe Text]
predictCaptureNames :: Option -> Text -> IO [Maybe Text]
predictCaptureNames Option
option Text
patt = do
Code
code <- StateT [AppliedOption] IO Code -> [AppliedOption] -> IO Code
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT
(ExtractOpts CompileEnv
extractCompileEnv ExtractOpts CompileEnv
-> (CompileEnv -> StateT [AppliedOption] IO Code)
-> StateT [AppliedOption] IO Code
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> CompileEnv -> StateT [AppliedOption] IO Code
extractCode Text
patt)
(Option -> [AppliedOption]
applyOption Option
option)
Code -> (Ptr Pcre2_code -> IO [Maybe Text]) -> IO [Maybe Text]
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Code
code Ptr Pcre2_code -> IO [Maybe Text]
getCaptureNames
getCaptureNames :: Ptr Pcre2_code -> IO [Maybe Text]
getCaptureNames :: Ptr Pcre2_code -> IO [Maybe Text]
getCaptureNames Ptr Pcre2_code
codePtr = do
CUInt
nameCount <- Ptr Pcre2_code -> CUInt -> IO CUInt
forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @CUInt Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_NAMECOUNT
CUInt
nameEntrySize <- Ptr Pcre2_code -> CUInt -> IO CUInt
forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @CUInt Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_NAMEENTRYSIZE
PCRE2_SPTR
nameTable <- Ptr Pcre2_code -> CUInt -> IO PCRE2_SPTR
forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @PCRE2_SPTR Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_NAMETABLE
let indexes :: [CUInt]
indexes = (CUInt -> Bool) -> [CUInt] -> [CUInt]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (CUInt -> CUInt -> Bool
forall a. Ord a => a -> a -> Bool
< CUInt
nameCount) [CUInt
0 ..]
IntMap Text
names <- ([(Int, Text)] -> IntMap Text)
-> IO [(Int, Text)] -> IO (IntMap Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Int, Text)] -> IntMap Text
forall a. [(Int, a)] -> IntMap a
IM.fromList (IO [(Int, Text)] -> IO (IntMap Text))
-> IO [(Int, Text)] -> IO (IntMap Text)
forall a b. (a -> b) -> a -> b
$ [CUInt] -> (CUInt -> IO (Int, Text)) -> IO [(Int, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CUInt]
indexes ((CUInt -> IO (Int, Text)) -> IO [(Int, Text)])
-> (CUInt -> IO (Int, Text)) -> IO [(Int, Text)]
forall a b. (a -> b) -> a -> b
$ \CUInt
i -> do
let entryPtr :: PCRE2_SPTR
entryPtr = PCRE2_SPTR
nameTable PCRE2_SPTR -> Int -> PCRE2_SPTR
forall a. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt
i CUInt -> CUInt -> CUInt
forall a. Num a => a -> a -> a
* CUInt
nameEntrySize)
groupNamePtr :: PCRE2_SPTR
groupNamePtr = PCRE2_SPTR
entryPtr PCRE2_SPTR -> Int -> PCRE2_SPTR
forall a. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` Int
1
PCRE2_UCHAR
groupNumber <- PCRE2_SPTR -> IO PCRE2_UCHAR
forall a. Storable a => Ptr a -> IO a
peek PCRE2_SPTR
entryPtr
Int
groupNameLen <- PCRE2_UCHAR -> PCRE2_SPTR -> IO Int
forall a. (Storable a, Eq a) => a -> Ptr a -> IO Int
lengthArray0 PCRE2_UCHAR
0 PCRE2_SPTR
groupNamePtr
Text
groupName <- Ptr Word16 -> I16 -> IO Text
Text.fromPtr
(PCRE2_SPTR -> Ptr Word16
fromCUs PCRE2_SPTR
groupNamePtr)
(Int -> I16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
groupNameLen)
(Int, Text) -> IO (Int, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (PCRE2_UCHAR -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PCRE2_UCHAR
groupNumber, Text
groupName)
CUInt
hiCaptNum <- Ptr Pcre2_code -> CUInt -> IO CUInt
forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @CUInt Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_CAPTURECOUNT
[Maybe Text] -> IO [Maybe Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe Text] -> IO [Maybe Text])
-> [Maybe Text] -> IO [Maybe Text]
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe Text) -> [Int] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (IntMap Text
names IntMap Text -> Int -> Maybe Text
forall a. IntMap a -> Int -> Maybe a
IM.!?) [Int
1 .. CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
hiCaptNum]
getCodeInfo :: (Storable a) => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo :: Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo Ptr Pcre2_code
codePtr CUInt
what = (Ptr a -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr a
wherePtr -> do
Ptr Pcre2_code -> CUInt -> Ptr a -> IO CInt
forall a. Ptr Pcre2_code -> CUInt -> Ptr a -> IO CInt
pcre2_pattern_info Ptr Pcre2_code
codePtr CUInt
what Ptr a
wherePtr IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
check (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0)
Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
wherePtr
predictCaptureNamesQ :: String -> Q [Maybe Text]
predictCaptureNamesQ :: String -> Q [Maybe Text]
predictCaptureNamesQ = IO [Maybe Text] -> Q [Maybe Text]
forall a. IO a -> Q a
runIO (IO [Maybe Text] -> Q [Maybe Text])
-> (String -> IO [Maybe Text]) -> String -> Q [Maybe Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Option -> Text -> IO [Maybe Text]
predictCaptureNames Option
forall a. Monoid a => a
mempty (Text -> IO [Maybe Text])
-> (String -> Text) -> String -> IO [Maybe Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
toKVs :: [Maybe Text] -> [(Int, Text)]
toKVs :: [Maybe Text] -> [(Int, Text)]
toKVs [Maybe Text]
names = [(Int
number, Text
name) | (Int
number, Just Text
name) <- [Int] -> [Maybe Text] -> [(Int, Maybe Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Maybe Text]
names]
capturesInfoQ :: String -> Q (Maybe Type)
capturesInfoQ :: String -> Q (Maybe Type)
capturesInfoQ String
s = String -> Q [Maybe Text]
predictCaptureNamesQ String
s Q [Maybe Text]
-> ([Maybe Text] -> Q (Maybe Type)) -> Q (Maybe Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> Maybe Type -> Q (Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing
[Maybe Text]
captureNames -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Q Type
promotedTupleT Int
2 Q Type -> Q Type -> Q Type
`appT` Q Type
hiQ Q Type -> Q Type -> Q Type
`appT` Q Type
kvsQ where
hiQ :: Q Type
hiQ = TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> TyLitQ -> Q Type
forall a b. (a -> b) -> a -> b
$ Integer -> TyLitQ
numTyLit (Integer -> TyLitQ) -> Integer -> TyLitQ
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Text]
captureNames
kvsQ :: Q Type
kvsQ = ((Int, Text) -> Q Type -> Q Type)
-> Q Type -> [(Int, Text)] -> Q Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Text) -> Q Type -> Q Type
forall a. Integral a => (a, Text) -> Q Type -> Q Type
f Q Type
promotedNilT ([(Int, Text)] -> Q Type) -> [(Int, Text)] -> Q Type
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [(Int, Text)]
toKVs [Maybe Text]
captureNames
f :: (a, Text) -> Q Type -> Q Type
f (a
number, Text
name) Q Type
r = Q Type
promotedConsT Q Type -> Q Type -> Q Type
`appT` Q Type
kvQ Q Type -> Q Type -> Q Type
`appT` Q Type
r where
kvQ :: Q Type
kvQ = Int -> Q Type
promotedTupleT Int
2
Q Type -> Q Type -> Q Type
`appT` TyLitQ -> Q Type
litT (String -> TyLitQ
strTyLit (String -> TyLitQ) -> String -> TyLitQ
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name)
Q Type -> Q Type -> Q Type
`appT` TyLitQ -> Q Type
litT (Integer -> TyLitQ
numTyLit (Integer -> TyLitQ) -> Integer -> TyLitQ
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
number)
matchTH :: (Alternative f) => Text -> Text -> f Text
matchTH :: Text -> Text -> f Text
matchTH Text
patt = Getting (Alt f Text) Text Text -> Text -> f Text
forall (f :: * -> *) a s.
Alternative f =>
Getting (Alt f a) s a -> s -> f a
toAlternativeOf (Getting (Alt f Text) Text Text -> Text -> f Text)
-> Getting (Alt f Text) Text Text -> Text -> f Text
forall a b. (a -> b) -> a -> b
$ Text -> Traversal' Text Text
_matchTH Text
patt
capturesTH :: forall info f. (Alternative f) =>
Text -> Text -> f (Captures info)
capturesTH :: Text -> Text -> f (Captures info)
capturesTH Text
patt = Getting (Alt f (Captures info)) Text (Captures info)
-> Text -> f (Captures info)
forall (f :: * -> *) a s.
Alternative f =>
Getting (Alt f a) s a -> s -> f a
toAlternativeOf (Getting (Alt f (Captures info)) Text (Captures info)
-> Text -> f (Captures info))
-> Getting (Alt f (Captures info)) Text (Captures info)
-> Text
-> f (Captures info)
forall a b. (a -> b) -> a -> b
$ Text -> Traversal' Text (Captures info)
forall (info :: CapturesInfo).
Text -> Traversal' Text (Captures info)
_capturesTH Text
patt
matchesTH :: Text -> Text -> Bool
matchesTH :: Text -> Text -> Bool
matchesTH Text
patt = Getting Any Text (Proxy Text) -> Text -> Bool
forall s a. Getting Any s a -> s -> Bool
has (Getting Any Text (Proxy Text) -> Text -> Bool)
-> Getting Any Text (Proxy Text) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Matcher -> FromMatch Proxy -> Traversal' Text (Proxy Text)
forall (t :: * -> *).
Traversable t =>
Matcher -> FromMatch t -> Traversal' Text (t Text)
_gcaptures (Text -> Matcher
memoMatcher Text
patt) FromMatch Proxy
getNoSlices
capturesNumberedTH :: Text -> [Int] -> Text -> [Text]
capturesNumberedTH :: Text -> [Int] -> Text -> [Text]
capturesNumberedTH Text
patt [Int]
numbers = Getting [Text] Text [Text] -> Text -> [Text]
forall a s. Getting a s a -> s -> a
view (Getting [Text] Text [Text] -> Text -> [Text])
-> Getting [Text] Text [Text] -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$
Matcher -> FromMatch [] -> Traversal' Text [Text]
forall (t :: * -> *).
Traversable t =>
Matcher -> FromMatch t -> Traversal' Text (t Text)
_gcaptures (Text -> Matcher
memoMatcher Text
patt) ([Int] -> FromMatch []
forall (t :: * -> *). Traversable t => t Int -> FromMatch t
getWhitelistedSlices [Int]
numbers)
_matchTH :: Text -> Traversal' Text Text
_matchTH :: Text -> Traversal' Text Text
_matchTH Text
patt = Matcher -> FromMatch Identity -> Traversal' Text (Identity Text)
forall (t :: * -> *).
Traversable t =>
Matcher -> FromMatch t -> Traversal' Text (t Text)
_gcaptures (Text -> Matcher
memoMatcher Text
patt) FromMatch Identity
get0thSlice ((Identity Text -> f (Identity Text)) -> Text -> f Text)
-> ((Text -> f Text) -> Identity Text -> f (Identity Text))
-> (Text -> f Text)
-> Text
-> f Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> f Text) -> Identity Text -> f (Identity Text)
forall a. Lens' (Identity a) a
_Identity
_capturesTH :: Text -> Traversal' Text (Captures info)
_capturesTH :: Text -> Traversal' Text (Captures info)
_capturesTH Text
patt = Matcher -> FromMatch NonEmpty -> Traversal' Text (NonEmpty Text)
forall (t :: * -> *).
Traversable t =>
Matcher -> FromMatch t -> Traversal' Text (t Text)
_gcaptures (Text -> Matcher
memoMatcher Text
patt) FromMatch NonEmpty
getAllSlices ((NonEmpty Text -> f (NonEmpty Text)) -> Text -> f Text)
-> ((Captures info -> f (Captures info))
-> NonEmpty Text -> f (NonEmpty Text))
-> (Captures info -> f (Captures info))
-> Text
-> f Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Captures info -> f (Captures info))
-> NonEmpty Text -> f (NonEmpty Text)
forall (f :: * -> *) (info :: CapturesInfo) (info :: CapturesInfo).
Functor f =>
(Captures info -> f (Captures info))
-> NonEmpty Text -> f (NonEmpty Text)
captured where
captured :: (Captures info -> f (Captures info))
-> NonEmpty Text -> f (NonEmpty Text)
captured Captures info -> f (Captures info)
f NonEmpty Text
cs = Captures info -> f (Captures info)
f (NonEmpty Text -> Captures info
forall (info :: CapturesInfo). NonEmpty Text -> Captures info
Captures NonEmpty Text
cs) f (Captures info)
-> (Captures info -> NonEmpty Text) -> f (NonEmpty Text)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Captures NonEmpty Text
cs') -> NonEmpty Text
cs'
regex :: QuasiQuoter
regex :: QuasiQuoter
regex = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter{
quoteExp :: String -> Q Exp
quoteExp = \String
s -> do
let regexQ :: Q Exp
regexQ = String -> Q (Maybe Type)
capturesInfoQ String
s Q (Maybe Type) -> (Maybe Type -> Q Exp) -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Type
Nothing -> [e| matchTH |]
Just Type
info -> [e| capturesTH |] Q Exp -> Q Type -> Q Exp
`appTypeE` Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
info
Q Exp
regexQ Q Exp -> Q Exp -> Q Exp
`appE` [e| Text.pack $(stringE s) |],
quotePat :: String -> Q Pat
quotePat = \String
s -> do
[Maybe Text]
captureNames <- String -> Q [Maybe Text]
predictCaptureNamesQ String
s
case [Maybe Text] -> [(Int, Text)]
toKVs [Maybe Text]
captureNames of
[] -> Q Exp -> Q Pat -> Q Pat
viewP
[e| matchesTH (Text.pack $(stringE s)) |]
[p| True |]
[(Int, Text)]
numberedNames -> Q Exp -> Q Pat -> Q Pat
viewP Q Exp
e Q Pat
p where
([Int]
numbers, [Text]
names) = [(Int, Text)] -> ([Int], [Text])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Int, Text)]
numberedNames
e :: Q Exp
e = [e| capturesNumberedTH
(Text.pack $(stringE s))
$(liftData numbers) |]
p :: Q Pat
p = (Text -> Q Pat -> Q Pat) -> Q Pat -> [Text] -> Q Pat
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Q Pat -> Q Pat
f Q Pat
wildP [Text]
names
f :: Text -> Q Pat -> Q Pat
f Text
name Q Pat
r = Name -> [Q Pat] -> Q Pat
conP '(:) [Name -> Q Pat
varP (Name -> Q Pat) -> Name -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name, Q Pat
r],
quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"regex: cannot produce a type",
quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"regex: cannot produce declarations"}
_regex :: QuasiQuoter
_regex :: QuasiQuoter
_regex = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter{
quoteExp :: String -> Q Exp
quoteExp = \String
s -> do
let _regexQ :: Q Exp
_regexQ = String -> Q (Maybe Type)
capturesInfoQ String
s Q (Maybe Type) -> (Maybe Type -> Q Exp) -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Type
Nothing -> [e| _matchTH |]
Just Type
info -> [e| _capturesTH |] Q Exp -> Q Type -> Q Exp
`appTypeE` Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
info
Q Exp
_regexQ Q Exp -> Q Exp -> Q Exp
`appE` [e| Text.pack $(stringE s) |],
quotePat :: String -> Q Pat
quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"_regex: cannot produce a pattern",
quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"_regex: cannot produce a type",
quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"_regex: cannot produce declarations"}