{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Regex.PCRE.Rex
-- Copyright   :  (c) Michael Sloan 2011
--
-- Maintainer  :  Michael Sloan (mgsloan@gmail.com)
-- Stability   :  unstable
-- Portability :  unportable
--
-- This module provides a template Haskell quasiquoter for regular expressions,
-- which provides the following features:
--
-- 1) Compile-time checking that the regular expression is valid.
--
-- 2) Arity of resulting tuple based on the number of selected capture patterns
-- in the regular expression.
--
-- 3) Allows for the inline interpolation of mapping functions :: String -> a.
--
-- 4) Precompiles the regular expression at compile time, by calling into the
-- PCRE library and storing a 'ByteString' literal representation of its state.
--
-- 5) Compile-time configurable to use different PCRE options, turn off
-- precompilation, use 'ByteString's, or set a default mapping expression.
--
-- Inspired by Matt Morrow's regexqq package:
-- <http://hackage.haskell.org/package/regexqq/docs/Text-Regex-PCRE-QQ.html>.
--
-- And some code from Erik Charlebois's interpolatedstring-qq package:
-- <http://hackage.haskell.org/package/interpolatedstring-qq/>.
--
-----------------------------------------------------------------------------

module Text.Regex.PCRE.Rex
  (

-- * Language Extensions
-- |
-- Since this is a quasiquoter library that generates code using view patterns,
-- the following extensions are required:
--
-- > {-# LANGUAGE TemplateHaskell, QuasiQuotes, ViewPatterns #-}

-- * First Example
-- |
-- Here's an example which parses peano numbers of the form Z, S Z, S S Z, etc.
-- The \s+ means that it is not sensitive to the quantity or type of separating
-- whitespace.  These examples can also be found in Test.hs.
--
-- > peano :: String -> Maybe Int
-- > peano = [rex|^(?{ length . filter (=='S') } \s* (?:S\s+)*Z)\s*$|]
--
-- > *Main> peano "Z"
-- > Just 0
-- > *Main> peano "S Z"
-- > Just 1
-- > *Main> peano "S   S Z"
-- > Just 2
-- > *Main> peano "S S S Z"
-- > Just 3
-- > *Main> peano "invalid"
-- > Nothing
--
-- The token \"(?{\" introduces a capture group which has a mapping applied to
-- the result. In this case, it's @length . filter (=='S')@.  If the ?{ ... }
-- are omitted, then the capture group is not taken as part of the results of
-- the match.  If the contents of the ?{ ... } is omitted, then a call to
-- 'rexView' is assumed:
--
-- > parsePair :: String -> Maybe (String, String)
-- > parsePair = [rex|^<\s* (?{ }[^\s,>]+) \s*,\s* (?{ }[^\s,>]+) \s*>$|]
--
-- The 'rexView' exported by this module is just equal to 'id', so by default
-- no preprocessing is done.  However, we can shadow this locally:
--
-- > parsePair' :: String -> Maybe (Int, Int)
-- > parsePair' = [rex|^<\s* (?{ }[^\s,>]+) \s*,\s* (?{ }[^\s,>]+) \s*>$|]
-- >   where
-- >     rexView = read
--
-- Additional shorthands can be added by using 'rexWithConf' and specifying
-- custom values for 'rexPreprocessExp' or 'rexPreprocessPat'.

-- * Second Example
-- |
-- This example is derived from
-- http://www.regular-expressions.info/dates.html
--
-- > parseDate :: String -> Maybe (Int, Int, Int)
-- > parseDate [rex|^(?{ read -> y }(?:19|20)\d\d)[- /.]
-- >                 (?{ read -> m }0[1-9]|1[012])[- /.]
-- >                 (?{ read -> d }0[1-9]|[12][0-9]|3[01])$|]
-- >   |  (d > 30 && (m `elem` [4, 6, 9, 11]))
-- >   || (m == 2 &&
-- >       (d == 29 && not (mod y 4 == 0 && (mod y 100 /= 0 || mod y 400 == 0)))
-- >      || (d > 29)) = Nothing
-- >   | otherwise = Just (y, m, d)
-- > parseDate _ = Nothing
--
-- The above example makes use of the regex quasi-quoter as a pattern matcher.
-- The interpolated Haskell patterns are used to construct an implicit view
-- pattern out of the inlined ones.  The above pattern is expanded to the
-- equivalent:
--
-- > parseDate ([rex|^(?{ read }(?:19|20)\d\d)[- /.]
-- >                  (?{ read }0[1-9]|1[012])[- /.]
-- >                  (?{ read }0[1-9]|[12][0-9]|3[01])$|]
-- >           -> Just (y, m, d))

-- * ByteStrings vs Strings
-- |
-- Since pcre-light is a wrapper over a C API, the most efficient interface is
-- ByteStrings, as it does not natively speak Haskell lists.  The [rex| ... ]
-- quasiquoter implicitely packs the input into a bystestring, and unpacks the
-- results to strings before providing them to your mappers.  The 'brex'
-- 'QuasiQuoter' is provided for this purpose.  You can also define your own
-- 'QuasiQuoter' - the definitions of the default configurations are as follows:
--
-- > rex  = rexWithConf $ defaultRexConf
-- > brex = rexWithConf $ defaultRexConf { rexByteString = True }
-- >
-- > defaultRexConf = RexConf False True "id" [PCRE.extended] []
--
-- The first @False@ specifies to use @String@ rather than 'ByteString'.  The
-- @True@ argument specifies to use precompilation.  --  The
-- string following is the default mapping expression, used when omitted.
-- Due to GHC staging restrictions, your configuration will need to be in a
-- different module than its usage.

-- * Future Work
-- |
-- There are a few things that could potentially be improved:
--
-- 1) PCRE captures, unlike .NET regular expressions, yield the last capture
-- made by a particular pattern.  So, for example, (...)*, will only yield one
-- match for '...'.  Ideally these would be detected and yield an implicit [a].
--
-- 2) Patterns with disjunction between captures ((?{f}a) | (?{g}b)) will
-- provide the empty string to one of f / g.  In the case of pattern
-- expressions, it would be convenient to be able to map multiple captures into
-- a single variable / pattern, preferring the first non-empty option.

