module Language.CSPM.AstToXML
(
moduleToXML
,astToXML
,showTopElement
)
where
import Text.XML.Light
import Data.Data
import Data.Generics.Aliases (extQ, ext1Q)
import Language.CSPM.AST
import Language.CSPM.SrcLoc as SrcLoc
moduleToXML :: Module a -> Element
moduleToXML m
= unode "Module"
[
unode "moduleDecls" $ astToXML $ moduleDecls m
,unode "modulePragmas" $ map
(unode "Pragma" . Attr (unqual "val"))
(modulePragmas m)
,unode "moduleComments" $ astToXML $ moduleComments m
]
astToXML :: Data a => a -> Element
astToXML
= genericCase `extQ` identToXML `ext1Q` labelToXML
`ext1Q` listToXML `extQ` intToXML `extQ` commentToXML
where
genericCase :: Data a => a -> Element
genericCase n = unode (showConstr $ toConstr n) $ gmapQ astToXML n
identToXML :: Ident -> Element
identToXML x = case x of
Ident s -> unode "Ident" (Attr (unqual "unIdent") s)
UIdent u -> unode "UIdent" $ uniqueIdentToXML u
labelToXML :: Data a => Labeled a -> Element
labelToXML l = add_attrs
( idAttr : location)
( astToXML $ unLabel l)
where
idAttr = strAttr "nodeId" $ show $ unNodeId $ nodeId l
location = srcLocAttr $ srcLoc l
listToXML :: Data a => [a] -> Element
listToXML = unode "list" . map astToXML
intToXML :: Integer -> Element
intToXML i = unode "Integer" $ strAttr "val" $ show i
uniqueIdentToXML n = unode "UniqueIdent"
[
strAttr "uniqueIdentId" $ show $ uniqueIdentId n
,strAttr "bindingSide" $ show $ bindingSide n
,strAttr "bindingLoc" $ "todo: bindingLoc"
,strAttr "idType" $ show $ idType n
,strAttr "realName" $ realName n
,strAttr "newName" $ newName n
,strAttr "prologMode" $ show $ prologMode n
,strAttr "bindType" $ show $ bindType n
]
strAttr a s = Attr (unqual a) s
srcLocAttr :: SrcLoc.SrcLoc -> [Attr]
srcLocAttr loc = case loc of
SrcLoc.TokPos {} -> [
locAttr "sLine" $ SrcLoc.getStartLine loc
, locAttr "sCol" $ SrcLoc.getStartCol loc
, locAttr "sPos" $ SrcLoc.getStartOffset loc
, locAttr "len" $ SrcLoc.getTokenLen loc
]
SrcLoc.TokSpan {} -> [
locAttr "sLine" $ SrcLoc.getStartLine loc
, locAttr "sCol" $ SrcLoc.getStartCol loc
, locAttr "eLine" $ SrcLoc.getEndLine loc
, locAttr "eCol" $ SrcLoc.getEndCol loc
, locAttr "sPos" $ SrcLoc.getStartOffset loc
, locAttr "len" $ SrcLoc.getTokenLen loc
]
SrcLoc.FixedLoc {} -> [
locAttr "sLine" $ SrcLoc.getStartLine loc
, locAttr "sCol" $ SrcLoc.getStartCol loc
, locAttr "eLine" $ SrcLoc.getEndLine loc
, locAttr "eCol" $ SrcLoc.getEndCol loc
, locAttr "sPos" $ SrcLoc.getStartOffset loc
, locAttr "len" $ SrcLoc.getTokenLen loc
]
_ -> []
locAttr s i = Attr (unqual s) $ show i
commentToXML :: (Comment,SrcLoc.SrcLoc) -> Element
commentToXML (comment,loc)
= add_attrs (srcLocAttr loc) $ case comment of
LineComment c -> unode "LineComment" $ strAttr "val" c
BlockComment c -> unode "BlockComment" $ strAttr "val" c
PragmaComment c -> unode "PragmaComment" $ strAttr "val" c