source: adblock2privoxy/adblock2privoxy/src/PolicyTree.hs @ e2b555c

Last change on this file since e2b555c was e2b555c, checked in by Alexey Zubritskiy <a.zubritskiy@…>, 4 years ago

Adapted to GHC 7.10, introduced stack build

  • Property mode set to 100644
File size: 4.4 KB
Line 
1module PolicyTree (
2NodePolicy (..),
3DomainTree (..),
4PolicyTree,
5restrictionsTree,
6mergeTrees,
7mergePolicyTrees,
8trimTree,
9mergeAndTrim,
10erasePolicy
11
12,domainTree
13) where
14--import Control.Applicative
15import InputParser hiding (Policy(..))
16import Data.String.Utils (split)
17import Utils
18
19data NodePolicy = None | Block | Unblock deriving (Eq, Show)
20data DomainTree a = Node { _name :: String, _value :: a, _children :: [DomainTree a] }
21type PolicyTree = DomainTree NodePolicy
22
23showTree :: Show a => Int -> DomainTree a -> String
24showTree lvl (Node name value children)
25    = concat $
26        [replicate (lvl * 2) ' ', "\"", name, "\" - ", show value]
27        ++ (('\n':) . showTree (lvl + 1) <$> children)
28
29instance Show a => Show (DomainTree a) where
30    show = showTree 0
31
32restrictionsTree :: NodePolicy -> Restrictions Domain -> Maybe PolicyTree
33restrictionsTree positivePolicy (Restrictions p n) = trimTree positivePolicy <$> mergedTree
34    where
35    negativePolicy = case positivePolicy of
36                        Block -> Unblock
37                        _     -> Block
38    positiveTree = case p of
39                        Nothing -> Just $ Node "" positivePolicy []
40                        Just p' -> concatTrees positivePolicy $ domainTree positivePolicy <$> p'
41    negativeTree = concatTrees negativePolicy $ domainTree negativePolicy <$> n
42    mergedTree = case negativeTree of
43                    Nothing -> positiveTree
44                    Just negativeTree' -> mergePolicyTrees negativePolicy negativeTree' <$> positiveTree
45
46erasePolicy :: NodePolicy -> PolicyTree -> PolicyTree
47erasePolicy policy (Node n p c) = Node n policy' (erasePolicy policy <$> c)
48    where policy'
49            | p == policy   = None
50            | otherwise     = p
51
52domainTree :: NodePolicy -> Domain -> PolicyTree
53domainTree policy domain = makeTree policy $ ("":) $ reverse $ split "." domain
54
55makeTree :: NodePolicy -> [String] -> PolicyTree
56makeTree _ [] = error "No nodes proviced"
57makeTree policy [node] = Node node policy []
58makeTree policy (node:nodes) = Node node None [makeTree policy nodes]
59
60mergeAndTrim :: NodePolicy -> PolicyTree -> PolicyTree -> PolicyTree
61mergeAndTrim trump = trimTree trump .*. mergePolicyTrees trump
62
63concatTrees :: NodePolicy -> [PolicyTree] -> Maybe PolicyTree
64concatTrees _ [] = Nothing
65concatTrees _ [tree] = Just tree
66concatTrees trump (tree:trees) = mergePolicyTrees trump tree <$> concatTrees trump trees
67
68mergePolicyTrees :: NodePolicy -> PolicyTree -> PolicyTree -> PolicyTree
69mergePolicyTrees trump = mergeTrees mergePolicy
70    where
71    mergePolicy policy1 policy2
72            | policy1 == None      = policy2
73            | policy2 == None      = policy1
74            | policy1 == trump     = policy1
75            | otherwise            = policy2
76
77mergeTrees :: (a -> b -> b) -> DomainTree a -> DomainTree b -> DomainTree b
78mergeTrees mergeValue t1@(Node name1 value1 children1) t2@(Node name2 value2 children2)
79        = Node mergeName (mergeValue value1 value2) (mergeChildren children1 children2)
80        where
81        -- names expected to be equal and/or empty
82        mergeName
83            | name1 == ""     = name2
84            | otherwise       = name1
85
86        t1Default = t1{_name = "", _children = []}
87        t2Default = t2{_name = "", _children = []}
88
89        mergeChildren [] [] = []
90        mergeChildren (t1Child:t1Children') [] = mergeTrees mergeValue t1Child   t2Default : mergeChildren t1Children' []
91        mergeChildren [] (t2Child:t2Children') = mergeTrees mergeValue t1Default t2Child   : mergeChildren []          t2Children'
92        mergeChildren t1Children@(t1Child:t1Children') t2Children@(t2Child:t2Children')
93            | _name t1Child == _name t2Child   = mergeTrees mergeValue t1Child   t2Child   : mergeChildren t1Children' t2Children'
94            | _name t1Child >  _name t2Child   = mergeTrees mergeValue t1Child   t2Default : mergeChildren t1Children' t2Children
95            | otherwise                        = mergeTrees mergeValue t1Default t2Child   : mergeChildren t1Children  t2Children'
96
97
98trimTree :: NodePolicy -> PolicyTree -> PolicyTree
99trimTree trump (Node name policy children) = Node name policy childrenFiltered
100    where
101    childrenFiltered = filter (not.redundantChild) childrenTrimmed
102    childrenTrimmed = trimTree trump <$> children
103    redundantChild (Node _ childPolicy childChildren) = samePolicy childPolicy && null childChildren
104    samePolicy childPolicy = childPolicy == policy || (policy == None && childPolicy /= trump)
Note: See TracBrowser for help on using the repository browser.