-- * Quasiquoters
    rex, brex
-- * Configurable QuasiQuoter
  , rexWithConf, RexConf(..), defaultRexConf
-- * Utilities
  , makeQuasiMultiline
  , eitherToParseResult
  , parseExp
  , parsePat
  , rexParseMode
-- * Used by the generated code
  , rexView
  ) where

import Text.Regex.PCRE.Precompile

import qualified Text.Regex.PCRE.Light as PCRE

import Control.Applicative   ( (<$>) )
import Control.Arrow         ( first )
import Data.ByteString.Char8 ( ByteString, pack, unpack, empty )
import Data.Either           ( partitionEithers )
import Data.Maybe            ( catMaybes )
import Data.Char             ( isSpace )
import System.IO.Unsafe      ( unsafePerformIO )

import Language.Haskell.TH (Body(..), Dec(..), Exp(..), ExpQ, Pat(..), PatQ, Lit(..),
                            mkName, newName, runIO)
import Language.Haskell.TH.Quote
import Language.Haskell.Meta (toExp,toPat)
import Language.Haskell.Exts.Extension (Extension(..), KnownExtension(..))
import Language.Haskell.Exts (parseExpWithMode, parsePatWithMode,
                              ParseMode, defaultParseMode, extensions,
                              ParseResult(..))
import Language.Haskell.Exts.SrcLoc (noLoc)

{- TODO:
  * Target Text.Regex.Base ?
  * Add unit tests
-}

data RexConf = RexConf {
  -- | When @True@, the input type is a ByteString, otherwise, it's a String.
  RexConf -> Bool
rexByteString :: Bool,
  -- | When @True@, the regex is precompiled.
  RexConf -> Bool
rexCompiled :: Bool,
  -- | Preprocess the string used in expression antiquotes.  'defaultRexConf'
  --   just passes through the string unaltered, unless it just consists of
  --   whitespace.  When it's all whitespace, @"rexView"@ is used.
  RexConf -> String -> String
rexPreprocessExp :: String -> String,
  -- | Preprocess the string used in pattern antiquotes. 'defaultRexConf'
  --   adds parenthesis around the string, so that view patterns will parse
  --   without requiring parenthesis around them.
  RexConf -> String -> String
rexPreprocessPat :: String -> String,
  -- | When a pattern match doesn't have a view pattern, this expression is
  --   used to preprocess it before matching.  When 'defaultRexConf' is used,
  --   perhaps via 'rex' or 'brex', a reference to @rexView@ is used.
  --
  --   The 'rexView' exported by this module is 'id', so by default no
  --   preprocessing is done before
  RexConf -> Exp
rexViewExp :: Exp,
  -- | Options used when compiling PCRE regular expressions.
  RexConf -> [PCREOption]
rexPCREOpts :: [PCRE.PCREOption],
  -- | Options used when executing PCRE regular expressions.
  RexConf -> [PCREExecOption]
rexPCREExecOpts :: [PCRE.PCREExecOption]
  }

