{-# LANGUAGE FlexibleInstances    #-}

{-# LANGUAGE PatternGuards        #-}

{-# LANGUAGE TypeSynonymInstances #-}

module Text.Pandoc.Readers.Docx.Combine ( smushInlines

                                        , smushBlocks

                                        )

       where

import Data.List

import Data.Sequence (ViewL (..), ViewR (..), viewl, viewr, (><), (|>))

import qualified Data.Sequence as Seq (null)

import Text.Pandoc.Builder

data Modifier a = Modifier (a -> a)

                | AttrModifier (Attr -> a -> a) Attr

                | NullModifier

spaceOutInlinesL :: Inlines -> (Inlines, Inlines)

spaceOutInlinesL ms = (l, stackInlines fs (m' <> r))

  where (l, m, r) = spaceOutInlines ms

        (fs, m')  = unstackInlines m

spaceOutInlinesR :: Inlines -> (Inlines, Inlines)

spaceOutInlinesR ms = (stackInlines fs (l <> m'), r)

  where (l, m, r) = spaceOutInlines ms

        (fs, m')  = unstackInlines m

spaceOutInlines :: Inlines -> (Inlines, Inlines, Inlines)

spaceOutInlines ils =

  let (fs, ils') = unstackInlines ils

      contents = unMany ils'

      left  = case viewl contents of

        (Space :< _) -> space

        _            -> mempty

      right = case viewr contents of

        (_ :> Space) -> space

        _            -> mempty in

  (left, stackInlines fs $ trimInlines . Many $ contents, right)

stackInlines :: [Modifier Inlines] -> Inlines -> Inlines

stackInlines [] ms = ms

stackInlines (NullModifier : fs) ms = stackInlines fs ms

stackInlines (Modifier f : fs) ms =

  if isEmpty ms

  then stackInlines fs ms

  else f $ stackInlines fs ms

stackInlines (AttrModifier f attr : fs) ms = f attr $ stackInlines fs ms

unstackInlines :: Inlines -> ([Modifier Inlines], Inlines)

unstackInlines ms = case ilModifier ms of

  NullModifier -> ([], ms)

  _            -> (f : fs, ms') where

    f = ilModifier ms

    (fs, ms') = unstackInlines $ ilInnards ms

ilModifier :: Inlines -> Modifier Inlines

ilModifier ils = case viewl (unMany ils) of

  (x :< xs) | Seq.null xs -> case x of

    (Emph _)          -> Modifier emph

    (Strong _)        -> Modifier strong

    (SmallCaps _)     -> Modifier smallcaps

    (Strikeout _)     -> Modifier strikeout

    (Superscript _)   -> Modifier superscript

    (Subscript _)     -> Modifier subscript

    (Link attr _ tgt) -> Modifier $ linkWith attr (fst tgt) (snd tgt)

    (Span attr _)     -> AttrModifier spanWith attr

    _                 -> NullModifier

  _ -> NullModifier

ilInnards :: Inlines -> Inlines

ilInnards ils = case viewl (unMany ils) of

  (x :< xs) | Seq.null xs -> case x of

    (Emph lst)        -> fromList lst

    (Strong lst)      -> fromList lst

    (SmallCaps lst)   -> fromList lst

    (Strikeout lst)   -> fromList lst

    (Superscript lst) -> fromList lst

    (Subscript lst)   -> fromList lst

    (Link _ lst _)    -> fromList lst

    (Span _ lst)      -> fromList lst

    _                 -> ils

  _          -> ils

inlinesL :: Inlines -> (Inlines, Inlines)

inlinesL ils = case viewl $ unMany ils of

  (s :< sq) -> (singleton s, Many sq)

  _         -> (mempty, ils)

inlinesR :: Inlines -> (Inlines, Inlines)

inlinesR ils = case viewr $ unMany ils of

  (sq :> s) -> (Many sq, singleton s)

  _         -> (ils, mempty)

combineInlines :: Inlines -> Inlines -> Inlines

combineInlines x y =

  let (xs', x') = inlinesR x

      (y', ys') = inlinesL y

  in

   xs' <> combineSingletonInlines x' y' <> ys'

combineSingletonInlines :: Inlines -> Inlines -> Inlines

combineSingletonInlines x y =

  let (xfs, xs) = unstackInlines x

      (yfs, ys) = unstackInlines y

      shared = xfs `intersect` yfs

      x_remaining = xfs \\ shared

      y_remaining = yfs \\ shared

      x_rem_attr = filter isAttrModifier x_remaining

      y_rem_attr = filter isAttrModifier y_remaining

  in

   case null shared of

     True | isEmpty xs && isEmpty ys ->

            stackInlines (x_rem_attr ++ y_rem_attr) mempty

          | isEmpty xs ->

            let (sp, y') = spaceOutInlinesL y in

            stackInlines x_rem_attr mempty <> sp <> y'

          | isEmpty ys ->

            let (x', sp) = spaceOutInlinesR x in

            x' <> sp <> stackInlines y_rem_attr mempty

          | otherwise ->

              let (x', xsp) = spaceOutInlinesR x

                  (ysp, y') = spaceOutInlinesL y

              in

               x' <> xsp <> ysp <> y'

     False -> stackInlines shared $

              combineInlines

              (stackInlines x_remaining xs)

              (stackInlines y_remaining ys)

combineBlocks :: Blocks -> Blocks -> Blocks

combineBlocks bs cs

  | bs' :> BlockQuote bs'' <- viewr (unMany bs)

  , BlockQuote cs'' :< cs' <- viewl (unMany cs) =

      Many $ (bs' |> BlockQuote (bs'' <> cs'')) >< cs'

combineBlocks bs cs = bs <> cs

instance (Monoid a, Eq a) => Eq (Modifier a) where

  (Modifier f) == (Modifier g) = f mempty == g mempty

  (AttrModifier f attr) == (AttrModifier g attr') = f attr mempty == g attr' mempty

  NullModifier == NullModifier = True

  _ == _ = False

isEmpty :: (Monoid a, Eq a) => a -> Bool

isEmpty x = x == mempty

isAttrModifier :: Modifier a -> Bool

isAttrModifier (AttrModifier _ _) = True

isAttrModifier _                  = False

smushInlines :: [Inlines] -> Inlines

smushInlines xs = foldl combineInlines mempty xs

smushBlocks :: [Blocks] -> Blocks

smushBlocks xs = foldl combineBlocks mempty xs