{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
module Symantic.XML.RelaxNG.Compact.Write where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (forM)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), id, const)
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..), maybe, catMaybes, isNothing)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..), String)
import Numeric.Natural (Natural)
import Prelude (Integer)
import qualified Control.Monad.Trans.State.Strict as S
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB

import Symantic.Base.Fixity
import Symantic.XML.Language
import Symantic.XML.RelaxNG.Language

-- | Get textual rendition of given 'RNCWriteSyn'.
writeRNC :: RNCWriteSyn a k -> TL.Text
writeRNC = TLB.toLazyText . runRNCWriteSyn

-- | Get textual rendition of given 'RNCWriteSyn'.
runRNCWriteSyn :: RNCWriteSyn a k -> TLB.Builder
runRNCWriteSyn RNCWriteSyn{..} =
  mconcat $
  List.concat
   [ [ "default namespace = \""<>textify (namespaces_default rncWriteInh_namespaces)<>"\"\n"
     | not $ TL.null $ unNamespace (namespaces_default rncWriteInh_namespaces)
     ]
   , [ "namespace "<>textify p<>" = \""<>textify n<>"\"\n"
     | (Namespace n, NCName p) <-
      HM.toList (namespaces_prefixes rncWriteInh_namespaces)
     ]
   , Map.foldrWithKey
     (\n v -> ((textify n<>" = "<>v<>"\n") :)) []
     defs
   ]
  where
  RNCWriteState{..} = rncWriteSyn_state $ RNCWriteState mempty mempty
  defs :: Map.Map DefineName TLB.Builder
  defs = Map.mapMaybe ($ inh) rncWriteState_defines
  inh = RNCWriteInh
   { rncWriteInh_namespaces
   , rncWriteInh_op = (infixN0, SideL)
   , rncWriteInh_pair = pairParen
   }
  rncWriteInh_namespaces :: Namespaces NCName
  rncWriteInh_namespaces = rncWriteState_namespaces
   { namespaces_prefixes =
    (`S.evalState` HS.empty) $
      forM prefixByNamespace $ \mp -> do
        usedPrefixes <- S.get
        let
         freshPrefix = maybe
           (freshNCName usedPrefixes)
           (freshifyNCName usedPrefixes)
           mp
        S.modify' $ HS.insert freshPrefix
        pure freshPrefix
   }
  prefixByNamespace :: HM.HashMap Namespace (Maybe NCName)
  prefixByNamespace =
    -- Add default prefixes if their 'Namespace' is used.
    HM.union
     (HM.intersectionWith (<|>)
       (namespaces_prefixes rncWriteState_namespaces)
       (Just <$> namespaces_prefixes defaultNamespaces)) $
    namespaces_prefixes rncWriteState_namespaces

-- * Type 'RNCWriteState'
-- | Chained values.
data RNCWriteState
 =   RNCWriteState
 {   rncWriteState_namespaces :: Namespaces (Maybe NCName)
     -- ^ The 'Namespaces' used throughout the 'RelaxNG' schema.
 ,   rncWriteState_defines    :: Map.Map DefineName (RNCWriteInh -> Maybe TLB.Builder)
     -- ^ Used to avoid infinite recursion,
     -- by looking up the 'DefineName' of 'define'.
 }

-- * Type 'RNCWriteSyn'
-- | Synthetized (bottom-up) values.
data RNCWriteSyn a k
 =   RNCWriteSyn
 {   rncWriteSyn_state  :: Chained RNCWriteState
 ,   rncWriteSyn_schema :: RNCWriteInh -> Maybe TLB.Builder
 }
instance IsString (RNCWriteSyn a k) where
  fromString s = RNCWriteSyn
   { rncWriteSyn_state = id
   , rncWriteSyn_schema = const $
    if List.null s then Nothing
    else Just (textify s)
   }

-- | Like the @State st ()@ monad, but without @()@.
-- The name comme from chained-attribute from Attribute Grammar.
type Chained a = a -> a

