{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.XML.Write where

import Control.Applicative (Applicative(..), Alternative((<|>)))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), id)
import Data.Functor ((<$>), (<$))
import Data.Int (Int)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Traversable (Traversable(..))
import Data.Tuple (fst)
import Numeric.Natural (Natural)
import Prelude (Integer, error)
import System.IO (IO, FilePath)
import Text.Show (Show(..))
import qualified Control.Exception as Exn
import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString.Lazy as BSL
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Encoding as TL
import qualified System.IO.Error as IO

import Symantic.Base.CurryN
import Symantic.XML.Language
import Symantic.XML.RelaxNG.Language

-- * Type 'Write'
newtype Write params k
 =      Write
 {    unWrite :: (WriteSyn -> k) -> params
 }

write :: Write params BSL.ByteString -> params
write = runWrite defaultWriteInh

runWrite :: WriteInh -> Write params BSL.ByteString -> params
runWrite def (Write params) = params $ \syn ->
  TL.encodeUtf8 $ TLB.toLazyText $
  fromMaybe mempty $ writeSyn_result syn def

writeUtf8 :: FilePath -> Write params (IO (Maybe ErrorWrite)) -> params
writeUtf8 path (Write params) = params $ \syn ->
  let txt =
       TL.encodeUtf8 $ TLB.toLazyText $
       fromMaybe mempty $
       writeSyn_result syn defaultWriteInh in
  (Nothing <$ BSL.writeFile path txt)
  `Exn.catch` \e ->
    if IO.isAlreadyInUseError e
    || IO.isPermissionError   e
    then pure $ Just e
    else IO.ioError e

-- ** Type 'Write'
type ErrorWrite = IO.IOError

-- ** Type 'WriteInh'
-- | Top-down inheritage.
data WriteInh
 =   WriteInh
 {   writeInh_namespaces   :: Namespaces NCName
     -- ^ 'Namespaces' from the parent element.
 ,   writeInh_indent       :: TLB.Builder
 ,   writeInh_indent_delta :: TL.Text
 }

defaultWriteInh :: WriteInh
defaultWriteInh = WriteInh
 { writeInh_namespaces   = defaultNamespaces
 , writeInh_indent       = mempty
 , writeInh_indent_delta = "  "
 }

-- ** Type 'WriteSyn'
-- | Bottom-up synthesis to build 'element' or 'attribute'.
data WriteSyn
 =   WriteSyn
 {   writeSyn_attrs :: HM.HashMap QName TL.Text
 ,   writeSyn_attr :: TL.Text
 ,   writeSyn_namespaces_default :: Maybe Namespace
 ,   writeSyn_namespaces_prefixes :: HM.HashMap Namespace NCName
 ,   writeSyn_result :: WriteInh -> Maybe TLB.Builder
 }

instance Semigroup WriteSyn where
  x <> y = WriteSyn
   { writeSyn_attrs = writeSyn_attrs x <> writeSyn_attrs y
   , writeSyn_attr = writeSyn_attr x <> writeSyn_attr y
   , writeSyn_namespaces_default = writeSyn_namespaces_default x <|> writeSyn_namespaces_default y
   , writeSyn_namespaces_prefixes = writeSyn_namespaces_prefixes x <> writeSyn_namespaces_prefixes y
   , writeSyn_result = writeSyn_result x <> writeSyn_result y
   }
instance Monoid WriteSyn where
  mempty = WriteSyn
   { writeSyn_attrs = mempty
   , writeSyn_attr = mempty
   , writeSyn_namespaces_default = Nothing
   , writeSyn_namespaces_prefixes = mempty
   , writeSyn_result = mempty
   }

instance Emptyable Write where
  empty = Write (\k -> k mempty)
instance Unitable Write where
  unit = Write (\k () -> k mempty)
instance Voidable Write where
  void a (Write x) = Write (\k -> x k a)
