{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
{- |
Module      :  ./Common/ToXml.hs
Description :  xml utilities
Copyright   :  (c) Christian Maeder, DFKI GmbH 2009
License     :  GPLv2 or higher, see LICENSE.txt
Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  non-portable

xml utilities on top of the xml light package and common hets data types
-}

module Common.ToXml where

import Common.AS_Annotation
import Common.Data
import Common.DocUtils
import Common.GlobalAnnotations
import Common.Id
import Common.Result

import Text.XML.Light

import Data.Data
import Data.Either

mkAttr :: String -> String -> Attr
mkAttr :: String -> String -> Attr
mkAttr = QName -> String -> Attr
Attr (QName -> String -> Attr)
-> (String -> QName) -> String -> String -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName
unqual

mkText :: String -> Content
mkText :: String -> Content
mkText s :: String
s = CData -> Content
Text (CData -> Content) -> CData -> Content
forall a b. (a -> b) -> a -> b
$ CDataKind -> String -> Maybe Line -> CData
CData CDataKind
CDataText String
s Maybe Line
forall a. Maybe a
Nothing

prettyElem :: Pretty a => String -> GlobalAnnos -> a -> Element
prettyElem :: String -> GlobalAnnos -> a -> Element
prettyElem name :: String
name ga :: GlobalAnnos
ga a :: a
a = String -> String -> Element
forall t. Node t => String -> t -> Element
unode String
name (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ GlobalAnnos -> a -> ShowS
forall a. Pretty a => GlobalAnnos -> a -> ShowS
showGlobalDoc GlobalAnnos
ga a
a ""

rangeAttrsF :: ([Pos] -> String) -> Range -> [Attr]
rangeAttrsF :: ([Pos] -> String) -> Range -> [Attr]
rangeAttrsF f :: [Pos] -> String
f rg :: Range
rg = case Range -> [Pos]
rangeToList Range
rg of
  [] -> []
  ps :: [Pos]
ps -> [String -> String -> Attr
mkAttr "range" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ [Pos] -> String
f [Pos]
ps]

rangeAttrs :: Range -> [Attr]
rangeAttrs :: Range -> [Attr]
rangeAttrs = ([Pos] -> String) -> Range -> [Attr]
rangeAttrsF (([Pos] -> String) -> Range -> [Attr])
-> ([Pos] -> String) -> Range -> [Attr]
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> ([Pos] -> Doc) -> [Pos] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pos] -> Doc
prettyRange

mkNameAttr :: String -> Attr
mkNameAttr :: String -> Attr
mkNameAttr = String -> String -> Attr
mkAttr "name"

mkPriorityAttr :: String -> Attr
mkPriorityAttr :: String -> Attr
mkPriorityAttr = String -> String -> Attr
mkAttr "priority"

annotationF :: (Range -> [Attr]) -> GlobalAnnos -> Annotation -> Element
annotationF :: (Range -> [Attr]) -> GlobalAnnos -> Annotation -> Element
annotationF f :: Range -> [Attr]
f ga :: GlobalAnnos
ga a :: Annotation
a = [Attr] -> Element -> Element
add_attrs (Range -> [Attr]
f (Range -> [Attr]) -> Range -> [Attr]
forall a b. (a -> b) -> a -> b
$ Annotation -> Range
forall a. GetRange a => a -> Range
getRangeSpan Annotation
a)
  (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> GlobalAnnos -> Annotation -> Element
forall a. Pretty a => String -> GlobalAnnos -> a -> Element
prettyElem "Annotation" GlobalAnnos
ga Annotation
a

annotations :: GlobalAnnos -> [Annotation] -> [Element]
annotations :: GlobalAnnos -> [Annotation] -> [Element]
annotations = (Annotation -> Element) -> [Annotation] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map ((Annotation -> Element) -> [Annotation] -> [Element])
-> (GlobalAnnos -> Annotation -> Element)
-> GlobalAnnos
-> [Annotation]
-> [Element]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range -> [Attr]) -> GlobalAnnos -> Annotation -> Element
annotationF Range -> [Attr]
rangeAttrs

subnodes :: String -> [Element] -> [Element]
subnodes :: String -> [Element] -> [Element]
subnodes name :: String
name elems :: [Element]
elems = if [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
elems then [] else [String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode String
name [Element]
elems]

eitherToElem :: String -> [Either Attr Element] -> Element
eitherToElem :: String -> [Either Attr Element] -> Element
eitherToElem s :: String
s l :: [Either Attr Element]
l = let (as :: [Attr]
as, es :: [Element]
es) = [Either Attr Element] -> ([Attr], [Element])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Attr Element]
l in
  [Attr] -> Element -> Element
add_attrs [Attr]
as (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode String
s [Element]
es

myDataToXml :: MyData -> Element
myDataToXml :: MyData -> Element
myDataToXml d :: MyData
d =
  let
    listTag, listItemTag, dataItemTag :: String
    listTag :: String
listTag = "List"
    listItemTag :: String
listItemTag = "li"
    dataItemTag :: String
dataItemTag = "d"

    myDataToXmlWorker :: String -> MyData -> Element
    myDataToXmlWorker :: String -> MyData -> Element
myDataToXmlWorker tag :: String
tag md :: MyData
md = case MyData
md of
      Builtin _ v :: String
v -> String -> String -> Element
forall t. Node t => String -> t -> Element
unode String
tag String
v
      ListOrTuple _ values :: [MyData]
values ->
        String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode String
tag ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ (MyData -> Element) -> [MyData] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (String -> MyData -> Element
myDataToXmlWorker String
listItemTag) [MyData]
values
      Cons _ Nothing values :: [MyData]
values ->
        String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode String
tag ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ (MyData -> Element) -> [MyData] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (String -> MyData -> Element
myDataToXmlWorker String
dataItemTag) [MyData]
values
      Cons _ (Just fields :: [String]
fields) values :: [MyData]
values ->
        String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode String
tag ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ (String -> MyData -> Element) -> [String] -> [MyData] -> [Element]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> MyData -> Element
myDataToXmlWorker [String]
fields [MyData]
values
  in
    case MyData
d of
      Cons constructor :: String
constructor _ _ -> String -> MyData -> Element
myDataToXmlWorker String
constructor MyData
d
      ListOrTuple _ _ -> String -> MyData -> Element
myDataToXmlWorker String
listTag MyData
d
      Builtin _ v :: String
v -> String -> String -> Element
forall t. Node t => String -> t -> Element
unode String
dataItemTag String
v

class ToXml a where
  asXml :: a -> Element

instance {-# OVERLAPPABLE #-} Data a => ToXml a where
  asXml :: a -> Element
asXml = MyData -> Element
myDataToXml (MyData -> Element) -> (a -> MyData) -> a -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MyData -> MyData
normalizeMyDataForSerialization (MyData -> MyData) -> (a -> MyData) -> a -> MyData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MyData
forall a. Data a => a -> MyData
dataToMyData