{- 
    Copyright 2013-2015 Mario Blazevic

    License: BSD3 (see BSD3-LICENSE.txt file)
-}

-- | This module defines monoid transformers that add support for markup over the base monoid type
-- 

{-# LANGUAGE Haskell2010 #-}

module Data.Monoid.Instances.Markup (
   TagSoup, soupLeaf, soupTag
   )
where

import Control.Applicative (Applicative(..))
import qualified Data.Foldable as Foldable
import Data.Functor -- ((<$>))
import qualified Data.List as List
import Data.Sequence (Seq, ViewL((:<)), ViewR((:>)), (<|), (|>))
import qualified Data.Sequence as Seq
import Data.Tree (Forest)
import qualified Data.Tree as Tree
import Data.String (IsString(..))
import Data.Monoid -- (Monoid(..))
import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..),
                                 LeftCancellativeMonoid, RightCancellativeMonoid,
                                 LeftGCDMonoid(..), RightGCDMonoid(..))
import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)
import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid)
import Data.Monoid.Textual (TextualMonoid(..))
import qualified Data.Monoid.Factorial as Factorial
import qualified Data.Monoid.Textual as Textual

import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap,
                       length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt)

newtype TagSoup a b = TagSoup (Seq (Either a b)) deriving (Eq)

instance Monoid b => Monoid (TagSoup a b) where
   mempty = TagSoup mempty
   TagSoup s1 `mappend` TagSoup s2
      | s1' :> Right t1 <- Seq.viewr s1, Right t2 :< s2' <- Seq.viewl s2 = TagSoup ((s1' |> Right (t1 <> t2)) <> s2')
      | otherwise = TagSoup (s1 <> s2)

instance (Eq a, Eq b, MonoidNull b, LeftReductiveMonoid b) => LeftReductiveMonoid (TagSoup a b) where
   stripPrefix (TagSoup s1) (TagSoup s2)
      | s1' :> Right t1 <- Seq.viewr s1 =
           case stripPrefix s1' s2
           of Just s2' | Right t2 :< s2'' <- Seq.viewl s2', Just t2' <- stripPrefix t1 t2 -> Just (TagSoup $ consL Right t2' s2'')
              _ -> Nothing
      | otherwise = TagSoup <$> stripPrefix s1 s2

instance (Eq a, Eq b, MonoidNull b, RightReductiveMonoid b) => RightReductiveMonoid (TagSoup a b) where
   stripSuffix (TagSoup s1) (TagSoup s2)
      | Right t1 :< s1' <- Seq.viewl s1 =
           case stripSuffix s1' s2
           of Just s2' | s2'' :> Right t2 <- Seq.viewr s2', Just t2' <- stripSuffix t1 t2 -> Just (TagSoup $ consR Right s2'' t2')
              _ -> Nothing
      | otherwise = TagSoup <$> stripSuffix s1 s2

instance (Eq a, Eq b, MonoidNull b, LeftCancellativeMonoid b) => LeftCancellativeMonoid (TagSoup a b)
instance (Eq a, Eq b, MonoidNull b, RightCancellativeMonoid b) => RightCancellativeMonoid (TagSoup a b)

instance (Eq a, Eq b, MonoidNull b, LeftGCDMonoid b) => LeftGCDMonoid (TagSoup a b) where
   stripCommonPrefix (TagSoup s1) (TagSoup s2)
      | Right t1 :< s1'' <- Seq.viewl s1', Right t2 :< s2'' <- Seq.viewl s2', (tp, t1', t2') <- stripCommonPrefix t1 t2 =
           (TagSoup $ consR Right prefix tp, TagSoup $ consL Right t1' s1'', TagSoup $ consL Right t2' s2'')
      | otherwise = (TagSoup prefix, TagSoup s1', TagSoup s2')
     where (prefix, s1', s2') = stripCommonPrefix s1 s2

instance (Eq a, Eq b, MonoidNull b, RightGCDMonoid b) => RightGCDMonoid (TagSoup a b) where
   stripCommonSuffix (TagSoup s1) (TagSoup s2)
      | s1'' :> Right t1 <- Seq.viewr s1', s2'' :> Right t2 <- Seq.viewr s2', (t1', t2', ts) <- stripCommonSuffix t1 t2 =
           (TagSoup $ consR Right s1'' t1', TagSoup $ consR Right s2'' t2', TagSoup $ consR Right suffix ts)
      | otherwise = (TagSoup s1', TagSoup s2', TagSoup suffix)
     where (s1', s2', suffix) = stripCommonSuffix s1 s2

instance Monoid b => MonoidNull (TagSoup a b) where
   null (TagSoup s) = null s

instance Monoid b => PositiveMonoid (TagSoup a b)