instance Dimapable Write where
  dimap _a2b b2a (Write x) = Write $ \k b ->
    x k (b2a b)
instance Dicurryable Write where
  dicurry (_::proxy args) _construct destruct (Write x) =
    Write $ \k r ->
      uncurryN @args (x k) (destruct r)
instance Composable Write where
  Write x <.> Write y = Write $ \k ->
    x (\mx -> y $ \my -> k (mx<>my))
instance Tupable Write where
  Write x <:> Write y = Write $ \k (a,b) ->
    x (\mx -> y (\my -> k (mx<>my)) b) a
instance Eitherable Write where
  Write x <+> Write y = Write $ \k -> \case
   Left  a -> x k a
   Right b -> y k b
instance Constant Write where
  constant _a = Write $ \k _a -> k mempty
instance Optionable Write where
  option = id
  optional (Write x) = Write $ \k ->
    \case
     Nothing -> k mempty
     Just a -> x k a
{-
instance Routable Write where
  Write x <!> Write y = Write $ \k ->
    x k :!: y k
-}
instance Repeatable Write where
  many0 (Write x) = Write $ \k -> \case
   [] -> k mempty
   a:as -> x (\ma ->
    unWrite (many0 (Write x))
     (\mas -> k (ma<>mas)) as) a
  many1 (Write x) = Write $ \k -> \case
   [] -> k mempty
   a:as -> x (\ma ->
    unWrite (many0 (Write x))
     (\mas -> k (ma<>mas)) as) a
instance Textable Write where
  type TextConstraint Write a = EncodeText a
  text = Write $ \k v ->
    let t = encodeText v in
    k mempty
     { writeSyn_attr = t
     , writeSyn_result = \_inh -> Just $ textify $ escapeText t
     }
