hets/Common/ToXml.hs

{-# 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 = Attr . unqual

mkText :: String -> Content
mkText s = Text $ CData CDataText s Nothing

prettyElem :: Pretty a => String -> GlobalAnnos -> a -> Element
prettyElem name ga a = unode name $ showGlobalDoc ga a ""

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

rangeAttrs :: Range -> [Attr]
rangeAttrs = rangeAttrsF $ show . prettyRange

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

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

annotationF :: (Range -> [Attr]) -> GlobalAnnos -> Annotation -> Element
annotationF f ga a = add_attrs (f $ getRangeSpan a)
  $ prettyElem "Annotation" ga a

annotations :: GlobalAnnos -> [Annotation] -> [Element]
annotations = map . annotationF rangeAttrs

subnodes :: String -> [Element] -> [Element]
subnodes name elems = if null elems then [] else [unode name elems]

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

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

    myDataToXmlWorker :: String -> MyData -> Element
    myDataToXmlWorker tag md = case md of
      Builtin _ v -> unode tag v
      ListOrTuple _ values ->
        unode tag $ map (myDataToXmlWorker listItemTag) values
      Cons _ Nothing values ->
        unode tag $ map (myDataToXmlWorker dataItemTag) values
      Cons _ (Just fields) values ->
        unode tag $ zipWith myDataToXmlWorker fields values
  in
    case d of
      Cons constructor _ _ -> myDataToXmlWorker constructor d
      ListOrTuple _ _ -> myDataToXmlWorker listTag d
      Builtin _ v -> unode dataItemTag v

class ToXml a where
  asXml :: a -> Element

instance Data a => ToXml a where
  asXml = myDataToXml . normalizeMyDataForSerialization . dataToMyData