-- | Default rex configuration, which specifies that the regexes operate on
--   strings, don't post-process the matched patterns, and use 'PCRE.extended'.
--   This setting causes whitespace to be non-semantic, and ignores # comments.
defaultRexConf :: RexConf
defaultRexConf :: RexConf
defaultRexConf = RexConf :: Bool
-> Bool
-> (String -> String)
-> (String -> String)
-> Exp
-> [PCREOption]
-> [PCREExecOption]
-> RexConf
RexConf
  { rexByteString :: Bool
rexByteString = Bool
False
  , rexCompiled :: Bool
rexCompiled = Bool
True
  , rexPreprocessExp :: String -> String
rexPreprocessExp = \String
s -> if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s then String
"rexView" else String
s
  , rexPreprocessPat :: String -> String
rexPreprocessPat = \String
s -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  , rexViewExp :: Exp
rexViewExp = Name -> Exp
VarE (String -> Name
mkName String
"rexView")
  , rexPCREOpts :: [PCREOption]
rexPCREOpts = [PCREOption
PCRE.extended]
  , rexPCREExecOpts :: [PCREExecOption]
rexPCREExecOpts = []
  }

-- | Rex quasiquoter which takes 'String' as input, and uses 'defaultRexConf'
--   for its configuration.  Can be used in expressions and patterns.
rex :: QuasiQuoter
rex :: QuasiQuoter
rex  = RexConf -> QuasiQuoter
rexWithConf RexConf
defaultRexConf

-- | Rex quasiquoter which takes 'ByteString' as input, and otherwise uses
--  'defaultRexConf' for its configuration.  Can be used in expressions and
--  patterns.
brex :: QuasiQuoter
brex :: QuasiQuoter
brex = RexConf -> QuasiQuoter
rexWithConf RexConf
defaultRexConf { rexByteString :: Bool
rexByteString = Bool
True }

-- | This is a 'QuasiQuoter' transformer, which allows for a whitespace-
--   sensitive quasi-quoter to be broken over multiple lines.  The default 'rex'
--   and 'brex' functions do not need this as they are already whitespace
--   insensitive. However, if you create your own configuration, which omits the
--   'PCRE.extended' parameter, then this could be useful. The leading space of
--   each line is ignored, and all newlines removed.
makeQuasiMultiline :: QuasiQuoter -> QuasiQuoter
makeQuasiMultiline :: QuasiQuoter -> QuasiQuoter
makeQuasiMultiline (QuasiQuoter String -> Q Exp
a String -> Q Pat
b String -> Q Type
c String -> Q [Dec]
d) =
    (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter (String -> Q Exp
a (String -> Q Exp) -> (String -> String) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
pre) (String -> Q Pat
b (String -> Q Pat) -> (String -> String) -> String -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
pre) (String -> Q Type
c (String -> Q Type) -> (String -> String) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
pre) (String -> Q [Dec]
d (String -> Q [Dec]) -> (String -> String) -> String -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
pre)
  where
    pre :: String -> String
pre = [String] -> String
removeLineSpaces ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    removeLineSpaces :: [String] -> String
removeLineSpaces [] = []
    removeLineSpaces (String
x:[String]
xs) = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace) [String]
xs

