{-# 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           Data.List                  (sortBy)
import           Data.List.NonEmpty         (NonEmpty)
import           Data.Map.Lazy              (Map)
import qualified Data.Map.Lazy              as Map
import           Data.Ord                   (comparing)
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                  (CUChar, 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

-- | A wrapper around a list of captures that carries additional type-level
-- information about the number and names of those captures.
--
-- This type is only intended to be created by `regex`\/`_regex` and consumed by
-- `capture`\/`_capture`, relying on type inference.  Specifying the @info@
-- explicitly in a type signature is not supported—the definition of
-- `CapturesInfo` is not part of the public API and may change.
--
-- After obtaining `Captures` it's recommended to immediately consume them and
-- transform them into application-level data, to avoid leaking the types.
newtype Captures (info :: CapturesInfo) = Captures (NonEmpty Text)
    deriving (Int -> Captures info -> ShowS
[Captures info] -> ShowS
Captures info -> String
(Int -> Captures info -> ShowS)
-> (Captures info -> String)
-> ([Captures info] -> ShowS)
-> Show (Captures info)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (info :: CapturesInfo). Int -> Captures info -> ShowS
forall (info :: CapturesInfo). [Captures info] -> ShowS
forall (info :: CapturesInfo). Captures info -> String
$cshowsPrec :: forall (info :: CapturesInfo). Int -> Captures info -> ShowS
showsPrec :: Int -> Captures info -> ShowS
$cshow :: forall (info :: CapturesInfo). Captures info -> String
show :: Captures info -> String
$cshowList :: forall (info :: CapturesInfo). [Captures info] -> ShowS
showList :: [Captures info] -> ShowS
Show {- ^ @since 2.0.4 -})

-- | The kind of `Captures`'s @info@.  The first number is the total number of
-- parenthesized captures, and the list is a lookup table from capture names to
-- numbers.
type CapturesInfo = (Nat, [(Symbol, Nat)])

-- | Look up the number of a capture at compile time, either by number or by
-- name.  Throw a helpful 'TypeError' if the index doesn't exist.
type family CaptNum (i :: k) (info :: CapturesInfo) :: Nat where
    CaptNum (i :: Nat) '(hi, _) = If (i `CmpNat` hi == 'GT)
        -- then
        (TypeError (TypeLits.Text "No capture numbered " :<>: ShowType i))
        -- else
        i

    CaptNum (i :: Symbol) '(_,  '(i, num) ': _)   = num
    CaptNum (i :: Symbol) '(hi, _         ': kvs) = CaptNum i '(hi, kvs)
    CaptNum (i :: Symbol) _                       = TypeError
        (TypeLits.Text "No capture named " :<>: ShowType i)

    CaptNum _ _ = TypeError
        (TypeLits.Text "Capture index must be a number (Nat) or name (Symbol)")

-- | Safely lookup a capture in a `Captures` result obtained from a Template
-- Haskell-generated matching function.
--
-- The type signature may be interpreted like this:  /Given some capture group/
-- /index @i@ and some @info@ about a regex, ensure that index exists and is/
-- /resolved to the number @num@ at compile time.  Then, at runtime, get a/
-- /capture group (numbered @num@) from a list of (at least @num@) captures./
--
-- In practice the variable @i@ is specified by type application and the other
-- variables are inferred.
--
-- > capture @3
-- > capture @"bar"
--
-- Specifying an invalid index will result in a type error.
capture :: forall i info num. (CaptNum i info ~ num, KnownNat num) =>
    Captures info -> Text
capture :: forall {k} (i :: k) (info :: CapturesInfo) (num :: Nat).
(CaptNum i info ~ num, KnownNat num) =>
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 (i :: k) (info :: CapturesInfo) (num :: Nat).
(CaptNum i info ~ num, KnownNat num) =>
Lens' (Captures info) Text
forall {k} (i :: k) (info :: CapturesInfo) (num :: Nat).
(CaptNum i info ~ num, KnownNat num) =>
Lens' (Captures info) Text
_capture @i

