Ticket #4345: Wrap.hs

File Wrap.hs, 6.0 KB (added by igloo, 4 years ago)
Line 
1
2module Wrap where
3
4import Control.Monad(liftM)
5import Data.Array(Array)
6import Data.Bits(Bits(..))
7import Data.Int(Int32,Int64)
8import Foreign(Ptr, nullPtr,
9               Storable(peekByteOff),
10               allocaBytes, withForeignPtr,ForeignPtr,plusPtr,peekElemOff)
11import Foreign.C(CSize,CInt,CChar)
12import Foreign.C.String(CString)
13
14type CRegex = ()
15
16type RegOffset = Int64
17
18type CompOption = CInt
19type ExecOption = CInt
20type ReturnCode = CInt
21
22data Regex = Regex (ForeignPtr CRegex) CompOption ExecOption
23
24type WrapError = (ReturnCode,String)
25
26wrapCount :: Regex -> CString
27          -> IO (Either WrapError Int)
28
29type CRegMatch = ()
30
31foreign import ccall unsafe "regexec"
32  c_regexec :: Ptr CRegex -> CString -> CSize
33            -> Ptr CRegMatch -> ExecOption -> IO ReturnCode
34
35nullTest :: Ptr a -> String -> IO (Either WrapError b) -> IO (Either WrapError b)
36nullTest ptr msg io = do
37  if nullPtr == ptr
38    then return (Left (0,"Ptr parameter was nullPtr in Text.Regex.TRE.Wrap."++msg))
39    else io
40
41isNewline,isNull :: Ptr CChar -> Int -> IO Bool
42isNewline cstr pos = liftM (newline ==) (peekElemOff cstr pos)
43  where newline = toEnum 10
44isNull cstr pos = liftM (nullChar ==) (peekElemOff cstr pos)
45  where nullChar = toEnum 0
46
47wrapError :: ReturnCode -> Ptr CRegex -> IO (Either WrapError b)
48wrapError = undefined
49
50doMatch :: Ptr CRegex -> CString -> CSize -> Ptr CRegMatch -> ExecOption
51        -> IO (Either WrapError (Maybe [(RegOffset,RegOffset)]))
52doMatch regex_ptr cstr nsub p_match flags = do
53  r <- c_regexec regex_ptr cstr (1 + nsub) p_match flags
54  if r == 0
55    then do
56       regions <- mapM getOffsets . take (1+fromIntegral nsub)
57                  . iterate (`plusPtr` (8)) $ p_match
58       return (Right (Just regions))
59    else if r == 1
60       then return (Right Nothing)
61       else wrapError r regex_ptr
62  where
63    getOffsets :: Ptr CRegMatch -> IO (RegOffset,RegOffset)
64    getOffsets pmatch' = do
65      start <- (\hsc_ptr -> peekByteOff hsc_ptr 0) pmatch' :: IO (Int32)
66      end   <- (\hsc_ptr -> peekByteOff hsc_ptr 4) pmatch' :: IO (Int32)
67      return (fromIntegral start,fromIntegral end)
68
69wrapMatchAll :: Regex -> CString -> IO (Either WrapError ())
70wrapMatchAll (Regex regex_fptr compileOptions flags) cstr = do
71 nullTest cstr "wrapMatchAll cstr" $ do
72  if (0 /= 8 .&. compileOptions)
73    then undefined
74    else do
75      withForeignPtr regex_fptr $ \regex_ptr -> do
76        nsub <- (\hsc_ptr -> peekByteOff hsc_ptr 48) regex_ptr :: IO CSize
77        let nsub_int,nsub_bytes :: Int
78            nsub_int = fromIntegral nsub
79            nsub_bytes = (1 + nsub_int) * 8
80
81        allocaBytes nsub_bytes $ \p_match -> do
82         nullTest p_match "wrapMatchAll p_match" $ do
83          let flagsBOL = complement 1 .&. flags
84              flagsMIDDLE = 1 .|. flags
85              atBOL pos = doMatch regex_ptr (plusPtr cstr pos) nsub p_match flagsBOL
86              atMIDDLE pos = doMatch regex_ptr (plusPtr cstr pos) nsub p_match flagsMIDDLE
87              loop acc old (s,e) | acc `seq` old `seq` False = undefined
88                                 | s == e = do
89                let pos = old + fromIntegral e
90                atEnd <- isNull cstr pos
91                if atEnd then return (Left undefined)
92                  else loop acc old (s,succ e)
93                                 | otherwise = do
94                let pos = old + fromIntegral e
95                prev'newline <- isNewline cstr (pred pos)
96                result <- if prev'newline then atBOL pos else atMIDDLE pos
97                case result of
98                  Right Nothing -> return (Left undefined)
99                  Right (Just parts@(whole:_)) -> let ma = toMA pos parts
100                                                 in loop (acc.(ma:)) pos whole
101                  Left err -> return (Left err)
102                  Right (Just []) -> return (Left undefined)
103          result <- doMatch regex_ptr cstr nsub p_match flags
104          case result of
105            Right Nothing -> return (Left undefined)
106            Right (Just parts@(whole:_)) -> let ma = toMA 0 parts
107                                            in loop (ma:) 0 whole
108            Left err -> return (Left err)
109            Right (Just []) -> return (Left undefined)
110  where
111    toMA :: Int -> [(RegOffset,RegOffset)] -> Array Int (Int,Int)
112    toMA = undefined
113
114wrapCount (Regex regex_fptr compileOptions flags) cstr = do
115 nullTest cstr "wrapCount cstr" $ do
116  if (0 /= 8 .&. compileOptions)
117    then do
118      r <- undefined
119      case r of
120        Right True -> return (Right 1)
121        Right False -> return (Right 0)
122        Left err -> return (Left err)
123    else do
124      withForeignPtr regex_fptr $ \regex_ptr -> do
125        allocaBytes 8 $ \p_match -> do
126         nullTest p_match "wrapCount p_match" $ do
127          let flagsBOL = complement 1 .&. flags
128              flagsMIDDLE = 1 .|. flags
129              atBOL pos = doMatch regex_ptr (plusPtr cstr pos) 0 p_match flagsBOL
130              atMIDDLE pos = doMatch regex_ptr (plusPtr cstr pos) 0 p_match flagsMIDDLE
131              loop acc old (s,e) | acc `seq` old `seq` False = undefined
132                                 | s == e = do
133                let pos = old + fromIntegral e
134                atEnd <- isNull cstr pos
135                if atEnd then return (Right acc)
136                  else loop acc old (s,succ e)
137                                 | otherwise = do
138                let pos = old + fromIntegral e
139                prev'newline <- isNewline cstr (pred pos)
140                result <- if prev'newline then atBOL pos else atMIDDLE pos
141                case result of
142                  Right Nothing -> return (Right acc)
143                  Right (Just (whole:_)) -> loop (succ acc) pos whole
144                  Left err -> return (Left err)
145                  Right (Just []) -> return (Right acc)
146          result <- doMatch regex_ptr cstr 0 p_match flags
147          case result of
148            Right Nothing -> return (Right 0)
149            Right (Just (whole:_)) -> loop 1 0 whole
150            Left err -> return (Left err)
151            Right (Just []) -> return (Right 0)
152