{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} {-# OPTIONS_GHC -optc-DHAVE_REGEX_H #-} {-# OPTIONS_GHC -optc-DHAVE_REGCOMP=1 #-} {-# INCLUDE #-} {-# INCLUDE "regex.h" #-} {-# LINE 1 "Text/Regex/Posix/Wrap.hsc" #-} {-# OPTIONS_GHC -fglasgow-exts -fffi #-} {-# LINE 2 "Text/Regex/Posix/Wrap.hsc" #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Regex.Posix.Wrap -- Copyright : (c) Chris Kuklewicz 2006 derived from (c) The University of Glasgow 2002 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : libraries@haskell.org, textregexlazy@personal.mightyreason.com -- Stability : experimental -- Portability : non-portable (regex-base needs MPTC+FD) -- -- WrapPosix.hsc exports a wrapped version of the ffi imports. To -- increase type safety, the flags are newtype'd. The other important -- export is a 'Regex' type that is specific to the Posix library -- backend. The flags are documented in "Text.Regex.Posix". The -- 'defaultCompOpt' is @(compExtended .|. compNewline)@. -- -- The 'Regex', 'CompOption', and 'ExecOption' types and their 'RegexOptions' -- instance is declared. The '=~' and '=~~' convenience functions are -- defined. -- -- The exported symbols are the same whether HAVE_REGEX_H is defined, but -- when it is not defined then @getVersion == Nothing@ and all other -- exported values will call error or fail. -- -- This module will fail or error only if allocation fails or a nullPtr -- is passed in. -- ----------------------------------------------------------------------------- module Text.Regex.Posix.Wrap( -- ** High-level API Regex, RegOffset, (=~), (=~~), -- ** Low-level API WrapError, wrapCompile, wrapTest, wrapMatch, wrapMatchAll, wrapCount, -- ** Miscellaneous unusedRegOffset, -- ** Compilation options CompOption(CompOption), compBlank, compExtended, -- use extended regex syntax compIgnoreCase, -- ignore case when matching compNoSub, -- no substring matching needed compNewline, -- '.' doesn't match newline -- ** Execution options ExecOption(ExecOption), execBlank, execNotBOL, -- not at begining of line execNotEOL, -- not at end of line -- ** Return codes ReturnCode(ReturnCode), retBadbr, retBadpat, retBadrpt, retEcollate, retEctype, retEescape, retEsubreg, retEbrack, retEparen, retEbrace, retErange, retEspace ) where {-# LINE 80 "Text/Regex/Posix/Wrap.hsc" #-} {-# LINE 81 "Text/Regex/Posix/Wrap.hsc" #-} {-# LINE 89 "Text/Regex/Posix/Wrap.hsc" #-} {-# LINE 91 "Text/Regex/Posix/Wrap.hsc" #-} {-# LINE 93 "Text/Regex/Posix/Wrap.hsc" #-} {-# LINE 94 "Text/Regex/Posix/Wrap.hsc" #-} {-# LINE 104 "Text/Regex/Posix/Wrap.hsc" #-} import Control.Monad(mapM) import Data.Array(Array,listArray) import Data.Bits(Bits(..)) import Data.Int -- need whatever #regoff_t type will be import Foreign(Ptr, FunPtr, nullPtr, mallocForeignPtrBytes, addForeignPtrFinalizer, Storable(peekByteOff), allocaArray, allocaBytes, withForeignPtr,ForeignPtr,plusPtr) import Foreign.C(CSize,CInt) import Foreign.C.String(peekCAString, CString) import Text.Regex.Base.RegexLike(RegexOptions(..),RegexMaker(..),RegexContext(..),MatchArray) type CRegex = () -- dummy regex_t used below to read out nsub value -- | RegOffset is "typedef int regoff_t" on Linux and ultimately "typedef -- long long __int64_t" on Max OS X. So rather than saying -- 2,147,483,647 is all the length you need, I'll take the larger: -- 9,223,372,036,854,775,807 should be enough bytes for anyone, no -- need for Integer. The alternative is to compile to different sizes -- in a platform dependent manner with "type RegOffset = (#type -- regoff_t)", which I do not want to do. -- -- There is also a special value 'unusedRegOffset' :: 'RegOffset' which is -- (-1) and as a starting index means that the subgroup capture was -- unused. Otherwise the RegOffset indicates a character boundary that -- is before the character at that index offset, with the first -- character at index offset 0. So starting at 1 and ending at 2 means -- to take only the second character. type RegOffset = Int64 -- | A bitmapped 'CInt' containing options for compilation of regular -- expressions. Option values (and their man 3 regcomp names) are -- -- * 'compBlank' which is a completely zero value for all the flags. -- This is also the 'blankCompOpt' value. -- -- * 'compExtended' (REG_EXTENDED) which can be set to use extended instead -- of basic regular expressions. -- This is set in the 'defaultCompOpt' value. -- -- * 'compNewline' (REG_NEWLINE) turns on newline sensitivity: The dot (.) -- and inverted set @[^ ]@ never match newline, and ^ and $ anchors do -- match after and before newlines. -- This is set in the 'defaultCompOpt' value. -- -- * 'compIgnoreCase' (REG_ICASE) which can be set to match ignoring upper -- and lower distinctions. -- -- * 'compNoSub' (REG_NOSUB) which turns off all information from matching -- except whether a match exists. {-# LINE 155 "Text/Regex/Posix/Wrap.hsc" #-} newtype CompOption = CompOption CInt deriving (Eq,Show,Num,Bits) {-# LINE 177 "Text/Regex/Posix/Wrap.hsc" #-} -- | A bitmapped 'CInt' containing options for execution of compiled -- regular expressions. Option values (and their man 3 regexec names) are -- -- * 'execBlank' which is a complete zero value for all the flags. This is -- the blankExecOpt value. -- -- * 'execNotBOL' (REG_NOTBOL) can be set to prevent ^ from matching at the -- start of the input. -- -- * 'execNotEOL' (REG_NOTEOL) can be set to prevent $ from matching at the -- end of the input (before the terminating NUL). {-# LINE 190 "Text/Regex/Posix/Wrap.hsc" #-} newtype ExecOption = ExecOption CInt deriving (Eq,Show,Num,Bits) {-# LINE 212 "Text/Regex/Posix/Wrap.hsc" #-} -- | ReturnCode is an enumerated 'CInt', corresponding to the error codes -- from @man 3 regex@: -- -- * 'retBadbr' (@REG_BADBR@) invalid repetition count(s) in @{ }@ -- -- * 'retBadpat' (@REG_BADPAT@) invalid regular expression -- -- * 'retBadrpt' (@REG_BADRPT@) @?@, @*@, or @+@ operand invalid -- -- * 'retEcollate' (@REG_ECOLLATE@) invalid collating element -- -- * 'retEctype' (@REG_ECTYPE@) invalid character class -- -- * 'retEescape' (@REG_EESCAPE@) @\\@ applied to unescapable character -- -- * 'retEsubreg' (@REG_ESUBREG@) invalid backreference number -- -- * 'retEbrack' (@REG_EBRACK@) brackets @[ ]@ not balanced -- -- * 'retEparen' (@REG_EPAREN@) parentheses @( )@ not balanced -- -- * 'retEbrace' (@REG_EBRACE@) braces @{ }@ not balanced -- -- * 'retErange' (@REG_ERANGE@) invalid character range in @[ ]@ -- -- * 'retEspace' (@REG_ESPACE@) ran out of memory -- -- * 'retNoMatch' (@REG_NOMATCH@) The regexec() function failed to match -- newtype ReturnCode = ReturnCode CInt deriving (Eq,Show) -- | A compiled regular expression. data Regex = Regex (ForeignPtr CRegex) CompOption ExecOption -- | A completely zero value for all the flags. -- This is also the 'blankCompOpt' value. compBlank :: CompOption compBlank = CompOption 0 -- | A completely zero value for all the flags. -- This is also the 'blankExecOpt' value. execBlank :: ExecOption execBlank = ExecOption 0 unusedRegOffset :: RegOffset unusedRegOffset = (-1) -- | The return code will be retOk when it is the Haskell wrapper and -- not the underlying library generating the error message. type WrapError = (ReturnCode,String) wrapCompile :: CompOption -- ^ Flags (bitmapped) -> ExecOption -- ^ Flags (bitmapped) -> CString -- ^ The regular expression to compile (ASCII only, no null bytes) -> IO (Either WrapError Regex) -- ^ Returns: the compiled regular expression wrapTest :: Regex -> CString -> IO (Either WrapError Bool) -- | wrapMatch returns offsets for the begin and end of each capture. -- Unused captures have offsets of unusedRegOffset which is (-1) wrapMatch :: Regex -> CString -> IO (Either WrapError (Maybe [(RegOffset,RegOffset)])) -- | wrapMatchAll returns the offset and length of each capture. -- Unused captures have an offset of unusedRegOffset which is (-1) and -- length of 0. wrapMatchAll :: Regex -> CString -> IO (Either WrapError [MatchArray]) wrapCount :: Regex -> CString -> IO (Either WrapError Int) (=~) :: (RegexMaker Regex CompOption ExecOption source,RegexContext Regex source1 target) => source1 -> source -> target (=~~) :: (RegexMaker Regex CompOption ExecOption source,RegexContext Regex source1 target,Monad m) => source1 -> source -> m target instance RegexOptions Regex CompOption ExecOption where blankCompOpt = compBlank blankExecOpt = execBlank defaultCompOpt = compExtended .|. compNewline defaultExecOpt = execBlank setExecOpts e' (Regex r c _) = Regex r c e' getExecOpts (Regex _ _ e) = e -- (=~) ::(RegexMaker Regex CompOption ExecOption source,RegexContext Regex source1 target) => source1 -> source -> target (=~) x r = let make :: RegexMaker Regex CompOption ExecOption a => a -> Regex make = makeRegex in match (make r) x -- (=~~) ::(RegexMaker Regex CompOption ExecOption source,RegexContext Regex source1 target,Monad m) => source1 -> source -> m target (=~~) x r = let make :: RegexMaker Regex CompOption ExecOption a => a -> Regex make = makeRegex in matchM (make r) x type CRegMatch = () -- dummy regmatch_t used below to read out so and eo values -- ----------------------------------------------------------------------------- -- The POSIX regex C interface {-# LINE 315 "Text/Regex/Posix/Wrap.hsc" #-} foreign import ccall unsafe "regcomp" c_regcomp :: Ptr CRegex -> CString -> CompOption -> IO ReturnCode foreign import ccall unsafe "®free" c_regfree :: FunPtr (Ptr CRegex -> IO ()) foreign import ccall unsafe "regexec" c_regexec :: Ptr CRegex -> CString -> CSize -> Ptr CRegMatch -> ExecOption -> IO ReturnCode foreign import ccall unsafe "regerror" c_regerror :: ReturnCode -> Ptr CRegex -> CString -> CSize -> IO CSize {-# LINE 362 "Text/Regex/Posix/Wrap.hsc" #-} retOk :: ReturnCode retOk = ReturnCode 0 -- Flags for regexec execNotBOL :: ExecOption execNotBOL = ExecOption 1 execNotEOL :: ExecOption execNotEOL = ExecOption 2 {-# LINE 370 "Text/Regex/Posix/Wrap.hsc" #-} -- Flags for regcomp compExtended :: CompOption compExtended = CompOption 1 compIgnoreCase :: CompOption compIgnoreCase = CompOption 2 compNoSub :: CompOption compNoSub = CompOption 4 compNewline :: CompOption compNewline = CompOption 8 {-# LINE 377 "Text/Regex/Posix/Wrap.hsc" #-} -- Return values from regexec (REG_NOMATCH, REG_ESPACE,...) -- Error codes from regcomp (not REG_NOMATCH) -- Though calling retNoMatch an error is rather missing the point... retNoMatch :: ReturnCode retNoMatch = ReturnCode 1 retBadbr :: ReturnCode retBadbr = ReturnCode 10 retBadpat :: ReturnCode retBadpat = ReturnCode 2 retBadrpt :: ReturnCode retBadrpt = ReturnCode 13 retEcollate :: ReturnCode retEcollate = ReturnCode 3 retEctype :: ReturnCode retEctype = ReturnCode 4 retEescape :: ReturnCode retEescape = ReturnCode 5 retEsubreg :: ReturnCode retEsubreg = ReturnCode 6 retEbrack :: ReturnCode retEbrack = ReturnCode 7 retEparen :: ReturnCode retEparen = ReturnCode 8 retEbrace :: ReturnCode retEbrace = ReturnCode 9 retErange :: ReturnCode retErange = ReturnCode 11 retEspace :: ReturnCode retEspace = ReturnCode 12 {-# LINE 395 "Text/Regex/Posix/Wrap.hsc" #-} ---- -- error helpers nullTest :: Ptr a -> String -> IO (Either WrapError b) -> IO (Either WrapError b) {-# INLINE nullTest #-} nullTest ptr msg io = do if nullPtr == ptr then return (Left (retOk,"Ptr parameter was nullPtr in Text.Regex.TRE.Wrap."++msg)) else io {- wrapRC :: ReturnCode -> IO (Either WrapError b) {-# INLINE wrapRC #-} wrapRC r = return (Left (r,"Error in Text.Regex.Posix.Wrap: "++show r)) -} wrapError :: ReturnCode -> Ptr CRegex -> IO (Either WrapError b) wrapError errCode regex_ptr = do -- Call once to compute the error message buffer size errBufSize <- c_regerror errCode regex_ptr nullPtr 0 -- Allocate a temporary buffer to hold the error message allocaArray (fromIntegral errBufSize) $ \errBuf -> do nullTest errBuf "wrapError errBuf" $ do c_regerror errCode regex_ptr errBuf errBufSize msg <- peekCAString errBuf :: IO String return (Left (errCode, msg)) ---------- wrapCompile flags e pattern = do nullTest pattern "wrapCompile pattern" $ do regex_fptr <- mallocForeignPtrBytes (16) {-# LINE 425 "Text/Regex/Posix/Wrap.hsc" #-} withForeignPtr regex_fptr $ \regex_ptr -> do if nullPtr == regex_ptr then return (Left (retOk,"Text.Regex.Posix.Wrap.wrapCompile could not malloc")) else do errCode <- c_regcomp regex_ptr pattern flags addForeignPtrFinalizer c_regfree regex_fptr if (errCode == retOk) then return . Right $ Regex regex_fptr flags e else wrapError errCode regex_ptr --------- wrapTest (Regex regex_fptr _ flags) cstr = do nullTest cstr "wrapTest" $ do withForeignPtr regex_fptr $ \regex_ptr -> do r <- c_regexec regex_ptr cstr 0 nullPtr flags if r == retOk then return (Right True) else if r == retNoMatch then return (Right False) else wrapError r regex_ptr --------- wrapMatch regex@(Regex regex_fptr compileOptions flags) cstr = do nullTest cstr "wrapMatch cstr" $ do if (0 /= compNoSub .&. compileOptions) then do r <- wrapTest regex cstr case r of Right True -> return (Right (Just [])) -- Source of much "wtf?" crap Right False -> return (Right Nothing) Left err -> return (Left err) else do withForeignPtr regex_fptr $ \regex_ptr -> do nsub <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) regex_ptr :: IO CSize {-# LINE 459 "Text/Regex/Posix/Wrap.hsc" #-} let nsub_int,nsub_bytes :: Int nsub_int = fromIntegral nsub nsub_bytes = ((1 + nsub_int) * (16)) {-# LINE 462 "Text/Regex/Posix/Wrap.hsc" #-} -- add one because index zero covers the whole match allocaBytes nsub_bytes $ \p_match -> do nullTest p_match "wrapMatch allocaBytes" $ do doMatch regex_ptr cstr nsub p_match flags -- Very very thin wrapper -- Requires, but does not check, that nsub>=0 -- Cannot return (Right (Just [])) doMatch :: Ptr CRegex -> CString -> CSize -> Ptr CRegMatch -> ExecOption -> IO (Either WrapError (Maybe [(RegOffset,RegOffset)])) {-# INLINE doMatch #-} doMatch regex_ptr cstr nsub p_match flags = do r <- c_regexec regex_ptr cstr (1 + nsub) p_match flags if r == retOk then do regions <- mapM getOffsets . take (1+fromIntegral nsub) . iterate (`plusPtr` (16)) $ p_match {-# LINE 479 "Text/Regex/Posix/Wrap.hsc" #-} return (Right (Just regions)) -- regions will not be [] else if r == retNoMatch then return (Right Nothing) else wrapError r regex_ptr where getOffsets :: Ptr CRegMatch -> IO (RegOffset,RegOffset) {-# INLINE getOffsets #-} getOffsets pmatch' = do start <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) pmatch' :: IO (Int64) {-# LINE 488 "Text/Regex/Posix/Wrap.hsc" #-} end <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) pmatch' :: IO (Int64) {-# LINE 489 "Text/Regex/Posix/Wrap.hsc" #-} return (fromIntegral start,fromIntegral end) wrapMatchAll regex@(Regex regex_fptr compileOptions flags) cstr = do nullTest cstr "wrapMatchAll cstr" $ do if (0 /= compNoSub .&. compileOptions) then do r <- wrapTest regex cstr case r of Right True -> return (Right [(toMA 0 [])]) -- Source of much "wtf?" crap Right False -> return (Right []) Left err -> return (Left err) else do withForeignPtr regex_fptr $ \regex_ptr -> do nsub <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) regex_ptr :: IO CSize {-# LINE 503 "Text/Regex/Posix/Wrap.hsc" #-} let nsub_int,nsub_bytes :: Int nsub_int = fromIntegral nsub nsub_bytes = ((1 + nsub_int) * (16)) {-# LINE 506 "Text/Regex/Posix/Wrap.hsc" #-} -- add one because index zero covers the whole match allocaBytes nsub_bytes $ \p_match -> do nullTest cstr "wrapMatchAll p_match" $ do let flags' = (execNotBOL .|. flags) at pos = doMatch regex_ptr (plusPtr cstr pos) nsub p_match flags' loop acc old (s,e) | old `seq` s == e = return (Right (acc [])) | otherwise = do let pos = old + fromIntegral e result <- at pos case result of Right Nothing -> return (Right (acc [])) Right (Just parts@(whole:_)) -> let ma = toMA pos parts in loop (acc.(ma:)) pos whole Left err -> return (Left err) Right (Just []) -> return (Right (acc [(toMA pos [])])) -- should never happen result <- doMatch regex_ptr cstr nsub p_match flags case result of Right Nothing -> return (Right []) Right (Just parts@(whole:_)) -> let ma = toMA 0 parts in loop (ma:) 0 whole Left err -> return (Left err) Right (Just []) -> return (Right [(toMA 0 [])]) -- should never happen where toMA :: Int -> [(RegOffset,RegOffset)] -> Array Int (Int,Int) toMA pos [] = listArray (0,0) [(pos,0)] -- wtf? toMA pos parts = listArray (0,pred (length parts)) . map (\(s,e)-> if s>=0 then (pos+fromIntegral s, fromIntegral (e-s)) else (-1,0)) $ parts --------- wrapCount regex@(Regex regex_fptr compileOptions flags) cstr = do nullTest cstr "wrapCount cstr" $ do if (0 /= compNoSub .&. compileOptions) then do r <- wrapTest regex cstr case r of Right True -> return (Right 1) Right False -> return (Right 0) Left err -> return (Left err) else do withForeignPtr regex_fptr $ \regex_ptr -> do let nsub_bytes = ((16)) {-# LINE 548 "Text/Regex/Posix/Wrap.hsc" #-} allocaBytes nsub_bytes $ \p_match -> do nullTest cstr "wrapCount p_match" $ do let flags' = (execNotBOL .|. flags) at pos = doMatch regex_ptr (plusPtr cstr pos) 0 p_match flags' loop acc old (s,e) | acc `seq` old `seq` False = undefined | s == e = return (Right acc) | otherwise = do let pos = old + fromIntegral e result <- at pos case result of Right Nothing -> return (Right acc) Right (Just (whole:_)) -> loop (succ acc) pos whole Left err -> return (Left err) Right (Just []) -> return (Right acc) -- should never happen result <- doMatch regex_ptr cstr 0 p_match flags case result of Right Nothing -> return (Right 0) Right (Just (whole:_)) -> loop 1 0 whole Left err -> return (Left err) Right (Just []) -> return (Right 0) -- should never happen {- -- This is the slower 0.66 version of the code (91s instead of 79s on 10^6 bytes) wrapMatchAll regex cstr = do let regex' = setExecOpts (execNotBOL .|. (getExecOpts regex)) regex at pos = wrapMatch regex' (plusPtr cstr pos) loop old (s,e) | s == e = return [] | otherwise = do let pos = old + fromIntegral e result <- at pos case unwrap result of Nothing -> return [] Just [] -> return ((toMA pos []):[]) -- wtf? Just parts@(whole:_) -> do rest <- loop pos whole return ((toMA pos parts) : rest) result <- wrapMatch regex cstr case unwrap result of Nothing -> return [] Just [] -> return ((toMA 0 []):[]) -- wtf? Just parts@(whole:_) -> do rest <- loop 0 whole return ((toMA 0 parts) : rest) --------- -- This was also changed to match wrapMatchAll after 0.66 wrapCount regex cstr = do let regex' = setExecOpts (execNotBOL .|. (getExecOpts regex)) regex at pos = wrapMatch regex' (plusPtr cstr pos) loop acc old (s,e) | acc `seq` old `seq` False = undefined | s == e = return acc | otherwise = do let pos = old + fromIntegral e result <- at pos case unwrap result of Nothing -> return acc Just [] -> return (succ acc) -- wtf? Just (whole:_) -> loop (succ acc) pos whole result <- wrapMatch regex cstr case unwrap result of Nothing -> return 0 Just [] -> return 1 -- wtf? Just (whole:_) -> loop 1 0 whole -}