adblock2privoxy-1.4.0: src/Utils.hs

module Utils (
Struct2 (..),
Struct3 (..),
Struct4 (..),
Struct5 (..),
testSquare,
ZipListM,
getZipListM,
zipListM,
maxList,
minList,
compareList,
appendIf,
pure',
pure'',
(<<$>),
(<<<$>),
(<<*>>),
(<<<*>>>),
($>),
($>>),
($>>>),
(.*.)
) where
import Control.Applicative hiding (many)
import Control.Monad.Writer
import Control.Monad.State

------------------------------------------------------------------------------------------
----------------------------- export -----------------------------------------------------
------------------------------------------------------------------------------------------

-- at least one list should be finite
compareList :: Ord a => [a] -> [a] -> Ordering
compareList = compareList' EQ
    where
        compareList' lx [] [] = lx
        compareList' _ [] _ = LT
        compareList' _ _ [] = GT
        compareList' lx (x:xs) (y:ys) = compareList' (lx <> compare x y) xs ys

maxList :: Ord a => [a] -> [a] -> [a]
maxList a b = if compareList a b == LT then b else a

minList :: Ord a => [a] -> [a] -> [a]
minList a b = if compareList a b == GT then b else a

appendIf :: Bool -> a -> [a] -> [a]
appendIf condition item list
    | condition = item : list
    | otherwise = list

newtype ZipListM a = ZipListM { getZipList' :: ZipList a } deriving (Functor, Applicative)
getZipListM :: ZipListM a -> [a]
getZipListM = getZipList.getZipList'

zipListM :: [a] -> ZipListM a
zipListM = ZipListM . ZipList

instance Monoid a => Monoid (ZipListM a) where
  mempty = pure mempty
  mappend x y = mappend <$> x <*> y

class Struct2 f where
        struct2 :: a1 -> a2 -> f a1 a2
        square2 :: (Applicative g, Monoid a1, Monoid a2) => g a1 -> g a2 -> [g (f a1 a2)]
        square2 a1 a2  = makeSquare (pure'' struct2 <%> a1 <%> a2)


class Struct3 f where
        struct3 :: a1 -> a2 -> a3 -> f a1 a2 a3
        square3 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3) =>
                    g a1 -> g a2 -> g a3 -> [g (f a1 a2 a3)]
        square3 a1 a2 a3  = makeSquare (pure'' struct3 <%> a1 <%> a2 <%> a3)

class Struct4 f where
        struct4 :: a1 -> a2 -> a3 -> a4 -> f a1 a2 a3 a4
        square4 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4) =>
                    g a1 -> g a2 -> g a3 -> g a4 -> [g (f a1 a2 a3 a4)]
        square4 a1 a2 a3 a4  = makeSquare (pure'' struct4 <%> a1 <%> a2 <%> a3 <%> a4)

class Struct5 f where
        struct5 :: a1 -> a2 -> a3 -> a4 -> a5 -> f a1 a2 a3 a4 a5
        square5 :: (Applicative g, Monoid a1, Monoid a2, Monoid a3, Monoid a4, Monoid a5) =>
                    g a1 -> g a2 -> g a3 -> g a4 -> g a5 -> [g (f a1 a2 a3 a4 a5)]
        square5 a1 a2 a3 a4 a5 = makeSquare (pure'' struct5 <%> a1 <%> a2 <%> a3 <%> a4 <%> a5)

instance Struct2 (,)    where struct2 = (,)
instance Struct3 (,,)   where struct3 = (,,)
instance Struct4 (,,,)  where struct4 = (,,,)
instance Struct5 (,,,,) where struct5 = (,,,,)


---------------------------------------------------------------------------------------------
------------------------- usage sample ------------------------------------------------------
---------------------------------------------------------------------------------------------

----- result is --------
-- [Just ( "a",  0 , False ),
--  Just ( "" ,  1,  False ),
--  Just ( "" ,  0 , True  )]
-------------------------
testSquare :: [Maybe (String, Sum Int, Any)]
testSquare = square3 (Just "a") (Just (Sum $ length "")) (Just (Any True))

-----------------------------------------------------------------------------------------------
------------------------- implementation ------------------------------------------------------
-----------------------------------------------------------------------------------------------

-- wraps value to have something meaningfull only on diagonal places in a matrix like
-- [(V,m),
--  (m,V)]
-- where V is for value, m is for mempty
-- involves 2 applicatives/monads :
-- State Int a - stores column number
-- Reader ((->) r) - provides row number from outside
valueOnDiagonal :: (Applicative f, Monoid a) =>  f a -> State Int (Int -> f a)
valueOnDiagonal val = do
        col <- get
        put (col + 1)
        return (\row -> if row == col
                                then val
                                else pure mempty)

-- lifts right argument 2 levels up to become s (r (f a)) where s = State and r = Reader
-- then applies left arg to right one
-- it's used to put items to a line in matrix
(<%>) :: (Applicative f, Monoid a) => State Int (Int -> f (a -> b))
                                       -> f a -- becomes State Int (Int -> f a) after lift with valueOnDiagonal
                                       -> State Int (Int -> f b)
(<%>) a b = a <<<*>>> valueOnDiagonal b

-- creates square matrix from given lines
-- values are on main diagonal
makeSquare :: State Int (Int -> a) -> [a]
makeSquare line = let   start = 0
                        (line', size) = runState line start
                  in    line' <$> [start .. size - 1]

-- pure level 2
pure' :: (Applicative f, Applicative g) => a -> f (g a)
pure' = pure.pure

-- pure level 3
pure'' :: (Applicative f, Applicative g, Applicative h) => a -> f (g (h a))
pure'' = pure.pure.pure

infixl 4 .*., <<$>, <<<$>, $>, $>>, $>>>, <<*>>, <<<*>>>

(.*.) :: (c -> d) ->
         (a -> b -> c) ->
          a -> b -> d
(.*.) = (.).(.)

(<<$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
(<<$>) = fmap.fmap

(<<<$>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))
(<<<$>) = fmap.fmap.fmap

($>) :: (Applicative f) => f (a -> b) -> a -> f b
($>) a b = a <*> pure b

($>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> a -> f (g b)
($>>) a b = a <<*>> pure' b

($>>>) :: (Applicative f, Applicative g, Applicative h) => f (g (h (a -> b))) -> a -> f (g (h b))
($>>>) a b = a <<<*>>> pure'' b

(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b)
(<<*>>) = liftA2 (<*>)

(<<<*>>>) :: (Applicative f, Applicative g, Applicative h) => f (g (h (a -> b))) ->  f (g (h a)) -> f (g (h b))
(<<<*>>>) = liftA2 (<<*>>)