{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
-- | Emit an xml-like AST with renderers to String and 'Element'.
-- Intended for use with generated code.
module Fadno.Xml.EmitXml
    (
     -- * Rendering functions
     renderString
    ,renderElement
    ,renderFile
     -- * API types
    ,EmitXml (..)
    ,XmlRep (..)
    ,QN (..)
    ) where

import Data.Decimal
import Text.XML.Light
import Data.Maybe

-- | QName type.
data QN = QN { QN -> String
qLocal :: String, QN -> Maybe String
qPrefix :: Maybe String }
instance Show QN where
    show :: QN -> String
show (QN String
l Maybe String
Nothing) = String
l
    show (QN String
l (Just String
p)) = String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:String
l



-- | XML AST.
data XmlRep where
    XEmpty :: XmlRep
    XLit :: String -> XmlRep
    XShow :: Show a => a -> XmlRep
    XElement :: QN -> XmlRep -> XmlRep
    XAttr :: QN -> XmlRep -> XmlRep
    XText :: XmlRep -> XmlRep
    XContent :: { XmlRep -> XmlRep
xtext :: XmlRep,
                  XmlRep -> [XmlRep]
xattrs :: [XmlRep],
                  XmlRep -> [XmlRep]
xels :: [XmlRep] } -> XmlRep
    XReps :: [XmlRep] -> XmlRep

deriving instance Show XmlRep

-- | Emit AST.
class EmitXml a where
    emitXml :: a -> XmlRep


instance EmitXml a => EmitXml (Maybe a) where
    emitXml :: Maybe a -> XmlRep
emitXml Maybe a
Nothing = XmlRep
XEmpty
    emitXml (Just a
a) = a -> XmlRep
forall a. EmitXml a => a -> XmlRep
emitXml a
a

instance {-# OVERLAPPING #-} EmitXml String where
    emitXml :: String -> XmlRep
emitXml = String -> XmlRep
XLit

instance {-# OVERLAPPABLE #-} EmitXml a => EmitXml [a] where
    emitXml :: [a] -> XmlRep
emitXml = [XmlRep] -> XmlRep
XReps ([XmlRep] -> XmlRep) -> ([a] -> [XmlRep]) -> [a] -> XmlRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> XmlRep) -> [a] -> [XmlRep]
forall a b. (a -> b) -> [a] -> [b]
map a -> XmlRep
forall a. EmitXml a => a -> XmlRep
emitXml

instance EmitXml Int where emitXml :: Int -> XmlRep
emitXml = Int -> XmlRep
forall a. Show a => a -> XmlRep
XShow
instance EmitXml Decimal where emitXml :: Decimal -> XmlRep
emitXml = Decimal -> XmlRep
forall a. Show a => a -> XmlRep
XShow
instance EmitXml Float where emitXml :: Float -> XmlRep
emitXml = Float -> XmlRep
forall a. Show a => a -> XmlRep
XShow
instance EmitXml Double where emitXml :: Double -> XmlRep
emitXml = Double -> XmlRep
forall a. Show a => a -> XmlRep
XShow
instance EmitXml Bool where emitXml :: Bool -> XmlRep
emitXml = Bool -> XmlRep
forall a. Show a => a -> XmlRep
XShow


-- | render AST to String.
renderString :: XmlRep -> String
renderString :: XmlRep -> String
renderString (XElement QN
name XmlRep
rep) =
    String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ QN -> String
forall a. Show a => a -> String
show QN
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ XmlRep -> String
attrs XmlRep
rep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">" String -> ShowS
forall a. [a] -> [a] -> [a]
++ XmlRep -> String
text XmlRep
rep String -> ShowS
forall a. [a] -> [a] -> [a]
++ XmlRep -> String
els XmlRep
rep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"</" String -> ShowS
forall a. [a] -> [a] -> [a]
++ QN -> String
forall a. Show a => a -> String
show QN
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
    where
      attrs :: XmlRep -> String
attrs (XContent XmlRep
_ [XmlRep]
as [XmlRep]
_) = (XmlRep -> String) -> [XmlRep] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> String
attr [XmlRep]
as
      attrs (XReps [XmlRep]
rs) = (XmlRep -> String) -> [XmlRep] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> String
attrs [XmlRep]
rs
      attrs XmlRep
_ = String
""
      attr :: XmlRep -> String
attr (XAttr QN
n XmlRep
r) = String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ QN -> String
forall a. Show a => a -> String
show QN
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ XmlRep -> String
renderString XmlRep
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
      attr XmlRep
XEmpty = String
""
      attr XmlRep
r = ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"renderString.attr: invalid production: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ XmlRep -> String
forall a. Show a => a -> String
show XmlRep
r
      text :: XmlRep -> String
text (XContent XmlRep
t [XmlRep]
_ [XmlRep]
_) = XmlRep -> String
renderString XmlRep
t
      text (XReps [XmlRep]
rs) = (XmlRep -> String) -> [XmlRep] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> String
text [XmlRep]
rs
      text XmlRep
XEmpty = String
""
      text XmlRep
r = XmlRep -> String
renderString XmlRep
r
      els :: XmlRep -> String
els (XContent XmlRep
_ [XmlRep]
_ [XmlRep]
es) = (XmlRep -> String) -> [XmlRep] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> String
renderString [XmlRep]
es
      els (XReps [XmlRep]
rs) = (XmlRep -> String) -> [XmlRep] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> String
els [XmlRep]
rs
      els XmlRep
XEmpty = String
""
      els XmlRep
_ = String
""
renderString (XReps [XmlRep]
rs) = (XmlRep -> String) -> [XmlRep] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> String
renderString [XmlRep]
rs
renderString XmlRep
XEmpty = String
""
renderString (XLit String
s) = String
s
renderString (XShow a
a) = a -> String
forall a. Show a => a -> String
show a
a
renderString (XContent XmlRep
XEmpty [] [XmlRep]
els) = (XmlRep -> String) -> [XmlRep] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> String
renderString [XmlRep]
els
renderString XmlRep
r = ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"renderString: invalid production: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ XmlRep -> String
forall a. Show a => a -> String
show XmlRep
r

-- | render AST to Element.
renderElement :: XmlRep -> Element
renderElement :: XmlRep -> Element
renderElement (XElement QN
en XmlRep
rep) =
    QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (QN -> QName
qn QN
en)  (XmlRep -> [Attr]
attrs XmlRep
rep) (XmlRep -> [Content]
text XmlRep
rep [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ XmlRep -> [Content]
els XmlRep
rep) Maybe Line
forall a. Maybe a
Nothing
    where
      qn :: QN -> QName
qn (QN String
l Maybe String
p) = String -> Maybe String -> Maybe String -> QName
QName String
l Maybe String
forall a. Maybe a
Nothing Maybe String
p
      attrs :: XmlRep -> [Attr]
attrs (XContent XmlRep
_ [XmlRep]
as [XmlRep]
_) = (XmlRep -> [Attr]) -> [XmlRep] -> [Attr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> [Attr]
attr [XmlRep]
as
      attrs (XReps [XmlRep]
rs) = (XmlRep -> [Attr]) -> [XmlRep] -> [Attr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> [Attr]
attrs [XmlRep]
rs
      attrs XmlRep
_ = []
      attr :: XmlRep -> [Attr]
attr (XAttr QN
n XmlRep
r) = [QName -> String -> Attr
Attr (QN -> QName
qn QN
n) (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (XmlRep -> Maybe String
str XmlRep
r))]
      attr XmlRep
XEmpty = []
      attr XmlRep
r = String -> [Attr]
forall a. HasCallStack => String -> a
error (String -> [Attr]) -> String -> [Attr]
forall a b. (a -> b) -> a -> b
$ String
"renderElement.attr: invalid production: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ XmlRep -> String
forall a. Show a => a -> String
show XmlRep
r
      textmay :: XmlRep -> [Content]
textmay = [Content] -> (String -> [Content]) -> Maybe String -> [Content]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\String
s -> [CData -> Content
Text (CDataKind -> String -> Maybe Line -> CData
CData CDataKind
CDataRaw String
s Maybe Line
forall a. Maybe a
Nothing)]) (Maybe String -> [Content])
-> (XmlRep -> Maybe String) -> XmlRep -> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlRep -> Maybe String
str
      text :: XmlRep -> [Content]
text (XContent XmlRep
t [XmlRep]
_ [XmlRep]
_) = XmlRep -> [Content]
textmay XmlRep
t
      text (XReps [XmlRep]
r) = (XmlRep -> [Content]) -> [XmlRep] -> [Content]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> [Content]
text [XmlRep]
r
      text XmlRep
XEmpty = []
      text XmlRep
r = XmlRep -> [Content]
textmay XmlRep
r
      els :: XmlRep -> [Content]
els (XContent XmlRep
_ [XmlRep]
_ [XmlRep]
es) = (XmlRep -> [Content]) -> [XmlRep] -> [Content]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> [Content]
els [XmlRep]
es
      els e :: XmlRep
e@(XElement {}) = [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ XmlRep -> Element
renderElement XmlRep
e]
      els (XReps [XmlRep]
rs) = (XmlRep -> [Content]) -> [XmlRep] -> [Content]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlRep -> [Content]
els [XmlRep]
rs
      els XmlRep
XEmpty = []
      els XmlRep
_ = []
      str :: XmlRep -> Maybe String
str (XReps [XmlRep]
rs) = case [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ((XmlRep -> Maybe String) -> [XmlRep] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map XmlRep -> Maybe String
str [XmlRep]
rs) of
                         [] -> Maybe String
forall a. Maybe a
Nothing
                         [String]
ss -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
ss
      str XmlRep
XEmpty = Maybe String
forall a. Maybe a
Nothing
      str (XLit String
s) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
      str (XShow a
a) = String -> Maybe String
forall a. a -> Maybe a
Just (a -> String
forall a. Show a => a -> String
show a
a)
      str (XContent XmlRep
XEmpty [] [XmlRep]
es) = XmlRep -> Maybe String
str ([XmlRep] -> XmlRep
XReps [XmlRep]
es)
      str XmlRep
r = String -> Maybe String
forall a. HasCallStack => String -> a
error (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"renderElement.str: invalid production: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ XmlRep -> String
forall a. Show a => a -> String
show XmlRep
r
renderElement XmlRep
r = String -> Element
forall a. HasCallStack => String -> a
error (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ String
"renderElement: invalid production: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ XmlRep -> String
forall a. Show a => a -> String
show XmlRep
r


renderFile :: EmitXml a => FilePath -> a -> IO ()
renderFile :: String -> a -> IO ()
renderFile String
fp = String -> String -> IO ()
writeFile String
fp (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> String
ppTopElement (Element -> String) -> (a -> Element) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlRep -> Element
renderElement (XmlRep -> Element) -> (a -> XmlRep) -> a -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> XmlRep
forall a. EmitXml a => a -> XmlRep
emitXml