OMDocXml.hs revision da955132262baab309a50fdffe228c9efe68251d
{- |
Module : $Header$
Description : XML conversion for OMDoc-model (in\/out)
Copyright : (c) Hendrik Iben, Uni Bremen 2005-2007
License : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
Maintainer : hiben@informatik.uni-bremen.de
Stability : provisional
Portability : portable
XmlRepresentations for the OMDoc modelled in OMDoc.OMDocInterface
-}
module OMDoc.OMDocXml where
import OMDoc.OMDocInterface
import Text.XML.HXT.Parser ( (.>), (+=), (+++), getValue )
import qualified Text.XML.HXT.Parser as HXT hiding (run, trace, when)
import qualified OMDoc.XmlHandling as XML
import qualified Network.URI as URI
import qualified Data.List as List
import Data.Char
import qualified Network.HTTP.Base64 as Base64
import qualified Numeric as Numeric
import qualified OMDoc.Util as Util
import Debug.Trace (trace)
{- debug -}
maybeGetXml::String->IO (Maybe HXT.XmlTrees)
maybeGetXml source =
do
xml <- HXT.run' $
[
(HXT.a_source, source)
, (HXT.a_validate, HXT.v_0)
]
return
(let
status = (read $ HXT.xshow $ XML.getValue "status" (head xml))::Int
result = if status < HXT.c_err then (Just xml) else Nothing
in
result)
{--}
{- |
this class defines functions an instance has to provide to write it to
or read it from a HXT-Xml-structure
-}
class XmlRepresentable a where
-- | render instance to an XmlFilter
toXml :: a -> HXT.XmlFilter
-- | try to construct an instance from a single node
fromXml :: HXT.XmlTree -> Maybe a
getAllFromXml::forall a . (XmlRepresentable a)=>HXT.XmlTrees->[a]
getAllFromXml trees =
foldl
(\as xa ->
case fromXml xa of
Nothing -> as
(Just a) -> as ++ [a]
)
[]
trees
instance (XmlRepresentable x1, XmlRepresentable x2)=>XmlRepresentable (Either x1 x2) where
toXml (Left l) = toXml l
toXml (Right r) = toXml r
fromXml t =
case fromXml t of
Nothing ->
case fromXml t of
Nothing -> Nothing
(Just r) -> Just $ Right r
(Just l) -> Just $ Left l
-- | XML-representable Structure (convenience class, mostly used via inference)
class XmlRepStructure a where
toXmlS::a->HXT.XmlFilter
fromXmlS::HXT.XmlTrees->Maybe a
-- | structure of two sequential lists
instance (XmlRepresentable x1, XmlRepresentable x2)=>XmlRepStructure ([x1], [x2]) where
toXmlS (t1l, t2l) =
let
t1f =
foldl
(\ts t ->
ts +++ toXml t +++ XML.xmlNL
)
t1l
t2f =
foldl
(\ts t ->
ts +++ toXml t +++ XML.xmlNL
)
t2l
in
t1f +++ t2f
fromXmlS xl =
let
(t1l, t2l, _) =
until
(\(_, _, (xl', _)) -> null xl' )
(\(t1l', t2l', (h:xl', get1)) ->
if get1
then
case fromXml h of
Nothing -> (t1l', t2l', (h:xl', False))
(Just t1) -> (t1l' ++ [t1::x1], t2l', (xl', get1))
else
case fromXml h of
Nothing -> (t1l', t2l', ([], get1))
(Just t2) -> (t1l', t2l' ++ [t2::x2], (xl', get1))
)
([],[],(XML.applyXmlFilter HXT.isXTag xl, True))
in
Just (t1l, t2l)
-- | structure of a tupel-list
instance (XmlRepresentable x1, XmlRepresentable x2) => XmlRepStructure [(x1, x2)] where
toXmlS tl =
foldl
(\xs (t1,t2) ->
xs +++ toXml t1 +++ toXml t2 +++ XML.xmlNL
)
tl
fromXmlS xl =
let
(l, _) =
until
(\(_, xl') -> length xl' < 2)
(\(l', (x1:x2:xr)) ->
case (fromXml x1, fromXml x2) of
(Just t1, Just t2) ->
(l' ++ [(t1, t2)], xr)
_ -> (l', [])
)
([], xl)
in
Just l
-- | Any list of XmlRepresentable-instances can be written in sequence
instance (XmlRepresentable x)=>XmlRepStructure [x] where
toXmlS tl =
foldl
(\ts t ->
ts +++ toXml t +++ XML.xmlNL
)
tl
fromXmlS = Just . getAllFromXml
-- | OMDoc
instance XmlRepresentable OMDoc where
toXml o =
HXT.etag "omdoc"
+= (
HXT.sattr "xmlns" "http://www.mathweb.org/omdoc"
+++
XML.qualattr "xml" "id" (omdocId o)
+++
foldl
(\ts t ->
ts +++ XML.xmlNL +++ toXml t
)
(omdocTheories o)
+++
foldl
(\is i ->
is +++ XML.xmlNL +++ toXml i
)
(omdocInclusions o)
)
fromXml t =
case (HXT.isTag "omdoc" t) of
[] -> Nothing
_ ->
let
children = HXT.getChildren t
ids = HXT.xshow $ XML.getQualValue "xml" "id" t
thes =
getAllFromXml children
incs =
getAllFromXml children
in
Just $ OMDoc ids thes incs
-- | Theory
instance XmlRepresentable Theory where
toXml the =
let
tId = theoryId the
(mTheoryPres, _, trempres) =
until
(\(_, rp, _) -> null rp)
(\(_, (p:pr), rl) ->
if tId == (presentationForId p)
then
(Just p, [], rl ++ pr)
else
(Nothing, pr, rl ++ [p])
)
(Nothing, (theoryPresentations the), [])
(conx, conrempres) =
foldl
(\(cx, rp) con ->
let
presnames =
getIdsForPresentation con
(thispres, rempres) =
(\pres ->
elem (presentationForId pres) presnames
)
rp
in
(
cx
+++
toXml con
+++
toXmlS thispres
, rempres
)
)
(XML.xmlNullFilter, trempres)
(theoryConstitutives the)
in
HXT.etag "theory"
+= (
XML.qualattr "xml" "id" (theoryId the)
+++
case theoryComment the of
Nothing -> XML.xmlNullFilter
+++
(
case mTheoryPres of
Nothing -> XML.xmlNullFilter
(Just p) -> toXml p
)
+++
conx
+++
toXmlS conrempres
)
fromXml t =
case (HXT.isTag "theory") t of
[] -> Nothing
_ ->
let
comments = HXT.getXCmt t
tcom =
case Util.trimString (HXT.xshow comments) of
[] -> Nothing
cs -> Just cs
children = HXT.getChildren t
ids = HXT.xshow $ XML.getQualValue "xml" "id" t
cons = getAllFromXml children
pres =
getAllFromXml children
in
Just $ (Theory ids cons pres tcom)
-- | Imports
instance XmlRepresentable Imports where
toXml imp =
HXT.etag "imports"
+= (
HXT.sattr "from" (showURI $ importsFrom imp)
+++
(
case (importsId imp) of
(Just i) -> XML.qualattr "xml" "id" i
_ -> XML.xmlNullFilter
)
{- +++
(
case importsMorphism imp of
Nothing -> XML.xmlNullFilter
(Just m) ->
case morphismHiding m of
[] -> XML.xmlNullFilter
h -> HXT.sattr "hiding" (Util.implode " " h)
{-
if null (importsHiding imp)
then
else
HXT.sattr "hiding" (Util.implode " " (importsHiding imp))
-}
)-}
+++
(
"type"
(
case (importsType imp) of
ITLocal -> "local"
ITGlobal -> "global"
)
)
+++
(
case (importsConservativity imp) of
CNone -> XML.xmlNullFilter
c -> HXT.sattr "conservativity" (show c)
)
+++
(
case (importsMorphism imp) of
Nothing ->
)
)
fromXml t =
case (HXT.isTag "imports") t of
[] -> Nothing
_ ->
let
froms = HXT.xshow $ HXT.getValue "from" t
mfromuri =
if length froms < 1
then
Nothing
else
URI.parseURIReference froms
{- hidings =
filter
(not . null)
$
map
$
" "
$
$
HXT.getValue "hiding" t -}
mid =
case HXT.xshow $ XML.getQualValue "xml" "id" t of
[] -> Nothing
s -> Just s
itype =
case map toLower $ HXT.xshow $ HXT.getValue "type" t of
[] -> ITGlobal
"global" -> ITGlobal
"local" -> ITLocal
u -> trace ("Unknown Import-Type : " ++ u) ITGlobal
mm =
case (HXT.getChildren .> HXT.isTag "morphism") t of
[] -> Nothing
(xm:_) -> fromXml xm
conss = HXT.xshow $ HXT.getValue "conservativity" t
cons =
case readsPrec 0 conss of
[] -> CNone
((c,_):_) -> c
in
case mfromuri of
Nothing ->
trace ("No 'from' in Imports!") Nothing
(Just u) ->
Just $ Imports u mm mid itype cons
-- | Use
instance XmlRepresentable Use where
toXml u =
HXT.etag "use"
+= (
HXT.sattr "format" (useFormat u)
+++
HXT.txt (useValue u)
)
fromXml t =
case (HXT.isTag "use") t of
[] -> Nothing
_ ->
let
formats = HXT.xshow $ HXT.getValue "format" t
values = HXT.xshow $ HXT.getChildren t
in
Just $ Use formats values
-- | Presentation
instance XmlRepresentable Presentation where
toXml pres =
let
xuses =
if length (presentationUses pres) == 0
then
else
foldl
(\us u ->
us +++ toXml u +++ XML.xmlNL
)
(presentationUses pres)
in
HXT.etag "presentation"
+= (
HXT.sattr "for" ("#" ++ (presentationForId pres))
+++
(
case (presentationSystem pres) of
Nothing -> XML.xmlNullFilter
(Just sys) -> HXT.sattr "system" sys
)
+++
xuses
)
fromXml t =
case (HXT.isTag "presentation") t of
[] -> Nothing
_ ->
let
fors' = HXT.xshow $ HXT.getValue "for" t
fors =
case fors' of
[] -> trace ("Missing 'for' attribute in presentation...") ""
('#':rid) -> rid
s -> trace ("Presentation 'for' attribute is no omdocref...") s
systems = case HXT.xshow $ HXT.getValue "system" t of
[] -> Nothing
s -> Just s
uses =
getAllFromXml (HXT.getChildren t)
in
Just $ Presentation fors systems uses
-- | Symbol
instance XmlRepresentable Symbol where
toXml s =
HXT.etag "symbol"
+= (
HXT.sattr "role" (show $ symbolRole s)
+++
HXT.sattr "name" (symbolId s)
+++
(
case (symbolGeneratedFrom s) of
Nothing -> XML.xmlNullFilter
(Just g) ->
HXT.sattr "generated-from" g
)
+++
(
case (symbolType s) of
Nothing -> XML.xmlNullFilter
(Just t) ->
+++
toXml t
+++
)
)
fromXml t =
case (HXT.isTag "symbol") t of
[] -> Nothing
_ ->
let
roles = HXT.xshow $ HXT.getValue "role" t
names = HXT.xshow $ HXT.getValue "name" t
ids = HXT.xshow $ XML.getQualValue "xml" "id" t
sname =
case names of
[] -> ids
_ -> names
mgf =
case HXT.xshow $ HXT.getValue "generated-from" t of
[] -> Nothing
gf -> Just gf
in
case readsPrec 0 roles of
[] ->
if Util.isPrefix "ymmud" (reverse sname)
then
Nothing
else
trace ("Unknown role \"" ++ roles ++ "\" for symbol " ++ sname)
Nothing
(sr,_):_ ->
let
typechilds = (HXT.getChildren .> HXT.isTag "type") t
in
case typechilds of
[] -> Just $ Symbol mgf sname sr Nothing
_ ->
case fromXml (head typechilds) of
Nothing -> trace ("cant parse type...") Nothing
jty -> Just $ Symbol mgf sname sr jty
-- | Type
instance XmlRepresentable Type where
toXml t =
HXT.etag "type"
+= (
(
case typeSystem t of
Nothing -> XML.xmlNullFilter
(Just ts) -> HXT.sattr "system" (showURI ts)
)
+++
+++
toXml (typeOMDocMathObject t)
+++
)
fromXml t =
case (HXT.isTag "type") t of
[] -> Nothing
_ ->
let
systems = HXT.xshow $ HXT.getValue "system" t
omchilds =
(
(
HXT.isTag "OMOBJ"
+++
HXT.isTag "math"
+++
HXT.isTag "legacy"
)
) t
in
case omchilds of
[] -> trace ("No Math-Object in type!") Nothing
_ ->
case fromXml (head omchilds) of
Nothing -> trace "error parsing omobj..." Nothing
(Just omobj) ->
let
typebody = (\u -> Type { typeSystem = u, typeOMDocMathObject = omobj })
in
if length systems > 0
then
case URI.parseURIReference systems of
Nothing -> trace ("Error parsing system-URI") Nothing
jsuri -> Just $ typebody jsuri
else
Just $ typebody Nothing
-- | Any Constitutive
instance XmlRepresentable Constitutive where
toXml (CAx ax) = toXml ax
toXml (CDe de) = toXml de
toXml (CSy sy) = toXml sy
toXml (CIm im) = toXml im
toXml (CAd ad) = toXml ad
toXml (CCo { conComCmt = cmt, conComCon = con }) =
fromXml t =
case fromXml t of
(Just a) -> Just $ CAx a
Nothing ->
case fromXml t of
(Just d) -> Just $ CDe d
Nothing ->
case fromXml t of
(Just s) -> Just $ CSy s
Nothing ->
case fromXml t of
(Just i) -> Just $ CIm i
Nothing ->
case fromXml t of
(Just a) -> Just $ CAd a
Nothing -> Nothing
-- | Axiom
instance XmlRepresentable Axiom where
toXml axiom =
HXT.etag "axiom"
+= (
XML.qualattr "xml" "id" (axiomName axiom)
+++
(
if null $ axiomCMPs axiom
then
else
toXmlS (axiomCMPs axiom)
)
+++
(
if null $ axiomFMPs axiom
then
else
toXmlS (axiomFMPs axiom)
)
)
fromXml t =
case (HXT.isTag "axiom") t of
[] -> Nothing
_ ->
let
ids = HXT.xshow $ XML.getQualValue "xml" "id" t
children = HXT.getChildren t
cmps = getAllFromXml children
fmps = getAllFromXml children
in
case ids of
[] -> trace "no id for axiom!" Nothing
_ -> Just $ Axiom ids cmps fmps
-- | CMP
instance XmlRepresentable CMP where
toXml cmp =
HXT.etag "CMP"
+= (
+++
toXml (cmpContent cmp)
)
fromXml t =
case (HXT.isTag "CMP") t of
[] -> Nothing
_ -> Just $ CMP $ MTextText $ HXT.xshow $ HXT.getChildren t
-- | FMP
instance XmlRepresentable FMP where
toXml fmp =
HXT.etag "FMP"
+= (
(
case fmpLogic fmp of
Nothing -> XML.xmlNullFilter
(Just l) -> HXT.sattr "logic" l
)
+++
case fmpContent fmp of
(Left o) -> toXml o
(Right ac) -> toXmlS ac
)
fromXml t =
case (HXT.isTag "FMP") t of
[] -> Nothing
_ ->
let
logics = HXT.xshow $ HXT.getValue "logic" t
logic = if length logics < 1 then Nothing else Just logics
children = HXT.getChildren t
omchildren = (HXT.getChildren .> HXT.isTag "OMOBJ") t
in
case children of
[] -> trace ("empty FMP!") Nothing
_ ->
case omchildren of
[] ->
case fromXmlS children of
Nothing -> trace "Wierd!" Nothing
(Just ac) -> Just $ FMP logic (Right ac)
_ ->
case fromXml $ head omchildren of
Nothing -> Nothing
(Just o) -> Just $ FMP logic (Left o)
-- | Assumption
instance XmlRepresentable Assumption where
toXml _ = HXT.etag "assumption"
fromXml t =
case (HXT.isTag "assumption") t of
[] -> Nothing
_ -> Just Assumption
-- | Conclusion
instance XmlRepresentable Conclusion where
toXml _ = HXT.etag "conclusion"
fromXml t =
case (HXT.isTag "conclusion") t of
[] -> Nothing
_ -> Just Conclusion
-- | Definition
instance XmlRepresentable Definition where
toXml def =
HXT.etag "symbol"
+= (
XML.qualattr "xml" "id" ((definitionId def) ++ "-dummy")
)
+++
+++
HXT.etag "definition"
+= (
XML.qualattr "xml" "id" (definitionId def)
+++
HXT.sattr "for" ((++) "#" $ (++) (definitionId def) "-dummy" )
+++
HXT.sattr "type" "implicit"
+++
toXmlS (definitionCMPs def)
+++
toXmlS (definitionFMPs def)
)
fromXml t =
case (HXT.isTag "definition") t of
[] -> Nothing
_ ->
let
ids = HXT.xshow $ XML.getQualValue "xml" "id" t
fors =
case HXT.xshow $ HXT.getValue "for" t of
'#':r -> r
r -> r
ids' = case ids of [] -> fors; _ -> ids
children = HXT.getChildren t
cmps = getAllFromXml children
fmps = getAllFromXml children
in
case ids' of
[] -> trace "no id in definition" Nothing
_ -> Just $ Definition ids' cmps fmps
-- | SortDef
instance XmlRepresentable SortDef where
toXml sd =
HXT.etag "sortdef"
+= (
HXT.sattr "name" (sortDefName sd)
+++
HXT.sattr "role" (show $ sortDefRole sd)
+++
HXT.sattr "type" (show $ sortDefType sd)
+++
toXmlS (sortDefConstructors sd)
+++
toXmlS (sortDefInsorts sd)
+++
toXmlS (sortDefRecognizers sd)
)
fromXml t =
case HXT.isTag "sortdef" t of
[] -> Nothing
_ ->
let
sdNameS = HXT.xshow $ HXT.getValue "name" t
sdRoleS = HXT.xshow $ HXT.getValue "role" t
sdTypeS = HXT.xshow $ HXT.getValue "type" t
sdRole =
case sdRoleS of
[] -> SRSort
_ ->
case readsPrec 0 sdRoleS of
[] -> trace ("Invalid Role : \"" ++ sdRoleS ++ "\"") SRSort
((sdR,_):_) -> sdR
sdType =
case sdTypeS of
[] -> STFree
_ ->
case readsPrec 0 sdTypeS of
[] -> trace ("Invalid Type : \"" ++ sdTypeS ++ "\"") STFree
((sdT,_):_) -> sdT
xchildren = HXT.getChildren t
cons = getAllFromXml xchildren
insorts = getAllFromXml xchildren
recognizers = getAllFromXml xchildren
in
case sdNameS of
[] -> trace ("SortDef for Nothing!") Nothing
_ ->
Just $ SortDef sdNameS sdRole sdType cons insorts recognizers
-- | Constructor
instance XmlRepresentable Constructor where
toXml con =
HXT.etag "constructor"
+= (
HXT.sattr "name" (constructorName con)
+++
HXT.sattr "role" (show $ constructorRole con)
+++
(
foldl
(\cx a ->
cx
+++
HXT.etag "argument"
+= (
toXml a
)
+++
)
(constructorArguments con)
)
)
fromXml t =
case HXT.isTag "constructor" t of
[] -> Nothing
_ ->
let
cNameS = HXT.xshow $ HXT.getValue "name" t
cRoleS = HXT.xshow $ HXT.getValue "role" t
cRole =
case cRoleS of
[] -> SRObject
_ ->
case readsPrec 0 cRoleS of
[] -> trace ("Invalid Role : \"" ++ cRoleS ++ "\"") SRObject
((cR,_):_) -> cR
argsxml = (HXT.getChildren .> HXT.isTag "argument") t
args =
foldl
(\as at ->
let
typechilds = (HXT.getChildren .> HXT.isTag "type") at
in
case typechilds of
[] -> trace ("no type in argument!") as
[tc] ->
case fromXml tc of
Nothing -> trace ("could not parse type!") as
(Just ty) -> as ++ [ty]
(tc:_) ->
case fromXml tc of
Nothing -> trace ("could not parse type and there are more!") as
(Just ty) -> trace ("more than one type in argument!") (as ++ [ty])
)
[]
argsxml
in
case cNameS of
[] -> trace ("No Name for Constructor!") Nothing
_ -> Just $ Constructor cNameS cRole args
-- | Insort
instance XmlRepresentable Insort where
toXml i =
HXT.etag "insort"
+= (
HXT.sattr "for" (showURI $ insortFor i)
)
fromXml t =
case HXT.isTag "insort" t of
[] -> Nothing
_ ->
let
forS = HXT.xshow $ HXT.getValue "for" t
in
case URI.parseURIReference forS of
Nothing -> trace ("No for...") Nothing
(Just u) -> Just $ Insort u
-- | Recognizer
instance XmlRepresentable Recognizer where
toXml i =
HXT.etag "recognizer"
+= (
HXT.sattr "name" (recognizerName i)
)
fromXml t =
case HXT.isTag "recognizer" t of
[] -> Nothing
_ ->
let
nameS = HXT.xshow $ HXT.getValue "name" t
in
case nameS of
"" -> trace ("No name...") Nothing
_ -> Just $ Recognizer nameS
-- | ADT
instance XmlRepresentable ADT where
toXml adt =
HXT.etag "adt"
+= (
(
case adtId adt of
Nothing -> XML.xmlNullFilter
(Just aid) -> XML.qualattr "xml" "id" aid
)
+++
(
toXmlS (adtSortDefs adt)
)
)
fromXml t =
case (HXT.isTag "adt") t of
[] -> Nothing
_ ->
let
xchildren = HXT.getChildren t
maid =
case HXT.xshow $ XML.getQualValue "xml" "id" t of
[] -> Nothing
s -> Just s
sds = getAllFromXml xchildren
in
Just $ ADT maid sds
-- | Inclusion
instance XmlRepresentable Inclusion where
toXml ti@(TheoryInclusion {}) =
HXT.etag "theory-inclusion"
+= (incBody ti)
toXml ai@(AxiomInclusion {}) =
HXT.etag "axiom-inclusion"
+= (incBody ai)
fromXml t =
case (HXT.isTag "axiom-inclusion") t of
[] ->
case (HXT.isTag "theory-inclusion") t of
[] -> Nothing
_ ->
case getIncBody of
Nothing -> Nothing
(Just (from,to,mm,mi,c)) -> Just $ TheoryInclusion from to mm mi c
_ ->
case getIncBody of
Nothing -> Nothing
(Just (from,to,mm,mi,c)) -> Just $ AxiomInclusion from to mm mi c
where
getIncBody =
let
froms = HXT.xshow $ HXT.getValue "from" t
tos = HXT.xshow $ HXT.getValue "to" t
fromuri = URI.parseURIReference froms
touri = URI.parseURIReference tos
ids = HXT.xshow $ XML.getQualValue "xml" "id" t
mid = if (length ids) > 0 then Just ids else Nothing
conss = HXT.xshow $ HXT.getValue "conservativity" t
cons =
case readsPrec 0 conss of
[] -> CNone
((c,_):_) -> c
mm = case (HXT.getChildren .> HXT.isTag "morphism") t of
[] -> Nothing
(xm:_) -> fromXml xm
in
if ( (length froms) < 1 || (length tos) < 1 )
then
trace
("No 'from' or no 'to' in Inclusion!")
Nothing
else
case (fromuri, touri) of
(Just fu, Just tu) ->
Just (fu, tu, mm, mid, cons)
_ -> trace ("Error parsing inclusion source or target!") Nothing
-- | used by Inclusion
incBody::
Inclusion
incBody tinc =
(
HXT.sattr "from" (showURI $ inclusionFrom tinc)
+++
HXT.sattr "to" (showURI $ inclusionTo tinc)
+++
(
case (inclusionId tinc) of
(Just i) -> XML.qualattr "xml" "id" i
_ -> XML.xmlNullFilter
)
-- conservativity has been removed from OMDoc-RNG
{-
+++
(
case (inclusionConservativity tinc) of
CNone -> XML.xmlNullFilter
c -> HXT.sattr "conservativity" (show c)
)
-}
+++
(
case (inclusionMorphism tinc) of
_ -> XML.xmlNullFilter
)
)
-- | Mathematical Text
instance XmlRepresentable MText where
toXml (MTextText x) = HXT.txt x
toXml (MTextOM omobj) = toXml omobj
fromXml t =
case (HXT.isTag "term") t of
[] ->
case (HXT.isTag "phrase") t of
[] ->
case (HXT.isTag "OMOBJ") t of
[] -> Nothing
_ ->
case fromXml t of
Nothing -> Nothing
(Just omobj) -> Just $ MTextOM omobj
_ ->
Just $ MTextPhrase (HXT.xshow $ HXT.getChildren t)
_ ->
Just $ MTextTerm (HXT.xshow $ HXT.getChildren t)
-- | Math Object
instance XmlRepresentable OMDocMathObject where
toXml (OMOMOBJ omobj) = toXml omobj
fromXml t =
case fromXml t of
(Just x) -> Just $ OMOMOBJ x
_ ->
case (HXT.isTag "legacy") t of
[] ->
case (HXT.isTag "math") t of
[] -> Nothing
_ -> Just $ OMMath (HXT.xshow $ HXT.getChildren t)
_ ->
Just $ OMLegacy (HXT.xshow $ HXT.getChildren t)
-- | OpenMath Object
instance XmlRepresentable OMObject where
toXml (OMObject e) =
HXT.etag "OMOBJ"
+=(
HXT.sattr "xmlns" "http://www.openmath.org/OpenMath"
+++
+++
toXml e
+++
)
fromXml t =
case (HXT.isTag "OMOBJ") t of
[] -> Nothing
_ ->
case (HXT.getChildren .> HXT.isXTag) t of
[] -> trace ("Empty OMOBJ!") Nothing
xoe ->
case fromXml (head xoe) of
Nothing -> Nothing
(Just e) -> Just $ OMObject e
-- | OMS
instance XmlRepresentable OMSymbol where
toXml oms =
HXT.etag "OMS"
+= (
(
case omsCDBase oms of
Nothing ->
(Just uri) ->
HXT.sattr "cdbase" (showURI uri)
)
+++ HXT.sattr "cd" (omsCD oms)
+++ HXT.sattr "name" (omsName oms)
)
fromXml t =
case (HXT.isTag "OMS") t of
[] -> Nothing
_ ->
let
cdbases = HXT.xshow $ getValue "cdbase" t
cds = HXT.xshow $ getValue "cd" t
names = HXT.xshow $ getValue "name" t
mref =
case cdbases of
[] ->
Nothing
s ->
case URI.parseURIReference s of
Nothing ->
trace
("Invalid CDBase in OMS!")
Nothing
mValidURI ->
mValidURI
in
Just $ OMS mref cds names
-- | OMI
instance XmlRepresentable OMInteger where
toXml omi =
HXT.etag "OMI"
+= ( HXT.txt (show $ omiInt omi) )
fromXml t =
case (HXT.isTag "OMI") t of
[] -> Nothing
_ ->
let
content = HXT.xshow $ HXT.getChildren t
in
case readsPrec 0 content of
[] ->
trace
("Invalid Integer in OMI : \"" ++ content ++ "\"!")
Nothing
((i,_):_) -> Just $ OMI i
-- | A Variable (OMV, OMATTR)
instance XmlRepresentable OMVariable where
toXml (OMVS omv) = toXml omv
toXml (OMVA omattr) = toXml omattr
fromXml t =
case (HXT.isTag "OMV") t of
[] ->
case (HXT.isTag "OMATTR") t of
[] -> Nothing
_ ->
case fromXml t of
Nothing -> Nothing
(Just omattr) -> Just (OMVA omattr)
_ ->
case fromXml t of
Nothing -> Nothing
(Just omv) -> Just (OMVS omv)
-- | OMV
instance XmlRepresentable OMSimpleVariable where
toXml omv =
HXT.etag "OMV"
+= (HXT.sattr "name" (omvName omv))
fromXml t =
case (HXT.isTag "OMV") t of
[] -> Nothing
_ ->
let
names = HXT.xshow $ getValue "name" t
in
if null names
then
trace
("Variable with empty name : \"" ++ (HXT.xshow [t]) ++ "\"!")
Nothing
else
Just $ OMV names
-- | OMATTR
instance XmlRepresentable OMAttribution where
toXml attr =
HXT.etag "OMATTR"
+= ( toXml (omattrATP attr) +++ toXml (omattrElem attr) )
fromXml t =
case (HXT.isTag "OMATTR") t of
[] -> Nothing
_ ->
case (HXT.getChildren .> HXT.isXTag) t of
[xatp, xe] ->
case (fromXml xatp, fromXml xe) of
(Just atp, Just e) -> Just $ OMATTR atp e
_ -> trace ("Error processing OMATTR!") Nothing
_ -> trace ("Invalid OMATTR-Content!") Nothing
-- | OMATP
instance XmlRepresentable OMAttributionPart where
toXml atp =
HXT.etag "OMATP"
+= (
foldl
(\a (s, e) ->
a +++ (toXml s) +++ (toXml e) +++ XML.xmlNL
)
(omatpAttribs atp)
)
fromXml t =
case (HXT.isTag "OMATP") t of
[] -> Nothing
_ ->
let
attribs =
foldl
(\a (xs, xe) ->
case (fromXml xs, fromXml xe) of
(Just s, Just e) ->
a ++ [(s, e)]
_ ->
trace
("Error processing attribution...")
a
)
[]
in
Just $ OMATP attribs
-- | OMBVAR
instance XmlRepresentable OMBindingVariables where
toXml ombvar =
HXT.etag "OMBVAR"
+= (
foldl
(\vs v ->
vs +++ toXml v
)
(ombvarVars ombvar)
)
fromXml t =
case (HXT.isTag "OMBVAR") t of
[] -> Nothing
_ ->
let
xchildren = (HXT.getChildren .> HXT.isXTag) t
vars =
foldl
(\vs xv ->
case fromXml xv of
Nothing ->
trace
("error processing variable in binding")
vs
(Just v) -> vs ++ [v]
)
[]
xchildren
in
Just $ OMBVAR vars
-- | OMB
instance XmlRepresentable OMBase64 where
toXml omb =
HXT.etag "OMB"
+= ( HXT.txt (Base64.encode (ombContent omb)) )
fromXml t =
case (HXT.isTag "OMB") t of
[] -> Nothing
_ ->
let
in
Just $ OMB content
-- | OMSTR
instance XmlRepresentable OMString where
toXml omstr =
HXT.etag "OMSTR"
+= ( HXT.txt (omstrText omstr) )
fromXml t =
case (HXT.isTag "OMSTR") t of
[] -> Nothing
_ ->
let
content = HXT.xshow $ HXT.getChildren t
in
Just $ OMSTR content
-- | OMF
instance XmlRepresentable OMFloat where
toXml omf =
HXT.etag "OMF"
+= ( HXT.sattr "dec" (show (omfFloat omf) ) )
fromXml t =
case (HXT.isTag "OMF") t of
[] -> Nothing
_ ->
let
deccontent = HXT.xshow $ HXT.getValue "dec" t
hexcontent = HXT.xshow $ HXT.getValue "hex" t
dec = Numeric.readSigned Numeric.readFloat deccontent
hex = Numeric.readSigned Numeric.readHex hexcontent
decerror = ("error parsing float : \"" ++ deccontent ++ "\"")
hexerror = ("error parsing float : \"" ++ hexcontent ++ "\"")
in
if length deccontent > 0
then
case dec of
[] -> trace decerror Nothing
(d,r):_ ->
case r of
[] -> Just $ OMF d
_ -> trace decerror Nothing
else
if length hexcontent > 0
then
case hex of
[] -> trace hexerror Nothing
(h,r):_ ->
case r of
[] -> Just $ OMF (fromIntegral (h::Integer))
_ -> trace hexerror Nothing
else
trace ("No Number!") Nothing
-- | OMA
instance XmlRepresentable OMApply where
toXml oma =
HXT.etag "OMA"
+= (
foldl
(\es e ->
es +++ toXml e
)
(omaElements oma)
)
fromXml t =
case (HXT.isTag "OMA") t of
[] -> Nothing
_ ->
let
xchildren = (HXT.getChildren .> HXT.isXTag) t
elems =
foldl
(\es xe ->
case fromXml xe of
Nothing -> trace ("error processing OMA Element!") es
(Just e) -> es ++ [e]
)
[]
xchildren
in
Just $ OMA elems
-- | OME
instance XmlRepresentable OMError where
toXml ome =
HXT.etag "OME"
+= (
toXml (omeSymbol ome) +++ XML.xmlNL
+++
foldl
(\es e ->
es +++ toXml e +++ XML.xmlNL
)
(omeExtra ome)
)
fromXml t =
case (HXT.isTag "OME") t of
[] -> Nothing
_ ->
let
xchildren = (HXT.getChildren .> HXT.isXTag) t
in
case xchildren of
[] -> trace ("No children in OME!") Nothing
(xs:xel) ->
let
elems =
foldl
(\es xe ->
case fromXml xe of
Nothing -> trace ("error reading error element!") es
(Just e) -> es ++ [e]
)
[]
xel
in
case fromXml xs of
(Just (oms@(OMS {}))) -> Just $ OME oms elems
_ -> trace ("OME does not start with OMS-element!") Nothing
-- | OMR
instance XmlRepresentable OMReference where
toXml omr =
HXT.etag "OMR"
+= (HXT.sattr "href" (showURI (omrHRef omr)))
fromXml t =
case (HXT.isTag "OMR") t of
[] -> Nothing
_ ->
let
uris = HXT.xshow $ HXT.getValue "href" t
in
case URI.parseURIReference uris of
Nothing -> trace ("Error parsing OMR-URI!") Nothing
(Just uri) -> Just $ OMR uri
-- | OMBIND
instance XmlRepresentable OMBind where
toXml ombind =
HXT.etag "OMBIND"
+= (
toXml (ombindBinder ombind) +++ XML.xmlNL
+++
toXml (ombindVariables ombind) +++ XML.xmlNL
+++
toXml (ombindExpression ombind)
)
fromXml t =
case (HXT.isTag "OMBIND") t of
[] -> Nothing
_ ->
let
xchildren = (HXT.getChildren .> HXT.isXTag) t
in
case xchildren of
[xbinder, xvars, xexpr] ->
case (fromXml xbinder, fromXml xvars, fromXml xexpr) of
(Just binder, Just vars, Just expr) ->
Just $ OMBIND binder vars expr
_ -> trace ("error reading OMBIND!") Nothing
_ -> trace ("invalid OMBIND-content!") Nothing
-- | Any OpenMath Element
instance XmlRepresentable OMElement where
toXml (OMES s) = toXml s
toXml (OMEV v) = toXml v
toXml (OMEI i) = toXml i
toXml (OMEB b) = toXml b
toXml (OMESTR s) = toXml s
toXml (OMEF f) = toXml f
toXml (OMEA a) = toXml a
toXml (OMEBIND b) = toXml b
toXml (OMEE e) = toXml e
toXml (OMEATTR a) = toXml a
toXml (OMER r) = toXml r
toXml (OMEC me c) =
case me of
Nothing ->
HXT.cmt c
(Just e) ->
fromXml t =
case HXT.getNode t of
(HXT.XTag qn _) ->
case HXT.localPart qn of
"OMS" ->
case fromXml t of
Nothing -> Nothing
(Just s) -> Just $ OMES s
"OMV" ->
case fromXml t of
Nothing -> Nothing
(Just v) -> Just $ OMEV v
"OMI" ->
case fromXml t of
Nothing -> Nothing
(Just i) -> Just $ OMEI i
"OMB" ->
case fromXml t of
Nothing -> Nothing
(Just b) -> Just $ OMEB b
"OMSTR" ->
case fromXml t of
Nothing -> Nothing
(Just s) -> Just $ OMESTR s
"OMF" ->
case fromXml t of
Nothing -> Nothing
(Just f) -> Just $ OMEF f
"OMA" ->
case fromXml t of
Nothing -> Nothing
(Just a) -> Just $ OMEA a
"OMBIND" ->
case fromXml t of
Nothing -> Nothing
(Just b) -> Just $ OMEBIND b
"OME" ->
case fromXml t of
Nothing -> Nothing
(Just e) -> Just $ OMEE e
"OMATTR" ->
case fromXml t of
Nothing -> Nothing
(Just a) -> Just $ OMEATTR a
"OMR" ->
case fromXml t of
Nothing -> Nothing
(Just r) -> Just $ OMER r
_ -> Nothing
_ -> Nothing
-- | OMDoc Morphism
instance XmlRepresentable Morphism where
toXml morphism =
let
idattr =
case morphismId morphism of
Nothing -> XML.xmlNullFilter
(Just mid) -> XML.qualattr "xml" "id" mid
hidingattr =
if null (morphismHiding morphism)
then
else
HXT.sattr "hiding" (Util.implode " " (map (\h -> '#':h) (morphismHiding morphism)))
baseattr =
if null (morphismBase morphism)
then
else
HXT.sattr "base" (Util.implode " " (map (\h -> '#':h) (morphismBase morphism)))
requations =
if null (morphismRequations morphism)
then
else
foldl
(\rs (so, to) ->
rs +++ XML.xmlNL
+++
HXT.etag "requation"
+= (
toXml so +++ toXml to
)
)
(morphismRequations morphism)
in
HXT.etag "morphism"
+= (
idattr
+++
baseattr
+++
hidingattr
+++
requations
)
fromXml t =
case (HXT.isTag "morphism") t of
[] -> Nothing
_ ->
let
reconstructIds =
(\idstring ->
filter
(not . null)
$
map
(\s ->
case s of
'#':r -> r
_ -> s
)
$
map
$
" "
idstring
)
mid =
case HXT.xshow $ XML.getQualValue "xml" "id" t of
[] -> Nothing
mids -> Just mids
hiding = reconstructIds $ HXT.xshow $ getValue "hiding" t
base = reconstructIds $ HXT.xshow $ getValue "base" t
xrequations = (HXT.getChildren .> HXT.isTag "requation") t
requations =
foldl
(\r xr ->
let
xomobjs = (HXT.getChildren .> HXT.isXTag) xr
in
case fromXmlS xomobjs of
(Just [(o1,o2)]) ->
r ++ [ (o1, o2) ]
_ -> trace ("error in morphism") r
)
[]
xrequations
morphism = Morphism mid hiding base requations
in
Just morphism