-- | Like `capture` but focus from a `Captures` to a capture.
_capture :: forall i info num. (CaptNum i info ~ num, KnownNat num) =>
    Lens' (Captures info) Text
_capture :: forall {k} (i :: k) (info :: CapturesInfo) (num :: Nat).
(CaptNum i info ~ num, KnownNat num) =>
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 -> Index (NonEmpty Text)
forall a. Num a => Integer -> a
fromInteger (Integer -> Index (NonEmpty Text))
-> Integer -> Index (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ 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

-- | Unexported, top-level `IORef` that's created upon the first runtime
-- evaluation of a Template Haskell `Matcher`.
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 #-}

-- | Given a pattern, create or retrieve a `Matcher` from the global cache.
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 a. a -> IO a
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)

-- | From options and pattern, determine number of parenthesized captures, along
-- with a list of their names (each indexed and in index order).
predictCapturesInfo :: Option -> Text -> IO (Int, [(Text, Int)])
predictCapturesInfo :: Option -> Text -> IO (Int, [(Text, Int)])
predictCapturesInfo 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 a b.
StateT [AppliedOption] IO a
-> (a -> StateT [AppliedOption] IO b)
-> StateT [AppliedOption] IO b
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 (Int, [(Text, Int)]))
-> IO (Int, [(Text, Int)])
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr Code
code ((Ptr Pcre2_code -> IO (Int, [(Text, Int)]))
 -> IO (Int, [(Text, Int)]))
-> (Ptr Pcre2_code -> IO (Int, [(Text, Int)]))
-> IO (Int, [(Text, Int)])
forall a b. (a -> b) -> a -> b
$ \Ptr Pcre2_code
codePtr -> do
        CUInt
count <- forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @CUInt Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_NAMECOUNT
        CUInt
entrySize <- forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @CUInt Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_NAMEENTRYSIZE
        PCRE2_SPTR
table <- forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @PCRE2_SPTR Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_NAMETABLE

        -- Can't do [0 .. count - 1] because it underflows when count == 0
        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
count) [CUInt
0 ..]
        [(Text, Int)]
lookupTable <- [CUInt] -> (CUInt -> IO (Text, Int)) -> IO [(Text, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CUInt]
indexes ((CUInt -> IO (Text, Int)) -> IO [(Text, Int)])
-> (CUInt -> IO (Text, Int)) -> IO [(Text, Int)]
forall a b. (a -> b) -> a -> b
$ \CUInt
i -> do
            let entryPtr :: PCRE2_SPTR
entryPtr = PCRE2_SPTR
table 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
entrySize)
                groupNamePtr :: PCRE2_SPTR