coerceRNCWriteSyn :: RNCWriteSyn a k -> RNCWriteSyn a' k'
coerceRNCWriteSyn RNCWriteSyn{..} = RNCWriteSyn{..}
{-# INLINE coerceRNCWriteSyn #-}

pairRNCWriteInh ::
 Semigroup s => IsString s =>
 RNCWriteInh -> Infix -> Maybe s -> Maybe s
pairRNCWriteInh inh op s =
  if isPairNeeded (rncWriteInh_op inh) op
  then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
  else s
  where (o,c) = rncWriteInh_pair inh

-- ** Type 'RNCWriteInh'
-- Inherited (top-down) values.
data RNCWriteInh
 =   RNCWriteInh
 {   rncWriteInh_namespaces :: Namespaces NCName
 ,   rncWriteInh_op :: (Infix, Side)
 ,   rncWriteInh_pair :: Pair
 }

instance Emptyable RNCWriteSyn where
  empty = "empty"
instance Unitable RNCWriteSyn where
  unit = ""
instance Voidable RNCWriteSyn where
  void _a = coerceRNCWriteSyn
instance Constant RNCWriteSyn where
  constant _a = ""
instance Composable RNCWriteSyn where
  x <.> y = RNCWriteSyn
   (rncWriteSyn_state x . rncWriteSyn_state y) $ \inh ->
    let
     inh' side = inh
      { rncWriteInh_op   = (op, side)
      , rncWriteInh_pair = pairParen
      } in
    case rncWriteSyn_schema x (inh' SideL) of
     Nothing -> rncWriteSyn_schema y (inh' SideR)
     Just xw ->
      case rncWriteSyn_schema y (inh' SideR) of
       Nothing -> Just xw
       Just yw ->
        pairRNCWriteInh inh op $
          Just $ xw <> ", " <> yw
    where
    op = infixB SideL 2
instance Tupable RNCWriteSyn where
  x <:> y = coerceRNCWriteSyn x <.> coerceRNCWriteSyn y
instance Eitherable RNCWriteSyn where
  x <+> y = RNCWriteSyn
   (rncWriteSyn_state x . rncWriteSyn_state y) $ \inh ->
    pairRNCWriteInh inh op $
    rncWriteSyn_schema x inh
     { rncWriteInh_op   = (op, SideL)
     , rncWriteInh_pair = pairParen
     } <>
    Just " | " <>
    rncWriteSyn_schema y inh
     { rncWriteInh_op   = (op, SideR)
     , rncWriteInh_pair = pairParen
     }
    where op = infixB SideL 3
instance Optionable RNCWriteSyn where
  option = coerceRNCWriteSyn . optional . coerceRNCWriteSyn
  optional w = w{ rncWriteSyn_schema = \inh ->
    pairRNCWriteInh inh op $
    rncWriteSyn_schema w inh
     { rncWriteInh_op   = (op, SideL)
     , rncWriteInh_pair = pairParen
     } <> Just "?"
    }
    where op = infixN 9
instance Dimapable RNCWriteSyn where
  dimap _a2b _b2a = coerceRNCWriteSyn
instance Dicurryable RNCWriteSyn where
  dicurry _args _constr _destr = coerceRNCWriteSyn
instance Repeatable RNCWriteSyn where
  many0 w = w{ rncWriteSyn_schema = \inh ->
    pairRNCWriteInh inh op $
    rncWriteSyn_schema w inh
     { rncWriteInh_op   = (op, SideL)
     , rncWriteInh_pair = pairParen
     } <> Just "*"
    }
    where op = infixN 9
  many1 w = w{ rncWriteSyn_schema = \inh ->
    pairRNCWriteInh inh op $
    rncWriteSyn_schema w inh
     { rncWriteInh_op   = (op, SideL)
     , rncWriteInh_pair = pairParen
     } <> Just "+"
    }
    where op = infixN 9
instance Textable RNCWriteSyn where
  type TextConstraint RNCWriteSyn a = RNCText a
  text :: forall a k. TextConstraint RNCWriteSyn a => RNCWriteSyn (a -> k) k
  text = RNCWriteSyn
   { rncWriteSyn_state = \st ->
    case HM.lookup
     (qNameSpace (rncText_qname @a))
     (namespaces_prefixes (rncWriteState_namespaces st)) of
     Just{} -> st
     Nothing ->
      let ns = qNameSpace (rncText_qname @a) in
      if ns == xmlns_empty then st else st
       { rncWriteState_namespaces = (rncWriteState_namespaces st)
        { namespaces_prefixes =
        HM.insertWith (<|>) ns Nothing $
        namespaces_prefixes (rncWriteState_namespaces st) } }
   , rncWriteSyn_schema = \inh ->
    let n = rncText_qname @a in
    let t = if TL.null (unNamespace (qNameSpace n))
            then textify (qNameLocal n)
            else textify (prefixifyQName (rncWriteInh_namespaces inh) n)
    in if null (rncText_params @a)
    then Just t
    else
      pairRNCWriteInh inh (infixN 8) $
      Just $
      t<>" {"<>Map.foldMapWithKey
       (\k v -> " "<>textify k<>" = \""<>textify v<>"\"")
       (rncText_params @a)<>" }"
   }
instance XML RNCWriteSyn where
  namespace mp ns = RNCWriteSyn
   { rncWriteSyn_state = \st -> st
    { rncWriteState_namespaces =
      let nss = rncWriteState_namespaces st in
      Namespaces
       { namespaces_prefixes =
        HM.insertWith (<|>) ns mp (namespaces_prefixes nss)
       , namespaces_default =
        if isNothing mp
        then ns
        else namespaces_default nss
       }
    }
   , rncWriteSyn_schema = const Nothing
   }
  element n w = w
   { rncWriteSyn_state = \st ->
    rncWriteSyn_state w $ st
     { rncWriteState_namespaces = (rncWriteState_namespaces st)
       { namespaces_prefixes =
        -- Insert this 'qNameSpace' even if this is the default namespace,
        -- because the default namespace here may not end up
        -- being the global default namespace
        -- if there is a default 'namespace' declaration after this one.
        -- at worse this will just add a superfluous ns# declaration
        -- in the schema rendering.
        HM.insertWith (<|>) (qNameSpace n) Nothing
         (namespaces_prefixes (rncWriteState_namespaces st)) } }
   , rncWriteSyn_schema = \inh ->
    pairRNCWriteInh inh (infixN 8) $
    Just ("element "
     <> textify (prefixifyQName (rncWriteInh_namespaces inh) n)
     <> " {")
    <> rncWriteSyn_schema w inh
     { rncWriteInh_op   = (infixN0, SideR)
     , rncWriteInh_pair = pairBrace
     }
    <> Just "}"
   }
  attribute n w = w
   { rncWriteSyn_state = \st ->
    rncWriteSyn_state w $
    if qNameSpace n == xmlns_empty then st else st
     { rncWriteState_namespaces = (rncWriteState_namespaces st)
       { namespaces_prefixes =
        HM.insertWith (<|>) (qNameSpace n) Nothing
         (namespaces_prefixes (rncWriteState_namespaces st)) } }
   , rncWriteSyn_schema = \inh ->
    pairRNCWriteInh inh (infixN 8) $
    Just ("attribute "
     -- The namespace name for an unprefixed attribute name always has no value.
     <> textify (prefixifyQName (rncWriteInh_namespaces inh){namespaces_default=xmlns_empty} n)
     <> " {")
    <> rncWriteSyn_schema w inh
     { rncWriteInh_op   = (infixN0, SideR)
     , rncWriteInh_pair = pairBrace
     }
    <> Just "}"
   }
  literal lit = RNCWriteSyn
   { rncWriteSyn_state = id
   , rncWriteSyn_schema = \_inh -> Just ("\""<>textify lit<>"\"")
   }
  pi _n   = ""
  comment = ""
  cdata   = ""
instance Definable RNCWriteSyn where
  define n w = w
   { rncWriteSyn_state = \st ->
    let defs = rncWriteState_defines st in
    case Map.lookup n defs of
     Nothing ->
      rncWriteSyn_state w $ st
       { rncWriteState_defines =
        Map.insert n (rncWriteSyn_schema w) defs
       }
     Just{} -> st
   , rncWriteSyn_schema = const $ Just $ textify n
   }
instance Permutable RNCWriteSyn where
  type Permutation RNCWriteSyn = RNCWriteSynPerm
  permutable (RNCWriteSynPerm ps) = RNCWriteSyn
   { rncWriteSyn_state = List.foldl' (.) id (rncWriteSyn_state <$> ps)
   , rncWriteSyn_schema = case ps of
     [] -> const Nothing
     _ -> \inh ->
      case
        List.intersperse " & " $
        catMaybes $ (<$> ps) $ \w ->
          rncWriteSyn_schema w inh{rncWriteInh_op=(op, SideL)}
      of
       [] -> Nothing
       [x] -> Just x
       xs -> pairRNCWriteInh inh op $ Just $ mconcat xs
   }
    where op = infixR 3
  perm = RNCWriteSynPerm . pure
  noPerm = RNCWriteSynPerm []
  permWithDefault _def p = RNCWriteSynPerm
   [coerceRNCWriteSyn (optional p)]
instance RelaxNG RNCWriteSyn where
  elementMatch nc w = w
   { rncWriteSyn_state = \st ->
    rncWriteSyn_state w $ st
     { rncWriteState_namespaces = (rncWriteState_namespaces st)
       { namespaces_prefixes =
        namespacesNameClass nc <>
        namespaces_prefixes (rncWriteState_namespaces st)
       } }
   , rncWriteSyn_schema = \inh ->
    pairRNCWriteInh inh (infixN 8) $
    Just ("element "
     <> textify (rncWriteInh_namespaces inh, (infixN0,SideL), nc)
     <> " ")
    <> rncWriteSyn_schema w inh
     { rncWriteInh_op = (infixN 9, SideR)
     , rncWriteInh_pair = pairBrace
     }
   }
  attributeMatch nc w = w
   { rncWriteSyn_state = \st ->
    let nss = HM.delete xmlns_empty $ namespacesNameClass nc in
    rncWriteSyn_state w $
    if null nss then st else st
     { rncWriteState_namespaces = (rncWriteState_namespaces st)
       { namespaces_prefixes =
        HM.unionWith (<|>) nss $
        namespaces_prefixes (rncWriteState_namespaces st)
       } }
   , rncWriteSyn_schema = \inh ->
    pairRNCWriteInh inh (infixN 8) $
    Just ("attribute "
     <> textify ( (rncWriteInh_namespaces inh){namespaces_default=xmlns_empty}
              , (infixN0,SideL)
              , nc )
     <> " ")
    <> rncWriteSyn_schema w inh
     { rncWriteInh_op   = (infixN 9, SideR)
     , rncWriteInh_pair = pairBrace
     }
   }

-- ** Type 'RNCWriteSynPerm'
newtype RNCWriteSynPerm a k
 =      RNCWriteSynPerm
 {      rncWriteSynPerm_alternatives :: [RNCWriteSyn a k]
        -- ^ Collect alternatives for rendering
        -- them all at once in 'runPermutation'.
 }
instance Composable RNCWriteSynPerm where
  RNCWriteSynPerm x <.> RNCWriteSynPerm y =
    RNCWriteSynPerm $
      (coerceRNCWriteSyn <$> x) <>
      (coerceRNCWriteSyn <$> y)
instance Dimapable RNCWriteSynPerm where
  dimap _a2b _b2a (RNCWriteSynPerm x) =
    RNCWriteSynPerm (coerceRNCWriteSyn <$> x)
instance Tupable RNCWriteSynPerm where
  RNCWriteSynPerm x <:> RNCWriteSynPerm y =
    RNCWriteSynPerm $
      (coerceRNCWriteSyn <$> x) <>
      (coerceRNCWriteSyn <$> y)
instance Definable RNCWriteSynPerm where
  define n (RNCWriteSynPerm ps) =
    RNCWriteSynPerm $ pure $
      coerceRNCWriteSyn $ define n $
        permutable $ RNCWriteSynPerm $
          coerceRNCWriteSyn <$> ps

-- * Class 'RNCText'
class RNCText a where
  rncText_qname  :: QName
  rncText_params :: Map.Map TL.Text TL.Text
  rncText_params = mempty
instance RNCText String where
  rncText_qname = QName (Namespace "") "text"
instance RNCText Text.Text where
  rncText_qname = QName (Namespace "") "text"
instance RNCText TL.Text where
  rncText_qname = QName (Namespace "") "text"
instance RNCText Bool where
  rncText_qname = QName xmlns_xsd "boolean"
instance RNCText Int where
  rncText_qname = QName xmlns_xsd "int"
instance RNCText Integer where
  rncText_qname = QName xmlns_xsd "integer"
instance RNCText Natural where
  rncText_qname = QName xmlns_xsd "nonNegativeInteger"