{-# LINE 1 "src/Text/Regex/Posix/Wrap.hsc" #-}
{-# OPTIONS_GHC -Wall -fno-warn-unused-imports #-}
module Text.Regex.Posix.Wrap(
Regex,
RegOffset,
RegOffsetT,
(=~),
(=~~),
WrapError,
wrapCompile,
wrapTest,
wrapMatch,
wrapMatchAll,
wrapCount,
unusedRegOffset,
CompOption(CompOption),
compBlank,
compExtended,
compIgnoreCase,
compNoSub,
compNewline,
ExecOption(ExecOption),
execBlank,
execNotBOL,
execNotEOL,
ReturnCode(ReturnCode),
retBadbr,
retBadpat,
retBadrpt,
retEcollate,
retEctype,
retEescape,
retEsubreg,
retEbrack,
retEparen,
retEbrace,
retErange,
retEspace
) where
{-# LINE 95 "src/Text/Regex/Posix/Wrap.hsc" #-}
import Prelude hiding (fail)
import Control.Monad.Fail (MonadFail)
import Control.Monad(liftM)
import Data.Array(Array,listArray)
import Data.Bits(Bits(..))
import Data.Int(Int32,Int64)
import Data.Word(Word32,Word64)
import Foreign(Ptr, FunPtr, nullPtr, newForeignPtr,
addForeignPtrFinalizer, Storable(peekByteOff), allocaArray,
allocaBytes, withForeignPtr,ForeignPtr,plusPtr,peekElemOff)
import Foreign.Marshal.Alloc(mallocBytes)
import Foreign.C(CChar)
{-# LINE 114 "src/Text/Regex/Posix/Wrap.hsc" #-}
import Foreign.C(CSize(CSize),CInt(CInt))
{-# LINE 118 "src/Text/Regex/Posix/Wrap.hsc" #-}
import Foreign.C.String(peekCAString, CString)
import Text.Regex.Base.RegexLike(RegexOptions(..),RegexMaker(..),RegexContext(..),MatchArray)
import qualified Control.Exception(try,IOException)
try :: IO a -> IO (Either Control.Exception.IOException a)
try = Control.Exception.try
data CRegex
type RegOffset = Int64
type RegOffsetT = (Int32)
{-# LINE 145 "src/Text/Regex/Posix/Wrap.hsc" #-}
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)
data Regex = Regex (ForeignPtr CRegex) CompOption ExecOption
compBlank :: CompOption
compBlank = CompOption 0
execBlank :: ExecOption
execBlank = ExecOption 0
unusedRegOffset :: RegOffset
unusedRegOffset = (-1)
type WrapError = (ReturnCode,String)
wrapCompile :: CompOption
-> ExecOption
-> CString
-> IO (Either WrapError Regex)
wrapTest :: Regex -> CString
-> IO (Either WrapError Bool)
wrapMatch :: Regex -> CString
-> IO (Either WrapError (Maybe [(RegOffset,RegOffset)]))
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,MonadFail 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
(=~) x r = let make :: RegexMaker Regex CompOption ExecOption a => a -> Regex
make = makeRegex
in match (make r) x
(=~~) x r = let make :: RegexMaker Regex CompOption ExecOption a => a -> Regex
make = makeRegex
in matchM (make r) x
type CRegMatch = ()
foreign import ccall unsafe "memset"
c_memset :: Ptr CRegex -> CInt -> CSize -> IO (Ptr CRegex)
foreign import ccall unsafe "&hs_regex_regfree"
c_myregfree :: FunPtr (Ptr CRegex -> IO ())
foreign import ccall unsafe "regex.h regcomp"
c_regcomp :: Ptr CRegex -> CString -> CompOption -> IO ReturnCode
foreign import ccall unsafe "regex.h regexec"
c_regexec :: Ptr CRegex -> CString -> CSize
-> Ptr CRegMatch -> ExecOption -> IO ReturnCode
foreign import ccall unsafe "regex.h regerror"
c_regerror :: ReturnCode -> Ptr CRegex
-> CString -> CSize -> IO CSize
retOk :: ReturnCode
retOk = ReturnCode 0
execNotBOL :: ExecOption
execNotBOL = ExecOption 1
execNotEOL :: ExecOption
execNotEOL = ExecOption 2
{-# LINE 314 "src/Text/Regex/Posix/Wrap.hsc" #-}
compExtended :: CompOption
compExtended = CompOption 1
compIgnoreCase :: CompOption
compIgnoreCase = CompOption 2
compNoSub :: CompOption
compNoSub = CompOption 8
compNewline :: CompOption
compNewline = CompOption 4
{-# LINE 321 "src/Text/Regex/Posix/Wrap.hsc" #-}
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 339 "src/Text/Regex/Posix/Wrap.hsc" #-}
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
isNewline,isNull :: Ptr CChar -> Int -> IO Bool
isNewline cstr pos = liftM (newline ==) (peekElemOff cstr pos)
where newline = toEnum 10
isNull cstr pos = liftM (nullChar ==) (peekElemOff cstr pos)
where nullChar = toEnum 0
wrapError :: ReturnCode -> Ptr CRegex -> IO (Either WrapError b)
wrapError errCode regex_ptr = do
errBufSize <- c_regerror errCode regex_ptr nullPtr 0
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
e_regex_ptr <- try $ mallocBytes (64)
{-# LINE 375 "src/Text/Regex/Posix/Wrap.hsc" #-}
case e_regex_ptr of
Left ioerror -> return (Left (retOk,"Text.Regex.Posix.Wrap.wrapCompile: IOError from mallocBytes(regex_t) : "++show ioerror))
Right raw_regex_ptr -> do
zero_regex_ptr <- c_memset raw_regex_ptr 0 (64)
{-# LINE 379 "src/Text/Regex/Posix/Wrap.hsc" #-}
regex_fptr <- newForeignPtr c_myregfree zero_regex_ptr
withForeignPtr regex_fptr $ \regex_ptr -> do
errCode <- c_regcomp regex_ptr pattern flags
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 []))
Right False -> return (Right Nothing)
Left err -> return (Left err)
else do
withForeignPtr regex_fptr $ \regex_ptr -> do
nsub <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) regex_ptr :: IO CSize
{-# LINE 410 "src/Text/Regex/Posix/Wrap.hsc" #-}
let nsub_int,nsub_bytes :: Int
nsub_int = fromIntegral nsub
nsub_bytes = ((1 + nsub_int) * (8))
{-# LINE 413 "src/Text/Regex/Posix/Wrap.hsc" #-}
allocaBytes nsub_bytes $ \p_match -> do
nullTest p_match "wrapMatch allocaBytes" $ do
doMatch regex_ptr cstr nsub p_match flags
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` (8)) $ p_match
{-# LINE 430 "src/Text/Regex/Posix/Wrap.hsc" #-}
return (Right (Just regions))
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 (Int32)
{-# LINE 439 "src/Text/Regex/Posix/Wrap.hsc" #-}
end <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) pmatch' :: IO (Int32)
{-# LINE 440 "src/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 [])])
Right False -> return (Right [])
Left err -> return (Left err)
else do
withForeignPtr regex_fptr $ \regex_ptr -> do
nsub <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) regex_ptr :: IO CSize
{-# LINE 454 "src/Text/Regex/Posix/Wrap.hsc" #-}
let nsub_int,nsub_bytes :: Int
nsub_int = fromIntegral nsub
nsub_bytes = ((1 + nsub_int) * (8))
{-# LINE 457 "src/Text/Regex/Posix/Wrap.hsc" #-}
allocaBytes nsub_bytes $ \p_match -> do
nullTest p_match "wrapMatchAll p_match" $ do
let flagsBOL = (complement execNotBOL) .&. flags
flagsMIDDLE = execNotBOL .|. flags
atBOL pos = doMatch regex_ptr (plusPtr cstr pos) nsub p_match flagsBOL
atMIDDLE pos = doMatch regex_ptr (plusPtr cstr pos) nsub p_match flagsMIDDLE
loop acc old (s,e) | acc `seq` old `seq` False = undefined
| s == e = do
let pos = old + fromIntegral e
atEnd <- isNull cstr pos
if atEnd then return (Right (acc []))
else loop acc old (s,succ e)
| otherwise = do
let pos = old + fromIntegral e
prev'newline <- isNewline cstr (pred pos)
result <- if prev'newline then atBOL pos else atMIDDLE 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 [])]))
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 [])])
where
toMA :: Int -> [(RegOffset,RegOffset)] -> Array Int (Int,Int)
toMA pos [] = listArray (0,0) [(pos,0)]
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 = ((8))
{-# LINE 507 "src/Text/Regex/Posix/Wrap.hsc" #-}
allocaBytes nsub_bytes $ \p_match -> do
nullTest p_match "wrapCount p_match" $ do
let flagsBOL = (complement execNotBOL) .&. flags
flagsMIDDLE = execNotBOL .|. flags
atBOL pos = doMatch regex_ptr (plusPtr cstr pos) 0 p_match flagsBOL
atMIDDLE pos = doMatch regex_ptr (plusPtr cstr pos) 0 p_match flagsMIDDLE
loop acc old (s,e) | acc `seq` old `seq` False = undefined
| s == e = do
let pos = old + fromIntegral e
atEnd <- isNull cstr pos
if atEnd then return (Right acc)
else loop acc old (s,succ e)
| otherwise = do
let pos = old + fromIntegral e
prev'newline <- isNewline cstr (pred pos)
result <- if prev'newline then atBOL pos else atMIDDLE 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)
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)