diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -3,31 +3,31 @@ module Test where import Text.Regex.PCRE.Rex -import Data.Maybe (catMaybes) --- main = interact (unlines . map (show . math) . lines) +import qualified Data.ByteString.Char8 as B +import Data.Maybe (catMaybes, isJust) math x = mathl x 0 mathl [] x = x -mathl [rex|^ \s*(?{ y }\d+)\s*(?{ id -> s }.*)$|] x = mathl s y -mathl [rex|^\+\s*(?{ y }\d+)\s*(?{ id -> s }.*)$|] x = mathl s $ x + y -mathl [rex|^ -\s*(?{ y }\d+)\s*(?{ id -> s }.*)$|] x = mathl s $ x - y -mathl [rex|^\*\s*(?{ y }\d+)\s*(?{ id -> s }.*)$|] x = mathl s $ x * y -mathl [rex|^ /\s*(?{ y }\d+)\s*(?{ id -> s }.*)$|] x = mathl s $ x / y +mathl [rex|^ \s*(?{ read -> y }\d+)\s*(?{ s }.*)$|] x = mathl s y +mathl [rex|^\+\s*(?{ read -> y }\d+)\s*(?{ s }.*)$|] x = mathl s $ x + y +mathl [rex|^ -\s*(?{ read -> y }\d+)\s*(?{ s }.*)$|] x = mathl s $ x - y +mathl [rex|^\*\s*(?{ read -> y }\d+)\s*(?{ s }.*)$|] x = mathl s $ x * y +mathl [rex|^ /\s*(?{ read -> y }\d+)\s*(?{ s }.*)$|] x = mathl s $ x / y mathl str x = error str peano :: String -> Maybe Int peano = [rex|^(?{ length . filter (=='S') } \s* (?:S\s+)*Z)\s*$|] -vect2d :: String -> Maybe (Int, Int) -vect2d = [rex|^<\s* (?{}\d+) \s*,\s* (?{}\d+) \s*>$|] +parsePair :: String -> Maybe (String, String) +parsePair = [rex|^<\s* (?{ }[^\s,>]+) \s*,\s* (?{ }[^\s,>]+) \s*>$|] -- From http://www.regular-expressions.info/dates.html parseDate :: String -> Maybe (Int, Int, Int) -parseDate [rex|^(?{ y }(?:19|20)\d\d)[- /.] - (?{ m }0[1-9]|1[012])[- /.] - (?{ d }0[1-9]|[12][0-9]|3[01])$|] +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))) @@ -44,3 +44,5 @@ | (?{nonNull $ Just . head -> b} ..) | (?{nonNull $ Just . last -> c} ...))$|] = head $ catMaybes [a, b, c] + +btest = [brex|(?{}hello)|] (B.pack "hello") == Just (B.pack "hello") diff --git a/Text/Regex/PCRE/Precompile.hs b/Text/Regex/PCRE/Precompile.hs --- a/Text/Regex/PCRE/Precompile.hs +++ b/Text/Regex/PCRE/Precompile.hs @@ -32,15 +32,16 @@ import Text.Regex.PCRE.Light import Text.Regex.PCRE.Light.Base +type CompiledBytes = B.ByteString + -- | Compiles the given regular expression, and assuming nothing bad -- happens, yields the bytestring filled with PCRE's compiled -- representation. -precompile :: B.ByteString -> [PCREOption] -> IO (Maybe B.ByteString) +precompile :: B.ByteString -> [PCREOption] -> IO (Maybe CompiledBytes) precompile pat opts = regexToTable $ compile pat opts --- | Takes a compiled regular expression adn yields its bytestring --- representation. -regexToTable :: Regex -> IO (Maybe B.ByteString) +-- | Takes a compiled regular expression, and yields . +regexToTable :: Regex -> IO (Maybe CompiledBytes) regexToTable (Regex p _) = withForeignPtr p $ \pcre -> alloca $ \res -> do success <- c_pcre_fullinfo pcre nullPtr info_size res @@ -49,8 +50,8 @@ then withForeignPtr p (liftM Just . unsafePackCStringLen . (, len) . castPtr) else return Nothing --- | Creates a regular expression -regexFromTable :: B.ByteString -> IO Regex +-- | Creates a regular expression from the compiled representation. +regexFromTable :: CompiledBytes -> IO Regex regexFromTable bytes = unsafeUseAsCString bytes $ \cstr -> do ptr <- newForeignPtr_ (castPtr cstr) return $ Regex ptr bytes diff --git a/Text/Regex/PCRE/Rex.hs b/Text/Regex/PCRE/Rex.hs --- a/Text/Regex/PCRE/Rex.hs +++ b/Text/Regex/PCRE/Rex.hs @@ -17,14 +17,19 @@ -- 2) Arity of resulting tuple based on the number of selected capture patterns -- in the regular expression. -- --- 3) By default utilizes type inference to determine how to parse capture --- patterns - uses the 'read' function's return-type polymorphism --- --- 4) Allows for the inline interpolation of a mapping function String -> a. +-- 3) Allows for the inline interpolation of mapping functions :: String -> a. -- --- 5) Precompiles the regular expression at compile time, by calling into the +-- 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, or use ByteStrings. +-- +-- Since this is a quasiquoter library that generates code using view patterns, +-- the following extensions are required: +-- +-- > {-# LANGUAGE TemplateHaskell, QuasiQuotes, ViewPatterns #-} +-- -- Here's a silly 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 seperating whitespace. (these examples can also be found in Test.hs) @@ -43,40 +48,38 @@ -- > *Main> peano "invalid" -- > Nothing -- --- The token \"(?{\" introduces a capture group which has a mapping applied to the --- result - in this case \"length . filter (=='S')\". If an expression is omitted, --- e.g. \"(?{} ... )\", then there is an implicit usage of the read function. --- --- If the ?{ ... } are omitted, then the capture group is not taken as part of --- the results of the match. --- --- > vect2d :: String -> Maybe (Int, Int) --- > vect2d = [rex|^<\s* (?{}\d+) \s*,\s* (?{}\d+) \s*>$|] +-- The token \"(?{\" introduces a capture group which has a mapping applied to +-- the -- result - in this case \"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 "id" is assumed: -- --- The following example is derived from http://www.regular-expressions.info/dates.html +-- parsePair :: String -> Maybe (String, String) +-- parsePair = [rex|^<\s* (?{ }[^\s,>]+) \s*,\s* (?{ }[^\s,>]+) \s*>$|] -- +-- The following example is derived from +-- http://www.regular-expressions.info/dates.html +-- -- > parseDate :: String -> Maybe (Int, Int, Int) --- > parseDate [rex|^(?{ y }(?:19|20)\d\d)[- /.] --- > (?{ m }0[1-9]|1[012])[- /.] --- > (?{ d }0[1-9]|[12][0-9]|3[01])$|] +-- > 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 && 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. The above pattern is expanded to the equivalent: +-- pattern out of the inlined ones. The above pattern is expanded to the +-- equivalent: -- --- > parseDate ([rex|^(?{}(?:19|20)\d\d)[- /.] --- > (?{}0[1-9]|1[012])[- /.] --- > (?{}0[1-9]|[12][0-9]|3[01])$|] +-- > 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)) -- --- In order to provide a capture-mapper along with a pattern, use view-patterns --- inside the interpolation brackets. -- -- Caveat: Since haskell-src-exts does not support parsing view-patterns, the -- above is implemented as a relatively naive split on \"->\". It presumes that @@ -84,7 +87,7 @@ -- expression on the left. This allows for lambdas to be present in the -- expression, but prevents nesting view patterns. -- --- There are a few other inelegances: +-- There are also a few other inelegances: -- -- 1) PCRE captures, unlike .NET regular expressions, yield the last capture -- made by a particular pattern. So, for example, (...)*, will only yield one @@ -96,14 +99,30 @@ -- a single variable / pattern, preferring the first non-empty option. The -- general logic for this is a bit complicated, and postponed for a later -- release. +-- +-- 3) While this error is believed to no longer exist, the following error +-- +-- > : out of memory (requested 17584491593728 bytes) -- +-- Used to occur when evaluating in GHCi, due to a bug in the way precompilation +-- worked. If this happens, please report it, and as a temporary work around, +-- make your own quasiquoter using \"rexConf _ False _ _\" to disable +-- pre-compilation. +-- -- 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. Use [brex| ... ] --- to bypass this, and process raw ByteStrings. In order to preserve the --- same default behavior, \"read . unpack\" is the default mapper for brex. +-- 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 = rexConf False True rexPCREOpts rexPCREExecOpts +-- > brex = rexConf True True rexPCREOpts rexPCREExecOpts +-- +-- As mentioned, the other Bool determines whether precompilation is used. +-- Due to GHC staging restrictions, your configuration will need to be in a +-- different module than its usage. +-- -- Inspired by / copy-modified from Matt Morrow's regexqq package: -- -- @@ -112,9 +131,11 @@ -- ----------------------------------------------------------------------------- -module Text.Regex.PCRE.Rex (rex, brex, maybeRead, padRight) where +module Text.Regex.PCRE.Rex ( + rex, brex, maybeRead, padRight, rexConf, rexPCREOpts, rexPCREExecOpts) where import qualified Text.Regex.PCRE.Light as PCRE +import qualified Text.Regex.PCRE.Light.Base as PCRE import Text.Regex.PCRE.Precompile import Control.Arrow (first, second) @@ -135,29 +156,47 @@ import System.IO.Unsafe (unsafePerformIO) +{- TODO: + * Fix mentioned caveats + * Target Text.Regex.Base ? + * Provide a variant which allows splicing in an expression that evaluates to + regex string. + * Add unit tests +-} + type ParseChunk = Either String (Int, String) type ParseChunks = (Int, String, [(Int, String)]) +type Config = (Bool, Bool, [PCRE.PCREOption], [PCRE.PCREExecOption]) -{- TODO: idea - provide a variant which allows splicing in an expression - that evaluates to regex string. The tricky thing here is that this - splice might contain capture groups - thus, the parser here would need to - be referenced in order to dispatch --} +-- | Default regular expression quasiquoter for Strings, and ByteStrings. +rex, brex :: QuasiQuoter +rex = rexConf False True rexPCREOpts rexPCREExecOpts +brex = rexConf True True rexPCREOpts rexPCREExecOpts -{- TODO: target Text.Regex.Base -} --- | The regular expression quasiquoter for strings. -rex, brex :: QuasiQuoter -rex = QuasiQuoter - (makeExp False . parseIt) - (makePat False . parseIt) - undefined undefined +rexPCREOpts :: [PCRE.PCREOption] +rexPCREOpts = + [ PCRE.extended + , PCRE.multiline ] + -- , dotall, caseless, utf8 + -- , newline_any, PCRE.newline_crlf ] --- | The regular expression quasiquoter for Data.ByteString.Char8. -brex = QuasiQuoter - (makeExp True . parseIt) - (makePat True . parseIt) +rexPCREExecOpts :: [PCRE.PCREExecOption] +rexPCREExecOpts = [] + -- [ PCRE.exec_newline_crlf + -- , exec_newline_any, PCRE.exec_notempty + -- , PCRE.exec_notbol, PCRE.exec_noteol ] + +-- | A configureable regular-expression QuasiQuoter. Takes the options to pass +-- to the PCRE engine, along with Bools to flag ByteString usage and +-- non-compilation respecively. +rexConf :: Bool -> Bool -> [PCRE.PCREOption] -> [PCRE.PCREExecOption] -> QuasiQuoter +rexConf bs pc os eos = QuasiQuoter + (makeExp conf . parseIt) + (makePat conf . parseIt) undefined undefined + where + conf = (bs, pc, [PCRE.combineOptions os], [PCRE.combineExecOptions eos]) -- Template Haskell Code Generation ------------------------------------------------------------------------------- @@ -166,9 +205,9 @@ -- 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 :: Bool -> ParseChunks -> ExpQ -makeExp bs (cnt, pat, exs) = buildExp bs cnt pat - . map (liftM (processExp bs) . snd . head) +makeExp :: Config -> ParseChunks -> ExpQ +makeExp conf (cnt, pat, exs) = buildExp conf cnt pat + . map (liftM processExp . snd . head) . groupSortBy (comparing fst) $ map (second Just) exs ++ [(i, Nothing) | i <- [0..cnt]] @@ -178,24 +217,23 @@ -- -- E.g. [reg| ... (?{e1 -> v1} ...) ... (?{e2 -> v2} ...) ... |] becomes -- [reg| ... (?{e1} ...) ... (?{e2} ...) ... |] -> (v1, v2) -makePat :: Bool -> ParseChunks -> PatQ -makePat bs (cnt, pat, exs) = do - viewExp <- buildExp bs cnt pat $ map (liftM fst) views +makePat :: Config -> ParseChunks -> PatQ +makePat conf (cnt, pat, exs) = do + viewExp <- buildExp conf cnt pat $ map (liftM fst) views return . ViewP viewExp . (\xs -> ConP (mkName "Just") [TupP xs]) . map snd $ catMaybes views where views :: [Maybe (Exp, Pat)] views = map (floatSnd . processView . snd . head) - . groupSortBy (comparing fst) - $ exs ++ [(i, "") | i <- [0..cnt]] + . groupSortBy (comparing fst) $ exs processView :: String -> (Exp, Maybe Pat) processView xs = case splitFromBack 2 ((split . onSublist) "->" xs) of - (_, [r]) -> onSpace (error $ "blank pattern in: " ++ r) - ((processExp bs "",) . processPat) r + (_, [r]) -> onSpace r (error $ "blank pattern in view: " ++ r) + ((processExp "",) . processPat) -- View pattern - (l, [_, r]) -> (processExp bs $ concat l, processPat r) + (l, [_, r]) -> (processExp $ concat l, processPat r) -- Included so that Haskell doesn't warn about non-exhaustive patterns -- (even though the above are exhaustive in this context) _ -> undefined @@ -203,45 +241,52 @@ -- 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 :: Bool -> Int -> String -> [Maybe Exp] -> ExpQ -buildExp bs cnt pat xs = if bs - then [| let r = unsafePerformIO (regexFromTable $! $(table_bytes)) in - liftM ( $(return maps) . padRight B.empty pad ) - . (flip $ PCRE.match r) pcreExecOpts |] - else [| let r = unsafePerformIO (regexFromTable $! $(table_bytes)) in - liftM ( $(return maps) . padRight "" pad . map B.unpack ) - . flip (PCRE.match r) pcreExecOpts . B.pack |] - where pad = cnt + 2 - --TODO: make sure this takes advantage of bytestring fusion stuff - is - -- the right pack / unpack. Or use XOverloadedStrings - table_bytes = [| B.pack $(runIO table_string) |] - table_string = precompile (B.pack pat) pcreOpts >>= - return . LitE . StringL . B.unpack . - forceMaybeMsg "Error while getting PCRE compiled representation\n" - vs = [mkName $ "v" ++ show i | i <- [0..cnt]] - maps = LamE [ListP . (WildP:) $ map VarP vs] - (TupE . map (uncurry AppE) - -- filter out all "Nothing" exprs - . map (first fromJust) . filter (isJust . fst) - -- [(Expr, Variable applied to)] - . zip xs $ map VarE vs) +buildExp :: Config -> Int -> String -> [Maybe Exp] -> ExpQ +buildExp (bs, nc, pcreOpts, pcreExecOpts) cnt pat xs = + [| let r = $(get_regex) in + $(process) . (flip $ PCRE.match r) $(liftRS pcreExecOpts) + . $(if bs then [| id |] else [| B.pack |]) |] + where + pad = cnt + 2 --- Default parsers, one for the bytestring case and one for the string. -defaultExp :: Bool -> String -defaultExp True = "read . unpack" -defaultExp False = "read" + liftRS x = [| read shown |] + where shown = show x --- Parse a Haskell expression into a template Haskell Exp, yielding the --- default for strings which just consist of whitespace. -processExp :: Bool -> String -> Exp -processExp bs xs = forceEitherMsg ("Error while parsing capture mapper " ++ xs) - . parseExp . onSpace (defaultExp bs) id $ xs + --TODO: make sure this takes advantage of bytestring fusion stuff - is + -- the right pack / unpack. Or use XOverloadedStrings + get_regex = if nc + then [| unsafePerformIO (regexFromTable $! $(table_bytes)) |] + else [| PCRE.compile (B.pack pat) $(liftRS pcreOpts)|] + table_bytes = [| B.pack $(runIO table_string) |] + table_string = precompile (B.pack pat) pcreOpts >>= + return . LitE . StringL . B.unpack . + forceMaybeMsg "Error while getting PCRE compiled representation\n" --- Parse a Haskell pattern match into a template Haskell Pat, yielding Nothing for --- strings which just consist of whitespace. + process = case (null vs, bs) of + (True, _) -> [| liftM ( const () ) |] + (_, False) -> [| liftM (($(return maps)) . padRight "" pad . map B.unpack) |] + (_, True) -> [| liftM (($(return maps)) . padRight B.empty pad) |] + maps = LamE [ListP . (WildP:) $ map VarP vs] + . TupE . map (uncurry AppE) + -- filter out all "Nothing" exprs + . map (first fromJust) . filter (isJust . fst) + -- [(Expr, Variable applied to)] + . zip xs $ map VarE vs + vs = [mkName $ "v" ++ show i | i <- [0..cnt]] + +-- Parse a Haskell expression into a template Haskell Exp +processExp :: String -> Exp +processExp xs + = forceEitherMsg ("Error while parsing capture mapper `" ++ xs ++ "'") + . parseExp $ onSpace xs "id" id + +-- Parse a Haskell pattern match into a template Haskell Pat, yielding Nothing +-- for patterns which consist of just whitespace. processPat :: String -> Maybe Pat -processPat xs = onSpace Nothing - (Just . forceEitherMsg ("Error while parsing capture pattern " ++ xs) . parsePat) xs +processPat xs = onSpace xs Nothing + $ Just + . forceEitherMsg ("Error while parsing capture pattern `" ++ xs ++ "'") + . parsePat -- Parsing ------------------------------------------------------------------------------- @@ -251,7 +296,8 @@ parseIt :: String -> ParseChunks parseIt xs = ( cnt, concat [x | Left x <- results] , [(i, x) | Right (i, x) <- results]) - where (cnt, results) = parseRegex (filter (`notElem` "\r\n") xs) "" (-1) + where + (cnt, results) = parseRegex (filter (`notElem` "\r\n") xs) "" (-1) -- A pair of mutually-recursive functions, one for processing the quotation -- and the other for the anti-quotation. @@ -294,8 +340,6 @@ (x:xs) -> parseHaskell xs (x:s) ix [] -> error "Regular-expression Haskell splice is never terminated with a trailing }" --- TODO: provide bytestring variant. - -- Utils ------------------------------------------------------------------------------- @@ -308,19 +352,6 @@ -- of the quasiquote. Would also be a juncture for informing arity / -- extension information. -pcreOpts :: [PCRE.PCREOption] -pcreOpts = - [ PCRE.extended - , PCRE.multiline ] - -- , dotall, caseless, utf8 - -- , newline_any, PCRE.newline_crlf ] - -pcreExecOpts :: [PCRE.PCREExecOption] -pcreExecOpts = [] - -- [ PCRE.exec_newline_crlf - -- , exec_newline_any, PCRE.exec_notempty - -- , PCRE.exec_notbol, PCRE.exec_noteol ] - groupSortBy :: (a -> a -> Ordering) -> [a] -> [[a]] groupSortBy f = groupBy (\x -> (==EQ) . f x) . sortBy f @@ -328,8 +359,8 @@ splitFromBack i xs = (reverse b, reverse a) where (a, b) = splitAt i $ reverse xs -onSpace :: a -> (String -> a) -> String -> a -onSpace x f s | all isSpace s = x +onSpace :: String -> a -> (String -> a) -> a +onSpace s x f | all isSpace s = x | otherwise = f s -- | Given a desired list-length, if the passed list is too short, it is padded diff --git a/rex.cabal b/rex.cabal --- a/rex.cabal +++ b/rex.cabal @@ -1,5 +1,5 @@ Name: rex -Version: 0.1 +Version: 0.2 Synopsis: A quasi-quoter for typeful results of regex captures. Description: Provides a quasi-quoter for regular expressions which yields a tuple, of appropriate arity and types, @@ -29,7 +29,7 @@ Library Extensions: TemplateHaskell, QuasiQuotes, TupleSections, ViewPatterns Exposed-modules: Text.Regex.PCRE.Rex, Text.Regex.PCRE.Precompile - Build-depends: base >= 3.0 && < 6, template-haskell >= 2.5.0.0, - haskell-src-meta, MissingH, bytestring, pcre-light, - split, containers, ghc >= 7 + Build-depends: base >= 3.0 && < 6, bytestring, containers, ghc >= 7.0, + haskell-src-meta, MissingH, pcre-light, split, + template-haskell >= 2.5.0.0 Ghc-options: -Wall