-- | A configureable regular-expression QuasiQuoter.  Takes the options to pass
--   to the PCRE engine, along with 'Bool's to flag 'ByteString' usage and
--   non-compilation respecively.  The provided 'String' indicates which mapping
--   function to use, when one is omitted - \"(?{} ...)\".
rexWithConf :: RexConf -> QuasiQuoter
rexWithConf :: RexConf -> QuasiQuoter
rexWithConf RexConf
conf =
  (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    (RexConf -> ParseChunks -> Q Exp
makeExp RexConf
conf (ParseChunks -> Q Exp)
-> (String -> ParseChunks) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseChunks
parseRex)
    (RexConf -> ParseChunks -> Q Pat
makePat RexConf
conf (ParseChunks -> Q Pat)
-> (String -> ParseChunks) -> String -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseChunks
parseRex)
    String -> Q Type
forall a. HasCallStack => a
undefined
    String -> Q [Dec]
forall a. HasCallStack => a
undefined

-- Template Haskell Code Generation
--------------------------------------------------------------------------------

-- Creates the template haskell Exp which corresponds to the parsed interpolated
-- regex.  This particular code mainly just handles making "read" the
-- default for captures which lack a parser definition, and defaulting to making
-- the parser that doesn't exist
makeExp :: RexConf -> ParseChunks -> ExpQ
makeExp :: RexConf -> ParseChunks -> Q Exp
makeExp RexConf
conf (Int
cnt, String
pat, [Maybe String]
exs) =
  RexConf -> Int -> String -> [Maybe Exp] -> Q Exp
buildExp RexConf
conf Int
cnt String
pat ([Maybe Exp] -> Q Exp) -> [Maybe Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((Maybe String -> Maybe Exp) -> [Maybe String] -> [Maybe Exp])
-> [Maybe String] -> (Maybe String -> Maybe Exp) -> [Maybe Exp]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe String -> Maybe Exp) -> [Maybe String] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map [Maybe String]
exs ((Maybe String -> Maybe Exp) -> [Maybe Exp])
-> (Maybe String -> Maybe Exp) -> [Maybe Exp]
forall a b. (a -> b) -> a -> b
$ (String -> Exp) -> Maybe String -> Maybe Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Exp) -> Maybe String -> Maybe Exp)
-> (String -> Exp) -> Maybe String -> Maybe Exp
forall a b. (a -> b) -> a -> b
$
    String -> ParseResult Exp -> Exp
forall a. Show a => String -> ParseResult a -> a
fromParseOk String
"While parsing expression antiquote"
    (ParseResult Exp -> Exp)
-> (String -> ParseResult Exp) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseResult Exp
parseExp
    (String -> ParseResult Exp)
-> (String -> String) -> String -> ParseResult Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RexConf -> String -> String
rexPreprocessExp RexConf
conf

-- Creates the template haskell Pat which corresponds to the parsed interpolated
-- regex. As well as handling the aforementioned defaulting considerations, this
-- turns per-capture view patterns into a single tuple-resulting view pattern.
--
-- E.g. [reg| ... (?{e1 -> v1} ...) ... (?{e2 -> v2} ...) ... |] becomes
--      [reg| ... (?{e1} ...) ... (?{e2} ...) ... |] -> (v1, v2)
makePat :: RexConf -> ParseChunks -> PatQ
makePat :: RexConf -> ParseChunks -> Q Pat
makePat RexConf
conf (Int
cnt, String
pat, [Maybe String]
exs) = do
  Exp
viewExp <- RexConf -> Int -> String -> [Maybe Exp] -> Q Exp
buildExp RexConf
conf Int
cnt String
pat ([Maybe Exp] -> Q Exp) -> [Maybe Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Maybe (Exp, Pat) -> Maybe Exp)
-> [Maybe (Exp, Pat)] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (((Exp, Pat) -> Exp) -> Maybe (Exp, Pat) -> Maybe Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp, Pat) -> Exp
forall a b. (a, b) -> a
fst) [Maybe (Exp, Pat)]
views
  Pat -> Q Pat
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> Q Pat) -> ([(Exp, Pat)] -> Pat) -> [(Exp, Pat)] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Pat -> Pat
ViewP Exp
viewExp
         (Pat -> Pat) -> ([(Exp, Pat)] -> Pat) -> [(Exp, Pat)] -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[Pat]
xs -> Name -> [Pat] -> Pat
ConP 'Just
#if MIN_VERSION_template_haskell(2,18,0)
                []
#endif
                [[Pat] -> Pat
TupP [Pat]
xs]
            )
         ([Pat] -> Pat) -> ([(Exp, Pat)] -> [Pat]) -> [(Exp, Pat)] -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Exp, Pat) -> Pat) -> [(Exp, Pat)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Exp, Pat) -> Pat
forall a b. (a, b) -> b
snd ([(Exp, Pat)] -> Q Pat) -> [(Exp, Pat)] -> Q Pat
forall a b. (a -> b) -> a -> b
$ [Maybe (Exp, Pat)] -> [(Exp, Pat)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Exp, Pat)]
views
 where
  views :: [Maybe (Exp, Pat)]
  views :: [Maybe (Exp, Pat)]
