module Happstack.Server.MinHaXML where
import Prelude hiding (elem, pi)
import Text.XML.HaXml.Types as Types
import Text.XML.HaXml.Escape
import Text.XML.HaXml.Pretty as Pretty
import Text.XML.HaXml.Verbatim as Verbatim
import Happstack.Util.Common
import Data.Maybe
import System.Time
import Happstack.Data.Xml as Xml
import Happstack.Data.Xml.HaXml
type StyleURL=String
data StyleSheet = NoStyle
| CSS {styleURL::StyleURL}
| XSL {styleURL::StyleURL} deriving (Read,Show)
hasStyleURL :: StyleSheet -> Bool
hasStyleURL NoStyle = False
hasStyleURL _ = True
type Element = Types.Element
isCSS :: StyleSheet -> Bool
isCSS (CSS _)=True
isCSS _ = False
isXSL :: StyleSheet -> Bool
isXSL = not.isCSS
t :: Name -> [(Name, String)] -> CharData -> Types.Element
t=textElem
l :: Name -> [(Name, String)] -> [Types.Element] -> Types.Element
l=listElem
e :: Name -> [(Name, String)] -> Types.Element
e=emptyElem
(</<) :: Name
-> [(Name, String)]
-> [Types.Element]
-> Types.Element
(</<)=l
(<>) :: Name -> [(Name, String)] -> CharData -> Types.Element
(<>)=t
xmlElem :: (t -> [Content])
-> Name
-> [(Name, String)]
-> t
-> Types.Element
xmlElem f = \name attrs val -> xmlelem name attrs (f val)
where
xmlelem name = Types.Elem name . map (uncurry attr)
attr name val= (name,AttValue [Left val])
textElem :: Name -> [(Name, String)] -> CharData -> Types.Element
textElem = xmlElem (return.CString True)
emptyElem :: Name -> [(Name, String)] -> Types.Element
emptyElem = \n a->xmlElem id n a []
listElem :: Name
-> [(Name, String)]
-> [Types.Element]
-> Types.Element
listElem = xmlElem $ map CElem
cdataElem :: CharData -> Content
cdataElem = CString False
simpleDocOld :: StyleSheet -> Types.Element -> String
simpleDocOld xsl = show . document .
flip (Document (simpleProlog xsl) []) [] . xmlStdEscape
simpleDoc :: StyleSheet -> Types.Element -> String
simpleDoc style elem = ("<?xml version='1.0' encoding='UTF-8' ?>\n"++
if hasStyleURL style then pi else "") ++
(verbatim $ xmlStdEscape elem)
where typeText=if isCSS style then "text/css" else "text/xsl"
pi= "<?xml-stylesheet type=\""++ typeText ++
"\" href=\""++styleURL style++"\" ?>\n"
simpleDoc' :: StyleSheet -> Types.Element -> String
simpleDoc' style elem = (if hasStyleURL style then pi else "") ++
(verbatim $ xmlStdEscape elem)
where typeText=if isCSS style then "text/css" else "text/xsl"
pi= "<?xml-stylesheet type=\""++ typeText ++
"\" href=\""++styleURL style++"\" ?>\n"
xmlEscaper :: XmlEscaper
xmlEscaper=stdXmlEscaper
xmlStdEscape :: Types.Element -> Types.Element
xmlStdEscape = xmlEscape stdXmlEscaper
verbim :: (Verbatim a) => a -> String
verbim = verbatim
simpleProlog :: StyleSheet -> Prolog
simpleProlog style =
Prolog
(Just (XMLDecl "1.0"
(Just $ EncodingDecl "UTF-8")
Nothing
))
[] Nothing
(if url=="" then [] else [pi])
where
pi = PI ("xml-stylesheet", "type=\""++typeText++"\" href=\""++url++"\"")
typeText = if isCSS style then "text/css" else "text/xsl"
url=if hasStyleURL style then styleURL style else ""
nonEmpty :: Name -> String -> Maybe Types.Element
nonEmpty name val = if val=="" then Nothing
else Just $ textElem name [] val
getRoot :: Document -> Types.Element
getRoot (Document _ _ root _) = root
data XML a = XML StyleSheet a
class ToElement x where toElement::x->Types.Element
instance (ToElement x) => ToElement (Maybe x) where
toElement = maybe (emptyElem "Nothing" []) toElement
instance ToElement String where toElement = textElem "String" []
instance ToElement Types.Element where toElement = id
instance ToElement CalendarTime where
toElement = recToEl "CalendarTime"
[attrFS "year" ctYear
,attrFS "month" (fromEnum.ctMonth)
,attrFS "day" ctDay
,attrFS "hour" ctHour
,attrFS "min" ctMin
,attrFS "sec" ctSec
,attrFS "time" time
] []
where time = epochPico
instance ToElement Int where toElement = toElement . show
instance ToElement Integer where toElement = toElement . show
instance ToElement Float where toElement = toElement . show
instance ToElement Double where toElement = toElement . show
instance (Xml a) => ToElement a where
toElement = un . head . map toHaXml . toXml
where
un (CElem el) = el
un _ = error "Case not handled in Xml toElement instance"
wrapElem :: (ToElement x) => Name -> x -> Types.Element
wrapElem tag x= listElem tag [] [toElement x]
elF :: (ToElement b) => Name -> (a -> b) -> a -> Types.Element
elF tag f = wrapElem tag.f
attrF :: t1 -> (t -> String) -> t -> (t1, String)
attrF name f rec = (name,quoteEsc $ f rec)
attrFS :: (Show a) => t1 -> (t -> a) -> t -> (t1, String)
attrFS name f rec = (name,quoteEsc $ show $ f rec)
attrFMb :: (a -> String)
-> String
-> (a1 -> Maybe a)
-> a1
-> (String, String)
attrFMb r name f = maybe ("","") (\x->(name,quoteEsc $ r x)) . f
quoteEsc :: String -> String
quoteEsc [] = []
quoteEsc ('"':list) = """ ++ quoteEsc list
quoteEsc (x:xs) = x:quoteEsc xs
recToEl :: Name
-> [a -> (String, String)]
-> [a -> Types.Element]
-> a
-> Types.Element
recToEl name attrs els rec = listElem name attrs' (revmap rec els)
where
attrs' = filter (\ (x,_)->not $ null x) (revmap rec attrs)
listToEl :: (ToElement a) =>
Name -> [(Name, String)] -> [a] -> Types.Element
listToEl name attrs = listElem name attrs . map toElement
toAttrs :: t -> [(t1, t -> t2)] -> [(t1, t2)]
toAttrs x = map (\ (s,f)->(s, f x))
newtype ElString = ElString {elString::String} deriving (Eq,Ord,Read,Show)