Changeset 15296 for src/Pugs/Prim/Match.hs
- Timestamp:
- 02/18/07 15:56:10 (21 months ago)
- Files:
-
- 1 modified
-
src/Pugs/Prim/Match.hs (modified) (16 diffs)
Legend:
- Unmodified
- Added
- Removed
-
src/Pugs/Prim/Match.hs
r15165 r15296 1 {-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances #-}1 {-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -foverloaded-strings #-} 2 2 3 3 module Pugs.Prim.Match ( … … 16 16 -- XXX - kluge: before we figure out the parrot calling convention, 17 17 -- we'll simply inline the adverbs into the regex. 18 ruleWithAdverbs :: VRule -> Eval VStr18 ruleWithAdverbs :: VRule -> Eval String 19 19 ruleWithAdverbs MkRulePGE{ rxRule = re, rxAdverbs = advs } = do 20 20 when (null re) $ … … 26 26 VBool False -> return "0" 27 27 _ -> fromVal v 28 return $ \x -> ":" ++ k ++ "(" ++ str ++ ")[" ++ x ++ "]"29 return $ combine advs re28 return $ \x -> ":" ++ cast k ++ "(" ++ str ++ ")[" ++ x ++ "]" 29 return $ combine advs (cast re) 30 30 ruleWithAdverbs _ = fail "PCRE regexes can't be compiled to PGE regexes" 31 31 … … 55 55 rv <- tryIO Nothing $ fmap Just (readIO $ decodeUTF8 pge) 56 56 let matchToVal PGE_Fail = VMatch mkMatchFail 57 matchToVal (PGE_String str) = VStr str57 matchToVal (PGE_String str) = _VStr str 58 58 matchToVal (PGE_Array ms) = VList (map matchToVal ms) 59 59 matchToVal (PGE_Match from to pos named) = VMatch $ 60 mkMatchOk from to substrpos' named'60 mkMatchOk from to (cast substr) pos' named' 61 61 where 62 62 substr = genericTake (to - from) (genericDrop from cs) … … 77 77 VMatch $ if fBytes == -1 then mkMatchFail else mkMatchOk 78 78 fChars (fChars + lChars) 79 ( substr csChars fChars lChars)79 (cast $ substr csChars fChars lChars) 80 80 [] Map.empty 81 81 | (fBytes, lBytes) <- subs … … 87 87 chars = genericLength . decodeUTF8 88 88 89 return $ mkMatchOk fromChars (fromChars + lenChars) ( substr csChars fromChars lenChars) subsMatch Map.empty89 return $ mkMatchOk fromChars (fromChars + lenChars) (cast $ substr csChars fromChars lenChars) subsMatch Map.empty 90 90 where 91 91 csBytes = encodeUTF8 csChars 92 92 93 93 matchFromMR :: MatchResult Char -> Val 94 matchFromMR mr = VMatch $ mkMatchOk 0 0 ( decodeUTF8 all) subsMatch Map.empty94 matchFromMR mr = VMatch $ mkMatchOk 0 0 (cast $ decodeUTF8 all) subsMatch Map.empty 95 95 where 96 96 (all:subs) = elems $ mrSubs mr 97 subsMatch = [ VMatch $ mkMatchOk 0 0 ( decodeUTF8 sub) [] Map.empty | sub <- subs ]97 subsMatch = [ VMatch $ mkMatchOk 0 0 (cast $ decodeUTF8 sub) [] Map.empty | sub <- subs ] 98 98 99 99 -- Used in op2Match … … 108 108 op2Match :: Val -> Val -> Eval Val 109 109 110 op2Match x y@ (VCode _)= do110 op2Match x y@VCode{} = do 111 111 (arity :: Int) <- fromVal =<< op1CodeArity y 112 112 res <- fromVal =<< case arity of 113 113 0 -> do 114 writeVar ( cast "$*_") x114 writeVar (_cast "$*_") x 115 115 evalExp $ App (Val y) Nothing [] 116 116 1 -> do 117 117 evalExp $ App (Val y) Nothing [Val x] 118 _ -> fail ("Unexpected arity in smart match: " ++ (show arity))118 _ -> fail ("Unexpected arity in smart match: " ++ show arity) 119 119 return $ VBool $ res 120 120 … … 127 127 (k, v) <- pair_fetch pv 128 128 isTrue <- fromVal v :: Eval Bool 129 testOp <- fromVal k 129 testOp <- fromVal k :: Eval VStr 130 130 file <- fromVal x 131 131 rv <- ($ file) $ case testOp of … … 178 178 if cnt == 0 then return (VBool False) else do 179 179 ref <- fromVal x 180 writeRef ref $ VStr str'180 writeRef ref $ _VStr str' 181 181 return $ castV cnt 182 182 where … … 186 186 if not (matchOk match) then return (str, ok) else do 187 187 glob <- askGlobal 188 matchSV <- findSymRef (cast "$/")glob188 matchSV <- findSymRef varMatch glob 189 189 writeRef matchSV (VMatch match) 190 190 str' <- fromVal =<< evalExp subst … … 205 205 if not (matchOk match) then return (VBool False) else do 206 206 glob <- askGlobal 207 matchSV <- findSymRef (cast "$/")glob207 matchSV <- findSymRef varMatch glob 208 208 writeRef matchSV (VMatch match) 209 209 str' <- fromVal =<< evalExp subst 210 writeRef ref . VStr $ concat210 writeRef ref . _VStr $ concat 211 211 [ genericTake (matchFrom match) str 212 212 , str' … … 252 252 match <- str `doMatch` rx 253 253 glob <- askGlobal 254 matchSV <- findSymRef (cast "$/")glob254 matchSV <- findSymRef varMatch glob 255 255 writeRef matchSV (VMatch match) 256 256 ifListContext … … 290 290 rxSplit rx str = do 291 291 match <- str `doMatch` rx 292 if not (matchOk match) then return [ VStr str] else do292 if not (matchOk match) then return [_VStr str] else do 293 293 if matchFrom match == matchTo match 294 294 then do 295 295 let (c:cs) = str 296 296 rest <- rxSplit rx cs 297 return ( VStr [c]:rest)297 return (_VStr [c]:rest) 298 298 else do 299 299 let before = genericTake (matchFrom match) str 300 300 after = genericDrop (matchTo match) str 301 301 rest <- rxSplit rx after 302 return $ ( VStr before:matchSubPos match) ++ rest302 return $ (_VStr before:matchSubPos match) ++ rest 303 303 304 304 -- duplicated for now, pending über-Haskell-fu … … 308 308 rxSplit_n rx str n = do 309 309 match <- str `doMatch` rx 310 if or [ ( n == 1 ), ( not (matchOk match) ) ] then return [ VStr str] else do310 if or [ ( n == 1 ), ( not (matchOk match) ) ] then return [_VStr str] else do 311 311 if matchFrom match == matchTo match 312 312 then do 313 313 let (c:cs) = str 314 314 rest <- rxSplit_n rx (cs) (n-1) 315 return ( VStr [c]:rest)315 return (_VStr [c]:rest) 316 316 else do 317 317 let before = genericTake (matchFrom match) str 318 318 after = genericDrop (matchTo match) str 319 319 rest <- rxSplit_n rx after (n-1) 320 return $ ( VStr before:matchSubPos match) ++ rest321 322 pkgParents :: VStr -> Eval [VStr]320 return $ (_VStr before:matchSubPos match) ++ rest 321 322 pkgParents :: String -> Eval [String] 323 323 pkgParents pkg = do 324 324 ref <- readVar $ cast (':':'*':pkg) … … 332 332 333 333 -- XXX - copy and paste code; merge with above! 334 pkgParentClasses :: VStr -> Eval [VStr]334 pkgParentClasses :: String -> Eval [String] 335 335 pkgParentClasses pkg = do 336 336 ref <- readVar $ cast (':':'*':pkg) … … 341 341 pkgs <- mapM pkgParentClasses attrs 342 342 return $ nub (pkg:concat pkgs) 343 344 -- | the match variable $/ 345 varMatch :: Var 346 varMatch = _cast "$/"