views = (Maybe String -> Maybe (Exp, Pat))
-> [Maybe String] -> [Maybe (Exp, Pat)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> (Exp, Pat)) -> Maybe String -> Maybe (Exp, Pat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> (Exp, Pat)
processView) [Maybe String]
exs

  processView :: String -> (Exp, Pat)
  processView :: String -> (Exp, Pat)
processView String
xs = case String -> ParseResult Pat
parsePat (RexConf -> String -> String
rexPreprocessPat RexConf
conf String
xs) of
    ParseOk (ParensP (ViewP Exp
e Pat
p)) -> (Exp
e,Pat
p)
    ParseOk Pat
p -> (RexConf -> Exp
rexViewExp RexConf
conf, Pat
p)
    ParseFailed SrcLoc
_ String
b -> String -> (Exp, Pat)
forall a. HasCallStack => String -> a
error String
b

-- Here's where the main meat of the template haskell is generated.  Given the
-- number of captures, the pattern string, and a list of capture expressions,
-- yields the template Haskell Exp which parses a string into a tuple.
buildExp :: RexConf -> Int -> String -> [Maybe Exp] -> ExpQ
buildExp :: RexConf -> Int -> String -> [Maybe Exp] -> Q Exp
buildExp RexConf{Bool
[PCREOption]
[PCREExecOption]
Exp
String -> String
rexPCREExecOpts :: [PCREExecOption]
rexPCREOpts :: [PCREOption]
rexViewExp :: Exp
rexPreprocessPat :: String -> String
rexPreprocessExp :: String -> String
rexCompiled :: Bool
rexByteString :: Bool
rexPCREExecOpts :: RexConf -> [PCREExecOption]
rexPCREOpts :: RexConf -> [PCREOption]
rexViewExp :: RexConf -> Exp
rexPreprocessPat :: RexConf -> String -> String
rexPreprocessExp :: RexConf -> String -> String
rexCompiled :: RexConf -> Bool
rexByteString :: RexConf -> Bool
..} Int
cnt String
pat [Maybe Exp]
xs =
    [| let r = $(get_regex) in
       $(process) . (flip $ PCRE.match r) $(liftRS rexPCREExecOpts)
     . $(if rexByteString then [| id |] else [| pack |]) |]
  where
    liftRS :: a -> Q Exp
liftRS a
x = [| read shown |] where shown :: String
shown = a -> String
forall a. Show a => a -> String
show a
x

    get_regex :: Q Exp
get_regex
      | Bool
rexCompiled = [| unsafePerformIO (regexFromTable $! $(table_bytes)) |]
      | Bool
otherwise = [| PCRE.compile (pack pat) $(liftRS pcreOpts) |]
    table_bytes :: Q Exp
table_bytes = [| pack $(LitE . StringL . unpack <$> runIO table_string) |]
    table_string :: IO CompiledBytes
table_string =
      String -> Maybe CompiledBytes -> CompiledBytes
forall a. String -> Maybe a -> a
fromJust' String
"Error while getting PCRE compiled representation\n" (Maybe CompiledBytes -> CompiledBytes)
-> IO (Maybe CompiledBytes) -> IO CompiledBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      CompiledBytes -> [PCREOption] -> IO (Maybe CompiledBytes)
precompile (String -> CompiledBytes
pack String
pat) [PCREOption]
pcreOpts
    pcreOpts :: [PCREOption]
pcreOpts = [PCREOption]
rexPCREOpts

    process :: Q Exp
