Changeset b6b5fc1 in adblock2privoxy


Ignore:
Timestamp:
Sep 1, 2013 4:40:42 PM (6 years ago)
Author:
zubr <a@…>
Branches:
master
Children:
79fd8bf
Parents:
54cefb3
Message:

cases parser

Files:
2 added
5 edited

Legend:

Unmodified
Added
Removed
  • AdBlock2Privoxy.cabal

    r54cefb3 rb6b5fc1  
    2020                   ParsecExt, 
    2121                   Foo, 
    22                    Utils 
     22                   Utils, 
     23                   ParserExtTests 
    2324 
  • src/Foo.hs

    r54cefb3 rb6b5fc1  
    33 
    44 
    5 class (Monad m) => MonadState s m | m -> s where 
    6     -- | Return the state from the internals of the monad. 
    7     get :: m s 
    8     -- | Replace the state inside the monad. 
    9     put :: s -> m () 
     5l :: b -> (a -> b)  
     6l x _ = x 
     7 
     8g12 = l -- first item: concatenate l with prev level first item  
     9g22 = l$id -- next items: pass prev level item to l 
     10 
     11g13 :: a1 -> a2 -> a3 -> a1 
     12g13 = l.l 
     13g23 :: a1 -> a2 -> a3 -> a2 
     14g23 = l$l 
     15--g33 :: a1 -> a2 -> a3 -> a3 
     16g33 = l$g23 
     17   
     18g41 = l.l.l  
     19g42 = l$l.l 
     20g43 = l$l$l 
     21g44 = l$l$l$id 
     22 
     23g51 = l.l.l.l  
     24g52 = l$l.l.l 
     25g53 = l$l$l.l 
     26g54 = l$l$l$l 
     27g55 = l$l$l$l$id 
     28 
     29 
  • src/InputParser.hs

    r54cefb3 rb6b5fc1  
    1111 
    1212-------------------------------------------------------------------------- 
    13 ---------------------------- data model  ------------------------------------ 
     13---------------------------- data model  --------------------------------- 
    1414-------------------------------------------------------------------------- 
    1515 
     
    5757-------------------------------------------------------------------------- 
    5858 
    59 adblockFile :: MyParser [Line]         
     59adblockFile :: Parser [Line]         
    6060adblockFile = header *> sepEndBy line (oneOf eol) 
    6161    where  
     
    6464 
    6565 
    66 line :: MyParser Line  
     66line :: Parser Line  
    6767line = Line <$> text <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule"   
    6868    where 
    6969        text = lookAhead (manyTill anyChar lineEnd) 
    7070 
    71 elementHide :: MyParser Record 
     71elementHide :: Parser Record 
    7272elementHide = ElementHide <$> domains ',' <*> excludeMatch <*> pattern 
    7373    where 
     
    7575        pattern = manyTill anyChar (lookAhead lineEnd) 
    7676 
    77 match :: MyParser Record 
     77match :: Parser Record 
    7878match = RequestBlock <$> excludeMatch <*> pattern <*> options 
    7979    where 
     
    8383        options = option '$' (char '$') *> requestOptions 
    8484 
    85 comment :: MyParser Record 
     85comment :: Parser Record 
    8686comment = Comment <$ (separatorLine <|> commentText) 
    8787            where commentText = char '!' <* skipMany notLineEnd 
    8888                  separatorLine = lookAhead lineEnd 
    8989 
    90 unknown :: MyParser Record 
     90unknown :: Parser Record 
    9191unknown = Unknown <$ skipMany notLineEnd 
    9292 
    93 requestOptions :: MyParser RequestOptions 
     93requestOptions :: Parser RequestOptions 
    9494requestOptions = runPermParser $ RequestOptions  
    9595                                    <$> requestTypes  
     
    109109        unknownOption = manyPerm $ try optionName 
    110110         
    111 requestOption :: String -> MyParser All 
     111requestOption :: String -> Parser All 
    112112requestOption name = All <$> option True (char '~' *> return False) <* checkOptionName name 
    113113                              
    114114 
    115115 
    116 requestTypeOption :: MyParser RequestType 
     116requestTypeOption :: Parser RequestType 
    117117requestTypeOption =  do  t <- optionName  
    118118                         case reads t of 
     
    122122       
    123123                     
    124 domainOption :: MyParser (Restrictions Domain) 
     124domainOption :: Parser (Restrictions Domain) 
    125125domainOption =  checkOptionName "Domain" *> lineSpaces *> char '=' *> lineSpaces *> domains '|' 
    126126 
    127 optionName :: MyParser String 
     127optionName :: Parser String 
    128128optionName = asOptionName <$> ((:) <$> letter <*> many (alphaNum <|> char '-')) 
    129129                where 
     
    133133                     asOptionName = join.liftA capitalize.ws 
    134134 
    135 checkOptionName :: String -> MyParser () 
     135checkOptionName :: String -> Parser () 
    136136checkOptionName name =  do t <- optionName 
    137137                           when (name /= t) (pzero <?> "option type") 
    138138                     
    139 domain :: MyParser Domain 
     139domain :: Parser Domain 
    140140domain = join <$> intersperse "." <$> parts 
    141141            where  
     
    143143            domainPart = many1 (alphaNum <|> char '-') 
    144144 
    145 domains :: Char -> MyParser (Restrictions Domain) 
     145domains :: Char -> Parser (Restrictions Domain) 
    146146domains sep = runPermParser restrictions 
    147147    where  
     
    154154eol = "\r\n" 
    155155 
    156 lineSpaces :: MyParser () 
     156lineSpaces :: Parser () 
    157157--lineSpaces = spaces 
    158158lineSpaces = skipMany (satisfy isLineSpace) <?> "white space" 
    159159    where isLineSpace c = c == ' ' || c == '\t' 
    160160 
    161 lineEnd :: MyParser Char 
     161lineEnd :: Parser Char 
    162162lineEnd = oneOf eol <|> ('\0' <$ eof) 
    163163 
    164 notLineEnd :: MyParser Char 
     164notLineEnd :: Parser Char 
    165165notLineEnd = noneOf eol 
    166166 
  • src/ParsecExt.hs

    r54cefb3 rb6b5fc1  
     1{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} 
    12module ParsecExt ( 
    2 testParsecExt, 
    3 CasesParser, 
    4 MyParser, 
    5 cases 
     3    --testParsecExt, 
     4    CasesParser, 
     5    Parser, 
     6    cases 
    67) where 
     8 
    79import Utils 
    810import Control.Applicative hiding (many) 
    911import Text.ParserCombinators.Parsec hiding ((<|>),State) 
    1012import Control.Monad.Trans  
    11 import Control.Monad.Writer 
     13import Control.Monad.RWS 
    1214         
    13 ---------------------------------------------------------------------------------------------         
    14          
    15 -- TODO:                   add optional sections 
    16  
    1715--------------------------------------------------------------------------------------------- 
    18 ------------------------- usage sample ------------------------------------------------------ 
     16------------------------- usage samples ------------------------------------------------------ 
    1917--------------------------------------------------------------------------------------------- 
    2018 
    21 prefixSuffixChain :: [MyParser ([String], String, String)] 
    22 prefixSuffixChain = square3 ((:[]) <$> prefix) mid suffix 
    23         where 
    24             prefix = string "a" <|> string "z" -- list of sequental tokens 
    25             mid =    option "\NUL" ((:[]) <$> letter) -- optional section 
    26             suffix = many alphaNum               -- just string 
     19type ExampleCase = ([String], String, String) 
    2720 
    28 testParsecExt :: Either ParseError ([([String], String, String)], String) 
    29 testParsecExt =  parse ((,) <$> cases prefixSuffixChain <*> string "$$$") "x" "aaz12$$$" 
     21-- auto way 
     22parsersChain' :: [ExampleCase -> Parser ExampleCase] 
     23parsersChain' = undefined 
     24 
     25parsersChainElem :: String -> Parser String 
     26parsersChainElem acc = if length acc > 3 then pzero else string "d" 
     27 
     28-- manual way 
     29 
     30parsersChainElem' :: ExampleCase -> Parser ExampleCase 
     31parsersChainElem' (_,_,acc) = (\x -> (mempty, mempty, x)) <$> (if length acc > 3 then pzero else string "s")  
     32 
     33 
     34--parsersChain :: [Parser ExampleCase] 
     35--parsersChain = bb ((:[]) <$> prefix) mid suffix 
     36--        where -- all parsers except for last one should consume some input and give some output 
     37--            bb = square3 
     38--             
     39--            prefix = string "ab" <|> string "zz" -- list of sequental tokens 
     40--            mid =    (:[]) <$> letter            -- list of letters 
     41--            suffix = many1 alphaNum <* eof              -- just string. Last pattern should be applied once and can deal with empty input/output 
     42 
     43--testParsecExt :: Either ParseError [([String], String, String)] 
     44--testParsecExt =  parse (cases parsersChain) "x" "abebz12" 
     45 
     46 
     47 
     48 
    3049 
    3150--------------------------------------------------------------------------------------------- 
     
    3352--------------------------------------------------------------------------------------------- 
    3453 
    35 type MyParser a = GenParser Char () a 
    36 type CasesParser r = WriterT [r] (GenParser Char ())  
     54--type StateParser = GenParser Char st 
     55type CasesParser r = RWST () [r] String Parser  
    3756 
    38 cases :: (Monoid r) => [MyParser r] -> MyParser [r] 
    39 cases parsers = execWriterT (mapWriterT lookAhead $ casesParser mempty 0 parsers) 
    40                         <* consumingParser parsers 
    41  
    42 consumingParser :: (Monoid r) => [MyParser r] -> MyParser () 
    43 consumingParser = foldl addParser (return ())  
    44     where  
    45         addParser res x = res <* many' x 
    46         many' parser = do  
    47                             posBefore <- getPosition 
    48                             maybeRes <- optionMaybe.try $ parser 
    49                             posAfter <- getPosition 
    50                             case maybeRes of  
    51                                 Nothing -> return () 
    52                                 Just _ -> when (posBefore /= posAfter) $ many' parser 
     57cases :: (Monoid r) => [r -> Parser r] -> Parser [r] 
     58cases parsers =  do 
     59                    input <- getInput 
     60                    let boxedParser = mapRWST lookAhead $ casesParser mempty parsers 
     61                    (input', res) <- execRWST boxedParser () input 
     62                    setInput input' 
     63                    return res 
    5364                                         
    54 casesParser :: (Monoid r) => r -> Int -> [MyParser r] -> CasesParser r () 
    55 casesParser acc _ [] = do 
    56                       tell [acc] 
    57                       return () 
    58 casesParser acc rep parsers@(parser:next) = do 
    59                         posBefore <- lift getPosition 
    60                         maybeRes <- lift.optionMaybe.try $ parser 
    61                         posAfter <- lift getPosition 
    62                         case maybeRes of  
    63                             Nothing -> return () 
    64                             Just res -> do 
    65                                         let acc' = acc <> res 
    66                                         when (posBefore /= posAfter || rep == 0) $ mapWriterT lookAhead $ casesParser acc' 0 next 
    67                                         when (posBefore /= posAfter) $ casesParser acc' (rep + 1) parsers 
     65casesParser :: (Monoid r) => r -> [r -> Parser r] -> CasesParser r () 
     66casesParser _ []                         = error "Empty parser list is not accepted" 
     67casesParser acc parsers@(parserFun:next) = do 
     68        maybeRes <- lift.optionMaybe.try $ parserFun acc 
     69        case maybeRes of  
     70            Nothing -> return () 
     71            Just res -> do 
     72                input <- lift getInput 
     73                if null input || null next  
     74                    then do  
     75                            put input 
     76                            tell [acc <> res] 
     77                    else do  
     78                            mapRWST lookAhead $ casesParser (acc <> res) next 
     79                            casesParser (acc <> res) parsers                                       
    6880                                         
    6981------------------------------------------------------------------------------------------------ 
  • src/Utils.hs

    r54cefb3 rb6b5fc1  
     1{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables #-} 
    12module Utils ( 
    2 Struct2 (..), 
     3ZipListM, 
     4getZipListM, 
     5zipListM, 
     6 
     7--Struct2 (..), 
    38Struct3 (..), 
    4 Struct4 (..), 
    5 Struct5 (..), 
    6 testSquare 
     9--Struct4 (..), 
     10--Struct5 (..), 
     11--testSquare 
    712) where 
    813import Control.Applicative hiding (many) 
    914import Control.Monad.Writer 
    10 import Control.Monad.State  
     15import Control.Monad.State 
     16import Control.Monad  
     17import Control.Monad.Identity 
     18 
    1119 
    1220------------------------------------------------------------------------------------------ 
     
    1422------------------------------------------------------------------------------------------ 
    1523 
    16 class Struct2 f 
    17     where 
    18         struct2 :: a1 -> a2 -> f a1 a2       
    19         square2 :: (Applicative g, Monoid a1, Monoid a2) => g a1 -> g a2 -> [g (f a1 a2)] 
    20         square2 a1 a2  = makeSquare (pure'' struct2 <%> a1 <%> a2) 
     24newtype ZipListM a = ZipListM { getZipList' :: ZipList a } deriving (Functor, Applicative) 
     25getZipListM :: ZipListM a -> [a] 
     26getZipListM = getZipList.getZipList' 
    2127 
     28zipListM = ZipListM . ZipList 
    2229 
    23 class Struct3 f 
    24     where 
     30instance Monoid a => Monoid (ZipListM a) where 
     31  mempty = pure mempty 
     32  mappend x y = mappend <$> x <*> y 
     33   
     34 
     35--class (Monoid a) => Fff a where 
     36--    fmapTup :: (Monoid a, Fff b, Monoid c) => (a,b) -> c -> c 
     37--    fmapTup (a, b) c = c <> a <>    
     38-- 
     39-- 
     40--heap = (1,(2,3,())) 
     41 
     42z :: (Applicative f, Applicative g, Monoid a) => f (g a) 
     43z = (pure.pure) mempty 
     44 
     45(<%%>) :: (Applicative f, Applicative g) => 
     46           f (g (a -> b)) -> f (g a) -> f (g b) 
     47(<%%>) = (liftA2 (<*>)) 
     48 
     49(<$$>) :: (Functor f, Functor g) => (a->b) -> f (g a) -> f (g b) 
     50(<$$>) = (<$>).(<$>) 
     51 
     52--class Struct2 f where 
     53--        struct2 :: a1 -> a2 -> f a1 a2 
     54--        destruct2 :: (a1 -> a2 -> b) -> (f a1 a2 -> b)           
     55-- 
     56--square2 :: forall f m a1 a2.(Struct2 f, Applicative m, Monoid a1, Monoid a2) =>  
     57--            (a1 -> m a1) -> (a2 -> m a2) -> [(f a1 a2) -> m (f a1 a2)] 
     58--square2 a1 a2  = [] 
     59--    where  
     60--     
     61--    structLine = [struct2 <$$> a1 <%%> z] 
     62--    --structLine' = makeSquare (pure'4 struct3 <%> a1 <%> (a2.toA2) <%> (a3.toA3)) 
     63--    destructLine = [\l a1' _ -> l a1'] 
     64           
     65 
     66class Struct3 f where 
    2567        struct3 :: a1 -> a2 -> a3 -> f a1 a2 a3 
    26         square3 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3) =>  
    27                     g a1 -> g a2 -> g a3 -> [g (f a1 a2 a3)] 
    28         square3 a1 a2 a3  = makeSquare (pure'' struct3 <%> a1 <%> a2 <%> a3) 
     68        destruct3 ::  (a1 -> a2 -> a3 -> b) -> (f a1 a2 a3 -> b) 
    2969         
    30 class Struct4 f 
    31     where 
    32         struct4 :: a1 -> a2 -> a3 -> a4 -> f a1 a2 a3 a4 
    33         square4 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4) =>  
    34                     g a1 -> g a2 -> g a3 -> g a4 -> [g (f a1 a2 a3 a4)] 
    35         square4 a1 a2 a3 a4  = makeSquare (pure'' struct4 <%> a1 <%> a2 <%> a3 <%> a4) 
     70       --des :: l -> (a -> b) 
     71        
    3672         
    37 class Struct5 f 
    38     where 
    39         struct5 :: a1 -> a2 -> a3 -> a4 -> a5 -> f a1 a2 a3 a4 a5 
    40         square5 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4, Monoid a5) =>  
    41                     g a1 -> g a2 -> g a3 -> g a4 -> g a5 -> [g (f a1 a2 a3 a4 a5)] 
    42         square5 a1 a2 a3 a4 a5 = makeSquare (pure'' struct5 <%> a1 <%> a2 <%> a3 <%> a4 <%> a5) 
     73         
     74--square3 :: (Struct3 f, Applicative m, Monoid a1, Monoid a2, Monoid a3) =>  
     75--            (a1 -> m a1) -> (a2 -> m a2) -> (a3 -> m a3) -> [(f a1 a2 a3) -> m (f a1 a2 a3)] 
     76--square3 a1 a2 a3 = makeSquare (pure'4 struct3 <%> (a1.toA1) <%> (a2.toA2) <%> (a3.toA3)) 
     77--            where  
     78--                toA1' = (\a _ _ -> a) 
     79--                toA1 = destruct3 toA1' 
     80--                toA2' = (\_ a _ -> a) 
     81--                toA2 = destruct3 toA2' 
     82--                toA3' = (\_ _ a -> a) 
     83--                toA3 = destruct3 toA3' 
     84--                                    
     85         
     86         
     87         
     88--class Struct4 f where 
     89--        struct4 :: a1 -> a2 -> a3 -> a4 -> f a1 a2 a3 a4 
     90--        square4 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4) =>  
     91--                    g a1 -> g a2 -> g a3 -> g a4 -> [g (f a1 a2 a3 a4)] 
     92--        square4 a1 a2 a3 a4  = makeSquare (pure'' struct4 <%> a1 <%> a2 <%> a3 <%> a4) 
     93--         
     94--class Struct5 f where 
     95--        struct5 :: a1 -> a2 -> a3 -> a4 -> a5 -> f a1 a2 a3 a4 a5 
     96--        square5 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4, Monoid a5) =>  
     97--                    g a1 -> g a2 -> g a3 -> g a4 -> g a5 -> [g (f a1 a2 a3 a4 a5)] 
     98--        square5 a1 a2 a3 a4 a5 = makeSquare (pure'' struct5 <%> a1 <%> a2 <%> a3 <%> a4 <%> a5) 
    4399 
    44 instance Struct2 (,) 
    45     where  
    46         struct2 = (,) 
    47  
    48 instance Struct3 (,,) 
    49     where  
    50         struct3 = (,,) 
    51  
    52 instance Struct4 (,,,) 
    53     where  
    54         struct4 = (,,,) 
    55          
    56 instance Struct5 (,,,,) 
    57     where  
    58         struct5 = (,,,,) 
     100--instance Struct2 (,)    where struct2 = (,) 
     101instance Struct3 (,,)   where  
     102    struct3 = (,,) 
     103    --destruct3 = id 
     104--instance Struct4 (,,,)  where struct4 = (,,,) 
     105--instance Struct5 (,,,,) where struct5 = (,,,,) 
    59106 
    60107--------------------------------------------------------------------------------------------- 
     
    67114--  Just ( "" ,  0 , True  )] 
    68115------------------------- 
    69 testSquare :: [Maybe (String, Sum Int, Any)] 
    70 testSquare = square3 (Just "a") (Just (Sum 1)) (Just (Any True)) 
     116--testSquare :: [Maybe (String, Sum Int, Any)] 
     117--testSquare = square3 (Just "a") (Just (Sum 1)) (Just (Any True)) 
    71118 
    72119----------------------------------------------------------------------------------------------- 
    73120------------------------- implementation ------------------------------------------------------ 
    74121----------------------------------------------------------------------------------------------- 
     122 
     123type Counter c = State Int (Int -> c) 
    75124 
    76125-- wraps value to have something meaningfull only on diagonal places in a matrix like 
     
    81130-- State Int a - stores column number 
    82131-- Reader ((->) r) - provides row number from outside  
    83 valueOnDiagonal :: (Applicative f, Monoid a) =>  f a -> State Int (Int -> f a) 
     132valueOnDiagonal :: (Applicative a, Monoid m) =>  (f -> a m) -> Counter (f -> a m) 
    84133valueOnDiagonal val = do 
    85134        col <- get 
     
    87136        return (\row -> if row == col  
    88137                                then val  
    89                                 else pure mempty) 
     138                                else (\_ -> pure mempty)) 
    90139 
    91140-- lifts right argument 2 levels up to become s (r (f a)) where s = State and r = Reader 
    92141-- then applies left arg to right one  
    93142-- it's used to put items to a line in matrix 
    94 (<%>) :: (Applicative f, Monoid a) => State Int (Int -> f (a -> b)) 
    95                                        -> f a -- becomes State Int (Int -> f a) after lift with valueOnDiagonal 
    96                                        -> State Int (Int -> f b) 
    97 (<%>) a b = (liftA2.liftA2 $ (<*>)) a (valueOnDiagonal b) 
     143(<%>) :: (Applicative a, Monoid m) => Counter (c -> a (m -> n)) 
     144                                       -> (c -> a m) 
     145                                       -> Counter (c -> a n) 
     146(<%>) a b = res 
     147            where 
     148                 --b' :: State Int (Int -> (c -> m a))       
     149                b' = valueOnDiagonal $ b      
     150                res = (liftA2.liftA2.liftA2 $ (<*>)) a b'  
     151                 
     152                 
    98153 
    99154-- creates square matrix from given lines 
    100155-- values are on main diagonal 
    101 makeSquare :: State Int (Int -> a) -> [a] 
     156makeSquare :: Counter x -> [x] 
    102157makeSquare line = let   start = 0 
    103158                        (line', size) = runState line start 
    104159                  in    line' <$> [start .. size - 1] 
    105160                   
    106 -- pure level 3 
    107 pure'' :: (Applicative f, Applicative g, Applicative h) => a -> f (g (h a)) 
    108 pure'' = pure.pure.pure 
     161-- pure level 4 
     162pure'4 :: (Applicative f, Applicative g, Applicative h, Applicative a) => b -> f (g (h (a b))) 
     163pure'4 = pure.pure.pure.pure 
     164 
     165 
     166 
     167 
     168 
     169 
     170 
     171 
     172 
     173 
     174 
     175 
     176 
     177 
     178 
     179 
Note: See TracChangeset for help on using the changeset viewer.