content: {-# LANGUAGE CPP #-}
  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.State
  import Data.Monoid
  
  ------------------------------------------------------------------------------------------
  ----------------------------- 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
  
  #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 (<<*>>)
  