| 744 | | |
| 745 | | doMatch :: String -> VRule -> Eval VMatch |
| 746 | | doMatch cs MkRulePGE{ rxRule = re } = do |
| 747 | | let pwd1 = getConfig "installarchlib" ++ "/CORE/pugs/pge" |
| 748 | | pwd2 = getConfig "sourcedir" ++ "/src/pge" |
| 749 | | hasSrc <- liftIO $ doesDirectoryExist pwd2 |
| 750 | | let pwd = if hasSrc then pwd2 else pwd1 |
| 751 | | pge <- liftIO $ evalPGE pwd (encodeUTF8 cs) (encodeUTF8 re) |
| 752 | | rv <- tryIO Nothing $ fmap Just (readIO $ decodeUTF8 pge) |
| 753 | | let matchToVal PGE_Fail = VMatch mkMatchFail |
| 754 | | matchToVal (PGE_Array ms) = VList (map matchToVal ms) |
| 755 | | matchToVal (PGE_Match from to pos named) = VMatch $ |
| 756 | | mkMatchOk from to substr pos' named' |
| 757 | | where |
| 758 | | substr = genericTake (to - from) (genericDrop from cs) |
| 759 | | pos' = map matchToVal pos |
| 760 | | named' = Map.map matchToVal $ Map.fromList named |
| 761 | | case rv of |
| 762 | | Just m -> fromVal (matchToVal m) |
| 763 | | Nothing -> do |
| 764 | | liftIO $ putStrLn ("*** Cannot parse PGE: " ++ re ++ "\n*** Error: " ++ pge) |
| 765 | | return mkMatchFail |
| 766 | | |
| 767 | | doMatch cs MkRulePCRE{ rxRegex = re } = do |
| 768 | | rv <- liftIO $ PCRE.execute re (encodeUTF8 cs) 0 |
| 769 | | if isNothing rv then return mkMatchFail else do |
| 770 | | let ((from, len):subs) = Array.elems (fromJust rv) |
| 771 | | substr from len = genericTake len (genericDrop from cs) |
| 772 | | subsMatch = [ VMatch $ mkMatchOk f (f + t) (substr f t) [] Map.empty | (f, t) <- subs ] |
| 773 | | return $ mkMatchOk from (from + len) (substr from len) subsMatch Map.empty |
| 774 | | |
| 775 | | matchFromMR mr = VMatch $ mkMatchOk 0 0 (decodeUTF8 all) subsMatch Map.empty |
| 776 | | where |
| 777 | | (all:subs) = elems $ mrSubs mr |
| 778 | | subsMatch = [ VMatch $ mkMatchOk 0 0 (decodeUTF8 sub) [] Map.empty | sub <- subs ] |
| 779 | | |
| 780 | | -- XXX - need to generalise this |
| 781 | | op2Match :: Val -> Val -> Eval Val |
| 782 | | op2Match x (VRef y) = do |
| 783 | | y' <- readRef y |
| 784 | | op2Match x y' |
| 785 | | |
| 786 | | op2Match x (VSubst (rx, subst)) | rxGlobal rx = do |
| 787 | | str <- fromVal x |
| 788 | | (str', cnt) <- doReplace str 0 |
| 789 | | if cnt == 0 then return (VBool False) else do |
| 790 | | ref <- fromVal x |
| 791 | | writeRef ref $ VStr str' |
| 792 | | return $ castV cnt |
| 793 | | where |
| 794 | | doReplace :: String -> Int -> Eval (String, Int) |
| 795 | | doReplace str ok = do |
| 796 | | match <- str `doMatch` rx |
| 797 | | if not (matchOk match) then return (str, ok) else do |
| 798 | | glob <- askGlobal |
| 799 | | matchSV <- findSymRef "$/" glob |
| 800 | | writeRef matchSV (VMatch match) |
| 801 | | str' <- fromVal =<< evalExp subst |
| 802 | | (after', ok') <- doReplace (genericDrop (matchTo match) str) (ok + 1) |
| 803 | | return (concat [genericTake (matchFrom match) str, str', after'], ok') |
| 804 | | |
| 805 | | op2Match x (VSubst (rx, subst)) = do |
| 806 | | str <- fromVal x |
| 807 | | ref <- fromVal x |
| 808 | | match <- str `doMatch` rx |
| 809 | | if not (matchOk match) then return (VBool False) else do |
| 810 | | glob <- askGlobal |
| 811 | | matchSV <- findSymRef "$/" glob |
| 812 | | writeRef matchSV (VMatch match) |
| 813 | | str' <- fromVal =<< evalExp subst |
| 814 | | writeRef ref . VStr $ concat |
| 815 | | [ genericTake (matchFrom match) str |
| 816 | | , str' |
| 817 | | , genericDrop (matchTo match) str |
| 818 | | ] |
| 819 | | return $ VBool True |
| 820 | | |
| 821 | | op2Match x (VRule rx) | rxGlobal rx = do |
| 822 | | str <- fromVal x |
| 823 | | rv <- matchOnce str |
| 824 | | ifListContext |
| 825 | | (return $ VList rv) |
| 826 | | (return . VInt $ genericLength rv) |
| 827 | | where |
| 828 | | matchOnce :: String -> Eval [Val] |
| 829 | | matchOnce str = do |
| 830 | | match <- str `doMatch` rx |
| 831 | | if not (matchOk match) then return [] else do |
| 832 | | rest <- matchOnce (genericDrop (matchTo match) str) |
| 833 | | return $ matchSubPos match ++ rest |
| 834 | | |
| 835 | | op2Match x (VRule rx) = do |
| 836 | | str <- fromVal x |
| 837 | | match <- str `doMatch` rx |
| 838 | | glob <- askGlobal |
| 839 | | matchSV <- findSymRef "$/" glob |
| 840 | | writeRef matchSV (VMatch match) |
| 841 | | ifListContext |
| 842 | | (return $ VList (matchSubPos match)) |
| 843 | | (return $ VMatch match) |
| 844 | | |
| 845 | | op2Match x y = op2Cmp vCastStr (==) x y |
| 846 | | |
| 847 | | rxSplit :: VRule -> String -> Eval [String] |
| 848 | | rxSplit _ [] = return [] |
| 849 | | rxSplit rx str = do |
| 850 | | match <- str `doMatch` rx |
| 851 | | if not (matchOk match) then return [str] else do |
| 852 | | if matchFrom match == matchTo match |
| 853 | | then do |
| 854 | | let (c:cs) = str |
| 855 | | rest <- rxSplit rx (cs) |
| 856 | | return ([c]:rest) |
| 857 | | else do |
| 858 | | let before = genericTake (matchFrom match) str |
| 859 | | after = genericDrop (matchTo match) str |
| 860 | | rest <- rxSplit rx after |
| 861 | | strs <- mapM fromVal (matchSubPos match) |
| 862 | | return $ (before:concat strs) ++ rest |
