Changeset f7023f1 in adblock2privoxy


Ignore:
Timestamp:
Sep 2, 2013 7:25:58 PM (6 years ago)
Author:
zubr <a@…>
Branches:
master
Children:
861fbae
Parents:
79fd8bf
Message:

parser cases ext done, normalizer draft

Location:
src
Files:
1 added
6 edited

Legend:

Unmodified
Added
Removed
  • src/InputParser.hs

    rb6b5fc1 rf7023f1  
    88import Control.Monad 
    99import Text.Parsec.Permutation 
    10 import ParsecExt 
    1110 
    1211-------------------------------------------------------------------------- 
  • src/Main.hs

    r79fd8bf rf7023f1  
    11module Main where 
    22import InputParser 
    3 import Normalizer 
    4 import ParsecExt 
    5 import Utils 
    63import Control.Applicative hiding ((<|>)) 
    74import Text.ParserCombinators.Parsec hiding (Line, many, optional) 
     
    96import Data.List 
    107import System.IO 
    11 import ParserExtTests 
     8import ParsecExt 
     9import Normalizer 
     10import Utils 
     11 
    1212 
    1313filename :: String 
  • src/Normalizer.hs

    r79fd8bf rf7023f1  
    33import Control.Applicative hiding (many) 
    44import Text.ParserCombinators.Parsec hiding (Line, (<|>)) 
    5 import Control.Monad 
     5import Control.Monad.State 
    66import Data.List 
     7import Data.String.Utils (replace) 
     8import Data.Maybe 
     9import Data.List.Utils (split) 
    710import ParsecExt 
    8 import Data.Monoid 
     11import Utils 
    912 
    1013type Path' = ( 
    11                 Sum Int,  -- bind start 
    1214                String,  -- proto 
    1315                String,  -- host 
    14                 String,  -- query 
    15                 Any   -- bind end     
     16                String  -- query    
    1617              ) 
    1718 
    1819 
    19 --cc :: String -> Either ParseError [Path'] 
    20 --cc = parse (cases urlParts) "url" 
     20url :: String -> Either ParseError [Path] 
     21url = parse (makePaths <$> bindStart <*> cases urlParts <*> bindEnd) "url" 
     22    where 
     23        bindStart = try (string "||") <|> try (string "|") <|> return "" <?> "query start" 
     24        bindEnd = (char '|' <* eof) <|> ('\0' <$ eof) <?> "query end" 
     25        makePath start (proto, host, query) end = Path (length start) proto host query end  
     26        makePaths start mid end = makePath start <$> mid <*> (pure (end == '|'))  
    2127 
    22 urlParts :: [Parser Path'] 
    23 urlParts = [bindStart', proto', host', query', bindEnd'] 
    24         where 
    25             bindStart' = (\x -> (x, z, z, z, z)) <$> bindStart 
    26             proto' =     (\x -> (z, x, z, z, z)) <$> proto 
    27             host' =      (\x -> (z, z, x, z, z)) <$> host 
    28             query' =     (\x -> (z, z, z, x, z)) <$> query 
    29             bindEnd' =   (\x -> (z, z, z, z, x)) <$> bindEnd 
     28urlParts :: [StringStateParser Path'] 
     29urlParts = square3 proto (manyCases host) (oneCase query) 
     30        where           
     31            append xs x = xs ++ [x] 
     32            proto :: StringStateParser String 
     33            proto = do 
     34                    masksString <- get 
     35                    case masksString of 
     36                        Nothing ->  
     37                            do 
     38                            put $ Just $ intercalate protocolsSeparator protocols 
     39                            return "" 
     40                        Just masksString' ->  
     41                            do 
     42                            let masks = split protocolsSeparator masksString' 
     43                            if null masks  
     44                                then lift pzero 
     45                                else  
     46                                    do 
     47                                    name <- lift $ many $ protocolChar 
     48                                    sep <- lift $ many $ oneOf $ hostSeparators 
     49                                    let chars = name ++ (replace "^" "//" sep) 
     50                                    nextChar <- lift $ lookAhead anyChar 
     51                                    let masks' = filterProtoMasks masks chars nextChar 
     52                                    if null masks' || null chars 
     53                                        then lift pzero 
     54                                        else 
     55                                            do 
     56                                            if isJust $ find null masks'  
     57                                                then put $ Just $ "" 
     58                                                else put $ Just $ intercalate protocolsSeparator masks'   
     59                                            if nextChar == '*'  
     60                                                then return $ chars ++ ['*'] 
     61                                                else return chars 
     62            host = try (append <$> many hostChar <*> char '*') <|> 
     63                   try (append <$> many1 hostChar <*> lookAhead (separator)) <?> "host" 
     64            separator = (oneOf hostSeparators <|> queryEnd) <?> "separator" 
     65            query = notFollowedBy (try $ string "//") *> manyTill anyChar (lookAhead (try queryEnd)) <?> "query" 
     66            queryEnd = (char '|' <* eof) <|> ('\0' <$ eof) <?> "query end" 
    3067             
    31             z :: Monoid a => a 
    32             z = mempty  
    33              
    34             bindStart = Sum <$> option 0 (1 <$ char '|') <?> "left border" 
    35             proto = option "" (try (many letter <* string "://")) <?> "proto" 
    36             host = ((:) <$> (char '*' <|> hostChar) <*> many1 hostChar) <|> lookAhead separator <?> "host" 
    37             separator = pure <$> (oneOf hostSeparators <|> queryEnd) <?> "separator" 
    38             query = manyTill anyChar (lookAhead (try queryEnd)) <?> "query" 
    39             queryEnd = (char '|' <* eof) <|> ('\0' <$ eof) <?> "query end" 
    40             bindEnd = Any <$> (False <$ eof <|> True <$ char '|' <* eof) <?> "right border" 
     68filterProtoMasks :: [String] -> String -> Char -> [String] 
     69filterProtoMasks masks chars nextChar = catMaybes $ map filterProtoMask masks 
     70    where filterProtoMask mask = if nextChar /= '*'  
     71                                    then if isSuffixOf chars mask 
     72                                         then Just "" 
     73                                         else Nothing  
     74                                    else let tailFound = find (chars `isPrefixOf`) (tails mask) 
     75                                         in drop (length chars) <$> tailFound  
    4176 
    4277                    
    43 data Path = Path { _bindStart :: Sum Int, 
     78data Path = Path { _bindStart :: Int, 
    4479                   _proto :: String, 
    4580                   _hosts :: String, 
    4681                   _query :: String, 
    47                    _bindEnd :: Any 
     82                   _bindEnd :: Bool 
    4883                   } 
    4984              deriving (Show) 
     
    5287hostChar = alphaNum <|> oneOf ".-:" 
    5388 
     89protocols :: [String] 
     90protocols = ["https://", "http://"] 
     91 
     92protocolsSeparator :: String 
     93protocolsSeparator = ";" 
     94 
     95protocolChar :: Parser Char 
     96protocolChar = oneOf (delete '/' $ nub $ join $ protocols) 
     97 
    5498hostSeparators :: String 
    55 hostSeparators = "^/*" 
    56  
    57  
    58 path :: Parser Path 
    59 path = Path <$> bindStart <*> proto <*> host <*> query <*> bindEnd 
    60     where  
    61         bindStart = Sum <$> option 0 (1 <$ char '|') <?> "left border" 
    62          
    63         proto = option "" (try (many letter <* string "://")) <?> "proto" 
    64          
    65         --hosts = try ((:) <$> host <*> hosts) <|> lookAhead separator <?> "hosts" 
    66         host = ((:) <$> (char '*' <|> hostChar) <*> many1 hostChar) <|> lookAhead separator <?> "host" 
    67         separator = pure <$> (oneOf hostSeparators <|> queryEnd) <?> "separator" 
    68         query = manyTill anyChar (lookAhead (try queryEnd)) <?> "query" 
    69         queryEnd = ('\0' <$ char '|') <|> ('\0' <$ eof) <?> "query end" 
    70         bindEnd = Any <$> option False (True <$ char '|') <?> "right border" 
    71          
    72 --path :: MyParser Path 
    73 --path = Path <$> bindStart <*> proto <*> optionMaybe hosts <*> query <*> bindEnd 
    74 --    where  
    75 --        bindStart = option BindStartNone (char '|' *> (option BindStartStrict (BindStartSoft <$ char '|'))) <?> "left border" 
    76 --        proto = option "" (try (many letter <* string "://")) <?> "proto" 
    77 --        hosts = try ((:) <$> host <*> hosts) <|> lookAhead separator <?> "hosts" 
    78 --        host = (:) <$> (char '*' <|> hostChar) <*> many1 hostChar  <?> "host" 
    79 --        separator = pure.pure <$> (oneOf hostSeparators <|> queryEnd) <?> "separator" 
    80 --        query = manyTill anyChar (lookAhead (try queryEnd)) <?> "query" 
    81 --        queryEnd = ('\0' <$ char '|') <|> ('\0' <$ eof) <?> "query end" 
    82 --        bindEnd = option False (True <$ char '|') <?> "right border" 
    83  
    84  
     99hostSeparators = "^/" 
    85100 
    86101normalizeLines :: [Line] -> [Line] 
  • src/ParsecExt.hs

    r79fd8bf rf7023f1  
    1 {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} 
     1{-# LANGUAGE RankNTypes, ScopedTypeVariables, FlexibleInstances #-} 
    22module ParsecExt ( 
    33    testParsecExt, 
     4    testParseMorse, 
    45    CasesParser, 
    56    StateParser, 
    67    StringStateParser, 
    7     cases 
     8    cases, 
     9    manyCases, 
     10    many1Cases, 
     11    oneCase 
    812) where 
    913 
     
    1317import Control.Monad.Trans  
    1418import Control.Monad.RWS 
     19import Control.Monad.State 
    1520import Data.Maybe 
     21import  {-# SOURCE #-} ParserExtTests  
    1622         
    1723--------------------------------------------------------------------------------------------- 
     
    2430parsersChain = square3 prefix mid suffix 
    2531        where -- all parsers except for last one should consume some input and give some output 
    26             prefix = do acc <- getState 
    27                         setState $ Just "" 
    28                         if isNothing acc  
    29                             then return []  
    30                             else ((:[]) <$> (string "ab" <|> string "zz")) 
    31             mid =    (:[]) <$> letter            -- list of letters 
    32             suffix = many1 alphaNum <* eof              
     32            prefix = manyCases ((:[]) <$> (string "ab" <|> string "zz")) 
     33            mid =    many1Cases $ (:[]) <$> letter            -- list of letters 
     34            suffix = many1Cases $ try $ many1 alphaNum   
     35             
    3336 
    3437testParsecExt :: Either ParseError [([String], String, String)] 
    35 testParsecExt =  runParser (cases parsersChain) Nothing "x" "abebz12" 
     38testParsecExt =  parse (cases parsersChain <* string "$$") "x" "abebz12$$" 
     39 
     40testParseMorse :: Either ParseError [String] 
     41testParseMorse = parseMorse "......-...-..---" 
    3642 
    3743--------------------------------------------------------------------------------------------- 
    3844--------------------------------------------------------------------------------------------- 
    3945--------------------------------------------------------------------------------------------- 
     46 
     47-- parser should consume some input to prevent infinite loop 
     48manyCases :: (Monoid a, Monoid st) => Parser a -> StateParser st a 
     49manyCases p = do    acc <- get 
     50                    put  $ Just mempty 
     51                    lift $ if isNothing acc  
     52                              then return mempty  
     53                              else p 
     54                         
     55oneCase :: (Monoid a, Monoid st) => Parser a -> StateParser st a 
     56oneCase p = do  acc <- get 
     57                put  $ Just mempty 
     58                lift $ if isNothing acc  
     59                          then p 
     60                          else pzero 
     61 
     62many1Cases :: Parser a -> StateParser st a 
     63many1Cases = lift 
     64 
    4065type StringStateParser = StateParser String 
    41 type StateParser st = GenParser Char (Maybe st) 
    42 type CasesParser st r = RWST () [r] String (StateParser st)  
     66type StateParser st = StateT (Maybe st) Parser 
     67type CasesParser st r = RWST () [r] String (StateParser st) 
    4368 
    44 cases :: forall r st.(Monoid r) => [StateParser st r] -> StateParser st [r] 
    45 cases parsers =  do 
    46                     input <- getInput 
    47                     let boxedParser = mapRWST lookAhead $ casesParser mempty parsers 
    48                     (input', res) <- execRWST boxedParser () input 
    49                     setInput input' 
     69optionMaybeTry :: StateParser st a -> StateParser st (Maybe a) 
     70optionMaybeTry p = liftM Just (mapStateT try p) <|> return Nothing 
     71 
     72cases :: forall r st.(Monoid r) => [StateParser st r] -> Parser [r] 
     73cases parsers =  evalStateT stateParser Nothing 
     74            where stateParser =  do 
     75                    input <- lift getInput 
     76                    let boxedParser = (mapRWST.mapStateT) lookAhead $ casesParser mempty parsers 
     77                    (input', res) <- execRWST boxedParser () input   
     78                    lift (setInput input') 
    5079                    return res 
     80                  
    5181                                         
    5282casesParser :: forall r st.(Monoid r) => r -> [StateParser st r] -> CasesParser st r () 
    5383casesParser _ []                         = error "Empty parser list is not accepted" 
    5484casesParser acc parsers@(parser:next) = do 
    55         maybeRes <- lift.optionMaybe.try $ parser 
     85        maybeRes <- lift (optionMaybeTry parser) 
    5686        case maybeRes of  
    5787            Nothing -> return () 
    5888            Just res -> do 
    59                 input <- lift getInput 
     89                input <- lift.lift $ getInput 
     90                let acc' = acc <> res 
    6091                if null input || null next  
    61                     then do  
    62                             put input 
    63                             tell [acc <> res] 
    64                     else do  
    65                             st <- lift getState 
    66                             lift (setState Nothing) 
    67                             mapRWST lookAhead $ casesParser (acc <> res) next 
    68                             lift (setState st) 
    69                             casesParser (acc <> res) parsers                                       
     92                        then do 
     93                            modify (minList input) -- TODO: somehow use processed length to select min input 
     94                            tell [acc'] 
     95                        else do  
     96                            st <- lift get 
     97                            lift (put Nothing) 
     98                            (mapRWST.mapStateT) lookAhead $ casesParser acc' next 
     99                            lift (put st) 
     100                when (not.null $ input) $ casesParser acc' parsers                                       
    70101                                         
    71102------------------------------------------------------------------------------------------------ 
  • src/ParserExtTests.hs

    r79fd8bf rf7023f1  
    11module ParserExtTests ( 
    2 testParseMorse, 
     2parseMorse, 
    33encodeMorse 
    44) where 
     
    1010import Data.List 
    1111import Data.Maybe 
     12import Control.Monad.State 
    1213import Debug.Trace 
    1314 
     
    7677                            Just match -> [match] 
    7778 
    78 morseStepParser :: [String] -> StringStateParser String 
     79morseStepParser :: [String] -> Parser String 
    7980morseStepParser [] = pzero 
    8081morseStepParser [step] = string step 
     
    8283 
    8384morseParser :: Int -> StringStateParser (ZipListM String) 
    84 morseParser pos = do     acc' <- getState 
     85morseParser pos = do     acc' <- get 
    8586                         let acc = case acc' of 
    8687                                      Nothing -> "" 
     
    8990                             steps = drop (length acc) <$> findMorseSteps acc candidates 
    9091                             parser = morseStepParser steps     
    91                          res <- parser 
    92                          setState (Just $ acc ++ res) 
     92                         res <- lift parser 
     93                         put (Just $ acc ++ res) 
    9394                         return (zipListM $ (replicate pos "") ++ (res : repeat "")) 
    9495                   
     
    9798morseParsers = (repeat morseParser) <*> [0..] 
    9899 
    99 testParseMorse :: Either ParseError [String] 
    100 testParseMorse = fmap (filter $ isPrefixOf "HELL") $ (fmap.fmap) postProcess $ parseMorse "x" "......-...-..---" 
     100parseMorse :: String -> Either ParseError [String] 
     101parseMorse s = fmap (filter $ isPrefixOf "HELL") $ (fmap.fmap) postProcess $ parseMorseRaw "x" s 
    101102            where  
    102             parseMorse =  runParser (cases $ morseParsers) Nothing  
     103            parseMorseRaw =  parse (cases $ morseParsers)  
    103104            postProcess = decodeMorse.toLists  
    104105            toLists = (takeWhile $ not.null) . getZipListM  
  • src/Utils.hs

    r79fd8bf rf7023f1  
    88ZipListM, 
    99getZipListM, 
    10 zipListM 
     10zipListM, 
     11maxList, 
     12minList, 
     13compareList 
    1114) where 
    1215import Control.Applicative hiding (many) 
     
    1720----------------------------- export ----------------------------------------------------- 
    1821------------------------------------------------------------------------------------------ 
     22 
     23-- at least one list should be finite 
     24compareList :: Ord a => [a] -> [a] -> Ordering 
     25compareList = compareList' EQ    
     26    where 
     27        compareList' lx [] [] = lx 
     28        compareList' _ [] _ = LT 
     29        compareList' _ _ [] = GT 
     30        compareList' lx (x:xs) (y:ys) = compareList' (lx <> compare x y) xs ys  
     31     
     32maxList :: Ord a => [a] -> [a] -> [a] 
     33maxList a b = if compareList a b == LT then b else a 
     34 
     35minList :: Ord a => [a] -> [a] -> [a] 
     36minList a b = if compareList a b == GT then b else a 
    1937 
    2038newtype ZipListM a = ZipListM { getZipList' :: ZipList a } deriving (Functor, Applicative) 
Note: See TracChangeset for help on using the changeset viewer.