groupNamePtr = PCRE2_SPTR
entryPtr PCRE2_SPTR -> Int -> PCRE2_SPTR
forall a. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` Int
2
            Int
groupNumber <- do
                (Int
hi, Int
lo) <- LensLike IO (Int, Int) (Int, Int) Int Int
-> (Int, Int) -> (Int -> IO Int) -> IO (Int, Int)
forall (f :: * -> *) s t a b.
LensLike f s t a b -> s -> (a -> f b) -> f t
forOf LensLike IO (Int, Int) (Int, Int) Int Int
forall s t a b. Each s t a b => Traversal s t a b
Traversal (Int, Int) (Int, Int) Int Int
each (Int
0, Int
1) ((Int -> IO Int) -> IO (Int, Int))
-> (Int -> IO Int) -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ \Int
off ->
                    forall a b. (Integral a, Num b) => a -> b
fromIntegral @CUChar (PCRE2_UCHAR -> Int) -> IO PCRE2_UCHAR -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PCRE2_SPTR -> Int -> IO PCRE2_UCHAR
forall b. Ptr b -> Int -> IO PCRE2_UCHAR
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff PCRE2_SPTR
entryPtr Int
off
                Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
hi Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lo
            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 Word8 -> I8 -> IO Text
Text.fromPtr
                (PCRE2_SPTR -> Ptr Word8
fromCUs PCRE2_SPTR
groupNamePtr)
                (Int -> I8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
groupNameLen)
            (Text, Int) -> IO (Text, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
groupName, Int
groupNumber)

        CUInt
hiCaptNum <- forall a. Storable a => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo @CUInt Ptr Pcre2_code
codePtr CUInt
pcre2_INFO_CAPTURECOUNT

        (Int, [(Text, Int)]) -> IO (Int, [(Text, Int)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
hiCaptNum, ((Text, Int) -> (Text, Int) -> Ordering)
-> [(Text, Int)] -> [(Text, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Text, Int) -> Int) -> (Text, Int) -> (Text, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Text, Int) -> Int
forall a b. (a, b) -> b
snd) [(Text, Int)]
lookupTable)

-- | Low-level access to compiled pattern info, per the docs.
getCodeInfo :: (Storable a) => Ptr Pcre2_code -> CUInt -> IO a
getCodeInfo :: forall a. Storable a => 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 a b. IO a -> (a -> IO b) -> IO b
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

-- | Predict info about parenthesized captures of a pattern at splice time.
predictCapturesInfoQ :: String -> Q (Int, [(Text, Int)])
predictCapturesInfoQ :: String -> Q (Int, [(Text, Int)])
predictCapturesInfoQ = IO (Int, [(Text, Int)]) -> Q (Int, [(Text, Int)])
forall a. IO a -> Q a
runIO (IO (Int, [(Text, Int)]) -> Q (Int, [(Text, Int)]))
-> (String -> IO (Int, [(Text, Int)]))
-> String
-> Q (Int, [(Text, Int)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Option -> Text -> IO (Int, [(Text, Int)])
predictCapturesInfo Option
forall a. Monoid a => a
mempty (Text -> IO (Int, [(Text, Int)]))
-> (String -> Text) -> String -> IO (Int, [(Text, Int)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

-- | Generate the data-kinded phantom type parameter of `Captures` of a pattern,
-- if needed.
capturesInfoQ :: String -> Q (Maybe Type)
capturesInfoQ :: String -> Q (Maybe Type)
capturesInfoQ String
s = String -> Q (Int, [(Text, Int)])
predictCapturesInfoQ String
s Q (Int, [(Text, Int)])
-> ((Int, [(Text, Int)]) -> Q (Maybe Type)) -> Q (Maybe Type)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- No parenthesized captures, so need for Captures, so no info.
    (Int
0, [(Text, Int)]
_) -> Maybe Type -> Q (Maybe Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing

    -- One or more parenthesized captures.  Produce
    --     '(5, '[ '("foo", 1), '("bar", 4)]).
    (Int
len, [(Text, Int)]
lookupTable) -> 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
forall (m :: * -> *). Quote m => Int -> m Type
promotedTupleT Int
2 Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
hiQ Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
kvsQ where
        -- 5
        hiQ :: Q Type
hiQ = Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> Q TyLit -> Q Type
forall a b. (a -> b) -> a -> b
$ Integer -> Q TyLit
forall (m :: * -> *). Quote m => Integer -> m TyLit
numTyLit (Integer -> Q TyLit) -> Integer -> Q TyLit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
        -- '[ '("foo", 1), '("bar", 4)]
        kvsQ :: Q Type
kvsQ = ((Text, Int) -> Q Type -> Q Type)
-> Q Type -> [(Text, Int)] -> Q Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text, Int) -> Q Type -> Q Type
forall {a} {m :: * -> *}.
(Integral a, Quote m) =>
(Text, a) -> m Type -> m Type
f Q Type
forall (m :: * -> *). Quote m => m Type
promotedNilT [(Text, Int)]
lookupTable
        -- '("foo", 1) ': ...
        f :: (Text, a) -> m Type -> m Type
f (Text
name, a
number) m Type
r = m Type
forall (m :: * -> *). Quote m => m Type
promotedConsT m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m Type
kvQ m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m Type
r where
            kvQ :: m Type
kvQ = Int -> m Type
forall (m :: * -> *). Quote m => Int -> m Type
promotedTupleT Int
2                           -- '(,)
                m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m TyLit -> m Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (String -> m TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (String -> m TyLit) -> String -> m TyLit
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name)    -- "foo"
                m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m TyLit -> m Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Integer -> m TyLit
forall (m :: * -> *). Quote m => Integer -> m TyLit
numTyLit (Integer -> m TyLit) -> Integer -> m TyLit
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
number) -- 1

-- | Helper for `regex` with no parenthesized captures.
matchTH :: (Alternative f) => Text -> Text -> f Text
matchTH :: forall (f :: * -> *). Alternative f => Text -> Text -> f Text
matchTH Text
patt = Getting (Alt f Text) Text Text -> Text -> f Text
forall (f :: * -> *) a s.
Applicative f =>
Getting (Alt f a) s a -> s -> f a
altOf (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

-- | Helper for `regex` with parenthesized captures.
capturesTH :: forall info f. (Alternative f) =>
    Text -> Text -> f (Captures info)
capturesTH :: forall (info :: CapturesInfo) (f :: * -> *).
Alternative f =>
Text -> Text -> f (Captures info)
capturesTH Text
patt = Getting (Alt f (Captures info)) Text (Captures info)
-> Text -> f (Captures info)
forall (f :: * -> *) a s.
Applicative f =>
Getting (Alt f a) s a -> s -> f a
altOf (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

-- | Helper for `regex` as a guard pattern.
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

-- | Helper for `regex` as a pattern that binds local variables.
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)

-- | Helper for `_regex` with no parenthesized captures.
_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 (f :: * -> *).
Functor f =>
(a -> f a) -> Identity a -> f (Identity a)
_Identity

-- | Helper for `_regex` with parenthesized captures.
_capturesTH :: Text -> Traversal' Text (Captures info)
_capturesTH :: forall (info :: CapturesInfo).
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'

-- | Helper to generate a `Text` in code.
textQ :: String -> ExpQ
textQ :: String -> ExpQ
textQ String
s = [e| Text.pack $(String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE String
s) |]

-- | Helper to generate a `quoteExp` function, which either simply matches the
-- subject or produces captures depending on the pattern.
mkQuoteExp :: ExpQ -> ExpQ -> String -> ExpQ
mkQuoteExp :: ExpQ -> ExpQ -> String -> ExpQ
mkQuoteExp ExpQ
matchE ExpQ
capturesE String
s = ExpQ
regexQ ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> ExpQ
textQ String
s where
    regexQ :: ExpQ
regexQ = String -> Q (Maybe Type)
capturesInfoQ String
s Q (Maybe Type) -> (Maybe Type -> ExpQ) -> ExpQ
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Type
Nothing   -> ExpQ
matchE
        Just Type
info -> ExpQ
capturesE ExpQ -> Q Type -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`appTypeE` Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
info

-- | === As an expression
--
-- @
-- regex :: (`Alternative` f) => String -> Text -> f (`Captures` info)
-- @
--
-- if there are parenthesized captures, or
--
-- > regex :: (Alternative f) => String -> Text -> f Text
--
-- if there are none.  In other words, if there is more than the 0th capture,
-- this behaves like `captures` (except returning an opaque `Captures` instead
-- of a `NonEmpty` list), otherwise it behaves like `Text.Regex.Pcre2.match`.
--
-- To retrieve an individual capture from a `Captures`, use `capture`.
--
-- > case [regex|(?<y>\d{4})-(?<m>\d{2})-(?<d>\d{2})|] "submitted 2020-10-20" of
-- >     Just cs ->
-- >         let date = capture @0 cs
-- >             year = read @Int $ Text.unpack $ capture @"y" cs
-- >             ...
--
-- > forM_ @Maybe ([regex|\s+$|] line) $ \spaces ->
-- >     printf "line has trailing spaces (%d characters)\n" (Text.length spaces)
--
-- === As a pattern
--
-- This matches when the regex first matches.  Any named captures are bound to
-- variables of the same names.
--
-- > case "submitted 2020-10-20" of
-- >     [regex|(?<y>\d{4})-(?<m>\d{2})-(?<d>\d{2})|] ->
-- >         let year = read @Int $ Text.unpack y
-- >             ...
--
-- Note that it is not possible to access the 0th capture this way.  As a
-- workaround, explicitly capture the whole pattern and name it.
--
-- If there are no named captures, this simply acts as a guard.
regex :: QuasiQuoter
regex :: QuasiQuoter
regex = QuasiQuoter{
    quoteExp :: String -> ExpQ
quoteExp = ExpQ -> ExpQ -> String -> ExpQ
mkQuoteExp [e| matchTH |] [e| capturesTH |],

    quotePat :: String -> Q Pat
quotePat = \String
s -> String -> Q (Int, [(Text, Int)])
predictCapturesInfoQ String
s Q (Int, [(Text, Int)]) -> ((Int, [(Text, Int)]) -> Q Pat) -> Q Pat
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Int, [(Text, Int)])
info -> case (Int, [(Text, Int)]) -> [(Text, Int)]
forall a b. (a, b) -> b
snd (Int, [(Text, Int)])
info of
        []          -> ExpQ -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Exp -> m Pat -> m Pat
viewP [e| matchesTH $(String -> ExpQ
textQ String
s) |] [p| True |]
        [(Text, Int)]
lookupTable -> ExpQ -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Exp -> m Pat -> m Pat
viewP ExpQ
e Q Pat
p where
            ([Text]
names, [Int]
numbers) = [(Text, Int)] -> ([Text], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Text, Int)]
lookupTable
            e :: ExpQ
e = [e| capturesNumberedTH $(String -> ExpQ
textQ String
s) $([Int] -> ExpQ
forall (m :: * -> *) a. (Quote m, Data a) => a -> m Exp
liftData [Int]
numbers) |]
            p :: Q Pat
p = (Text -> Q Pat -> Q Pat) -> Q Pat -> [Text] -> Q Pat
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Q Pat -> Q Pat
forall {m :: * -> *}. Quote m => Text -> m Pat -> m Pat
f Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP [Text]
names
            f :: Text -> m Pat -> m Pat
f Text
name m Pat
r = Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP '(:) [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> m Pat) -> Name -> m 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, m Pat
r],

    quoteType :: String -> Q Type
quoteType = \String
_ -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"regex: cannot produce a type",
    quoteDec :: String -> Q [Dec]
quoteDec  = \String
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"regex: cannot produce declarations"}

-- | An optical variant of `regex`\/a type-annotated variant of `_captures`. Can
-- only be used as an expression.
--
-- @
-- _regex :: String -> `Traversal'` Text (`Captures` info)
-- _regex :: String -> Traversal' Text Text
-- @
--
-- > embeddedNumbers :: Traversal' String Int
-- > embeddedNumbers = packed . [_regex|\d+|] . unpacked . _Show
-- >
-- > main :: IO ()
-- > main = putStrLn $ "There are 14 competing standards" & embeddedNumbers %~ (+ 1)
-- >
-- > -- There are 15 competing standards
_regex :: QuasiQuoter
_regex :: QuasiQuoter
_regex = QuasiQuoter{
    quoteExp :: String -> ExpQ
quoteExp = ExpQ -> ExpQ -> String -> ExpQ
mkQuoteExp [e| _matchTH |] [e| _capturesTH |],

    quotePat :: String -> Q Pat
quotePat  = \String
_ -> String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"_regex: cannot produce a pattern",
    quoteType :: String -> Q Type
quoteType = \String
_ -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"_regex: cannot produce a type",
    quoteDec :: String -> Q [Dec]
quoteDec  = \String
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"_regex: cannot produce declarations"}