adblock2privoxy-3.0.0: src/Utils.hs

{-# LANGUAGE CPP #-}

module Utils
  ( Struct2 (..),
    Struct3 (..),
    Struct4 (..),
    Struct5 (..),
    testSquare,
    ZipListM,
    getZipListM,
    zipListM,
    maxList,
    minList,
    compareList,
    appendIf,
    replace,
    split,
    startswith,
    mergeBalanced,
    pure',
    pure'',
    (<<$>),
    (<<<$>),
    (<<*>>),
    (<<<*>>>),
    ($>),
    ($>>),
    ($>>>),
    (.*.),
  )
where

import Control.Applicative hiding (many)
import Control.Monad.State
import Data.List (isPrefixOf)
import Data.List.Extra (replace, splitOn)
import Data.Monoid

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

-- export @Data.List.isPrefixOf@ under the original name
startswith :: (Eq a) => [a] -> [a] -> Bool
startswith = isPrefixOf

-- export @Data.List.Extra.splitOn@ under the original name
split :: (Eq a) => [a] -> [a] -> [[a]]
split = splitOn

-- 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

-- Combine values using divide-and-conquer rather than linear folds
mergeBalanced :: (a -> a -> a) -> [a] -> a
mergeBalanced _ [x] = x
mergeBalanced f xs = mergeBalanced f (pairUp xs)
  where
    pairUp (a : b : rest) = f a b : pairUp rest
    pairUp rest = rest

newtype ZipListM a = ZipListM {getZipList' :: ZipList a} deriving (Functor, Applicative)

getZipListM :: ZipListM a -> [a]
getZipListM = getZipList . getZipList'

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

#if (MIN_VERSION_base(4,11,0))
instance Semigroup a => Semigroup (ZipListM a) where
  x <> y = (<>) <$> x <*> y
#endif

instance (Monoid a) => Monoid (ZipListM a) where
  mempty = pure mempty
#if (MIN_VERSION_base(4,11,0))
  mappend = (<>)
#else
  mappend x y = mappend <$> x <*> y
#endif

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 (<<*>>)