{-# language UndecidableInstances, OverlappingInstances, IncoherentInstances, FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-}

module TPDB.Xml

( XmlContent (..), mkel, rmkel
, content, (&|)
  , escape, nospaceString
)
  
where

import Data.Typeable

import Control.Monad
import Control.Applicative

import Text.XML
import Text.XML.Cursor

import Data.String
import qualified Data.Text as T

class XmlContent a where
  toContents :: a -> [ Node ]
  parseContents :: Cursor -> [a]

instance XmlContent Int where
  toContents :: Int -> [Node]
toContents = Node -> [Node]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> [Node]) -> (Int -> Node) -> Int -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Node
nospaceString (Text -> Node) -> (Int -> Text) -> Int -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show
instance XmlContent Integer where
  toContents :: Integer -> [Node]
toContents = Node -> [Node]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> [Node]) -> (Integer -> Node) -> Integer -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Node
nospaceString (Text -> Node) -> (Integer -> Text) -> Integer -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show
instance XmlContent Bool where
  toContents :: Bool -> [Node]
toContents Bool
False = Node -> [Node]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> [Node]) -> Node -> [Node]
forall a b. (a -> b) -> a -> b
$ Text -> Node
nospaceString Text
"false"
  toContents Bool
True = Node -> [Node]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> [Node]) -> Node -> [Node]
forall a b. (a -> b) -> a -> b
$ Text -> Node
nospaceString Text
"true"

mkel :: Name -> [Node] -> Node
mkel Name
name [Node]
cs = Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
Element Name
name Map Name Text
forall a. Monoid a => a
mempty [Node]
cs 
rmkel :: Name -> [Node] -> m Node
rmkel Name
name [Node]
cs = Node -> m Node
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> m Node) -> Node -> m Node
forall a b. (a -> b) -> a -> b
$ Name -> [Node] -> Node
mkel Name
name [Node]
cs
       
nospaceString :: T.Text -> Node
nospaceString :: Text -> Node
nospaceString = Text -> Node
NodeContent 

{-


instance Typeable t => HTypeable t where 
    toHType x = let cs = show ( typeOf x ) in Prim cs cs
-}

escape :: String -> String
escape [] = []
escape ( Char
c : String
cs ) = case Char
c of
    Char
'<' -> String
"&lt;" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
cs
    Char
'>' -> String
"&gt;" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
cs
    Char
_   -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:       String -> String
escape String
cs

{-
type Contents = [ Content Posn ]

data CParser a = CParser { unCParser :: Contents -> Maybe ( a, Contents ) }

instance Functor CParser where
    fmap f (CParser p) = CParser $ \ cs ->
        do ( x, cs' ) <- p cs ; return ( f x, cs' )

instance Applicative CParser where
    pure = return ; (<*>) = ap
         
instance Monad CParser where
    return x = CParser $ \ cs -> return ( x, cs )
    CParser p >>= f = CParser $ \ cs0 -> 
        do ( x, cs1 ) <- p cs0 ; unCParser ( must_succeed $ f x ) cs1


must_succeed :: CParser a -> CParser a
must_succeed (CParser p ) = CParser $ \ cs -> 
    case p cs of
        Nothing -> error $ "must succeed:" ++ errmsg cs
        ok -> ok

class Typeable a => XRead a where xread :: CParser a


instance ( Typeable a, XmlContent a ) => XRead a where
    xread = CParser $ \ cs -> case runParser parseContents cs of
          ( Right x, rest ) -> Just ( x, rest )  
          ( Left err, rest ) -> Nothing

wrap :: forall a . Typeable a => CParser a -> Parser ( Content Posn ) a
wrap ( CParser p ) = P $ \ cs -> case p cs of
     Nothing -> Failure cs $ unlines
             $ "want expression of type " 
             :  show ( typeOf ( undefined :: a )) 
             :  errmsg cs
             : []
     Just ( x, cs' ) -> Committed ( Success cs' x )

errmsg cs = unlines $ case cs of 
                  ( c  : etc ) -> 
                     [ show $ P.content c
                    
                     ]
                  _ -> [ show $ length cs ]

orelse :: CParser a -> CParser a  -> CParser a
orelse ( CParser p ) ( CParser q ) = CParser $ \ cs -> 
    case p cs of Nothing -> q cs ; ok -> ok

many :: CParser a -> CParser [a]
many p = ( do x <- p ; xs <- TPDB.Xml.many p ; return $ x : xs ) `orelse` return []

element tag p = element0 (N tag) $ must_succeed p

element0 tag p = CParser $ \ cs -> case strip cs of
     ( CElem ( Elem name atts con ) _ : etc ) | name == tag -> 
         case unCParser p con of
             Nothing -> Nothing
             Just ( x, _ ) -> Just ( x, etc )
     _ -> Nothing

strip [] = []
strip input @ ( CElem ( Elem {} ) _ : _ ) = input
strip (c : cs) = strip cs

xfromstring :: Read a => CParser a
xfromstring = CParser $ \ cs -> case cs of
    ( CString _ s _ : etc ) -> Just ( read s, etc )
    _ -> Nothing

complain :: String -> CParser a
complain tag = CParser $ \ cs -> error $ "ERROR: in branch for " ++ tag ++ errmsg cs

info :: Contents -> String
info [] = "empty contents"
info ( c : cs ) = case c of
    CElem ( Elem name atts con ) _ -> "CElem, name: " ++ show name
    CString _ s _ -> "CString : " ++ s
    CRef _ _ -> "CRef"
    CMisc _ _ -> "CMisc"

-}