process = case ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
vs, Bool
rexByteString) of
      (Bool
True, Bool
_)  -> [| fmap ( const () ) |]
      (Bool
_, Bool
False) -> [| fmap ($(maps 'unconsStr)) |]
      (Bool
_, Bool
True)  -> [| fmap ($(maps 'unconsByte)) |]
    maps :: Name -> Q Exp
maps Name
def = do
      Name
vsName <- String -> Q Name
newName String
"vs"
      [Dec]
lets <- Name -> [Pat] -> Q [Dec]
makeLets Name
vsName ([Pat] -> Q [Dec]) -> ([Pat] -> [Pat]) -> [Pat] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pat
WildPPat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:) ([Pat] -> Q [Dec]) -> [Pat] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vs
      Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
vsName] (Exp -> Exp) -> ([Exp] -> Exp) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dec] -> Exp -> Exp
LetE [Dec]
lets
         (Exp -> Exp) -> ([Exp] -> Exp) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Exp] -> Exp
TupE
         -- filter out all "Nothing" exprs
         -- [(Expr, Variable applied to)]
#if MIN_VERSION_template_haskell(2,16,0)
         ([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#endif
         ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ [Exp -> Exp -> Exp
AppE Exp
x (Name -> Exp
VarE Name
v) | (Just Exp
x, Name
v) <- [Maybe Exp] -> [Name] -> [(Maybe Exp, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe Exp]
xs [Name]
vs]
      where
        makeLets :: Name -> [Pat] -> Q [Dec]
makeLets Name
_ [] = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        makeLets Name
vsName (Pat
y:[Pat]
ys)
          | [Pat] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pat]
ys = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Pat -> Dec
makeLet Pat
WildP] -- special case so we don't create a variable we don't use
          | Bool
otherwise = do
            Name
innerVsName <- String -> Q Name
newName String
"vs"
            let yLet :: Dec
yLet = Pat -> Dec
makeLet (Name -> Pat
VarP Name
innerVsName)
            [Dec]
yLets <- Name -> [Pat] -> Q [Dec]
makeLets Name
innerVsName [Pat]
ys
            [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
yLetDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[Dec]
yLets
          where
            makeLet :: Pat -> Dec
makeLet Pat
innerVs = Pat -> Body -> [Dec] -> Dec
ValD ([Pat] -> Pat
TupP [Pat
y,Pat
innerVs]) (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
def) (Name -> Exp
VarE Name
vsName))) []
    vs :: [Name]
vs = [String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i | Int
i <- [Int
0..Int
cnt]]

-- | Converts @Left@ to @'ParseFailed' 'noLoc'@, and a @Right@ to @'ParseOk'@.
eitherToParseResult :: Either String a -> ParseResult a
eitherToParseResult :: Either String a -> ParseResult a
eitherToParseResult (Left String
err) = SrcLoc -> String -> ParseResult a
forall a. SrcLoc -> String -> ParseResult a
ParseFailed SrcLoc
noLoc String
err
eitherToParseResult (Right a
x) = a -> ParseResult a
forall a. a -> ParseResult a
ParseOk a
x

-- | Parse a Haskell expression into a Template Haskell Exp.
parseExp :: String -> ParseResult Exp
parseExp :: String -> ParseResult Exp
parseExp = (Exp SrcSpanInfo -> Exp)
-> ParseResult (Exp SrcSpanInfo) -> ParseResult Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp SrcSpanInfo -> Exp
forall a. ToExp a => a -> Exp
toExp (ParseResult (Exp SrcSpanInfo) -> ParseResult Exp)
-> (String -> ParseResult (Exp SrcSpanInfo))
-> String
-> ParseResult Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseMode -> String -> ParseResult (Exp SrcSpanInfo)
parseExpWithMode ParseMode
rexParseMode

-- | Parse a Haskell pattern match into a Template Haskell Pat.
parsePat :: String -> ParseResult Pat
parsePat :: String -> ParseResult Pat
parsePat = (Pat SrcSpanInfo -> Pat)
-> ParseResult (Pat SrcSpanInfo) -> ParseResult Pat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat SrcSpanInfo -> Pat
forall a. ToPat a => a -> Pat
toPat (ParseResult (Pat SrcSpanInfo) -> ParseResult Pat)
-> (String -> ParseResult (Pat SrcSpanInfo))
-> String
-> ParseResult Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseMode -> String -> ParseResult (Pat SrcSpanInfo)
parsePatWithMode ParseMode
rexParseMode

-- | Parse mode used by 'parseExp' and 'parsePat'.
rexParseMode :: ParseMode
rexParseMode :: ParseMode
rexParseMode = ParseMode
defaultParseMode { extensions :: [Extension]
extensions = (KnownExtension -> Extension) -> [KnownExtension] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map KnownExtension -> Extension
EnableExtension [KnownExtension]
exts }
  where
    -- probably the quasiquote should have access to the pragmas in the current
    -- file, but for now just enable some common extensions that do not steal
    -- much syntax
    exts :: [KnownExtension]
exts =
      [ KnownExtension
ViewPatterns
      , KnownExtension
ImplicitParams
      , KnownExtension
RecordPuns
      , KnownExtension
RecordWildCards
      , KnownExtension
ScopedTypeVariables
      , KnownExtension
TupleSections
      , KnownExtension
TypeFamilies
      , KnownExtension
TypeOperators
      ]

-- Parsing
--------------------------------------------------------------------------------

type ParseChunk = Either String (Maybe String)
type ParseChunks = (Int, String, [Maybe String])

-- Postprocesses the results of the chunk-wise parse output, into the pattern to
-- be pased to the regex engine, with the interpolated patterns / expressions.
parseRex :: String -> ParseChunks
parseRex :: String -> ParseChunks
parseRex String
xs = (Int
cnt, [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
chunks, [Maybe String]
quotes)
  where
    ([String]
chunks, [Maybe String]
quotes) = [Either String (Maybe String)] -> ([String], [Maybe String])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either String (Maybe String)]
results
    (Int
cnt, [Either String (Maybe String)]
results) = String -> String -> Int -> (Int, [Either String (Maybe String)])
parseRegex ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"\r\n") String
xs) String
"" (-Int
1)

