Changeset 79fd8bf in adblock2privoxy


Ignore:
Timestamp:
Sep 1, 2013 6:05:01 PM (6 years ago)
Author:
zubr <a@…>
Branches:
master
Children:
f7023f1
Parents:
b6b5fc1
Message:

cases parser with state

Location:
src
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • src/Main.hs

    r54cefb3 r79fd8bf  
    99import Data.List 
    1010import System.IO 
     11import ParserExtTests 
    1112 
    1213filename :: String 
  • src/Normalizer.hs

    r54cefb3 r79fd8bf  
    1717 
    1818 
    19 cc :: String -> Either ParseError [Path'] 
    20 cc = parse (cases urlParts) "url" 
     19--cc :: String -> Either ParseError [Path'] 
     20--cc = parse (cases urlParts) "url" 
    2121 
    22 urlParts :: [MyParser Path'] 
     22urlParts :: [Parser Path'] 
    2323urlParts = [bindStart', proto', host', query', bindEnd'] 
    2424        where 
     
    4949              deriving (Show) 
    5050 
    51 hostChar :: MyParser Char 
     51hostChar :: Parser Char 
    5252hostChar = alphaNum <|> oneOf ".-:" 
    5353 
     
    5656 
    5757 
    58 path :: MyParser Path 
     58path :: Parser Path 
    5959path = Path <$> bindStart <*> proto <*> host <*> query <*> bindEnd 
    6060    where  
  • src/ParsecExt.hs

    rb6b5fc1 r79fd8bf  
    11{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} 
    22module ParsecExt ( 
    3     --testParsecExt, 
     3    testParsecExt, 
    44    CasesParser, 
    5     Parser, 
     5    StateParser, 
     6    StringStateParser, 
    67    cases 
    78) where 
     
    1213import Control.Monad.Trans  
    1314import Control.Monad.RWS 
     15import Data.Maybe 
    1416         
    1517--------------------------------------------------------------------------------------------- 
     
    1921type ExampleCase = ([String], String, String) 
    2022 
    21 -- auto way 
    22 parsersChain' :: [ExampleCase -> Parser ExampleCase] 
    23 parsersChain' = undefined 
     23parsersChain :: [StringStateParser ExampleCase] 
     24parsersChain = square3 prefix mid suffix 
     25        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              
    2433 
    25 parsersChainElem :: String -> Parser String 
    26 parsersChainElem acc = if length acc > 3 then pzero else string "d" 
    27  
    28 -- manual way 
    29  
    30 parsersChainElem' :: ExampleCase -> Parser ExampleCase 
    31 parsersChainElem' (_,_,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  
     34testParsecExt :: Either ParseError [([String], String, String)] 
     35testParsecExt =  runParser (cases parsersChain) Nothing "x" "abebz12" 
    4936 
    5037--------------------------------------------------------------------------------------------- 
    5138--------------------------------------------------------------------------------------------- 
    5239--------------------------------------------------------------------------------------------- 
     40type StringStateParser = StateParser String 
     41type StateParser st = GenParser Char (Maybe st) 
     42type CasesParser st r = RWST () [r] String (StateParser st)  
    5343 
    54 --type StateParser = GenParser Char st 
    55 type CasesParser r = RWST () [r] String Parser  
    56  
    57 cases :: (Monoid r) => [r -> Parser r] -> Parser [r] 
     44cases :: forall r st.(Monoid r) => [StateParser st r] -> StateParser st [r] 
    5845cases parsers =  do 
    5946                    input <- getInput 
     
    6350                    return res 
    6451                                         
    65 casesParser :: (Monoid r) => r -> [r -> Parser r] -> CasesParser r () 
     52casesParser :: forall r st.(Monoid r) => r -> [StateParser st r] -> CasesParser st r () 
    6653casesParser _ []                         = error "Empty parser list is not accepted" 
    67 casesParser acc parsers@(parserFun:next) = do 
    68         maybeRes <- lift.optionMaybe.try $ parserFun acc 
     54casesParser acc parsers@(parser:next) = do 
     55        maybeRes <- lift.optionMaybe.try $ parser 
    6956        case maybeRes of  
    7057            Nothing -> return () 
     
    7663                            tell [acc <> res] 
    7764                    else do  
     65                            st <- lift getState 
     66                            lift (setState Nothing) 
    7867                            mapRWST lookAhead $ casesParser (acc <> res) next 
     68                            lift (setState st) 
    7969                            casesParser (acc <> res) parsers                                       
    8070                                         
  • src/ParserExtTests.hs

    rb6b5fc1 r79fd8bf  
    1010import Data.List 
    1111import Data.Maybe 
     12import Debug.Trace 
    1213 
    1314-------------------------------------------------------------------------------- 
     
    7576                            Just match -> [match] 
    7677 
    77 morseStepParser :: [String] -> Parser String 
     78morseStepParser :: [String] -> StringStateParser String 
    7879morseStepParser [] = pzero 
    7980morseStepParser [step] = string step 
    8081morseStepParser (step:steps') = string step <|> morseStepParser steps' 
    8182 
    82 morseParser :: Int -> ZipListM String -> Parser (ZipListM String) 
    83 morseParser pos accs = let acc = (getZipListM accs) !! pos  
    84                            candidates = filter (\x -> isPrefixOf acc x && acc /= x) morseCharCodes 
    85                            steps = drop (length acc) <$> findMorseSteps acc candidates 
    86                            parser = morseStepParser steps 
    87                            update res = zipListM $ (replicate pos "") ++ (res : repeat "") 
    88                        in update <$> parser 
     83morseParser :: Int -> StringStateParser (ZipListM String) 
     84morseParser pos = do     acc' <- getState 
     85                         let acc = case acc' of 
     86                                      Nothing -> "" 
     87                                      Just val -> val 
     88                             candidates = filter (\x -> isPrefixOf acc x && acc /= x) morseCharCodes 
     89                             steps = drop (length acc) <$> findMorseSteps acc candidates 
     90                             parser = morseStepParser steps     
     91                         res <- parser 
     92                         setState (Just $ acc ++ res) 
     93                         return (zipListM $ (replicate pos "") ++ (res : repeat "")) 
     94                   
    8995 
    90 morseParsers :: [ZipListM String -> Parser (ZipListM String)] 
     96morseParsers :: [StringStateParser (ZipListM String)] 
    9197morseParsers = (repeat morseParser) <*> [0..] 
    9298 
    9399testParseMorse :: Either ParseError [String] 
    94 testParseMorse = fmap (filter (isPrefixOf "HELL")) $ (fmap.fmap) postProcess $ parseMorse "x" "......-...-..---" 
     100testParseMorse = fmap (filter $ isPrefixOf "HELL") $ (fmap.fmap) postProcess $ parseMorse "x" "......-...-..---" 
    95101            where  
    96             parseMorse =  parse $ cases $ morseParsers  
     102            parseMorse =  runParser (cases $ morseParsers) Nothing  
    97103            postProcess = decodeMorse.toLists  
    98104            toLists = (takeWhile $ not.null) . getZipListM  
  • src/Utils.hs

    rb6b5fc1 r79fd8bf  
    1 {-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables #-} 
     1{-# LANGUAGE GeneralizedNewtypeDeriving #-} 
    22module Utils ( 
     3Struct2 (..), 
     4Struct3 (..), 
     5Struct4 (..), 
     6Struct5 (..), 
     7testSquare, 
    38ZipListM, 
    49getZipListM, 
    5 zipListM, 
    6  
    7 --Struct2 (..), 
    8 Struct3 (..), 
    9 --Struct4 (..), 
    10 --Struct5 (..), 
    11 --testSquare 
     10zipListM 
    1211) where 
    1312import Control.Applicative hiding (many) 
    1413import Control.Monad.Writer 
    15 import Control.Monad.State 
    16 import Control.Monad  
    17 import Control.Monad.Identity 
    18  
     14import Control.Monad.State  
    1915 
    2016------------------------------------------------------------------------------------------ 
     
    2622getZipListM = getZipList.getZipList' 
    2723 
     24zipListM :: [a] -> ZipListM a 
    2825zipListM = ZipListM . ZipList 
    2926 
     
    3128  mempty = pure mempty 
    3229  mappend x y = mappend <$> x <*> y 
    33    
    3430 
    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,())) 
     31class Struct2 f where 
     32        struct2 :: a1 -> a2 -> f a1 a2       
     33        square2 :: (Applicative g, Monoid a1, Monoid a2) => g a1 -> g a2 -> [g (f a1 a2)] 
     34        square2 a1 a2  = makeSquare (pure'' struct2 <%> a1 <%> a2) 
    4135 
    42 z :: (Applicative f, Applicative g, Monoid a) => f (g a) 
    43 z = (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            
    6536 
    6637class Struct3 f where 
    6738        struct3 :: a1 -> a2 -> a3 -> f a1 a2 a3 
    68         destruct3 ::  (a1 -> a2 -> a3 -> b) -> (f a1 a2 a3 -> b) 
     39        square3 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3) =>  
     40                    g a1 -> g a2 -> g a3 -> [g (f a1 a2 a3)] 
     41        square3 a1 a2 a3  = makeSquare (pure'' struct3 <%> a1 <%> a2 <%> a3) 
    6942         
    70        --des :: l -> (a -> b) 
    71         
     43class Struct4 f where 
     44        struct4 :: a1 -> a2 -> a3 -> a4 -> f a1 a2 a3 a4 
     45        square4 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4) =>  
     46                    g a1 -> g a2 -> g a3 -> g a4 -> [g (f a1 a2 a3 a4)] 
     47        square4 a1 a2 a3 a4  = makeSquare (pure'' struct4 <%> a1 <%> a2 <%> a3 <%> a4) 
    7248         
    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) 
     49class Struct5 f where 
     50        struct5 :: a1 -> a2 -> a3 -> a4 -> a5 -> f a1 a2 a3 a4 a5 
     51        square5 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4, Monoid a5) =>  
     52                    g a1 -> g a2 -> g a3 -> g a4 -> g a5 -> [g (f a1 a2 a3 a4 a5)] 
     53        square5 a1 a2 a3 a4 a5 = makeSquare (pure'' struct5 <%> a1 <%> a2 <%> a3 <%> a4 <%> a5) 
    9954 
    100 --instance Struct2 (,)    where struct2 = (,) 
    101 instance Struct3 (,,)   where  
    102     struct3 = (,,) 
    103     --destruct3 = id 
    104 --instance Struct4 (,,,)  where struct4 = (,,,) 
    105 --instance Struct5 (,,,,) where struct5 = (,,,,) 
     55instance Struct2 (,)    where struct2 = (,) 
     56instance Struct3 (,,)   where struct3 = (,,) 
     57instance Struct4 (,,,)  where struct4 = (,,,) 
     58instance Struct5 (,,,,) where struct5 = (,,,,) 
    10659 
    10760--------------------------------------------------------------------------------------------- 
     
    11467--  Just ( "" ,  0 , True  )] 
    11568------------------------- 
    116 --testSquare :: [Maybe (String, Sum Int, Any)] 
    117 --testSquare = square3 (Just "a") (Just (Sum 1)) (Just (Any True)) 
     69testSquare :: [Maybe (String, Sum Int, Any)] 
     70testSquare = square3 (Just "a") (Just (Sum 1)) (Just (Any True)) 
    11871 
    11972----------------------------------------------------------------------------------------------- 
    12073------------------------- implementation ------------------------------------------------------ 
    12174----------------------------------------------------------------------------------------------- 
    122  
    123 type Counter c = State Int (Int -> c) 
    12475 
    12576-- wraps value to have something meaningfull only on diagonal places in a matrix like 
     
    13081-- State Int a - stores column number 
    13182-- Reader ((->) r) - provides row number from outside  
    132 valueOnDiagonal :: (Applicative a, Monoid m) =>  (f -> a m) -> Counter (f -> a m) 
     83valueOnDiagonal :: (Applicative f, Monoid a) =>  f a -> State Int (Int -> f a) 
    13384valueOnDiagonal val = do 
    13485        col <- get 
     
    13687        return (\row -> if row == col  
    13788                                then val  
    138                                 else (\_ -> pure mempty)) 
     89                                else pure mempty) 
    13990 
    14091-- lifts right argument 2 levels up to become s (r (f a)) where s = State and r = Reader 
    14192-- then applies left arg to right one  
    14293-- it's used to put items to a line in matrix 
    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                  
     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) 
    15398 
    15499-- creates square matrix from given lines 
    155100-- values are on main diagonal 
    156 makeSquare :: Counter x -> [x] 
     101makeSquare :: State Int (Int -> a) -> [a] 
    157102makeSquare line = let   start = 0 
    158103                        (line', size) = runState line start 
    159104                  in    line' <$> [start .. size - 1] 
    160105                   
    161 -- pure level 4 
    162 pure'4 :: (Applicative f, Applicative g, Applicative h, Applicative a) => b -> f (g (h (a b))) 
    163 pure'4 = pure.pure.pure.pure 
    164  
    165  
    166  
    167  
    168  
    169  
    170  
    171  
    172  
    173  
    174  
    175  
    176  
    177  
    178  
    179  
     106-- pure level 3 
     107pure'' :: (Applicative f, Applicative g, Applicative h) => a -> f (g (h a)) 
     108pure'' = pure.pure.pure 
Note: See TracChangeset for help on using the changeset viewer.