{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.XML.Tree.Data
 ( module Symantic.XML.Tree.Data
 , TS.unTree
 , TS.subTrees
 ) where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), id)
import Data.Functor ((<$>))
import Data.Functor.Identity (Identity(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Prelude (error)
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict as TS

import Symantic.Base
import Symantic.XML.Language
import Symantic.XML.RelaxNG.Language
import Symantic.XML.Write
import Symantic.XML.Tree.Source

-- * Type 'Tree'
type Tree src = TS.Tree (src (Node (src EscapedAttr)))

-- ** Type 'Trees'
type Trees src = TS.Trees (src (Node (src EscapedAttr)))

pattern Tree0 :: a -> TS.Tree a
pattern Tree0 a <- TS.Tree a (null -> True)
  where Tree0 a = TS.Tree a Seq.empty

-- ** Type 'Node'
data Node attr
   = NodeElem    QName (HM.HashMap QName attr) -- ^ Node.
   | NodePI      PName TL.Text -- ^ Leaf (except for @<?xml?>@ which has 'NodePI' children.
   | NodeText    EscapedText   -- ^ Leaf.
   | NodeComment TL.Text       -- ^ Leaf.
   | NodeCDATA   TL.Text       -- ^ Leaf.
   deriving (Eq, Ord, Show)

-- * Type 'TreeData'
newtype TreeData params k
 =      TreeData
 {    unTreeData :: ( HM.HashMap QName (Identity EscapedAttr) ->
                      TL.Text ->
                      Trees Identity -> k
                    ) -> params }

tree :: TreeData callers (Trees Identity) -> callers
tree (TreeData callers) = callers (\_as _txt ts -> ts)

type SourcedTree  src = Tree  (Sourced src)
type SourcedTrees src = Trees (Sourced src)
type FileSourcedTree  = SourcedTree  (FileSource Offset)
type FileSourcedTrees = SourcedTrees (FileSource Offset)

-- | Unify two 'Trees', merging border 'NodeText's if any.
union ::
 Semigroup (Sourced src EscapedText) =>
 SourcedTrees src -> SourcedTrees src -> SourcedTrees src
union x y =
  case (Seq.viewr x, Seq.viewl y) of
   (xs Seq.:> x0, y0 Seq.:< ys) ->
    case (x0,y0) of
     (  Tree0 (Sourced sx (NodeText tx))
      , Tree0 (Sourced sy (NodeText ty)) ) ->
      xs `union`
      Seq.singleton (Tree0 $ (NodeText <$>) $
        Sourced sx tx <> Sourced sy ty) `union`
      ys
     _ -> x <> y
   (Seq.EmptyR, _) -> y
   (_, Seq.EmptyL) -> x

unions ::
 Semigroup (Sourced src EscapedText) =>
 Foldable f => f (SourcedTrees src) -> SourcedTrees src
unions = foldl' union mempty

instance Emptyable TreeData where
  empty = TreeData (\k -> k mempty mempty mempty)
instance Unitable TreeData where
  unit = TreeData (\k () -> k mempty mempty mempty)
instance Voidable TreeData where
  void a (TreeData x) = TreeData (`x` a)
instance Dimapable TreeData where
  dimap _a2b b2a (TreeData x) = TreeData $ \k b ->
    x k (b2a b)
instance Dicurryable TreeData where
  dicurry (_::proxy args) _construct destruct (TreeData x) = TreeData $ \k r ->
    uncurryN @args (x k) (destruct r)
instance Composable TreeData where
  TreeData x <.> TreeData y = TreeData $ \k ->
    x (\ax vx tx -> y (\ay vy ty -> k (ax<>ay) (vx<>vy) (tx<>ty)))
instance Tupable TreeData where
  TreeData x <:> TreeData y = TreeData $ \k (a,b) ->
    x (\ax vx tx -> y (\ay vy ty -> k (ax<>ay) (vx<>vy) (tx<>ty)) b) a
instance Eitherable TreeData where
  TreeData x <+> TreeData y = TreeData $ \k -> \case
   Left  a -> x k a
   Right b -> y k b
instance Constant TreeData where
  constant _a = TreeData $ \k _a -> k mempty mempty mempty
instance Optionable TreeData where
  option = id
  optional (TreeData x) = TreeData $ \k ->
    \case
     Nothing -> k mempty mempty mempty
     Just a -> x k a
{-
instance Routable TreeData where
  TreeData x <!> TreeData y = TreeData $ \k ->
    x k :!: y k
-}
instance Repeatable TreeData where
  many0 (TreeData x) = TreeData $ \k -> \case
   [] -> k mempty mempty mempty
   a:as -> x (\ax vx tx ->
    unTreeData (many0 (TreeData x))
     (\aas vas tas -> k (ax<>aas) (vx<>vas) (tx<>tas)) as) a
  many1 (TreeData x) = TreeData $ \k -> \case
   [] -> k mempty mempty mempty
   a:as -> x (\ax vx tx ->
    unTreeData (many1 (TreeData x))
     (\aas vas tas -> k (ax<>aas) (vx<>vas) (tx<>tas)) as) a
instance Textable TreeData where
  type TextConstraint TreeData a = EncodeText a
  text = TreeData $ \k v ->
    let t = encodeText v in
    k mempty t $ pure $
      TS.Tree (Identity (NodeText (escapeText t))) mempty
instance XML TreeData where
  namespace _nm _ns = empty
  element n (TreeData x) = TreeData $ \k ->
    x $ \as _txt ts ->
      k mempty mempty $ pure $
        TS.Tree (Identity (NodeElem n as)) ts
  attribute n (TreeData x) = TreeData $ \k ->
    x $ \as txt _ts ->
      k (HM.insert n (Identity (escapeAttr txt)) as) mempty mempty
  literal lit = TreeData $ \k ->
    k mempty lit $ pure $
      TS.Tree (Identity (NodeText (escapeText lit))) mempty
  pi n = TreeData $ \k v ->
    k mempty mempty $ pure $
      TS.Tree (Identity (NodePI n v)) mempty
  comment = TreeData $ \k v ->
    k mempty mempty $ pure $
      TS.Tree (Identity (NodeComment v)) mempty
  cdata = TreeData $ \k v ->
    k mempty mempty $ pure $
      TS.Tree (Identity (NodeCDATA v)) mempty
instance Permutable TreeData where
  type Permutation TreeData = TreeDataPerm TreeData
  permutable = unTreeDataPerm
  perm = TreeDataPerm
  noPerm = TreeDataPerm empty
  permWithDefault _a = TreeDataPerm
instance Definable TreeData where
  define _n = id
instance RelaxNG TreeData where
  elementMatch nc x = TreeData $ \k n ->
    if matchNameClass nc n
    then error "elementMatch: given QName does not match expected NameClass"
    else unTreeData (element n x) k
  attributeMatch nc x = TreeData $ \k n ->
    if matchNameClass nc n
    then error "attributeMatch: given QName does not match expected NameClass"
    else unTreeData (attribute n x) k

-- ** Type 'TreeDataPerm'
newtype TreeDataPerm repr xml k
 =      TreeDataPerm
 {    unTreeDataPerm :: repr xml k }
instance Transformable (TreeDataPerm repr) where
  type UnTrans (TreeDataPerm repr) = repr
  noTrans = TreeDataPerm
  unTrans = unTreeDataPerm
instance Dimapable (TreeDataPerm TreeData)
instance Composable (TreeDataPerm TreeData)
instance Tupable (TreeDataPerm TreeData)