    {-# LANGUAGE TypeSynonymInstances, FlexibleInstances,
        PatternGuards #-}

    module Text.Pandoc.Readers.Docx.Reducible ( concatReduce
                                              , (<+>)
                                              )
           where

    import Text.Pandoc.Builder
    import Data.List
    import Data.Sequence (ViewR(..), ViewL(..), viewl, viewr)
    import qualified Data.Sequence as Seq (null)

    data Modifier a = Modifier (a -> a)
                    | AttrModifier (Attr -> a -> a) Attr
                    | NullModifier

    class (Eq a) => Modifiable a where
      modifier :: a -> Modifier a
      innards :: a -> a
      getL    :: a -> (a, a)
      getR    :: a -> (a, a)
      spaceOut :: a -> (a, a, a)

    spaceOutL :: (Monoid a, Modifiable a) => a -> (a, a)
    spaceOutL ms = (l, stack fs (m' <> r))
      where (l, m, r) = spaceOut ms
            (fs, m')  = unstack m

    spaceOutR :: (Monoid a, Modifiable a) => a -> (a, a)
    spaceOutR ms = (stack fs (l <> m'), r)
      where (l, m, r) = spaceOut ms
            (fs, m')  = unstack m

    instance (Monoid a, Show a) => Show (Modifier a) where
      show (Modifier f) = show $ f mempty
      show (AttrModifier f attr) = show $ f attr mempty
      show (NullModifier) = "NullModifier"

    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

    instance Modifiable Inlines where
      modifier 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
          (Span attr _)   -> AttrModifier spanWith attr
          _               -> NullModifier
        _ -> NullModifier

      innards 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
          (Span _ lst)      -> fromList lst
          _        -> ils
        _          -> ils

      getL ils = case viewl $ unMany ils of
        (s :< sq) -> (singleton s, Many sq)
        _          -> (mempty, ils)

      getR ils = case viewr $ unMany ils of
        (sq :> s) -> (Many sq, singleton s)
        _          -> (ils, mempty)

      spaceOut ils =
        let (fs, ils') = unstack ils
            contents = unMany ils'
            left  = case viewl contents of
              (Space :< _) -> space
              _            -> mempty
            right = case viewr contents of
              (_ :> Space) -> space
              _            -> mempty in
        (left, (stack fs $ trimInlines .Many $ contents), right)

    instance Modifiable Blocks where
      modifier blks = case viewl (unMany blks) of
        (x :< xs) | Seq.null xs -> case x of
          (BlockQuote _) -> Modifier blockQuote
          -- (Div attr _)   -> AttrModifier divWith attr
          _               -> NullModifier
        _ -> NullModifier

      innards blks = case viewl (unMany blks) of
        (x :< xs) | Seq.null xs -> case x of
          (BlockQuote lst) -> fromList lst
          -- (Div attr lst)   -> fromList lst
          _        -> blks
        _          -> blks

      spaceOut blks = (mempty, blks, mempty)

      getL ils = case viewl $ unMany ils of
        (s :< sq) -> (singleton s, Many sq)
        _          -> (mempty, ils)

      getR ils = case viewr $ unMany ils of
        (sq :> s) -> (Many sq, singleton s)
        _          -> (ils, mempty)

    unstack :: (Modifiable a) => a -> ([Modifier a], a)
    unstack ms = case modifier ms of
      NullModifier -> ([], ms)
      _            -> (f : fs, ms') where
        f = modifier ms
        (fs, ms') = unstack $ innards ms

    stack :: (Monoid a, Modifiable a) => [Modifier a] -> a -> a
    stack [] ms = ms
    stack (NullModifier : fs) ms = stack fs ms
    stack ((Modifier f) : fs) ms =
      if isEmpty ms
      then stack fs ms
      else f $ stack fs ms
    stack ((AttrModifier f attr) : fs) ms = f attr $ stack fs ms

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

    combine :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
    combine x y =
      let (xs', x') = getR x
          (y', ys') = getL y
      in
       xs' <> (combineSingleton x' y') <> ys'

    isAttrModifier :: Modifier a -> Bool
    isAttrModifier (AttrModifier _ _) = True
    isAttrModifier _                  = False

    combineSingleton :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
    combineSingleton x y =
      let (xfs, xs) = unstack x
          (yfs, ys) = unstack 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 ->
                stack (x_rem_attr ++ y_rem_attr) mempty
              | isEmpty xs ->
                let (sp, y') = spaceOutL y in
                (stack x_rem_attr mempty) <> sp <> y'
              | isEmpty ys ->
                let (x', sp) = spaceOutR x in
                x' <> sp <> (stack y_rem_attr mempty)
              | otherwise ->
                  let (x', xsp) = spaceOutR x
                      (ysp, y') = spaceOutL y
                  in
                   x' <> xsp <> ysp <> y'
         False -> stack shared $
                  combine
                  (stack x_remaining xs)
                  (stack y_remaining ys)

    (<+>) :: (Monoid a, Modifiable a, Eq a) => a -> a -> a
    x <+> y = combine x y

    concatReduce :: (Monoid a, Modifiable a) => [a] -> a
    concatReduce xs = foldl combine mempty xs