{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language UndecidableInstances #-}
{-# language QuasiQuotes #-}

module TPDB.Data.Xml where

import TPDB.Data
import TPDB.Xml

import Text.Hamlet.XML
import Data.String
import Data.Typeable

-- | FIXME: move to separate module
instance XmlContent Identifier where
    parseContents :: Cursor -> [Identifier]
parseContents = Cursor -> [Text]
content (Cursor -> [Text])
-> (Text -> Identifier) -> Cursor -> [Identifier]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| \ Text
c -> Text -> Identifier
mknullary Text
c
    toContents :: Identifier -> [Node]
toContents Identifier
i =
          -- probably not here: E.xmlEscape E.stdXmlEscaper
          -- this introduces whitespace between < and =
          -- [ CString False $ show i ]
          -- and this creates a CDATA element
          -- [ CString True $ show i ]
          -- so here comes an UGLY HACK:
          [xml|#{fromString $ escape $ show i}|]


instance (  TermC v c, Show v, XmlContent v, XmlContent c )
         => XmlContent ( Term v c ) where
    toContents :: Term v c -> [Node]
toContents ( Var v
v ) = [xml|<var>#{fromString $ show v}|]
{-
-- for Rainbow:
    toContents ( Node f xs ) = return $ mkel "app"
         $ mkel "fun" ( toContents f )
         : map ( \ x -> mkel "arg" $ toContents x ) xs
-}
-- for CPF:

-- the problem is this:
-- a variable is an Identifier, and must look like "<var>foo</var>"
-- a constructor symbol is also an Identifier
-- but it must look like "<funapp><name>bar<name>..."
-- so it should be wrapped into <name>
-- but no, if the constructor is sharped (or labelled)
-- then it must look like "<funapp><sharp><name>bar..."
-- price question: what is the correct 
-- instance XmlContent Identifier ?
-- the answer probably is "there is none",
-- and toContents (Term v Identifier) should never occur,
-- instead need to call  toContents (Term v Symbol)

    toContents ( Node c
f [Term v c]
args ) =
      [xml|<funapp>
             ^{no_sharp_name_HACK ( toContents f )}
             $forall arg <- args
               <arg>^{toContents arg}
      |]


no_sharp_name_HACK :: p -> p
no_sharp_name_HACK p
e = p
e

{-
sharp_name_HACK e = case e of
    [ CElem ( Elem (N "sharp") [] cs ) () ] -> 
        rmkel "sharp" $ rmkel "name" cs
    _ -> rmkel "name" e

-}



instance ( TermC v c, XmlContent ( Term v c ) ) 
         => XmlContent ( Rule ( Term v c ) ) where
    toContents :: Rule (Term v c) -> [Node]
toContents Rule (Term v c)
u =
      [xml|<rule>
             <lhs>^{toContents $ lhs u}
             <rhs>^{toContents $ rhs u}
      |]