-- A pair of mutually-recursive functions, one for processing the quotation
-- and the other for the anti-quotation.

parseRegex :: String -> String -> Int -> (Int, [ParseChunk])
parseRegex :: String -> String -> Int -> (Int, [Either String (Maybe String)])
parseRegex String
inp String
s Int
ix = case String
inp of
  -- Disallow branch-reset capture.
  (Char
'(':Char
'?':Char
'|':String
_) ->
    String -> (Int, [Either String (Maybe String)])
forall a. HasCallStack => String -> a
error String
"Branch reset pattern (?| not allowed in quasi-quoted regex."

  -- Ignore non-capturing parens / handle backslash escaping.
  (Char
'\\':Char
'\\'  :String
xs) -> String -> String -> Int -> (Int, [Either String (Maybe String)])
parseRegex String
xs (String
"\\\\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) Int
ix
  (Char
'\\':Char
'('   :String
xs) -> String -> String -> Int -> (Int, [Either String (Maybe String)])
parseRegex String
xs (String
")\\"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) Int
ix
  (Char
'\\':Char
')'   :String
xs) -> String -> String -> Int -> (Int, [Either String (Maybe String)])
parseRegex String
xs (String
"(\\"  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) Int
ix
  (Char
'(':Char
'?':Char
':':String
xs) -> String -> String -> Int -> (Int, [Either String (Maybe String)])
parseRegex String
xs (String
":?("  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) Int
ix

  -- Anti-quote for processing a capture group.
  (Char
'(':Char
'?':Char
'{':String
xs) -> ([Either String (Maybe String)] -> [Either String (Maybe String)])
-> (Int, [Either String (Maybe String)])
-> (Int, [Either String (Maybe String)])
forall t t2 t1. (t -> t2) -> (t1, t) -> (t1, t2)
mapSnd ((String -> Either String (Maybe String)
forall a b. a -> Either a b
Left (String -> Either String (Maybe String))
-> String -> Either String (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
:String
s)) Either String (Maybe String)
-> [Either String (Maybe String)] -> [Either String (Maybe String)]
forall a. a -> [a] -> [a]
:)
                    ((Int, [Either String (Maybe String)])
 -> (Int, [Either String (Maybe String)]))
-> (Int, [Either String (Maybe String)])
-> (Int, [Either String (Maybe String)])
forall a b. (a -> b) -> a -> b
$ String -> String -> Int -> (Int, [Either String (Maybe String)])
parseAntiquote String
xs String
"" (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

  -- Keep track of how many capture groups we've seen.
  (Char
'(':String
xs) -> ([Either String (Maybe String)] -> [Either String (Maybe String)])
-> (Int, [Either String (Maybe String)])
-> (Int, [Either String (Maybe String)])
forall t t2 t1. (t -> t2) -> (t1, t) -> (t1, t2)
mapSnd (Maybe String -> Either String (Maybe String)
forall a b. b -> Either a b
Right Maybe String
forall a. Maybe a
Nothing Either String (Maybe String)
-> [Either String (Maybe String)] -> [Either String (Maybe String)]
forall a. a -> [a] -> [a]
:)
            ((Int, [Either String (Maybe String)])
 -> (Int, [Either String (Maybe String)]))
-> (Int, [Either String (Maybe String)])
-> (Int, [Either String (Maybe String)])
forall a b. (a -> b) -> a -> b
$ String -> String -> Int -> (Int, [Either String (Maybe String)])
parseRegex String
xs (Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
:String
s) (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

  -- Consume the regular expression contents.
  (Char
x:String
xs) -> String -> String -> Int -> (Int, [Either String (Maybe String)])
parseRegex String
xs (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
s) Int
ix
  [] -> (Int
ix, [String -> Either String (Maybe String)
forall a b. a -> Either a b
Left (String -> Either String (Maybe String))
-> String -> Either String (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
s])

parseAntiquote :: String -> String -> Int -> (Int, [ParseChunk])
parseAntiquote :: String -> String -> Int -> (Int, [Either String (Maybe String)])
parseAntiquote String
inp String
s Int
ix = case String
inp of
  -- Escape } in the Haskell splice using a backslash.
  (Char
'\\':Char
'}':String
xs) -> String -> String -> Int -> (Int, [Either String (Maybe String)])
parseAntiquote String
xs (Char
'}'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s) Int
ix

  -- Capture accumulated antiquote, and continue parsing regex literal.
  (Char
'}':String
xs) -> ([Either String (Maybe String)] -> [Either String (Maybe String)])
-> (Int, [Either String (Maybe String)])
-> (Int, [Either String (Maybe String)])
forall t t2 t1. (t -> t2) -> (t1, t) -> (t1, t2)
mapSnd ((Maybe String -> Either String (Maybe String)
forall a b. b -> Either a b
Right (String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
forall a. [a] -> [a]
reverse String
s)))Either String (Maybe String)
-> [Either String (Maybe String)] -> [Either String (Maybe String)]
forall a. a -> [a] -> [a]
:)
            ((Int, [Either String (Maybe String)])
 -> (Int, [Either String (Maybe String)]))
-> (Int, [Either String (Maybe String)])
-> (Int, [Either String (Maybe String)])
forall a b. (a -> b) -> a -> b
$ String -> String -> Int -> (Int, [Either String (Maybe String)])
parseRegex String
xs String
"" Int
ix

  -- Consume the antiquoute contents, appending to a reverse accumulator.
  (Char
x:String
xs) -> String -> String -> Int -> (Int, [Either String (Maybe String)])
parseAntiquote String
xs (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
s) Int
ix
  [] -> String -> (Int, [Either String (Maybe String)])
forall a. HasCallStack => String -> a
error String
"Rex haskell splice terminator, }, never found"

-- Utils
--------------------------------------------------------------------------------

unconsStr :: [ByteString] -> (String,[ByteString])
unconsStr :: [CompiledBytes] -> (String, [CompiledBytes])
unconsStr [] = (String
"",[])
unconsStr (CompiledBytes
x:[CompiledBytes]
xs) = (CompiledBytes -> String
unpack CompiledBytes
x,[CompiledBytes]
xs)

unconsByte :: [ByteString] -> (ByteString,[ByteString])
unconsByte :: [CompiledBytes] -> (CompiledBytes, [CompiledBytes])
unconsByte [] = (CompiledBytes
empty,[])
unconsByte (CompiledBytes
x:[CompiledBytes]
xs) = (CompiledBytes
x,[CompiledBytes]
xs)

-- | A default view function used when expression antiquotes are empty, or when
--   pattern antiquotes omit a view pattern.  See the documentation for
--   'rexPreprocessPat' and 'rexPreprocessExp' for more details.
--
--   You can locally shadow this 'rexView' with your own version, if you wish.
--   One good option is readMay from the safe package:
--   <http://hackage.haskell.org/package/safe/docs/Safe.html#v:readMay>.
--
--   The type of this identity rexView is fully polymorphic so that it can be
--   used with either 'String' or 'ByteString'.
rexView :: a -> a
rexView :: a -> a
rexView = a -> a
forall a. a -> a
id

mapSnd :: (t -> t2) -> (t1, t) -> (t1, t2)
mapSnd :: (t -> t2) -> (t1, t) -> (t1, t2)
mapSnd t -> t2
f (t1
x, t
y) = (t1
x, t -> t2
f t
y)

fromJust' :: String -> Maybe a -> a
fromJust' :: String -> Maybe a -> a
fromJust' String
msg Maybe a
Nothing = String -> a
forall a. HasCallStack => String -> a
error String
msg
fromJust' String
_ (Just a
x) = a
x

fromParseOk :: Show a => String -> ParseResult a -> a
fromParseOk :: String -> ParseResult a -> a
fromParseOk String
_ (ParseOk a
x) = a
x
fromParseOk String
msg ParseResult a
err = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseResult a -> String
forall a. Show a => a -> String
show ParseResult a
err