/tmp/Override.hs

tmpOverride.hs

module Override where

import Control.Arrow ((&&&), (|||))

newtype Selector a = Selector { unSelector :: a -> Bool }

class Or a where
    or :: a -> a -> a

class And a where
    and :: a -> a -> a

instance Or (Selector a) where
    (Selector a) `or` (Selector b) = Selector ((a ||| b) . Right)

instance And (Selector a) where
    (Selector a) `and` (Selector b) = Selector (uncurry (||) . (a &&& b))

newtype Mutator a = Mutator { unMutator :: a -> a }

instance Semigroup (Mutator a) where
    (Mutator a) <> (Mutator b) = Mutator (b . a)

data Override a = Override { selector :: Selector a, mutator :: Mutator a}

any :: Selector a
any = Selector $ const True

overrides :: [Override Int]
overrides = [ Override { selector = Override.any
                       , mutator = Mutator id
                       }
            , Override { selector = Selector even
                       , mutator = Mutator (+1)
                       }
            , Override { selector = Selector ((== 0) . (`div` 3)) `Override.and` Selector ((== 0) . (`div` 5))
                       , mutator = Mutator (+1000)
                       }
            ]

override :: Override a -> a -> a
override Override { selector = Selector s, mutator = Mutator m } x | s x = m x
                                                                   | otherwise = x

main :: IO ()
main = do
    print $ foldr override 0 overrides
    print $ foldr override 2 overrides
    print $ foldr override 15 overrides