instance XML Write where
  namespace nm ns = Write $ \k ->
    k $ case nm of
     Nothing -> mempty{writeSyn_namespaces_default=Just ns}
     Just p  -> mempty{writeSyn_namespaces_prefixes=HM.singleton ns p}
  element elemQName (Write x) = Write $ \k ->
    x $ \syn ->
      k mempty{ writeSyn_result = \inh ->
      let
        hasIndenting = not $ TL.null $ writeInh_indent_delta inh
        defNS = fromMaybe
         (namespaces_default (writeInh_namespaces inh))
         (writeSyn_namespaces_default syn)
        usedNS =
          HS.singleton (qNameSpace elemQName) <>
          HS.delete xmlns_empty (HS.fromList (qNameSpace <$> HM.keys (writeSyn_attrs syn)))
        -- The inherited namespaces,
        -- including those declared at this element.
        inhNS =
          HM.union
           (writeSyn_namespaces_prefixes syn)
           (namespaces_prefixes (writeInh_namespaces inh))
        -- The namespaces used but not declared nor default,
        -- with fresh prefixes.
        autoNS =
          -- HM.delete defNS $
          (`S.evalState` HS.empty) $
          traverse
           (\() -> S.gets freshNCName)
           (HS.toMap usedNS `HM.difference` inhNS)
        write_xmlnsAttrs =
          (if defNS == namespaces_default (writeInh_namespaces inh)
          then mempty
          else textifyAttr (PName Nothing "xmlns") (escapeAttr (unNamespace defNS))) <>
          HM.foldrWithKey (\(Namespace ns) qNameLocal acc ->
            textifyAttr (PName (Just "xmlns") qNameLocal) (escapeAttr ns) <> acc
           ) mempty
           (autoNS <> writeSyn_namespaces_prefixes syn)
        scopeNS = Namespaces
         { namespaces_prefixes = autoNS <> inhNS
         , namespaces_default = defNS
         }
        write_elemPName = textify $ prefixifyQName scopeNS elemQName
        write_elemAttrs =
          foldMap (\(an, av) -> textifyAttr
           (prefixifyQName scopeNS{namespaces_default=xmlns_empty} an)
           (escapeAttr av)) $
          List.sortOn fst $ -- This makes the rendition more predictible, but this is useless.
          HM.toList (writeSyn_attrs syn)
        write_elemChilds = writeSyn_result syn inh
         { writeInh_namespaces = scopeNS
         -- Disable indenting unless hasIndenting.
         , writeInh_indent =
          if hasIndenting
          then
            writeInh_indent inh <>
            textify (writeInh_indent_delta inh)
          else mempty
         , writeInh_indent_delta =
          if hasIndenting
          then writeInh_indent_delta inh
          else mempty
         }
      in Just $
      writeInh_indent inh
       <> "<"
       <> write_elemPName
       <> write_xmlnsAttrs
       <> write_elemAttrs
       <> case write_elemChilds of
       Nothing -> "/>" <> nl inh
       Just w -> ">"
         <> nl inh
         <> w
         <> (if hasIndenting then writeInh_indent inh else mempty)
         <> "</"<>write_elemPName<>">"
         <> nl inh
      }
  attribute n@(QName ans aln) (Write x) = Write $ \k ->
    x $ \syn ->
      if ans == xmlns_xmlns
      then unWrite (namespace (Just aln) (Namespace (writeSyn_attr syn))) k
      else if ans == xmlns_empty && aln == NCName "xmlns"
      then unWrite (namespace Nothing (Namespace (writeSyn_attr syn))) k
      else k mempty{writeSyn_attrs = HM.insert n (writeSyn_attr syn) (writeSyn_attrs syn)}
  literal lit = Write $ \k ->
    k mempty
     { writeSyn_attr = lit
     , writeSyn_result = \_inh ->
      Just $ textify $ escapeText lit
     }
  pi n = Write $ \k v ->
    k mempty{ writeSyn_result = \inh ->
      let s | TL.null v = ""
            | otherwise  = " " in
      Just $
      writeInh_indent inh <>
      "<?"<>textify n<>s <>
      textify (TL.replace "?>" "?&gt;" v) <>
      "?>"<>nl inh
    }
  comment = Write $ \k v ->
    k mempty{ writeSyn_result = \inh ->
      Just $
      writeInh_indent inh <>
      "<!--"<>textify (TL.replace "-->" "--&gt;" v)<>"-->"<>nl inh
    }
  cdata = Write $ \k v ->
    k mempty{ writeSyn_result = \inh ->
      Just $
      writeInh_indent inh <>
      "<[CDATA[["<>textify (TL.replace "]]>" "]]&gt;" v)<>"]]>"<>nl inh
    }
instance Permutable Write where
  type Permutation Write = WritePerm Write
  permutable = unWritePerm
  perm = WritePerm
  noPerm = WritePerm empty
  permWithDefault _a = WritePerm
instance Definable Write where
  define _n = id
instance RelaxNG Write where
  elementMatch nc x = Write $ \k n ->
    if matchNameClass nc n
    then error "elementMatch: given QName does not match expected NameClass"
    else unWrite (element n x) k
  attributeMatch nc x = Write $ \k n ->
    if matchNameClass nc n
    then error "attributeMatch: given QName does not match expected NameClass"
    else unWrite (attribute n x) k

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

nl :: WriteInh -> TLB.Builder
nl inh | TL.null (writeInh_indent_delta inh) = mempty
       | otherwise = "\n"

-- * Class 'EncodeText'
class EncodeText a where
  encodeText :: a -> TL.Text
  default encodeText :: Show a => a -> TL.Text
  encodeText = TL.pack . show
instance EncodeText String where
  encodeText = TL.pack
instance EncodeText Text.Text where
  encodeText = TL.fromStrict
instance EncodeText TL.Text where
  encodeText = id
instance EncodeText Bool where
  encodeText = \case
   False -> "0"
   True  -> "1"
instance EncodeText Int
instance EncodeText Integer
instance EncodeText Natural