instance FactorialMonoid b => FactorialMonoid (TagSoup a b) where
   factors (TagSoup s) = List.concatMap (either (\t-> [soupTag t]) (fmap nonNullSoupLeaf . factors)) (Foldable.toList s)
   splitPrimePrefix (TagSoup s) =
      case Seq.viewl s
      of Seq.EmptyL -> Nothing
         p@Left{} :< s' -> Just (TagSoup $ Seq.singleton p, TagSoup s')
         Right t :< s' | ~(Just (p, t')) <- splitPrimePrefix t -> Just (nonNullSoupLeaf p, TagSoup $ consL Right t' s')
   primePrefix ts@(TagSoup s) =
      case Seq.viewl s
      of Seq.EmptyL -> ts
         p@Left{} :< _ -> TagSoup (Seq.singleton p)
         Right t :< _ -> nonNullSoupLeaf (primePrefix t)
   splitPrimeSuffix (TagSoup s) =
      case Seq.viewr s
      of Seq.EmptyR -> Nothing
         s' :> p@Left{} -> Just (TagSoup s', TagSoup $ Seq.singleton p)
         s' :> Right t | ~(Just (t', p)) <- splitPrimeSuffix t -> Just (TagSoup $ consR Right s' t', nonNullSoupLeaf p)
   primeSuffix ts@(TagSoup s) =
      case Seq.viewr s
      of Seq.EmptyR -> ts
         _ :> p@Left{} -> TagSoup (Seq.singleton p)
         _ :> Right t -> nonNullSoupLeaf (primeSuffix t)
   foldl f a0 (TagSoup s) = Foldable.foldl g a0 s
      where g a p@Left{} = f a (TagSoup $ Seq.singleton p)
            g a (Right t) = Factorial.foldl (\a'-> f a' . nonNullSoupLeaf) a t
   foldl' f a0 (TagSoup s) = Foldable.foldl' g a0 s
      where g a p@Left{} = f a (TagSoup $ Seq.singleton p)
            g a (Right t) = Factorial.foldl' (\a'-> f a' . nonNullSoupLeaf) a t
   foldr f a0 (TagSoup s) = Foldable.foldr g a0 s
      where g p@Left{} a = f (TagSoup $ Seq.singleton p) a
            g (Right t) a = Factorial.foldr (f . nonNullSoupLeaf) a t
   length (TagSoup s) = getSum $ Foldable.foldMap (either (const $ Sum 1) (Sum . length)) s
   foldMap f (TagSoup s) = Foldable.foldMap (either (f . soupTag) (Factorial.foldMap $ f . nonNullSoupLeaf)) s
   span p (TagSoup x) =
      case Seq.viewl x
      of Seq.EmptyL -> (mempty, mempty)
         xp@Left{} :< xs | p (TagSoup $ Seq.singleton xp) -> (TagSoup (xp <| xsp), xss)
                         | otherwise -> (mempty, TagSoup x)
            where (TagSoup xsp, xss) = Factorial.span p (TagSoup xs)
         Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss)
                        | null xpp -> (mempty, TagSoup x)
                        | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs))
            where (xpp, xps) = Factorial.span (p . nonNullSoupLeaf) xp
                  (TagSoup xsp, xss) = Factorial.span p (TagSoup xs)
   spanMaybe s0 f (TagSoup x) =
      case Seq.viewl x
      of Seq.EmptyL -> (mempty, mempty, s0)
         xp@Left{} :< xs -> case f s0 (TagSoup $ Seq.singleton xp)
                            of Just s' -> let (TagSoup xsp, xss, s'') = Factorial.spanMaybe s' f (TagSoup xs)
                                          in (TagSoup (xp <| xsp), xss, s'')
                               Nothing -> (mempty, TagSoup x, s0)
         Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')
                        | null xpp -> (mempty, TagSoup x, s')
                        | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')
            where (xpp, xps, s') = Factorial.spanMaybe s0 (\s-> f s . nonNullSoupLeaf) xp
                  (TagSoup xsp, xss, s'') = Factorial.spanMaybe s' f (TagSoup xs)
   spanMaybe' s0 f (TagSoup x) =
      seq s0 $
      case Seq.viewl x
      of Seq.EmptyL -> (mempty, mempty, s0)
         xp@Left{} :< xs -> case f s0 (TagSoup $ Seq.singleton xp)
                            of Just s' -> let (TagSoup xsp, xss, s'') = Factorial.spanMaybe' s' f (TagSoup xs)
                                          in (TagSoup (xp <| xsp), xss, s'')
                               Nothing -> (mempty, TagSoup x, s0)
         Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')
                        | null xpp -> (mempty, TagSoup x, s')
                        | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')
            where (xpp, xps, s') = Factorial.spanMaybe' s0 (\s-> f s . nonNullSoupLeaf) xp
                  (TagSoup xsp, xss, s'') = Factorial.spanMaybe' s' f (TagSoup xs)
   split p (TagSoup x) = Foldable.foldr splitNext [mempty] x
      where splitNext t@Left{} ~l@(xp:xs)
               | p (TagSoup $ Seq.singleton t) = mempty:l
               | otherwise = (TagSoup (Seq.singleton t) <> xp):xs
            splitNext (Right t) ~(xp:xs) =
               let ts = soupLeaf <$> Factorial.split (p . nonNullSoupLeaf) t
               in if null xp
                  then ts ++ xs
                  else init ts ++ (last ts <> xp):xs
   splitAt 0 s = (mempty, s)
   splitAt n (TagSoup x) =
      case Seq.viewl x
      of Seq.EmptyL -> (mempty, mempty)
         xp@Left{} :< xs -> (TagSoup (xp <| xsp), xss)
           where (TagSoup xsp, xss) = splitAt (n - 1) (TagSoup xs)
         Right xp :< xs | k < n -> (TagSoup (Right xp <| xsp), xss)
                        | otherwise -> (nonNullSoupLeaf xpp, TagSoup $ consL Right xps xs)
            where k = length xp
                  (TagSoup xsp, xss) = splitAt (n - k) (TagSoup xs)
                  (xpp, xps) = splitAt n xp
   reverse (TagSoup x) = TagSoup (either Left (Right . reverse) <$> reverse x)

instance StableFactorialMonoid b => StableFactorialMonoid (TagSoup a b)

instance (IsString b, MonoidNull b) => IsString (TagSoup a b) where
   fromString s = soupLeaf (fromString s)

instance (Eq a, Eq b, TextualMonoid b) => TextualMonoid (TagSoup a b) where
   splitCharacterPrefix (TagSoup s) =
      case Seq.viewl s
      of Right t :< s' | Just (c, t') <- splitCharacterPrefix t -> Just (c, TagSoup $ consL Right t' s')
         _ -> Nothing
   characterPrefix (TagSoup s) =
      case Seq.viewl s
      of Right t :< _ -> characterPrefix t
         _ -> Nothing
   fromText = soupLeaf . fromText
   singleton = nonNullSoupLeaf . singleton
   map f (TagSoup x) = TagSoup (fmap (either Left $ Right . map f) x)
   any p (TagSoup x) = Foldable.any (either (const False) $ any p) x
   all p (TagSoup x) = Foldable.all (either (const False) $ all p) x
   foldl ft fc a0 (TagSoup x) = Foldable.foldl g a0 x
      where g a (Right t) = Textual.foldl (\a1-> ft a1 . nonNullSoupLeaf) fc a t
            g a t@Left{} = ft a (TagSoup $ Seq.singleton t)
   foldl' ft fc a0 (TagSoup x) = Foldable.foldl' g a0 x
      where g a t@Left{} = a `seq` ft a (TagSoup $ Seq.singleton t)
            g a (Right t) = Textual.foldl' (\a1-> ft a1 . nonNullSoupLeaf) fc a t
   foldr ft fc a0 (TagSoup x) = Foldable.foldr g a0 x
      where g t@Left{} a = ft (TagSoup $ Seq.singleton t) a
            g (Right t) a = Textual.foldr (ft . nonNullSoupLeaf) fc a t
   toString ft (TagSoup x) = List.concatMap (either (ft . soupTag) (toString $ ft . nonNullSoupLeaf)) (Foldable.toList x)
   span pt pc (TagSoup x) =
      case Seq.viewl x
      of Seq.EmptyL -> (mempty, mempty)
         xp@Left{} :< xs | pt (TagSoup $ Seq.singleton xp) -> (TagSoup (xp <| xsp), xss)
                         | otherwise -> (mempty, TagSoup x)
            where (TagSoup xsp, xss) = Textual.span pt pc (TagSoup xs)
         Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss)
                        | null xpp -> (mempty, TagSoup x)
                        | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs))
            where (xpp, xps) = Textual.span (pt . nonNullSoupLeaf) pc xp
                  (TagSoup xsp, xss) = Textual.span pt pc (TagSoup xs)
   span_ bt pc (TagSoup x) =
      case Seq.viewl x
      of Seq.EmptyL -> (mempty, mempty)
         xp@Left{} :< xs -> if bt then (TagSoup (xp <| xsp), xss) else (mempty, TagSoup x)
            where (TagSoup xsp, xss) = Textual.span_ bt pc (TagSoup xs)
         Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss)
                        | null xpp -> (mempty, TagSoup x)
                        | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs))
            where (xpp, xps) = Textual.span_ bt pc xp
                  (TagSoup xsp, xss) = Textual.span_ bt pc (TagSoup xs)
   break pt pc = Textual.span (not . pt) (not . pc)
   takeWhile_ bt pc = fst . span_ bt pc
   dropWhile_ bt pc = snd . span_ bt pc
   break_ bt pc = span_ (not bt) (not . pc)
   spanMaybe s0 ft fc (TagSoup x) =
      case Seq.viewl x
      of Seq.EmptyL -> (mempty, mempty, s0)
         xp@Left{} :< xs | Just s' <- ft s0 (TagSoup $ Seq.singleton xp),
                           (TagSoup xsp, xss, s'') <- Textual.spanMaybe s' ft fc (TagSoup xs) -> (TagSoup (xp <| xsp), xss, s'')
                         | otherwise -> (mempty, TagSoup x, s0)
         Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')
                        | null xpp -> (mempty, TagSoup x, s')
                        | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')
            where (xpp, xps, s') = Textual.spanMaybe s0 (\s-> ft s . nonNullSoupLeaf) fc xp
                  (TagSoup xsp, xss, s'') = Textual.spanMaybe s' ft fc (TagSoup xs)
   spanMaybe' s0 ft fc (TagSoup x) =
      seq s0 $
      case Seq.viewl x
      of Seq.EmptyL -> (mempty, mempty, s0)
         xp@Left{} :< xs | Just s' <- ft s0 (TagSoup $ Seq.singleton xp),
                           (TagSoup xsp, xss, s'') <- Textual.spanMaybe' s' ft fc (TagSoup xs) -> (TagSoup (xp <| xsp), xss, s'')
                         | otherwise -> (mempty, TagSoup x, s0)
         Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')
                        | null xpp -> (mempty, TagSoup x, s')
                        | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')
            where (xpp, xps, s') = Textual.spanMaybe' s0 (\s-> ft s . nonNullSoupLeaf) fc xp
                  (TagSoup xsp, xss, s'') = Textual.spanMaybe' s' ft fc (TagSoup xs)
   spanMaybe_ s0 fc (TagSoup x) =
      case Seq.viewl x
      of Seq.EmptyL -> (mempty, mempty, s0)
         xp@Left{} :< xs | (TagSoup xsp, xss, s') <- Textual.spanMaybe_ s0 fc (TagSoup xs) -> (TagSoup (xp <| xsp), xss, s')
                         | otherwise -> (mempty, TagSoup x, s0)
         Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')
                        | null xpp -> (mempty, TagSoup x, s')
                        | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')
            where (xpp, xps, s') = Textual.spanMaybe_ s0 fc xp
                  (TagSoup xsp, xss, s'') = Textual.spanMaybe_ s' fc (TagSoup xs)
   spanMaybe_' s0 fc (TagSoup x) =
      seq s0 $
      case Seq.viewl x
      of Seq.EmptyL -> (mempty, mempty, s0)
         xp@Left{} :< xs | (TagSoup xsp, xss, s') <- Textual.spanMaybe_' s0 fc (TagSoup xs) -> (TagSoup (xp <| xsp), xss, s')
                         | otherwise -> (mempty, TagSoup x, s0)
         Right xp :< xs | null xps -> (TagSoup (Right xp <| xsp), xss, s'')
                        | null xpp -> (mempty, TagSoup x, s')
                        | otherwise -> (nonNullSoupLeaf xpp, TagSoup (Right xps <| xs), s')
            where (xpp, xps, s') = Textual.spanMaybe_' s0 fc xp
                  (TagSoup xsp, xss, s'') = Textual.spanMaybe_' s' fc (TagSoup xs)
   split p (TagSoup x) = Foldable.foldr splitNext [mempty] x
      where splitNext tag@Left{} ~(xp:xs) = (TagSoup (Seq.singleton tag) <> xp):xs
            splitNext (Right t) ~(xp:xs) =
               let ts = soupLeaf <$> Textual.split p t
               in if null xp
                  then ts ++ xs
                  else init ts ++ (last ts <> xp):xs
   find p (TagSoup x) = getFirst $ Foldable.foldMap (First . either (const Nothing) (find p)) x
   elem c (TagSoup x) = Foldable.any (either (const False) $ Textual.elem c) x

soupLeaf :: MonoidNull b => b -> TagSoup a b
soupLeaf l | null l = TagSoup Seq.empty
           | otherwise = TagSoup (Seq.singleton $ Right l)

soupTag :: a -> TagSoup a b
soupTag = TagSoup . Seq.singleton . Left

-- Helper functions

nonNullSoupLeaf :: b -> TagSoup a b
nonNullSoupLeaf = TagSoup . Seq.singleton . Right

consL :: MonoidNull a => (a -> b) -> a -> Seq b -> Seq b
consL f t s | null t = s
            | otherwise = f t <| s

consR :: MonoidNull a => (a -> b) -> Seq b -> a -> Seq b
consR f s t | null t = s
            | otherwise = s |> f t