regex-tre-0.91: Text/Regex/TRE/Wrap.hsc
{-# OPTIONS_GHC -fglasgow-exts -fffi -fno-warn-unused-imports #-}
-- | http://laurikari.net/tre/index.html http://laurikari.net/tre/api.html
--
-- This will fail or error only if allocation fails or a nullPtr is passed in.
{- Copyright : (c) Chris Kuklewicz 2007 -}
module Text.Regex.TRE.Wrap(
-- ** High-level interface
Regex,
CompOption(CompOption),
ExecOption(ExecOption),
(=~),
(=~~),
-- ** Low-level interface
RegOffset,
ReturnCode(ReturnCode),
WrapError,
wrapCompile,
wrapTest,
wrapMatch,
wrapMatchAll,
wrapCount,
-- ** Miscellaneous
getVersion,
getNumSubs,
unusedRegOffset,
-- ** CompOption values
compBlank,
compExtended, -- use extended regex syntax
compIgnoreCase, -- ignore case when matching
compNoSub, -- no substring matching needed
compNewline, -- '.' doesn't match newline
compRightAssoc, -- flip from left to right assoc
-- ** ExecOption values
execBlank,
execNotBOL, -- not at begining of line
execNotEOL, -- not at end of line
-- ** ReturnCode values
retOk,
retBadbr,
retBadpat,
retBadrpt,
retEcollate,
retEctype,
retEescape,
retEsubreg,
retEbrack,
retEparen,
retEbrace,
retErange,
retEspace
) where
#if defined(HAVE_TRE_H)
import Control.Monad(when)
import Data.Int
import Data.Array(listArray)
import Data.Bits(Bits((.|.))) -- ((.&.),(.|.),complement))
import Foreign
import Foreign.C(CInt,CChar,CSize)
import Foreign.C.String(CString,CStringLen,peekCString)
import Text.Regex.Base.RegexLike(RegexOptions(..),RegexMaker(..),RegexContext(..),MatchArray)
#else
import Data.Array(Array)
import Data.Bits(Bits)
import Foreign(ForeignPtr)
import Foreign.C(CInt)
import Foreign.C.String(CString,CStringLen)
import Text.Regex.Base.RegexLike(RegexOptions(..),RegexMaker(..),RegexContext(..),MatchArray)
#endif
-- | return version of libtre used or Nothing if libtre is not available.
getVersion :: Maybe String
type CRegMatch = () -- dummy regmatch_t used below to read out so and eo values
type Regex_t = () -- regex_t placeholder
type RegOffset = (#type regoff_t)
newtype CompOption = CompOption CInt deriving (Eq,Show,Num,Bits)
newtype ExecOption = ExecOption CInt deriving (Eq,Show,Num,Bits)
newtype ReturnCode = ReturnCode CInt deriving (Eq,Show)
-- | A compiled regular expression
data Regex = Regex (ForeignPtr Regex_t) CompOption ExecOption
type WrapError = (ReturnCode,String)
wrapCompile :: CompOption -- ^ Flags (summed together)
-> ExecOption -- ^ Flags (summed together)
-> CStringLen -- ^ The regular expression to compile
-> IO (Either WrapError Regex) -- ^ Returns: an error offset and string or the compiled regular expression
wrapTest :: Regex -- ^ Compiled regular expression
-> CStringLen -- ^ String to match against and length in bytes
-> IO (Either WrapError Bool)
wrapMatch :: Regex -- ^ Compiled regular expression
-> CStringLen -- ^ String to match against and length in bytes
-> IO (Either WrapError (Maybe [(RegOffset,RegOffset)]))
-- ^ Returns: 'Right Nothing' if the regex did not match the
-- string, or:
-- 'Right Just' an array of (offset,length) pairs where index 0 is whole match, and the rest are the captured subexpressions, or:
-- 'Left WrapError' if there is some strange error
wrapMatchAll :: Regex -> CStringLen -> IO (Either WrapError [ MatchArray ])
wrapCount :: Regex -> CStringLen -> IO (Either WrapError Int)
getNumSubs :: Regex -> 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
compBlank :: CompOption
execBlank :: ExecOption
unusedRegOffset :: RegOffset
retOk :: ReturnCode
#if defined(HAVE_TRE_H)
#include <tre/regex.h>
compBlank = CompOption 0
execBlank = ExecOption 0
unusedRegOffset = (-1)
retOk = ReturnCode 0
fi :: (Integral i,Num n ) => i -> n
fi x = fromIntegral x
{-# INLINE getNumSubs #-}
getNumSubs (Regex r _ _) = fi . unsafePerformIO $ withForeignPtr r getNumSubs'
getNumSubs' :: Ptr Regex_t -> IO CSize
{-# INLINE getNumSubs' #-}
getNumSubs' x = (#peek regex_t,re_nsub) x
size_Regex_t :: Int
size_Regex_t = (#size regex_t)
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 q :: Regex
q = makeRegex r
in match q x
-- (=~~) ::(RegexMaker Regex CompOption ExecOption source,RegexContext Regex source1 target,Monad m) => source1 -> source -> m target
(=~~) x r = do (q :: Regex) <- makeRegexM r
matchM q x
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.TRE.Wrap: "++show r))
-- | Compiles a regular expression
wrapCompile flags e (pattern,len) = do
nullTest pattern "wrapCompile pattern" $ do
fregex <- newForeignPtr finalizerFree =<< mallocBytes size_Regex_t
withForeignPtr fregex $ \regex -> do
if regex == nullPtr
then return (Left (retOk,"Could not malloc regex in Text.Regex.TRE.Wrap.wrapCompile"))
else do
ret <- c_regncomp regex pattern (fi len) flags
if ret == retOk
then return (Right (Regex fregex flags e))
else wrapRC ret
wrapTest (Regex fregex _ flags) (cstr,len) = do
nullTest cstr "wrapTest cstr" $ do
withForeignPtr fregex $ \regex -> do
r@(ReturnCode r') <- c_regnexec regex cstr (fi len) 0 nullPtr flags
if r == retNoMatch
then return (Right False)
else if r' < 0
then wrapRC r
else return (Right True)
-- | Matches a regular expression against a string
wrapMatch (Regex fregex _ flags) (cstr,len) = do
nullTest cstr "wrapMatch cstr" $ do
withForeignPtr fregex $ \regex -> do
nsub <- getNumSubs' regex
let nmatch = 1 + fi nsub
pmatch_bytes = nmatch * (#size regmatch_t)
allocaBytes pmatch_bytes $ \pmatch -> do
r@(ReturnCode r') <- c_regnexec regex cstr (fi len) (succ nsub) pmatch flags
if r == retNoMatch
then return (Right Nothing)
else if r' < 0
then wrapRC r
else do
regions <- mapM getOffsets . take nmatch
. iterate (`plusPtr` (#size regmatch_t)) $ pmatch
return (Right (Just regions)) -- regions will not be []
-- | wrapMatchAll is an improvement over wrapMatch since it only
-- allocates memory with allocaBytes once at the start.
--
--
wrapMatchAll (Regex fregex _ flags) full_source = do
nullTest (fst full_source) "wrapMatchAll source" $ do
withForeignPtr fregex $ \regex -> do
nsub <- getNumSubs' regex
let nmatch = 1 + fi nsub
pmatch_bytes = (nmatch) * (#size regmatch_t)
flags' = (execNotBOL .|. flags)
allocaBytes pmatch_bytes $ \pmatch ->
let loop acc flags_in_use (source,len) pos | pos `seq` len `seq` source `seq` False = undefined
| otherwise = do
r@(ReturnCode r') <- c_regnexec regex source (fi len) (succ nsub) pmatch flags_in_use
if r == retNoMatch
then return (Right (acc []))
else if r' < 0
then wrapRC r
else do
start_ends <- mapM getOffsets . take nmatch
. iterate (`plusPtr` (#size regmatch_t)) $ pmatch
let start_offs = map (\(s,e) -> (pos + fi s,fi (e-s))) start_ends :: [(Int,Int)]
arr = listArray (0,fi nsub) start_offs
acc' = acc . (arr:)
delta = fi (snd (head start_ends)) :: Int
pos' = pos + delta :: Int
source' = plusPtr source delta :: CString
len' = len - delta :: Int
if (arr `seq` delta) == 0
then return (Right (acc' []))
else loop acc' flags' (source',len') pos'
in loop id flags full_source 0
getOffsets :: Ptr CRegMatch -> IO (RegOffset,RegOffset)
getOffsets p_match = do
start <- (#peek regmatch_t, rm_so) p_match :: IO RegOffset
end <- (#peek regmatch_t, rm_eo) p_match :: IO RegOffset
return (start,end)
wrapCount (Regex fregex _ flags) (in_source,in_len) = do
nullTest in_source "wrapCount source" $ do
withForeignPtr fregex $ \regex ->
allocaBytes (#size regmatch_t) $ \pmatch -> do
nullTest pmatch "wrapCount pmatch" $
let flags' = (execNotBOL .|. flags)
loop flags_in_use (source,len) count | count `seq` False = undefined
| otherwise = do
r@(ReturnCode r') <- c_regnexec regex source len 1 pmatch flags_in_use
if r == retNoMatch
then return (Right count)
else if r'<0
then wrapRC r
else do
(start,end) <- getOffsets pmatch
-- (start == unusedRegOffset) check omitted
let len' = len - fi end
source' = plusPtr source (fi end)
if end > start
then loop flags' (source',len') (succ count)
else return (Right (succ count))
in loop flags (in_source,fi in_len) 0
getVersion = unsafePerformIO $ do
version <- c_tre_version
if version == nullPtr
then return (Just "tre_version was null")
else return . Just =<< peekCString version
foreign import ccall unsafe "tre/regex.h regncomp"
c_regncomp :: Ptr Regex_t -> CString -> CSize -> CompOption
-> IO ReturnCode
foreign import ccall unsafe "tre/regex.h tre_version"
c_tre_version :: IO (Ptr CChar)
foreign import ccall unsafe "tre/regex.h regnexec"
c_regnexec :: Ptr Regex_t -> CString -> CSize
-> CSize -> Ptr CRegMatch -> ExecOption
-> IO ReturnCode
{-
newtype InfoWhat = InfoWhat CInt deriving (Eq,Show)
newtype ConfigWhat = ConfigWhat CInt deriving (Eq,Show)
foreign import ccall unsafe "tre/regex.h tre_config"
c_tre_config :: ConfigWhat -> Ptr a
-> IO ReturnCode
-}
-- Flags for regexec
#enum ExecOption,ExecOption, \
execNotBOL = REG_NOTBOL, \
execNotEOL = REG_NOTEOL
-- Flags for regcomp
#enum CompOption,CompOption, \
compExtended = REG_EXTENDED, \
compIgnoreCase = REG_ICASE, \
compNoSub = REG_NOSUB, \
compNewline = REG_NEWLINE, \
compRightAssoc = REG_RIGHT_ASSOC
-- 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...
#enum ReturnCode,ReturnCode, \
retNoMatch = REG_NOMATCH, \
retBadbr = REG_BADBR, \
retBadpat = REG_BADPAT, \
retBadrpt = REG_BADRPT, \
retEcollate = REG_ECOLLATE, \
retEctype = REG_ECTYPE, \
retEescape = REG_EESCAPE, \
retEsubreg = REG_ESUBREG, \
retEbrack = REG_EBRACK, \
retEparen = REG_EPAREN, \
retEbrace = REG_EBRACE, \
retErange = REG_ERANGE, \
retEspace = REG_ESPACE
#else /* do not HAVE_TRE_H */
instance RegexOptions Regex CompOption ExecOption where
blankCompOpt = err
blankExecOpt = err
defaultCompOpt = err
defaultExecOpt = err
getExecOpts = err
setExecOpts = err
msg :: String
msg = "WrapTre.hsc was not compiled against libtre regex library with HAVE_TRE_H defined"
err :: a
err = error msg
(=~) = err
(=~~) = err
-- Hack to avoid the constructor from being unused
wrapCompile _ _ _ = err >> return (Right (Regex err err err))
wrapTest = err
wrapMatch = err
wrapMatchAll = err
wrapCount = err
compExtended,compIgnoreCase,compNoSub,compNewline :: CompOption
compBlank = err
compExtended = err
compIgnoreCase = err
compNoSub = err
compNewline = err
execNotBOL,execNotEOL :: ExecOption
execBlank = err
execNotBOL = err
execNotEOL = err
retBadbr, retBadpat, retBadrpt, retEcollate, retEctype, retEescape, retEsubreg, retEbrack, retEparen, retEbrace, retErange, retEspace :: ReturnCode
retBadbr = err
retBadpat = err
retBadrpt = err
retEcollate = err
retEctype = err
retEescape = err
retEsubreg = err
retEbrack = err
retEparen = err
retEbrace = err
retErange = err
retEspace = err
getVersion = Nothing
#endif /* HAVE_TRE_H */