diff --git a/Data/ContentMathML3.hs b/Data/ContentMathML3.hs
new file mode 100644
--- /dev/null
+++ b/Data/ContentMathML3.hs
@@ -0,0 +1,6 @@
+module Data.ContentMathML3
+where
+
+import Data.ContentMathML3.Structure
+import Data.ContentMathML3.Parser
+import Data.ContentMathML3.Serialiser
diff --git a/Data/ContentMathML3/NSToS.hs b/Data/ContentMathML3/NSToS.hs
new file mode 100644
--- /dev/null
+++ b/Data/ContentMathML3/NSToS.hs
@@ -0,0 +1,705 @@
+{-# LANGUAGE RankNTypes,PatternGuards #-}
+
+-- | A module for the translation of non-strict MathML 3 to strict form
+module Data.ContentMathML3.NSToS (nsToStrict)
+where
+
+import Data.ContentMathML3.Structure
+import Network.URL
+import Data.Maybe
+import qualified Data.Map as M
+import qualified Data.Array.Unboxed as U
+import Data.List
+import Control.Monad
+import Data.ContentMathML3.Parser
+
+import Text.XML.HXT.Core
+import qualified Text.XML.HXT.DOM.XmlNode as XN
+import qualified Text.XML.HXT.DOM.QualifiedName as XN
+
+import Data.Generics
+
+-- | Take a non-strict structure, and make a strict structure, possibly giving an error:
+nsToStrict :: NSASTC -> Either String ASTC
+nsToStrict = strictNSToS . nsToStrictNS
+
+-- | Take a non-strict structure, and make another non-strict structure that only uses
+-- | strict features.
+nsToStrictNS :: NSASTC -> NSASTC
+nsToStrictNS inp = let
+ p1r = everywhere' pass1 inp
+ p2r = everywhere' pass2 p1r
+ p3r = everywhere' pass3 p2r
+ p4r = everywhere' pass4 p3r
+ p5r = everywhere' pass5 p4r
+ p6r = everywhere' pass6 p5r
+ p6br = everywhere' pass6b p5r
+ p7r = everywhere' pass7 p6br
+ p8r = everywhere' pass8 p7r
+ in
+ everywhere' pass9 p8r
+
+-- | Take a non-strict structure that only uses strict features, and convert to a
+-- | strict structure, giving an error if any non-strict features are found.
+strictNSToS :: NSASTC -> Either String ASTC
+strictNSToS (WithMaybeSemantics s (WithNSCommon c v)) = do
+ common <- strictNSCommonToS c
+ expr <- strictNSExprToS v
+ return $ WithMaybeSemantics s (WithCommon common expr)
+
+strictNSCommonToS :: NSCommon -> Either String Common
+strictNSCommonToS (NSCommon { nsCommon = c, nsCommonDefinitionURL = u, nsCommonEncoding = e }) =
+ if u /= Nothing then
+ Left ("Found a residual definitionURL: " ++ (fromJust u))
+ else
+ if e /= Nothing then
+ Left ("Found a residual encoding attribute: " ++ (fromJust e))
+ else
+ return c
+
+strictNSExprToS :: NSAST -> Either String AST
+strictNSExprToS cn@(NSCn (Just _) _) = Left ("Found a cn with a base: " ++ show cn)
+strictNSExprToS (NSCn _ (NSCnInteger v)) = return $ Cn (CnInteger v)
+strictNSExprToS (NSCn _ (NSCnReal v)) = return $ Cn (CnReal v)
+strictNSExprToS (NSCn _ (NSCnDouble v)) = return $ Cn (CnDouble v)
+strictNSExprToS (NSCn _ (NSCnHexDouble v)) = return $ Cn (CnHexDouble v)
+strictNSExprToS cn@(NSCn _ _) = Left ("Found a cn of a type invalid for strict MathML: " ++ show cn)
+strictNSExprToS (NSASTCi ci) = liftM ASTCi (strictNSCiToS ci)
+strictNSExprToS cs@(NSCsymbol _ (Just _) _) = Left ("Found a csymbol with a type attribute: " ++ show cs)
+strictNSExprToS cs@(NSCsymbol _ _ (NSCiMGlyph s)) = Left ("Found a csymbol with mglyph content: " ++ show cs)
+strictNSExprToS cs@(NSCsymbol _ _ (NSCiPresentationExpression s)) = Left ("Found a csymbol with presentation content: " ++ show cs)
+strictNSExprToS (NSCsymbol cd _ (NSCiText name)) = return $ Csymbol cd name
+strictNSExprToS (NSCs s) = return $ Cs s
+strictNSExprToS a@(NSApply { nsApplyBvar = _:_ }) = Left ("Found an apply with bvar children: " ++ show a)
+strictNSExprToS a@(NSApply { nsApplyQualifier = _:_ }) = Left ("Found an apply with qualifier children: " ++ show a)
+strictNSExprToS a@(NSApply { nsApplyOperator = nsop, nsApplyOperands = nsoperands }) = do
+ op <- strictNSToS nsop
+ operands <- sequence . map strictNSToS $ nsoperands
+ return $ Apply op operands
+strictNSExprToS a@(NSBind { nsBindQualifiers = _:_ }) = Left ("Found a bind with qualifier children: " ++ show a)
+strictNSExprToS a@(NSBind { nsBindOperands = [] }) = Left ("Found a bind with no operands: " ++ show a)
+strictNSExprToS a@(NSBind { nsBindOperands = _:(_:_) }) = Left ("Found a bind with more than one operand: " ++ show a)
+strictNSExprToS a@(NSBind { nsBindOperator = nsop, nsBindBvar = nsbvar, nsBindOperands = nsoperand:_ }) = do
+ op <- strictNSToS nsop
+ bvars <- sequence . map strictNSBvarToS $ nsbvar
+ operand <- strictNSToS nsoperand
+ return $ Bind op bvars operand
+strictNSExprToS a@(NSError nset nsea) = do
+ et <- strictNSToS nset
+ ea <- mapM strictNSToS nsea
+ return $ Error et ea
+strictNSExprToS a@(NSCBytes s) = return $ CBytes s
+strictNSExprToS x = Left ("Symbol found that is not present in strict MathML 3: " ++ show x)
+
+strictNSCiToS ci@(NSCi (Just _) _) = Left ("ci element has a type attribute" ++ show ci)
+strictNSCiToS ci@(NSCi _ (NSCiMGlyph _)) = Left ("Found mglyph content in a ci element: " ++ show ci)
+strictNSCiToS ci@(NSCi _ (NSCiPresentationExpression _)) = Left ("Found presentation content in a ci element: " ++ show ci)
+strictNSCiToS (NSCi _ (NSCiText t)) = return $ Ci t
+
+strictNSBvarToS bv@(NSBvar _ (Just _)) = Left ("Found a bvar with degree attribute: " ++ show bv)
+strictNSBvarToS bv@(NSBvar (WithMaybeSemantics s (WithNSCommon nsc nsci)) _) = do
+ c <- strictNSCommonToS nsc
+ ci <- strictNSCiToS nsci
+ return $ WithMaybeSemantics s (WithCommon c ci)
+
+pass1 :: forall a . Data a => a -> a
+pass1 = mkT normaliseNSBind
+
+normaliseNSBind (NSBind op bvar qual operands)
+ | not (null bvar) || not (null qual) || length (take 2 operands) > 1 =
+ NSApply op bvar qual operands
+normaliseNSBind (NSRelation op l) = NSApply op [] [] l
+normaliseNSBind (NSFunction (WithMaybeSemantics _ (WithNSCommon _ ex))) = ex
+normaliseNSBind x = x
+
+simpleCsymbol cd cn = (NSCsymbol (Just cd) Nothing (NSCiText cn))
+
+isQualDegree (NSQualDegree _) = True
+isQualDegree _ = False
+tryGetQualDegree l = do
+ qd <- find isQualDegree l
+ let NSQualDegree deg = qd
+ return deg
+
+pass2 :: forall a . Data a => a -> a
+pass2 = mkT exprPass2
+exprPass2 (NSApply (WithMaybeSemantics s (WithNSCommon c NSDiff)) bv@[NSBvar (WithMaybeSemantics sx (WithNSCommon cx x)) Nothing] [] e@[expr]) =
+ NSApply (noNSSemCom $
+ NSApply (WithMaybeSemantics s $ WithNSCommon c $ simpleCsymbol "calculus1" "diff") [] []
+ [
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] e
+ ]) [] [] [WithMaybeSemantics sx (WithNSCommon cx $ NSASTCi x)]
+exprPass2 (NSApply (WithMaybeSemantics s (WithNSCommon c NSDiff)) bv@[NSBvar (WithMaybeSemantics sx (WithNSCommon cx x)) (Just d)] [] e@[expr]) =
+ NSApply (noNSSemCom $
+ NSApply (WithMaybeSemantics s $ WithNSCommon c $ simpleCsymbol "calculus1" "nthdiff") [] []
+ [
+ d,
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] e
+ ]) [] [] [WithMaybeSemantics sx (WithNSCommon cx $ NSASTCi x)]
+-- Don't touch partialdiff with no bound variables...
+exprPass2 x@(NSApply (WithMaybeSemantics _ (WithNSCommon _ NSPartialdiff)) [] _ _) = x
+-- Otherwise, transform it...
+exprPass2 (NSApply (WithMaybeSemantics s (WithNSCommon c NSPartialdiff)) bvars quals e@[expr]) =
+ let
+ bvarExps = map (\(NSBvar (WithMaybeSemantics _ (WithNSCommon _ ci)) _) -> noNSSemCom $ NSASTCi ci) bvars
+ bvarDegs = map (\(NSBvar _ deg) -> fromMaybe (noNSSemCom $ NSCn Nothing (NSCnInteger 1)) deg) bvars
+ totalDegree = fromMaybe (noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "arith1" "plus") [] [] bvarDegs) $ tryGetQualDegree quals
+ in
+ NSApply (noNSSemCom $
+ NSApply (WithMaybeSemantics s $ WithNSCommon c $ simpleCsymbol "calculus1" "partialdiffdegree") [] []
+ [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "list1" "list") [] [] bvarExps,
+ totalDegree,
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bvars [] e
+ ]) [] [] bvarExps
+
+exprPass2 (NSApply (WithMaybeSemantics s (WithNSCommon c NSLimit))
+ bv@[NSBvar (WithMaybeSemantics _ (WithNSCommon _ x)) _]
+ [NSQualDomain (NSCondition (WithMaybeSemantics _
+ (WithNSCommon _
+ (NSApply (WithMaybeSemantics _ (WithNSCommon _ (NSTendsto _)))
+ [] [] [WithMaybeSemantics _ (WithNSCommon _ (NSASTCi x2)), approach]))))]
+ ex@[_]
+ )
+ | x == x2 =
+ NSApply (WithMaybeSemantics s $ WithNSCommon c $ simpleCsymbol "limit1" "limit") [] []
+ [approach, noNSSemCom $ simpleCsymbol "limit1" "null",
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] ex]
+
+exprPass2 (NSTendsto _) = NSASTCi (NSCi Nothing (NSCiText "tendsto"))
+
+exprPass2 (NSApply (WithMaybeSemantics s (WithNSCommon c NSRoot))
+ []
+ quals
+ [ex]) =
+ let
+ isDegree (NSQualDegree _) = True
+ isDegree _ = False
+ degr = maybe (noNSSemCom $ NSCn Nothing $ NSCnInteger 2) (\(NSQualDegree v) -> v) $ find isDegree quals
+ in
+ NSApply (WithMaybeSemantics s (WithNSCommon c (simpleCsymbol "arith1" "root")))
+ [] []
+ [ex, degr]
+
+exprPass2 (NSApply (WithMaybeSemantics s (WithNSCommon c NSLog))
+ []
+ quals
+ [ex]) =
+ let
+ isLogbase (NSQualLogbase _) = True
+ isLogbase _ = False
+ base = maybe (noNSSemCom $ NSCn Nothing $ NSCnInteger 10) (\(NSQualLogbase v) -> v) $ find isLogbase quals
+ in
+ NSApply (WithMaybeSemantics s (WithNSCommon c (simpleCsymbol "transc1" "log")))
+ [] []
+ [base, ex]
+
+exprPass2 (NSApply (WithMaybeSemantics s (WithNSCommon c NSMoment))
+ []
+ quals
+ exl) =
+ let
+ isMomentabout (NSQualMomentabout _) = True
+ isMomentabout _ = False
+ momentabout = maybe (noNSSemCom $ NSCn Nothing $ NSCnReal 0) (\(NSQualMomentabout v) -> v) $ find isMomentabout quals
+ isDegree (NSQualDegree _) = True
+ isDegree _ = False
+ degr = maybe (noNSSemCom $ NSCn Nothing $ NSCnInteger 1) (\(NSQualDegree v) -> v) $ find isDegree quals
+ isData = length exl /= 1
+ cs = if isData then simpleCsymbol "s_data1" "moment" else simpleCsymbol "s_dist1" "moment"
+ in
+ NSApply (WithMaybeSemantics s (WithNSCommon c cs))
+ [] []
+ (degr:momentabout:exl)
+
+exprPass2 x = domainedRewrite x
+
+pass3 :: forall a . Data a => a -> a
+pass3 = mkT (exprPass3a . exprPass3)
+
+exprPass3 :: forall a . CanHaveDomain a => a -> a
+exprPass3 a
+ | Just l <- lowlimit, Just u <- uplimit =
+ setDomains a (NSDomainOfApplication
+ (noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "interval1" "interval") [] [] [l, u]):
+ excludingLimits)
+ | _:_ <- conditions =
+ setDomains a ((NSDomainOfApplication . noNSSemCom $
+ NSApply (noNSSemCom $ simpleCsymbol "set1" "suchthat") [] []
+ [rexp, noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] [conjCondition]]):
+ excludingConditionsAndDOA
+ )
+ where
+ bv = getBvars a
+ quals = getDomains a
+ isLowlimit (NSLowlimit _) = True
+ isLowlimit _ = False
+ lowlimit = liftM (\(NSLowlimit x) -> x) $ find isLowlimit quals
+ isUplimit (NSUplimit _) = True
+ isUplimit _ = False
+ uplimit = liftM (\(NSUplimit x) -> x) $ find isUplimit quals
+ excludingLimits = filter (\x -> not (isLowlimit x || isUplimit x)) quals
+ isCondition (NSCondition _) = True
+ isCondition _ = False
+ conditions = map (\(NSCondition c) -> c) $ filter isCondition quals
+ conjCondition = case conditions of
+ cond:[] -> cond
+ _ -> noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "logic1" "and") [] [] conditions
+ excludingConditionsAndDOA = filter (\x -> not (isCondition x || isDomainQualifierDOA x)) quals
+ mdoa = listToMaybe $ mapMaybe domainQualifierToMaybeDOA quals
+ mvartype | (NSBvar (WithMaybeSemantics _ (WithNSCommon _ (NSCi (Just (NSStrictVariableType vt)) _))) _):_ <- bv
+ = Just vt
+ | otherwise = Nothing
+ rexp | Just doa <- mdoa = doa
+ | mvartype == Just CiInteger = noNSSemCom $ simpleCsymbol "setname1" "Z"
+ | mvartype == Just CiReal = noNSSemCom $ simpleCsymbol "setname1" "R"
+ | mvartype == Just CiRational = noNSSemCom $ simpleCsymbol "setname1" "Q"
+ | mvartype == Just CiComplex = noNSSemCom $ simpleCsymbol "setname1" "C"
+ | mvartype == Just CiComplexPolar = noNSSemCom $ simpleCsymbol "setname1" "C"
+ | mvartype == Just CiComplexCartesian = noNSSemCom $ simpleCsymbol "setname1" "C"
+ | otherwise = noNSSemCom $ NSASTCi $ NSCi Nothing (NSCiText "R")
+
+exprPass3 x = x
+
+exprPass3a (NSApply op bvs quals exl)
+ | _:(_:_) <- doas = NSApply op bvs ((NSQualDomain . NSDomainOfApplication $ singleDOA):excludingDOAs) exl
+ where
+ doas = mapMaybe qualifierToMaybeDOA quals
+ excludingDOAs = filter (not . isQualifierDOA) quals
+ singleDOA = noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "set1" "intersect") [] [] doas
+exprPass3a x = x
+
+pass4 :: forall a . Data a => a -> a
+pass4 = (mkT exprPass4a) {- `extT` (mkT exprPass4b) -}
+
+domainQualifierToMaybeDOA (NSDomainOfApplication doa) = Just doa
+domainQualifierToMaybeDOA _ = Nothing
+qualifierToMaybeDOA (NSQualDomain (NSDomainOfApplication doa)) = Just doa
+qualifierToMaybeDOA _ = Nothing
+isQualifierDOA (NSQualDomain (NSDomainOfApplication _)) = True
+isQualifierDOA _ = False
+isDomainQualifierDOA (NSDomainOfApplication _) = True
+isDomainQualifierDOA _ = False
+
+exprPass4a (NSSet bvars quals [expr])
+ | not (null doaQuals) =
+ foldl' (\inner qual -> NSApply (noNSSemCom $ simpleCsymbol "set1" "map") [] [] [noNSSemCom inner, qual])
+ (NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bvars [] [expr])
+ doaQuals
+ where
+ doaQuals = mapMaybe domainQualifierToMaybeDOA quals
+
+-- To do: Specification refers to rule for vector which doesn't exist.
+-- To do: Specification refers to rule for matrix which doesn't exist.
+-- To do: Specification refers to rule for matrixrow which doesn't exist.
+-- exprPass4a (NSVector bvars dom expr) =
+
+exprPass4a (NSLambda bvars domain expr)
+ | null doas = NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bvars [] [expr]
+ | otherwise = foldl' (\inner doa -> NSApply (noNSSemCom $ simpleCsymbol "fns1" "restrict") [] [] [noNSSemCom inner, doa])
+ (NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bvars [] [expr])
+ doas
+ where
+ doas = mapMaybe domainQualifierToMaybeDOA domain
+
+exprPass4a (NSPiecewise (cases, motherwise)) =
+ let
+ lotherwise = maybeToList $
+ liftM (\(WithNSCommon c ow) ->
+ WithMaybeSemantics Nothing . WithNSCommon c $ NSApply (noNSSemCom $ simpleCsymbol "piece1" "otherwise") [] [] [ow])
+ motherwise
+ lcases = map (\(WithNSCommon c (val, cond)) -> WithMaybeSemantics Nothing $
+ WithNSCommon c (NSApply (noNSSemCom $ simpleCsymbol "piece1" "piece") [] [] [val, cond])) cases
+ lchild = lcases ++ lotherwise
+ in
+ NSApply (noNSSemCom $ simpleCsymbol "piece1" "piecewise") [] [] lchild
+
+exprPass4a x = x
+
+{- This rule only makes sense for intervals that aren't qualifiers, which our
+ structure doesn't allow for...
+
+closureToOperator (Just "open") = simpleCsymbol "interval1" "interval_oo"
+closureToOperator (Just "open-closed") = simpleCsymbol "interval1" "interval_oc"
+closureToOperator (Just "closed-open") = simpleCsymbol "interval1" "interval_co"
+closureToOperator _ = simpleCsymbol "interval1" "interval_cc"
+
+exprPass4b (NSInterval closure l h) =
+ noNSSemCom $
+ NSApply (noNSSemCom $ closureToOperator closure) [] [] [l, h]
+-}
+
+pass5 :: forall a . Data a => a -> a
+pass5 = mkT exprPass5
+
+statsOrMinMaxToSym NSMin = Just $ simpleCsymbol "minmax1" "min"
+statsOrMinMaxToSym NSMax = Just $ simpleCsymbol "minmax1" "max"
+statsOrMinMaxToSym NSMean = Just $ simpleCsymbol "s_data1" "mean"
+statsOrMinMaxToSym NSSdev = Just $ simpleCsymbol "s_data1" "sdev"
+statsOrMinMaxToSym NSVariance = Just $ simpleCsymbol "s_data1" "variance"
+statsOrMinMaxToSym NSMedian = Just $ simpleCsymbol "s_data1" "median"
+statsOrMinMaxToSym NSMode = Just $ simpleCsymbol "s_data1" "mode"
+statsOrMinMaxToSym _ = Nothing
+
+statsOrMinMaxToDistSym NSMean = Just $ simpleCsymbol "s_dist1" "mean"
+statsOrMinMaxToDistSym NSSdev = Just $ simpleCsymbol "s_dist1" "sdev"
+statsOrMinMaxToDistSym NSVariance = Just $ simpleCsymbol "s_dist1" "variance"
+statsOrMinMaxToDistSym NSMedian = Just $ simpleCsymbol "s_dist1" "median"
+statsOrMinMaxToDistSym NSMode = Just $ simpleCsymbol "s_dist1" "mode"
+statsOrMinMaxToDistSym x = statsOrMinMaxToSym x
+
+exprPass5 (NSApply (WithMaybeSemantics _ (WithNSCommon _ op)) bv quals v)
+ | Just sym <- statsOrMinMaxToSym op =
+ case (doas, v) of
+ ([], el:[]) ->
+ NSApply (noNSSemCom . fromJust $ statsOrMinMaxToDistSym op) [] [] [el]
+ (doa:_, el:_) ->
+ NSApply (noNSSemCom sym) [] []
+ [noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "set1" "map") [] []
+ [noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] (el:doa:[])]]
+ ([], ell) ->
+ NSApply (noNSSemCom sym) [] [] [noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "set1" "set") [] [] ell]
+ where
+ doas = mapMaybe qualifierToMaybeDOA quals
+
+exprPass5 (NSApply (WithMaybeSemantics _ (WithNSCommon _ NSExists)) bv@((NSBvar (WithMaybeSemantics s (WithNSCommon c bvar1)) _):_) quals (v:_))
+ | not (null doas) = NSBind (noNSSemCom $ simpleCsymbol "quant1" "exists") bv [] [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "logic1" "and") [] [] [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "set1" "in") [] [] [WithMaybeSemantics s $ WithNSCommon c $ NSASTCi bvar1, head doas],
+ v
+ ]
+ ]
+ where
+ doas = mapMaybe qualifierToMaybeDOA quals
+
+exprPass5 (NSApply (WithMaybeSemantics _ (WithNSCommon _ NSForall)) bv@((NSBvar (WithMaybeSemantics s (WithNSCommon c bvar1)) _):_) quals (v:_))
+ | not (null doas) = NSBind (noNSSemCom $ simpleCsymbol "quant1" "forall") bv [] [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "logic1" "implies") [] [] [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "set1" "in") [] [] [WithMaybeSemantics s $ WithNSCommon c $ NSASTCi bvar1, head doas],
+ v
+ ]
+ ]
+ where
+ doas = mapMaybe qualifierToMaybeDOA quals
+
+exprPass5 x = domainedRewrite x
+
+domainedRewrite (NSApply (WithMaybeSemantics s (WithNSCommon c NSInt)) bv@[NSBvar (WithMaybeSemantics sx (WithNSCommon cx x)) Nothing] [] e@[expr]) =
+ NSApply (noNSSemCom $
+ NSApply (WithMaybeSemantics s $ WithNSCommon c $ simpleCsymbol "calculus1" "int") [] []
+ [
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] e
+ ]) [] [] [WithMaybeSemantics sx (WithNSCommon cx $ NSASTCi x)]
+
+domainedRewrite (NSApply (WithMaybeSemantics s (WithNSCommon c NSInt))
+ bv@[_] quals e@[expr])
+ | doa:_ <- doas =
+ NSApply (WithMaybeSemantics s $ WithNSCommon c $ simpleCsymbol "calculus1" "defint") [] []
+ [
+ doa,
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] e
+ ]
+ where
+ doas = mapMaybe qualifierToMaybeDOA quals
+
+domainedRewrite (NSApply (WithMaybeSemantics s (WithNSCommon c NSInt))
+ bv@[_] quals e@[expr])
+ | Just (l,u) <- luMaybe =
+ NSApply (WithMaybeSemantics s $ WithNSCommon c $ simpleCsymbol "calculus1" "defint") [] []
+ [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "interval1" "orientated_interval") [] [] [l, u],
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] e
+ ]
+ where
+ toMaybeLowlimit (NSQualDomain (NSLowlimit l)) = Just l
+ toMaybeLowlimit _ = Nothing
+ toMaybeUplimit (NSQualDomain (NSUplimit u)) = Just u
+ toMaybeUplimit _ = Nothing
+ lMaybe = listToMaybe $ mapMaybe toMaybeLowlimit quals
+ uMaybe = listToMaybe $ mapMaybe toMaybeUplimit quals
+ luMaybe = liftM2 (,) lMaybe uMaybe
+
+domainedRewrite (NSApply (WithMaybeSemantics s (WithNSCommon c NSSum))
+ bv@[_]
+ quals
+ ex@[_]
+ )
+ | Just (l, u) <- luMaybe =
+ NSApply (WithMaybeSemantics s (WithNSCommon c $ simpleCsymbol "arith1" "sum")) [] []
+ [noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "interval1" "integer_interval") [] [] [l, u],
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] ex]
+ where
+ toMaybeLowlimit (NSQualDomain (NSLowlimit l)) = Just l
+ toMaybeLowlimit _ = Nothing
+ toMaybeUplimit (NSQualDomain (NSUplimit u)) = Just u
+ toMaybeUplimit _ = Nothing
+ lMaybe = listToMaybe $ mapMaybe toMaybeLowlimit quals
+ uMaybe = listToMaybe $ mapMaybe toMaybeUplimit quals
+ luMaybe = liftM2 (,) lMaybe uMaybe
+
+domainedRewrite (NSApply (WithMaybeSemantics s (WithNSCommon c NSProduct))
+ bv@[_]
+ [NSQualDomain (NSLowlimit l), NSQualDomain (NSUplimit u)]
+ ex@[_]
+ ) =
+ NSApply (WithMaybeSemantics s (WithNSCommon c $ simpleCsymbol "arith1" "product")) [] []
+ [noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "interval1" "integer_interval") [] [] [l, u],
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] ex
+ ]
+domainedRewrite x = x
+
+naryRelnToSym NSEq = Just $ simpleCsymbol "relation1" "eq"
+naryRelnToSym NSGt = Just $ simpleCsymbol "relation1" "gt"
+naryRelnToSym NSLt = Just $ simpleCsymbol "relation1" "lt"
+naryRelnToSym NSGeq = Just $ simpleCsymbol "relation1" "geq"
+naryRelnToSym NSLeq = Just $ simpleCsymbol "relation1" "leq"
+naryRelnToSym NSSubset = Just $ simpleCsymbol "set1" "subset"
+naryRelnToSym NSPrSubset = Just $ simpleCsymbol "set1" "prsubset"
+naryRelnToSym _ = Nothing
+
+naryGeneralToSym NSPlus = Just $ simpleCsymbol "arith1" "plus"
+naryGeneralToSym NSTimes = Just $ simpleCsymbol "arith1" "times"
+naryGeneralToSym NSGcd = Just $ simpleCsymbol "arith1" "gcd"
+naryGeneralToSym NSLcm = Just $ simpleCsymbol "arith1" "lcm"
+naryGeneralToSym NSCompose = Just $ simpleCsymbol "fns1" "left_compose"
+naryGeneralToSym NSAnd = Just $ simpleCsymbol "logic1" "and"
+naryGeneralToSym NSOr = Just $ simpleCsymbol "logic1" "or"
+naryGeneralToSym NSXor = Just $ simpleCsymbol "logic1" "xor"
+naryGeneralToSym NSSelector = Just $ simpleCsymbol "linalg1" "matrix_selector"
+naryGeneralToSym NSUnion = Just $ simpleCsymbol "set1" "union"
+naryGeneralToSym NSIntersect = Just $ simpleCsymbol "set1" "intersect"
+naryGeneralToSym NSCartesianProduct = Just $ simpleCsymbol "set1" "cartesian_product"
+
+pass6 :: forall a . Data a => a -> a
+pass6 = mkT exprPass6
+exprPass6 (NSApply opc@(WithMaybeSemantics _ (WithNSCommon _ op)) bv quals exs)
+ | Just doa <- mdoa, [] <- bv =
+ (NSApply (noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "fns1" "restriction") [] [] [opc, doa])
+ [] [] exs)
+ | Just sym <- mrsym, Just doa <- mdoa, ex:_ <- exs =
+ NSApply (noNSSemCom $ simpleCsymbol "fns2" "predicate_on_list") [] []
+ [noNSSemCom sym,
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "list1" "map") [] []
+ [doa, noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] exs]
+ ]
+ | Just sym <- mrsym, ex1:ex2:[] <- exs = NSApply (noNSSemCom sym) [] [] exs
+ | Just sym <- mrsym = NSApply (noNSSemCom $ simpleCsymbol "fns2" "predicate_on_list") [] []
+ [noNSSemCom sym, noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "list1" "list") [] [] exs]
+ | Just sym <- mgsym, Just doa <- mdoa, ex1:[] <- exs =
+ NSApply (noNSSemCom $ simpleCsymbol "fns2" "apply_to_list") [] [] [
+ noNSSemCom sym,
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "list1" "map") [] [] [
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] exs
+ ]
+ ]
+ | Just sym <- mrsym = NSApply (noNSSemCom sym) [] [] exs
+ where
+ mdoa = listToMaybe $ mapMaybe qualifierToMaybeDOA quals
+ mrsym = naryRelnToSym op
+ mgsym = naryGeneralToSym op
+
+exprPass6 (NSVector bv quals expr)
+ | Just doa <- mdoa =
+ NSApply (noNSSemCom $ simpleCsymbol "fns2" "apply_to_list") [] [] [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "linalg2" "vector") [] [] [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "list1" "map") [] [] [
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") [] [] expr,
+ doa
+ ]
+ ]
+ ]
+ where
+ mdoa = listToMaybe $ mapMaybe domainQualifierToMaybeDOA quals
+
+exprPass6 (NSMatrixByFunction bv quals expr)
+ | Just doa <- mdoa =
+ NSApply (noNSSemCom $ simpleCsymbol "fns2" "apply_to_list") [] [] [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "linalg2" "matrix") [] [] [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "list1" "map") [] [] [
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") [] [] [expr],
+ doa
+ ]
+ ]
+ ]
+ where
+ mdoa = listToMaybe $ mapMaybe domainQualifierToMaybeDOA quals
+
+exprPass6 (NSMatrixByRow rs) = NSApply (noNSSemCom $ simpleCsymbol "linalg2" "matrix") [] [] (map exprPass6MR rs)
+
+exprPass6MR (WithNSCommon c (NSMatrixRow bv quals (expr:_)))
+ | Just doa <- mdoa =
+ WithMaybeSemantics Nothing $ WithNSCommon c $
+ NSApply (noNSSemCom $ simpleCsymbol "fns2" "apply_to_list") [] [] [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "linalg2" "matrixrow") [] [] [
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "list1" "map") [] [] [
+ noNSSemCom $ NSBind (noNSSemCom $ simpleCsymbol "fns1" "lambda") [] [] [expr],
+ doa
+ ]
+ ]
+ ]
+ where
+ mdoa = listToMaybe $ mapMaybe domainQualifierToMaybeDOA quals
+
+pass6b :: forall a . Data a => a -> a
+pass6b = mkT exprPass6b
+exprPass6b (NSApply op bv@(_:_) quals args) =
+ let
+ doas = mapMaybe qualifierToMaybeDOA quals
+ lambdaArgs = flip map args $ \arg ->
+ noNSSemCom $ NSApply (noNSSemCom $ simpleCsymbol "fns1" "lambda") bv [] [arg]
+ in
+ NSApply op [] [] (doas ++ lambdaArgs)
+exprPass6b x = x
+
+pass7 :: forall a . Data a => a -> a
+pass7 = mkT exprPass7
+
+exprPass7 (NSCn base (NSCnENotation a b)) =
+ NSApply (noNSSemCom $ simpleCsymbol "bigfloat1" "bigfloat") [] [] [
+ noNSSemCom $ NSCn base (NSCnReal a),
+ noNSSemCom $ NSCn base (NSCnReal b)
+ ]
+exprPass7 (NSCn base (NSCnRational a b)) =
+ NSApply (noNSSemCom $ simpleCsymbol "nums1" "rational") [] [] [
+ noNSSemCom $ NSCn base (NSCnInteger a),
+ noNSSemCom $ NSCn base (NSCnInteger b)
+ ]
+exprPass7 (NSCn base (NSCnComplexCartesian a b)) =
+ NSApply (noNSSemCom $ simpleCsymbol "complex1" "complex_cartesian") [] [] [
+ noNSSemCom $ NSCn base (NSCnReal a),
+ noNSSemCom $ NSCn base (NSCnReal b)
+ ]
+exprPass7 (NSCn base (NSCnComplexPolar a b)) =
+ NSApply (noNSSemCom $ simpleCsymbol "complex1" "complex_polar") [] [] [
+ noNSSemCom $ NSCn base (NSCnReal a),
+ noNSSemCom $ NSCn base (NSCnReal b)
+ ]
+exprPass7 (NSCn _ (NSCnOther v1 v2)) = simpleCsymbol v1 v2
+exprPass7 (NSCn _ (NSCnConstant "π")) = simpleCsymbol "nums1" "pi"
+exprPass7 (NSCn _ (NSCnConstant "ⅇ")) = simpleCsymbol "nums1" "e"
+exprPass7 (NSCn _ (NSCnConstant "ⅈ")) = simpleCsymbol "nums1" "i"
+exprPass7 (NSCn _ (NSCnConstant "γ")) = simpleCsymbol "nums1" "gamma"
+exprPass7 (NSCn _ (NSCnConstant "∞")) = simpleCsymbol "nums1" "infinity"
+exprPass7 (NSCn _ (NSCnConstant v)) = simpleCsymbol "other" v
+exprPass7 (NSCn (Just 10) v) = NSCn Nothing v
+exprPass7 (NSCn (Just base) v) =
+ NSApply (noNSSemCom $ simpleCsymbol "nums1" "based_integer") [] [] [
+ noNSSemCom $ NSCn Nothing (NSCnInteger base),
+ noNSSemCom $ NSCn Nothing v
+ ]
+-- To do: Remove presentation MathML and name identifiers...
+exprPass7 (NSApply (WithMaybeSemantics s (WithNSCommon c NSMinus)) _ _ exs@(ex:[])) =
+ NSApply (WithMaybeSemantics s $ WithNSCommon c $ simpleCsymbol "arith1" "unary_minus") [] [] exs
+exprPass7 (NSApply (WithMaybeSemantics s (WithNSCommon c NSMinus)) _ _ exs) =
+ NSApply (WithMaybeSemantics s $ WithNSCommon c $ simpleCsymbol "arith1" "minus") [] [] exs
+exprPass7 x = x
+
+symbolMap = M.fromList symbolTable
+symbolTable =
+ [(NSInverse, ("fns1", "inverse")), (NSIdent, ("fns1", "identity")),
+ (NSDomain, ("fns1", "domain")), (NSCodomain, ("fns1", "range")),
+ (NSImage, ("fns1", "image")), (NSLn, ("transc1", "ln")),
+ (NSQuotient, ("integer1", "quotient")), (NSDivide, ("arith1", "divide")),
+ (NSPower, ("arith1", "power")), (NSRem, ("integer1", "remainder")),
+ (NSFactorial, ("integer1", "factorial")), (NSAbs, ("arith1", "abs")),
+ (NSConjugate, ("complex1", "conjugate")),
+ (NSArg, ("complex1", "argument")),
+ (NSReal, ("complex1", "real")), (NSImaginary, ("complex1", "imaginary")),
+ (NSFloor, ("rounding1", "floor")), (NSCeiling, ("rounding1", "ceiling")),
+ (NSExp, ("transc1", "exp")), (NSNot, ("logic1", "not")),
+ (NSImplies, ("logic1", "implies")),
+ (NSEquivalent, ("logic1", "equivalent")), (NSNeq, ("relation1", "neq")),
+ (NSApprox, ("relation1", "approx")),
+ (NSFactorof, ("integer1", "factorof")),
+ (NSDivergence, ("veccalc1", "divergence")),
+ (NSGrad, ("veccalc1", "grad")), (NSCurl, ("veccalc1", "curl")),
+ (NSLaplacian, ("veccalc1", "laplacian")), (NSIn, ("set1", "in")),
+ (NSNotIn, ("set1", "notin")), (NSNotSubset, ("set1", "notsubset")),
+ (NSNotPrSubset, ("set1", "notprsubset")), (NSSubset, ("set1", "subset")),
+ (NSPrSubset, ("set1", "prsubset")), (NSSin, ("transc1", "sin")),
+ (NSCos, ("transc1", "cos")), (NSTan, ("transc1", "tan")),
+ (NSSec, ("transc1", "sec")), (NSCsc, ("transc1", "csc")),
+ (NSCot, ("transc1", "cot")), (NSSinh, ("transc1", "sinh")),
+ (NSCosh, ("transc1", "cosh")), (NSTanh, ("transc1", "tanh")),
+ (NSSech, ("transc1", "sech")), (NSCsch, ("transc1", "csch")),
+ (NSCoth, ("transc1", "coth")), (NSArcsin, ("transc1", "arcsin")),
+ (NSArccos, ("transc1", "arccos")), (NSArctan, ("transc1", "arctan")),
+ (NSArccosh, ("transc1", "arccosh")), (NSArccot, ("transc1", "arccot")),
+ (NSArccoth, ("transc1", "arccoth")), (NSArccsc, ("transc1", "arccsc")),
+ (NSArccsch, ("transc1", "arccsch")), (NSArcsec, ("transc1", "arcsec")),
+ (NSArcsech, ("transc1", "arcsech")), (NSArcsinh, ("transc1", "arcsinh")),
+ (NSArctanh, ("transc1", "arctanh")),
+ (NSDeterminant, ("linalg1", "determinant")),
+ (NSTranspose, ("linalg1", "transpose")),
+ (NSVectorProduct, ("linalg1", "vectorproduct")),
+ (NSScalarProduct, ("linalg1", "scalarproduct")),
+ (NSOuterProduct, ("linalg1", "outerproduct")),
+ (NSIntegers, ("setname1", "Z")), (NSReals, ("setname1", "R")),
+ (NSRationals, ("setname1", "Q")), (NSNaturalNumbers, ("setname1", "N")),
+ (NSComplexes, ("setname1", "C")), (NSPrimes, ("setname1", "P")),
+ (NSExponentialE, ("nums1", "e")), (NSImaginaryi, ("nums1", "i")),
+ (NSNotanumber, ("nums1", "NaN")), (NSTrue, ("logic1", "true")),
+ (NSFalse, ("logic1", "false")), (NSPi, ("nums1", "pi")),
+ (NSEulergamma, ("nums1", "gamma")), (NSInfinity, ("nums1", "infinity")),
+ (NSLog, ("transc1", "log")), (NSMoment, ("s_data1", "moment")),
+ (NSCompose, ("fns1", "compose")), (NSRoot, ("arith1", "root")),
+ (NSMin, ("minmax1", "min")), (NSMax, ("minmax1", "max")),
+ (NSPlus, ("arith1", "plus")), (NSTimes, ("arith1", "times")),
+ (NSGcd, ("arith1", "gcd")), (NSLcm, ("arith1", "lcm")),
+ (NSAnd, ("logic1", "and")), (NSOr, ("logic1", "or")),
+ (NSXor, ("logic1", "xor")), (NSForall, ("quant1", "forall")),
+ (NSExists, ("quant1", "exists")), (NSEq, ("relation1", "eq")),
+ (NSGt, ("relation1", "gt")), (NSLt, ("relation1", "lt")),
+ (NSGeq, ("relation1", "geq")), (NSLeq, ("relation1", "leq")),
+ (NSInt, ("calculus1", "int")), (NSDiff, ("calculus1", "diff")),
+ (NSPartialdiff, ("calculus1", "partialdiff")), (NSUnion, ("set1", "union")),
+ (NSIntersect, ("set1", "intersect")), (NSCartesianProduct, ("set1", "cartesian_product")),
+ (NSSetDiff, ("set1", "setdiff")), (NSCard, ("set1", "size")),
+ (NSSum, ("arith1", "sum")), (NSProduct, ("arith1", "product")),
+ (NSLimit, ("limit1", "limit")), (NSMean, ("s_data1", "mean")),
+ (NSSdev, ("s_data1", "sdev")), (NSVariance, ("s_data1", "variance")),
+ (NSMedian, ("s_data1", "median")), (NSMode, ("s_data1", "mode")),
+ (NSSelector, ("linalg1", "matrix_selector")), (NSEmptySet, ("set1", "emptyset"))
+ ]
+
+pass8 :: forall a . Data a => a -> a
+pass8 = mkT exprPass8
+exprPass8 x
+ | Just (cd, n) <- msym = simpleCsymbol cd n
+ | otherwise = x
+ where
+ msym = M.lookup x symbolMap
+
+pass9 :: forall a . Data a => a -> a
+pass9 = mkT exprPass9
+exprPass9 (WithMaybeSemantics s (WithNSCommon c (NSCi (Just t) v))) =
+ WithMaybeSemantics
+ (combineSemantics ( defaultSemantics {
+ semanticsAnnotationXml = [
+ XN.mkElement (XN.mkNsName "annotation-xml" mathmlNS)
+ [XN.mkAttr (XN.mkName "cd") [XN.mkText "mathmltypes"],
+ XN.mkAttr (XN.mkName "name") [XN.mkText "type"],
+ XN.mkAttr (XN.mkName "encoding") [XN.mkText "MathML-Content"]]
+ [XN.mkElement (XN.mkNsName "ci" mathmlNS) [] [XN.mkText $ nameType t]]
+ ]}) s) $ WithNSCommon c $ NSCi Nothing v
+
+nameType :: NSVariableType -> String
+nameType (NSStrictVariableType CiInteger) = "integer_type"
+nameType (NSStrictVariableType CiReal) = "real_type"
+nameType (NSStrictVariableType CiRational) = "rational_type"
+nameType (NSStrictVariableType CiComplex) = "complex_cartesian_type"
+nameType (NSStrictVariableType CiComplexPolar) = "complex_polar_type"
+nameType (NSStrictVariableType CiComplexCartesian) = "complex_cartesian_type"
+nameType (NSStrictVariableType CiConstant) = "constant_type"
+nameType (NSStrictVariableType CiFunction) = "fn_type"
+nameType (NSStrictVariableType CiVector) = "vector_type"
+nameType (NSStrictVariableType CiSet) = "set_type"
+nameType (NSStrictVariableType CiList) = "list_type"
+nameType (NSStrictVariableType CiMatrix) = "matrix_type"
+nameType (NSCiOther s) = s
+
+combineSemantics :: Semantics -> Maybe Semantics -> Maybe Semantics
+combineSemantics s Nothing = Just s
+combineSemantics ((Semantics { semanticsAnnotationXml = l1, semanticsAnnotation = l2 }))
+ (Just s@(Semantics {semanticsAnnotationXml = l1', semanticsAnnotation = l2'})) =
+ Just $ s { semanticsAnnotationXml = l1 ++ l1', semanticsAnnotation = l2 ++ l2' }
diff --git a/Data/ContentMathML3/Parser.hs b/Data/ContentMathML3/Parser.hs
new file mode 100644
--- /dev/null
+++ b/Data/ContentMathML3/Parser.hs
@@ -0,0 +1,485 @@
+module Data.ContentMathML3.Parser
+where
+
+import Control.Arrow
+import Control.Arrow.ApplyUtils
+import Text.XML.HXT.Core
+import Data.ContentMathML3.Structure
+import Data.Maybe
+import Control.Monad
+import Control.Monad.Error
+import Control.Monad.Trans.Error
+import Text.Parsec hiding ((<|>))
+import Control.Applicative hiding (liftA, liftA2, liftA3)
+import Text.Parsec.Language
+import Text.Parsec.Token
+import Text.Printf
+import qualified System.IO.Unsafe
+import qualified Foreign
+import qualified Foreign.C.Types
+import Data.Char
+import qualified Text.XML.HXT.DOM.XmlNode as XN
+import qualified Data.Map as M
+
+newtype InvalidMathML = InvalidMathML String deriving (Show, Eq, Ord)
+instance Error InvalidMathML where
+ strMsg m = InvalidMathML m
+type PossibleMathMLError a = Either InvalidMathML a
+type PME a = PossibleMathMLError a
+
+mathmlNS = "http://www.w3.org/1998/Math/MathML"
+mname lp = mkQName "mml" lp mathmlNS
+
+allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
+allM f l = liftM and $ mapM f l
+
+melem lp = isElem >>> hasQName (mname lp)
+
+melemExcluding :: ArrowXml a => [String] -> a XmlTree XmlTree
+melemExcluding lexcl =
+ let
+ jlexcl = map (Just . mname) lexcl
+ in
+ (arrL $ \v -> if ((XN.getName v) `elem` jlexcl) then [] else [v])
+
+parseMathML :: ArrowXml a => a XmlTree (PME NSASTC)
+parseMathML = propagateNamespaces >>> melem "math" /> parseMathMLExpression
+
+parseInt :: (Monad m, Integral a) => Int -> String -> String -> m a
+parseInt base n v =
+ either (fail $ n ++ " must be an integer in base " ++ (show base)) return $
+ parse (intParser (fromIntegral base)) "" v
+
+parseReal :: Monad m => Int -> String -> String -> m Double
+parseReal base n v =
+ either (fail $ n ++ " must be an real in base " ++ (show base)) return $
+ parse (realParser (fromIntegral base)) "" v
+
+allDigits = ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z']
+digitToNumber d | d >= '0' && d <= '9' = ord d - ord '0'
+ | d >= 'A' && d <= 'Z' = ord d - ord 'A'
+ | d >= 'a' && d <= 'z' = ord d - ord 'a'
+
+intParser :: Integral a => a -> Parsec String () a
+intParser base = liftM (0-) (char '-' >> unsignedIntParser base) <|>
+ unsignedIntParser base
+unsignedIntParser :: Integral a => a -> Parsec String () a
+unsignedIntParser base = let
+ validDigits = take (fromIntegral base) allDigits
+ in
+ unsignedIntParser' validDigits (fromIntegral base) 0
+unsignedIntParser' :: Integral a => String -> a -> a -> Parsec String () a
+unsignedIntParser' vd b v =
+ (do
+ c <- liftM (fromIntegral . digitToNumber) (oneOf vd)
+ unsignedIntParser' vd b ((v * b) + c)
+ ) <|> return v
+
+realParser :: Int -> Parsec String () Double
+realParser base = do
+ let validDigits = take (fromIntegral base) allDigits
+ vi <- liftM (fromInteger . fromIntegral) $ intParser base
+ (do
+ char '.'
+ let
+ invb :: Double
+ invb = 1 / (fromInteger . fromIntegral $ base)
+ vdec <- afterPointParser validDigits invb
+ if vi >= 0 then return $ vi + vdec * invb else return $ vi - vdec * invb
+ ) <|> (return vi)
+
+afterPointParser digits invb = do
+ c <- liftM (fromIntegral . digitToNumber) $ oneOf digits
+ v <- afterPointParser digits invb
+ return $ c + v * invb
+
+intBitPatternToDouble :: (Integral a, Fractional b) => a -> b
+intBitPatternToDouble bp =
+ let
+ cl :: Foreign.C.Types.CLong
+ cl = (fromIntegral bp)
+ cd :: Foreign.C.Types.CDouble
+ cd =
+ System.IO.Unsafe.unsafePerformIO $ Foreign.with cl $ \clp ->
+ Foreign.peek (Foreign.castPtr clp)
+ in
+ fromRational . toRational $ cd
+
+exactlyOneOrError :: Monad m => String -> [a] -> m a
+exactlyOneOrError msg l = case l of
+ (v:[]) -> return v
+ l ->
+ let
+ nl = length l
+ fullMsg = printf "Expected exactly one %s, but found %d" msg nl
+ in
+ fail fullMsg
+
+parseMathMLExpression :: (Arrow a, ArrowXml a) => a XmlTree (PME NSASTC)
+parseMathMLExpression =
+ parseMaybeSemantics (parseWithNSCommon parseNSAST)
+
+monadicEA :: ArrowApply a => (b -> (ErrorT InvalidMathML (ArrowAsMonad a) c)) -> a b (PME c)
+monadicEA f = monadicA $ \el -> runErrorT $ f el
+
+monadicEA' :: ArrowApply a => (b -> (ErrorT InvalidMathML (ArrowAsMonad a) c)) -> a (PME b) (PME c)
+monadicEA' f = monadicEA $ \v -> ErrorT (return v) >>= f
+
+unmonadicEA :: ArrowApply a => a b (PME c) -> b -> ErrorT InvalidMathML (ArrowAsMonad a) c
+unmonadicEA a f = ErrorT (unmonadicA a f)
+
+parseMaybeSemantics :: ArrowXml a => a XmlTree (PME c) -> a XmlTree (PME (WithMaybeSemantics c))
+parseMaybeSemantics f =
+ (melem "semantics" >>> (monadicEA $ \el -> do
+ common <- unmonadicEA parseCommon el
+ xmlAn <- lift $ unmonadicA (listA $ getChildren >>> melem "annotation-xml") el
+ an <- lift $ unmonadicA (listA $ getChildren >>> melem "annotation") el
+ cd <- lift $ unmonadicA (maybeAttr "cd") el
+ n <- lift $ unmonadicA (maybeAttr "name") el
+ fv <- unmonadicEA f el
+ return $ WithMaybeSemantics (Just Semantics { semanticsCommon = common,
+ semanticsCD = cd,
+ semanticsName = n,
+ semanticsAnnotationXml = xmlAn,
+ semanticsAnnotation = an }) fv
+ )) <+> liftAM (WithMaybeSemantics Nothing) f
+
+maybeAttr :: ArrowXml a => String -> a XmlTree (Maybe String)
+maybeAttr = liftA listToMaybe . listA . getAttrValue0
+
+attrOrFail :: ArrowXml a => String -> String -> a XmlTree (PME String)
+attrOrFail why attrname =
+ liftA (maybe (Left . InvalidMathML $ why) Right . listToMaybe)
+ (listA $ getAttrValue0 attrname)
+
+parseWithNSCommon :: ArrowXml a => a XmlTree (PME c) -> a XmlTree (PME (WithNSCommon c))
+parseWithNSCommon f = monadicEA $ \el -> do
+ fv <- unmonadicEA f el
+ du <- lift $ unmonadicA (maybeAttr "definitionURL") el
+ enc <- lift $ unmonadicA (maybeAttr "encoding") el
+ c <- unmonadicEA parseCommon el
+ let nsc = NSCommon { nsCommon = c, nsCommonDefinitionURL = du,
+ nsCommonEncoding = enc }
+ return $ WithNSCommon nsc fv
+
+parseCommon :: ArrowXml a => a XmlTree (PME Common)
+parseCommon = monadicA $ \el -> do
+ id <- unmonadicA (maybeAttr "id") el
+ xref <- unmonadicA (maybeAttr "xref") el
+ class' <- unmonadicA (maybeAttr "class") el
+ style <- unmonadicA (maybeAttr "style") el
+ href <- unmonadicA (maybeAttr "href") el
+ return . return $ Common { commonId = id, commonXref = xref, commonClass = class',
+ commonStyle = style, commonHref = href }
+
+parseSepEl :: ArrowXml a => a XmlTree (PME (String, String))
+parseSepEl = listA getChildren >>> (monadicEA $ \ell ->
+ let (elh, elt) = break (not . XN.isText) ell
+ in
+ case elt of
+ (sep:textlist) -> if all XN.isText textlist &&
+ XN.getName sep == Just (mname "sep")
+ then return $
+ (concatMap (fromMaybe "" . XN.getText) elh,
+ concatMap (fromMaybe "" . XN.getText) textlist)
+ else fail $ "cn element should contain separated list, \
+ \but contains non-text-nodes other than a \
+ \single "
+ _ -> fail "No found in cn element type requiring a "
+ )
+
+parseNSConstantPart :: ArrowXml a => Int -> a XmlTree (PME NSConstantPart)
+parseNSConstantPart b = monadicEA $ \el -> do
+ t <- liftM (fromMaybe "real") (unmonadicEA (liftA return $ maybeAttr "type") el)
+ let
+ parsePackContents :: ArrowXml a => (b -> c) -> (String -> String -> ErrorT InvalidMathML (ArrowAsMonad a) b) -> ErrorT InvalidMathML (ArrowAsMonad a) c
+ parsePackContents pck prs =
+ (lift (unmonadicA extractChildText el)) >>=
+ (liftM pck . prs "cn contents")
+ let parseSep2Pack pck prs = do
+ (t1, t2) <- unmonadicEA parseSepEl el
+ d1 <- prs b "separated cn entry" t1
+ d2 <- prs b "separated cn entry" t2
+ return $ pck d1 d2
+ case () of
+ () | t == "integer" -> parsePackContents NSCnInteger (parseInt b)
+ | t == "real" -> parsePackContents NSCnReal (parseReal b)
+ | t == "double" -> parsePackContents NSCnDouble (parseReal b)
+ | t == "hexdouble" -> parsePackContents (NSCnHexDouble . intBitPatternToDouble)
+ (parseInt 16)
+ | t == "e-notation" -> parseSep2Pack NSCnENotation parseReal
+ | t == "rational" -> parseSep2Pack NSCnRational parseInt
+ | t == "complex-cartesian" -> parseSep2Pack NSCnComplexCartesian parseReal
+ | t == "complex-polar" -> parseSep2Pack NSCnComplexPolar parseReal
+ | t == "constant" -> parsePackContents NSCnConstant (const return)
+ _ -> parsePackContents (NSCnOther t) (const return)
+
+ciTypeToConstructor :: String -> Maybe VariableType
+ciTypeToConstructor = flip M.lookup
+ (M.fromList
+ [("integer", CiInteger), ("rational", CiRational),
+ ("real", CiReal), ("complex", CiComplex),
+ ("complex-polar", CiComplexPolar),
+ ("complex-cartesian", CiComplexCartesian),
+ ("constant", CiConstant), ("function", CiFunction),
+ ("vector", CiVector), ("list", CiList), ("set", CiSet),
+ ("matrix", CiMatrix)
+ ])
+
+parseNSCiType :: ArrowXml a => a XmlTree (PME (Maybe NSVariableType))
+parseNSCiType =
+ monadicEA $ \el -> do
+ ma <- lift $ unmonadicA (maybeAttr "type") el
+ maybe (return Nothing)
+ (\a ->
+ maybe (return . Just . NSCiOther $ a)
+ (return . Just . NSStrictVariableType) (ciTypeToConstructor a))
+ ma
+
+parseNSSymbolContent :: ArrowXml a => a XmlTree (PME NSSymbolContent)
+parseNSSymbolContent = monadicEA $ \el -> do
+ mgl <- liftM listToMaybe $ lift $
+ unmonadicA (listA $ getChildren >>> melem "mglyph") el
+ case mgl of
+ Just gl -> return $ NSCiMGlyph gl
+ Nothing -> do
+ me <- liftM listToMaybe $ lift $
+ unmonadicA (listA $ getChildren >>> isElem) el
+ case me of
+ Just e -> return $ NSCiPresentationExpression e
+ Nothing -> lift (unmonadicA extractChildText el) >>= return . NSCiText
+
+parseNSAST :: ArrowXml a => a XmlTree (PME NSAST)
+parseNSAST =
+ (melem "cn" >>> (monadicEA $ \el -> do
+ baseStr <- (lift $ unmonadicA (maybeAttr "base") el)
+ base <- (maybe (return Nothing) (liftM Just . (parseInt 10 "base attribute")) baseStr)
+ let useBase = fromMaybe 10 base
+ cp <- unmonadicEA (parseNSConstantPart useBase) el
+ return $ NSCn base cp)) <+>
+ (melem "ci" >>> (liftAM NSASTCi $
+ liftAM2 NSCi parseNSCiType parseNSSymbolContent)
+ ) <+>
+ (melem "csymbol" >>>
+ liftAM3 NSCsymbol
+ (alwaysSuccessA $ maybeAttr "cd")
+ (alwaysSuccessA $ maybeAttr "type")
+ parseNSSymbolContent) <+>
+ (melem "cs" >>> liftAM NSCs (alwaysSuccessA extractChildText)) <+>
+ (melem "apply" >>> (monadicEA $ \app -> do
+ hElem <- unmonadicEA (getNthElemA "apply - find operator" 0) app
+ h <- unmonadicEA parseMathMLExpression hElem
+ tElems <- unmonadicEA (listAM $ getChildren >>> isntBvar >>> isntQualifier >>> parseMathMLExpression) app
+ let t = drop 1 tElems
+ bv <- unmonadicEA (listAM (getChildren >>> melem "bvar" >>> parseBvar)) app
+ qual <- unmonadicEA (listAM (getChildren >>> isQualifier >>> parseQualifier)) app
+ return $ NSApply h bv qual t
+ )) <+>
+ (melem "bind" >>> liftAM4 NSBind
+ ((listA getChildren >>^ head) >>> parseMathMLExpression)
+ (listAM (melem "bvar" >>> parseBvar))
+ (listAM (isQualifier >>> parseQualifier))
+ (listAM ((listA getChildren >>^ tail) >>> unlistA >>>
+ parseMathMLExpression))) <+>
+ (melem "cerror" >>> liftAM2 NSError
+ ((listA getChildren >>^ head) >>> parseMathMLExpression)
+ (listAM ((listA getChildren >>^ tail) >>> unlistA >>>
+ parseMathMLExpression))) <+>
+ (melem "cbytes" >>> alwaysSuccessA (liftA NSCBytes extractChildText)) <+>
+ (melem "piecewise" >>>
+ (liftAM NSPiecewise $
+ liftAM2 (,)
+ (listAM $ parseWithNSCommon $ melem "piece" >>>
+ liftAM2 (,) (monadicEA $ \el -> do
+ p <- unmonadicEA (getNthElemA "piece" 0) el
+ unmonadicEA parseMathMLExpression p)
+ (monadicEA $ \el -> do
+ p <- unmonadicEA (getNthElemA "piece" 1) el
+ unmonadicEA parseMathMLExpression p))
+ (defaultA (Right Nothing) (getChildren >>>
+ liftAM Just (parseWithNSCommon (melem "otherwise" />
+ parseMathMLExpression)))))) <+>
+ (melem "relation" >>>
+ liftAM2 NSRelation ((listA getChildren >>^ head) >>> parseMathMLExpression)
+ (listAM ((listA getChildren >>^ tail) >>> unlistA >>> parseMathMLExpression))
+ ) <+>
+ (melem "function" >>>
+ liftAM NSFunction (listAM (getChildren >>> parseMathMLExpression) >>>
+ monadicEA' (exactlyOneOrError "expression child of function"))) <+>
+ (melem "declare" >>>
+ (monadicEA $ \el -> do
+ typeA <- lift $ unmonadicA (maybeAttr "type") el
+ scopeA <- lift $ unmonadicA (maybeAttr "scope") el
+ rawNArgsA <- lift $ unmonadicA (maybeAttr "nargs") el
+ nargsA <- maybe (return Nothing) (\v -> parseInt 10 "nargs" v >>= return . Just) rawNArgsA
+ rawNOccurA <- lift $ unmonadicA (maybeAttr "noccur") el
+ noccurA <- case rawNOccurA of
+ Nothing -> return Nothing
+ Just "prefix" -> return $ Just NSDeclarePrefix
+ Just "infix" -> return $ Just NSDeclareInfix
+ Just "function-model" -> return $ Just NSDeclareFunctionModel
+ Just v -> fail $ "Invalid noccur attribute value " ++ v
+ ndecl <- unmonadicEA (listAM (getChildren >>> parseMathMLExpression)) el
+ return $ NSDeclare typeA scopeA nargsA noccurA ndecl)) <+>
+ (melem "lambda" >>>
+ (monadicEA $ \el -> do
+ bv <- unmonadicEA (listAM (getChildren >>> melem "bvar" >>> parseBvar)) el
+ children <- unmonadicEA (listAM (getChildren >>> isntBvar >>> isntQualifier >>> parseMathMLExpression)) el
+ expr <- exactlyOneOrError "non-qualifier element on lambda" children
+ dom <- unmonadicEA (listAM (getChildren >>> parseDomainQualifier)) el
+ return $ NSLambda bv dom expr
+ )) <+>
+ (melem "vector" >>>
+ (monadicEA $ \el -> do
+ bv <- unmonadicEA (listAM (getChildren >>> melem "bvar" >>> parseBvar)) el
+ children <- unmonadicEA (listAM (getChildren >>> isntBvar >>> isntQualifier >>> parseMathMLExpression)) el
+ dom <- unmonadicEA (listAM (getChildren >>> parseDomainQualifier)) el
+ return $ NSVector bv dom children
+ )) <+>
+ (melem "matrix" >>>
+ (monadicEA $ \el -> do
+ bv <- unmonadicEA (listAM (getChildren >>> melem "bvar" >>> parseBvar)) el
+ dom <- unmonadicEA (listAM (getChildren >>> parseDomainQualifier)) el
+ rows <- unmonadicEA (listAM (getChildren >>> melem "matrixrow" >>>
+ parseWithNSCommon parseMatrixRow)) el
+ if rows == []
+ then return $ NSMatrixByRow rows
+ else do
+ children <- unmonadicEA (listAM (getChildren >>> isntBvar >>> isntQualifier >>> parseMathMLExpression)) el
+ firstChild <- exactlyOneOrError "MathML expressions inside matrix" children
+ return $ NSMatrixByFunction bv dom firstChild
+ )) <+>
+ (melem "tendsto" >>>
+ alwaysSuccessA (liftA NSTendsto (maybeAttr "type"))) <+>
+ (melem "list" >>>
+ (monadicEA $ \el -> do
+ bv <- unmonadicEA (listAM (getChildren >>> melem "bvar" >>> parseBvar)) el
+ children <- unmonadicEA (listAM (getChildren >>> isntBvar >>> isntQualifier >>> parseMathMLExpression)) el
+ dom <- unmonadicEA (listAM (getChildren >>> parseDomainQualifier)) el
+ return $ NSList bv dom children
+ )) <+>
+ (melem "set" >>>
+ (monadicEA $ \el -> do
+ bv <- unmonadicEA (listAM (getChildren >>> melem "bvar" >>> parseBvar)) el
+ children <- unmonadicEA (listAM (getChildren >>> isntBvar >>> isntQualifier >>> parseMathMLExpression)) el
+ dom <- unmonadicEA (listAM (getChildren >>> parseDomainQualifier)) el
+ return $ NSSet bv dom children
+ )) <+>
+ (foldl (<+>) zeroArrow $
+ map (\(n,v) -> melem n >>>
+ (alwaysSuccessA . arr . const $ v)) $
+ [("inverse", NSInverse), ("ident", NSIdent), ("domain", NSDomain),
+ ("codomain", NSCodomain), ("image", NSImage), ("ln", NSLn),
+ ("log", NSLog), ("moment", NSMoment), ("compose", NSCompose),
+ ("quotient", NSQuotient), ("divide", NSDivide), ("minus", NSMinus),
+ ("power", NSPower), ("rem", NSRem), ("root", NSRoot),
+ ("factorial", NSFactorial), ("abs", NSAbs), ("conjugate", NSConjugate),
+ ("arg", NSArg), ("real", NSReal), ("imaginary", NSImaginary),
+ ("floor", NSFloor), ("ceiling", NSCeiling), ("exp", NSExp),
+ ("max", NSMax), ("min", NSMin), ("plus", NSPlus), ("times", NSTimes),
+ ("gcd", NSGcd), ("lcm", NSLcm), ("and", NSAnd), ("or", NSOr),
+ ("xor", NSXor), ("not", NSNot), ("implies", NSImplies),
+ ("equivalent", NSEquivalent), ("forall", NSForall),
+ ("exists", NSExists), ("eq", NSEq), ("gt", NSGt), ("lt", NSLt),
+ ("geq", NSGeq), ("leq", NSLeq), ("neq", NSNeq),
+ ("approx", NSApprox), ("factorof", NSFactorof),
+ ("int", NSInt), ("diff", NSDiff), ("partialdiff", NSPartialdiff),
+ ("divergence", NSDivergence), ("grad", NSGrad), ("curl", NSCurl),
+ ("laplacian", NSLaplacian),
+ ("union", NSUnion), ("intersect", NSIntersect),
+ ("cartesianproduct", NSCartesianProduct), ("in", NSIn),
+ ("notin", NSNotIn), ("notsubset", NSNotSubset),
+ ("notprsubset", NSNotPrSubset), ("setdiff", NSSetDiff),
+ ("subset", NSSubset), ("prsubset", NSPrSubset), ("card", NSCard),
+ ("sum", NSSum), ("product", NSProduct), ("limit", NSLimit),
+ ("sin", NSSin), ("cos", NSCos), ("tan", NSTan), ("sec", NSSec),
+ ("csc", NSCsc), ("cot", NSCot), ("sinh", NSSinh), ("cosh", NSCosh),
+ ("tanh", NSTanh), ("sech", NSSech), ("csch", NSCsch), ("coth", NSCoth),
+ ("arcsin", NSArcsin), ("arccos", NSArccos), ("arctan", NSArctan),
+ ("arccosh", NSArccosh), ("arccot", NSArccot), ("arccoth", NSArccoth),
+ ("arccsc", NSArccsc), ("arccsch", NSArccsch), ("arcsec", NSArcsec),
+ ("arcsech", NSArcsech), ("arcsinh", NSArcsinh), ("arctanh", NSArctanh),
+ ("mean", NSMean), ("sdev", NSSdev), ("variance", NSVariance),
+ ("median", NSMedian), ("mode", NSMode), ("determinant", NSDeterminant),
+ ("transpose", NSTranspose), ("selector", NSSelector),
+ ("vectorproduct", NSVectorProduct), ("scalarproduct", NSScalarProduct),
+ ("outerproduct", NSOuterProduct), ("integers", NSIntegers),
+ ("reals", NSReals), ("rationals", NSRationals),
+ ("naturalnumbers", NSNaturalNumbers), ("complexes", NSComplexes),
+ ("primes", NSPrimes), ("emptyset", NSEmptySet),
+ ("exponentiale", NSExponentialE), ("imaginaryi", NSImaginaryi),
+ ("notanumber", NSNotanumber), ("true", NSTrue), ("false", NSFalse),
+ ("pi", NSPi), ("eulergamma", NSEulergamma), ("infinity", NSInfinity)
+ ])
+
+parseMatrixRow :: ArrowXml a => a XmlTree (PME NSMatrixRow)
+parseMatrixRow = monadicEA $ \el -> do
+ bv <- unmonadicEA (listAM (getChildren >>> melem "bvar" >>> parseBvar)) el
+ dom <- unmonadicEA (listAM (getChildren >>> parseDomainQualifier)) el
+ children <- unmonadicEA (listAM (getChildren >>> isntBvar >>> isntQualifier >>> parseMathMLExpression)) el
+ return $ NSMatrixRow bv dom children
+
+alwaysSuccessA :: (Arrow a, Error e) => a b c -> a b (Either e c)
+alwaysSuccessA a = a >>^ Right
+extractChildText :: ArrowXml a => a XmlTree String
+extractChildText = liftA concat $ listA $ getChildren >>> getText
+
+getNthElemA el n = listA getChildren >>^ (\l -> let v = drop n l in
+ if null v then Left (InvalidMathML (el ++ ": Expected at least " ++ show (n + 1) ++ " child elements"))
+ else Right (head v))
+
+listAM :: (ArrowList a) => a b (PME c) -> a b (PME [c])
+listAM a =
+ let
+ leftOrRightList :: Either e a -> Either e [a] -> Either e [a]
+ leftOrRightList _ l@(Left _) = l
+ leftOrRightList (Left l) _ = Left l
+ leftOrRightList (Right e) (Right l) = Right (e:l)
+ in
+ listA a >>^ (foldr leftOrRightList (Right []))
+listToMaybeMax1 :: (ArrowApply a, ArrowList a, Arrow a) => String -> a b (PME c) -> a b (PME (Maybe c))
+listToMaybeMax1 n a = (monadicEA $ \b -> do
+ alist <- unmonadicEA (listAM a) b
+ case alist of
+ [] -> return Nothing
+ v:[] -> return (Just v)
+ _ -> error (n ++ ": At most one matching element is allowed"))
+
+defaultA :: (ArrowList a, ArrowApply a) => c -> a b c -> a b c
+defaultA dv a = ((liftA2 (<|>) (listA a >>^ listToMaybe) (constA (Just dv))) >>^ maybeToList) >>> unlistA
+
+isQualifier :: ArrowXml a => a XmlTree XmlTree
+isQualifier = melem "domainofapplication" <+> melem "condition" <+> melem "interval" <+> melem "lowlimit" <+>
+ melem "uplimit" <+> melem "degree" <+> melem "momentabout" <+> melem "logbase"
+
+isntQualifier :: ArrowXml a => a XmlTree XmlTree
+isntQualifier = melemExcluding ["domainofapplication", "condition", "interval", "lowlimit", "uplimit",
+ "degree", "momentabout", "logbase"]
+
+isntBvar :: ArrowXml a => a XmlTree XmlTree
+isntBvar = melemExcluding ["bvar"]
+
+parseQualifier :: ArrowXml a => a XmlTree (PME NSQualifier)
+parseQualifier = liftAM NSQualDomain parseDomainQualifier <+>
+ (melem "degree" /> liftAM NSQualDegree parseMathMLExpression) <+>
+ (melem "momentabout" /> liftAM NSQualMomentabout parseMathMLExpression) <+>
+ (melem "logbase" /> liftAM NSQualLogbase parseMathMLExpression)
+
+parseDomainQualifier :: ArrowXml a => a XmlTree (PME NSDomainQualifier)
+parseDomainQualifier =
+ ((melem "domainofapplication" /> liftAM NSDomainOfApplication parseMathMLExpression) <+>
+ (melem "condition" /> liftAM NSCondition parseMathMLExpression) <+>
+ (melem "interval" >>> liftAM NSQInterval
+ (parseWithNSCommon $ monadicEA $ \interval -> do
+ closure <- lift $ unmonadicA (maybeAttr "closure") interval
+ lowlim <- unmonadicEA (getNthElemA "interval" 0) interval >>= unmonadicEA parseMathMLExpression
+ uplim <- unmonadicEA (getNthElemA "interval" 1) interval >>= unmonadicEA parseMathMLExpression
+ return $ NSInterval closure lowlim uplim
+ )) <+>
+ (melem "lowlimit" /> liftAM NSLowlimit parseMathMLExpression) <+>
+ (melem "uplimit" /> liftAM NSUplimit parseMathMLExpression)
+ )
+parseBvar :: ArrowXml a => a XmlTree (PME NSBvar)
+parseBvar = melem "bvar" >>>
+ liftAM2 NSBvar (parseMaybeSemantics (parseWithNSCommon $ liftAM2 NSCi parseNSCiType parseNSSymbolContent))
+ (liftAM listToMaybe $ listAM (getChildren >>> melem "degree" /> parseMathMLExpression))
diff --git a/Data/ContentMathML3/Structure.hs b/Data/ContentMathML3/Structure.hs
new file mode 100644
--- /dev/null
+++ b/Data/ContentMathML3/Structure.hs
@@ -0,0 +1,389 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module Data.ContentMathML3.Structure
+where
+
+import Text.XML.HXT.DOM.TypeDefs
+import Data.ContentMathML3.XNodeOrd
+import Data.Data
+import Data.Typeable
+import Data.Maybe
+
+-- | Represents the attributes common to all strict MathML 3 content elements.
+data Common = Common {
+ commonId :: Maybe String, -- ^ An identifier for the element
+ commonXref :: Maybe String, -- ^ The identifier of the parallel presentation MathML markup.
+ commonClass :: Maybe String, -- ^ The identifier of the class used in styling.
+ commonStyle :: Maybe String, -- ^ The style to be applied.
+ commonHref :: Maybe String -- ^ The URI to link the element to.
+ } deriving (Eq, Ord, Typeable, Data, Show)
+
+-- | A starting point for building a Common
+commonDefault = Common Nothing Nothing Nothing Nothing Nothing
+
+-- | A constant (cn) value representation.
+data ConstantPart = CnInteger Int -- ^ An integer
+ | CnReal Double -- ^ A real number
+ | CnDouble Double -- ^ A double precision real number
+ | CnHexDouble Double -- ^ A double precision real number, in hex
+ deriving (Eq, Ord, Typeable, Data, Show)
+
+-- | A variable (ci) type
+data VariableType = CiInteger -- ^ An integer-valued variable.
+ | CiReal -- ^ A real-valued variable.
+ | CiRational -- ^ A rational-valued variable.
+ | CiComplex -- ^ A complex-valued variable.
+ | CiComplexPolar -- ^ A complex (polar) valued variable.
+ | CiComplexCartesian -- ^ A complex (cartesian) valued variable.
+ | CiConstant -- ^ A constant-valued variable.
+ | CiFunction -- ^ A function-valued variable.
+ | CiVector -- ^ A vector-valued variable.
+ | CiSet -- ^ A set-valued variable.
+ | CiList -- ^ A list-valued variable.
+ | CiMatrix -- ^ A matrix-valued variable.
+ deriving (Eq, Ord, Typeable, Data, Show)
+
+data WithCommon a = WithCommon Common a deriving (Eq, Ord, Typeable, Data, Show)
+data Semantics = Semantics {
+ semanticsCommon :: Common,
+ semanticsCD :: Maybe String,
+ semanticsName :: Maybe String,
+ semanticsAnnotationXml :: [XmlTree],
+ semanticsAnnotation :: [XmlTree]
+ } deriving (Eq, Ord, Typeable, Data, Show)
+data WithMaybeSemantics a = WithMaybeSemantics (Maybe Semantics) a deriving (Eq, Ord, Typeable, Data, Show)
+defaultSemantics = Semantics commonDefault Nothing Nothing [] []
+withDefaultSemantics a = WithMaybeSemantics (Just defaultSemantics) a
+
+noSemCom :: a -> WithMaybeSemantics (WithCommon a)
+noSemCom a = WithMaybeSemantics Nothing (WithCommon commonDefault a)
+
+noNSSemCom :: a -> WithMaybeSemantics (WithNSCommon a)
+noNSSemCom a = WithMaybeSemantics Nothing (WithNSCommon nsCommonDefault a)
+
+-- | Strict MathML 3 Abstract Syntax Tree
+type ASTC = WithMaybeSemantics (WithCommon AST)
+
+data Ci = Ci String deriving (Eq, Ord, Typeable, Data, Show)
+type CCi = WithCommon Ci
+
+-- | Strict Abstract Syntax Tree, without common information on tree root
+data AST = Cn ConstantPart -- ^ Constant
+ | ASTCi Ci -- ^ Variable
+ | Csymbol { csymbolContentDictionary :: Maybe String, -- ^ The OpenMath cd
+ csymbolSymbolName :: String -- ^ The name in the cd
+ } -- ^ External symbol
+ | Cs String -- ^ String literal
+ | Apply { applyOperator :: ASTC, -- ^ The operator to apply
+ applyOperands :: [ASTC] -- ^ The operands to use
+ } -- ^ Function application
+ | Bind { bindOperator :: ASTC, -- ^ The binding operator
+ bindBvar :: [WithMaybeSemantics (CCi)], -- ^ The bound variables
+ bindExpression :: ASTC -- ^ The expression
+ } -- ^ Binding
+ | Error { errorType :: ASTC, errorArgs :: [ASTC] } -- ^ A math error
+ | CBytes String -- ^ A string of bytes
+ deriving (Eq, Ord, Data, Typeable, Show)
+
+-- | Represents the attributes common to all non-strict MathML elements.
+data NSCommon = NSCommon {
+ nsCommon :: Common, -- ^ Strict common attributes
+ nsCommonDefinitionURL :: Maybe String, -- ^ The definition URL for the element.
+ nsCommonEncoding :: Maybe String -- ^ The encoding of the defintion.
+ } deriving (Eq, Ord, Typeable, Data, Show)
+
+-- | Default values for non-strict common attributes (all absent)
+nsCommonDefault = NSCommon commonDefault Nothing Nothing
+
+-- | Represents some data structure alongside the non-strict common data.
+data WithNSCommon a = WithNSCommon NSCommon a deriving (Eq, Ord, Typeable, Data, Show)
+
+-- | Non-strict MathML 3 Abstract Syntax Tree
+type NSASTC = WithMaybeSemantics (WithNSCommon NSAST)
+
+-- | A non-strict constant (cn) value representation.
+data NSConstantPart = NSCnInteger Int -- ^ An integer constant
+ | NSCnReal Double -- ^ A real constant
+ | NSCnDouble Double -- ^ A double precision real
+ | NSCnHexDouble Double -- ^ A real constant in hex
+ | NSCnENotation Double Double -- ^ A constant in e-notation
+ | NSCnRational Int Int -- ^ A rational constant
+ -- | A complex cartesian constant
+ | NSCnComplexCartesian Double Double
+ -- | A complex polar constant
+ | NSCnComplexPolar Double Double
+ | NSCnConstant String -- ^ A predefined constant
+ | NSCnOther String String -- ^ Another type of constant
+ deriving (Eq, Ord, Typeable, Data, Show)
+
+-- | The type of a variable
+data NSVariableType = NSStrictVariableType VariableType -- ^ A strict variable type
+ | NSCiOther String -- ^ A user-defined type
+ deriving (Eq, Ord, Typeable, Data, Show)
+
+-- | The content of a non-strict ci or csymbol element.
+data NSSymbolContent = NSCiText String -- ^ A named element
+ | NSCiMGlyph XmlTree -- ^ An mglyph node
+ | NSCiPresentationExpression XmlTree -- ^ Presentation MathML
+ deriving (Eq, Ord, Typeable, Data, Show)
+
+-- | A non-strict ci
+data NSCi = NSCi (Maybe NSVariableType) NSSymbolContent deriving (Eq, Ord, Typeable, Data, Show)
+
+-- | A bound variable
+data NSBvar = NSBvar { bvarCi :: WithMaybeSemantics (WithNSCommon NSCi), -- ^ The inner ci
+ bvarDegree :: Maybe NSASTC -- ^ The degree (e.g. for diff)
+ } deriving (Eq, Ord, Typeable, Data, Show)
+
+-- | Non-strict MathML AST, without common information on tree root.
+data NSAST = NSCn { nsCnBase :: Maybe Int, -- ^ The base used to represent it
+ nsCnData :: NSConstantPart -- ^ The constant data itself
+ }
+ | NSASTCi NSCi -- ^ A ci element
+ -- | A csymbol element
+ | NSCsymbol { nsCsymbolContentDictionary :: Maybe String,
+ nsCsymbolSymbolType :: Maybe String,
+ nsCsymbolContent :: NSSymbolContent }
+ | NSCs String -- ^ A string constant (cs)
+ | NSApply { nsApplyOperator :: NSASTC,
+ nsApplyBvar :: [NSBvar],
+ nsApplyQualifier :: [NSQualifier],
+ nsApplyOperands :: [NSASTC] } -- ^ Function application
+ | NSBind { nsBindOperator :: NSASTC,
+ nsBindBvar :: [NSBvar],
+ nsBindQualifiers :: [NSQualifier],
+ nsBindOperands :: [NSASTC] } -- ^ Function binding
+ | NSError { nsErrorType :: NSASTC,
+ nsErrorArgs :: [NSASTC] } -- ^ Error
+ | NSCBytes String -- ^ A string of bytes.
+ -- | A piecewise expression
+ | NSPiecewise ([WithNSCommon (NSASTC, NSASTC)], Maybe (WithNSCommon NSASTC))
+ -- | A (deprecated) relation
+ | NSRelation NSASTC [NSASTC]
+ -- | A (deprecated) function
+ | NSFunction NSASTC
+ -- | A (deprecated) declare
+ | NSDeclare { nsDeclareType :: Maybe String,
+ nsScope :: Maybe String,
+ nsNArgs :: Maybe Int,
+ nsOccurrence :: Maybe NSDeclareOccurrence,
+ nsDeclareExprs :: [NSASTC] }
+ | NSInverse -- ^ Inverse
+ | NSIdent -- ^ Identify function
+ | NSDomain -- ^ Domain
+ | NSCodomain -- ^ Codomain
+ | NSImage -- ^ Image
+ | NSLn -- ^ Natural log
+ | NSLog -- ^ Log
+ | NSMoment -- ^ Moment
+ | NSLambda { nsLambdaBVar :: [NSBvar],
+ nsLambdaDomain :: [NSDomainQualifier],
+ nsLambdaExpr :: NSASTC } -- ^ Lambda function
+ | NSCompose -- ^ Compose
+ | NSQuotient -- ^ Quotient
+ | NSDivide -- ^ Divide
+ | NSMinus -- ^ Minus
+ | NSPower -- ^ Power
+ | NSRem -- ^ Remainder
+ | NSRoot -- ^ Root
+ | NSFactorial -- ^ Factorial
+ | NSAbs -- ^ Absolute
+ | NSConjugate -- ^ Conjugate
+ | NSArg -- ^ Argument
+ | NSReal -- ^ Real
+ | NSImaginary -- ^ Imaginary
+ | NSFloor -- ^ Floor
+ | NSCeiling -- ^ Ceiling
+ | NSExp -- ^ Exponential
+ | NSMax -- ^ Maximum
+ | NSMin -- ^ Minimum
+ | NSPlus -- ^ Plus
+ | NSTimes -- ^ Times
+ | NSGcd -- ^ Greatest common denominator
+ | NSLcm -- ^ Lowest common multiple
+ | NSAnd -- ^ And
+ | NSOr -- ^ Or
+ | NSXor -- ^ Exclusive or
+ | NSNot -- ^ Not
+ | NSImplies -- ^ Implies
+ | NSEquivalent -- ^ Equivalent
+ | NSForall -- ^ Forall
+ | NSExists -- ^ Exists
+ | NSEq -- ^ Equal
+ | NSGt -- ^ Greater Than
+ | NSLt -- ^ Less Than
+ | NSGeq -- ^ Greater Than or Equal To
+ | NSLeq -- ^ Less Than Or Equal To
+ | NSNeq -- ^ Not Equal
+ | NSApprox -- ^ Approximately Equal
+ | NSFactorof -- ^ Factor of
+ | NSTendsto (Maybe String) -- ^ Tends to
+ | NSInt -- ^ Integral
+ | NSDiff -- ^ Differential
+ | NSPartialdiff -- ^ Partial Differential
+ | NSDivergence -- ^ Divergence
+ | NSGrad -- ^ Gradient
+ | NSCurl -- ^ Curl
+ | NSLaplacian -- ^ Laplacian
+ | NSSet [NSBvar] [NSDomainQualifier] [NSASTC] -- ^ Set
+ | NSList [NSBvar] [NSDomainQualifier] [NSASTC] -- ^ List
+ | NSUnion -- ^ Union
+ | NSIntersect -- ^ Intersection
+ | NSCartesianProduct -- ^ Cartesian product
+ | NSIn -- ^ Set membership
+ | NSNotIn -- ^ Non set membership
+ | NSNotSubset -- ^ Set not subset
+ | NSNotPrSubset -- ^ Set not proper subset
+ | NSSetDiff -- ^ Set difference
+ | NSSubset -- ^ Subset
+ | NSPrSubset -- ^ Proper subset
+ | NSCard -- ^ Cardinality
+ | NSSum -- ^ Sum
+ | NSProduct -- ^ Product
+ | NSLimit -- ^ Limit
+ | NSSin -- ^ Sine
+ | NSCos -- ^ Cosine
+ | NSTan -- ^ Tangent
+ | NSSec -- ^ Secant
+ | NSCsc -- ^ Cosecant
+ | NSCot -- ^ Cotangent
+ | NSSinh -- ^ Hyperbolic sine
+ | NSCosh -- ^ Hyperbolic cosine
+ | NSTanh -- ^ Hyperbolic tangent
+ | NSSech -- ^ Hyperbolic secant
+ | NSCsch -- ^ Hyperbolic cosecant
+ | NSCoth -- ^ Hyperbolic cotangent
+ | NSArcsin -- ^ Inverse sine
+ | NSArccos -- ^ Inverse cosine
+ | NSArctan -- ^ Inverse tangent
+ | NSArccosh -- ^ Inverse hyperbolic cosine
+ | NSArccot -- ^ Inverse cotangent
+ | NSArccoth -- ^ Inverse hyperbolic cotangent
+ | NSArccsc -- ^ Inverse cosecant
+ | NSArccsch -- ^ Inverse hyperbolic cosecant
+ | NSArcsec -- ^ Inverse secant
+ | NSArcsech -- ^ Inverse hyperbolic secant
+ | NSArcsinh -- ^ Inverse hyperbolic sine
+ | NSArctanh -- ^ Inverse hyperbolic tan
+ | NSMean -- ^ Mean
+ | NSSdev -- ^ Standard deviation
+ | NSVariance -- ^ Variance
+ | NSMedian -- ^ Median
+ | NSMode -- ^ Mode
+ | NSVector { nsVectorBvar :: [NSBvar],
+ nsVectorDomain :: [NSDomainQualifier],
+ nsVectorExpressions :: [NSASTC] } -- ^ Vector constructor
+ | NSMatrixByRow [WithNSCommon NSMatrixRow]
+ | NSMatrixByFunction { nsMatrixBvar :: [NSBvar],
+ nsMatrixDomain :: [NSDomainQualifier],
+ nsMatrixExpr :: NSASTC } -- ^ Matrix
+ | NSDeterminant -- ^ Determinant
+ | NSTranspose -- ^ Transpose
+ | NSSelector -- ^ Selector
+ | NSVectorProduct -- ^ Vector product
+ | NSScalarProduct -- ^ Scalar product
+ | NSOuterProduct -- ^ Outer product
+ | NSIntegers -- ^ Integers
+ | NSReals -- ^ Reals
+ | NSRationals -- ^ Rationals
+ | NSNaturalNumbers -- ^ Natural numbers
+ | NSComplexes -- ^ Complex numbers
+ | NSPrimes -- ^ Primes
+ | NSEmptySet -- ^ Empty set
+ | NSExponentialE -- ^ Exponential e
+ | NSImaginaryi -- ^ Imaginary i
+ | NSNotanumber -- ^ notanumber
+ | NSTrue -- ^ true
+ | NSFalse -- ^ false
+ | NSPi -- ^ pi
+ | NSEulergamma -- ^ Euler gamma
+ | NSInfinity -- ^ +Infinity
+ deriving (Eq, Ord, Typeable, Data, Show)
+
+data NSMatrixRow = NSMatrixRow { nsMatrixRowBvar :: [NSBvar],
+ nsMatrixRowDomain :: [NSDomainQualifier],
+ msMatrixRowExpressions :: [NSASTC] }
+ deriving (Eq, Ord, Typeable, Data, Show)
+
+data NSDeclareOccurrence = NSDeclarePrefix | NSDeclareInfix | NSDeclareFunctionModel
+ deriving (Eq, Ord, Typeable, Data, Show)
+
+data NSInterval = NSInterval { nsIntervalClosure :: Maybe String,
+ nsIntervalLow :: NSASTC,
+ nsIntervalHigh :: NSASTC }
+ deriving (Eq, Ord, Typeable, Data, Show)
+
+data NSDomainQualifier = NSDomainOfApplication NSASTC | NSCondition NSASTC |
+ NSQInterval (WithNSCommon NSInterval) |
+ NSLowlimit NSASTC |
+ NSUplimit NSASTC deriving (Eq, Ord, Typeable, Data, Show)
+data NSQualifier = NSQualDomain NSDomainQualifier |
+ NSQualDegree NSASTC |
+ NSQualMomentabout NSASTC |
+ NSQualLogbase NSASTC
+ deriving (Eq, Ord, Typeable, Data, Show)
+
+class CanHaveDomain a where
+ getDomains :: a -> [NSDomainQualifier]
+ setDomains :: a -> [NSDomainQualifier] -> a
+ getBvars :: a -> [NSBvar]
+ setBvars :: a -> [NSBvar] -> a
+
+instance CanHaveDomain NSAST where
+ getDomains (NSLambda _ dq _) = dq
+ getDomains (NSSet _ dq _) = dq
+ getDomains (NSList _ dq _) = dq
+ getDomains (NSVector _ dq _) = dq
+ getDomains (NSMatrixByFunction _ dq _) = dq
+ getDomains (NSApply _ _ q _) = mapMaybe (\qv ->
+ case qv of
+ NSQualDomain d -> Just d
+ _ -> Nothing) q
+ getDomains (NSBind _ _ q _) = mapMaybe (\qv ->
+ case qv of
+ NSQualDomain d -> Just d
+ _ -> Nothing) q
+ getDomains _ = []
+
+ setDomains (NSLambda a _ c) dq = NSLambda a dq c
+ setDomains (NSSet a _ c) dq = NSSet a dq c
+ setDomains (NSList a _ c) dq = NSList a dq c
+ setDomains (NSVector a _ c) dq = NSVector a dq c
+ setDomains (NSMatrixByFunction a _ c) dq = NSMatrixByFunction a dq c
+ setDomains (NSApply a b c d) dq = NSApply a b (map NSQualDomain dq ++
+ filter (\qv ->
+ case qv of
+ NSQualDomain d -> False
+ _ -> True
+ ) c) d
+ setDomains (NSBind a b c d) dq = NSBind a b (map NSQualDomain dq ++
+ filter (\qv ->
+ case qv of
+ NSQualDomain d -> False
+ _ -> True
+ ) c) d
+ setDomains x _ = x
+
+ getBvars (NSLambda bv _ _) = bv
+ getBvars (NSSet bv _ _) = bv
+ getBvars (NSList bv _ _) = bv
+ getBvars (NSVector bv _ _) = bv
+ getBvars (NSMatrixByFunction bv _ _) = bv
+ getBvars (NSApply _ bv _ _) = bv
+ getBvars (NSBind _ bv _ _) = bv
+ getBvars _ = []
+
+ setBvars (NSLambda _ b c) bv = NSLambda bv b c
+ setBvars (NSSet _ b c) bv = NSSet bv b c
+ setBvars (NSList _ b c) bv = NSSet bv b c
+ setBvars (NSVector _ b c) bv = NSVector bv b c
+ setBvars (NSMatrixByFunction _ b c) bv = NSMatrixByFunction bv b c
+ setBvars (NSApply a _ c d) bv = NSApply a bv c d
+ setBvars (NSBind a _ c d) bv = NSBind a bv c d
+ setBvars x _ = x
+
+instance CanHaveDomain NSMatrixRow where
+ getDomains (NSMatrixRow _ dq _) = dq
+ setDomains (NSMatrixRow a _ c) dq = NSMatrixRow a dq c
+
+ getBvars (NSMatrixRow bv _ _) = bv
+ setBvars (NSMatrixRow _ b c) bv = NSMatrixRow bv b c
diff --git a/Data/ContentMathML3/XNodeOrd.hs b/Data/ContentMathML3/XNodeOrd.hs
new file mode 100644
--- /dev/null
+++ b/Data/ContentMathML3/XNodeOrd.hs
@@ -0,0 +1,198 @@
+module Data.ContentMathML3.XNodeOrd
+where
+
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.QualifiedName
+import Data.Data
+import Data.Tree.NTree.TypeDefs
+
+instance Ord XNode where
+ (XText v1) `compare` (XText v2) = v1 `compare` v2
+ (XText _) `compare` _ = LT
+ _ `compare` (XText _) = GT
+
+ (XBlob v1) `compare` (XBlob v2) = v1 `compare` v2
+ (XBlob _) `compare` _ = LT
+ _ `compare` (XBlob _) = GT
+
+ (XCharRef v1) `compare` (XCharRef v2) = v1 `compare` v2
+ (XCharRef _) `compare` _ = LT
+ _ `compare` (XCharRef _) = GT
+
+ (XEntityRef v1) `compare` (XEntityRef v2) = v1 `compare` v2
+ (XEntityRef _) `compare` _ = LT
+ _ `compare` (XEntityRef _) = GT
+
+ (XCmt v1) `compare` (XCmt v2) = v1 `compare` v2
+ (XCmt _) `compare` _ = LT
+ _ `compare` (XCmt _) = GT
+
+ (XCdata v1) `compare` (XCdata v2) = v1 `compare` v2
+ (XCdata _) `compare` _ = LT
+ _ `compare` (XCdata _) = GT
+
+ (XPi qn1 t1) `compare` (XPi qn2 t2) =
+ let c1 = qn1 `compare` qn2
+ in
+ case c1
+ of
+ EQ -> t1 `compare` t2
+ _ -> c1
+ (XPi _ _) `compare` _ = LT
+ _ `compare` (XPi _ _) = GT
+
+ (XTag qn1 t1) `compare` (XTag qn2 t2) =
+ let c1 = qn1 `compare` qn2
+ in
+ case c1
+ of
+ EQ -> t1 `compare` t2
+ _ -> c1
+ (XTag _ _) `compare` _ = LT
+ _ `compare` (XTag _ _) = GT
+
+ (XDTD qn1 t1) `compare` (XDTD qn2 t2) =
+ let c1 = qn1 `compare` qn2
+ in
+ case c1
+ of
+ EQ -> t1 `compare` t2
+ _ -> c1
+ (XDTD _ _) `compare` _ = LT
+ _ `compare` (XDTD _ _) = GT
+
+ (XAttr v1) `compare` (XAttr v2) = v1 `compare` v2
+ (XAttr _) `compare` _ = LT
+ _ `compare` (XAttr _) = GT
+
+ (XError qn1 t1) `compare` (XError qn2 t2) =
+ let c1 = qn1 `compare` qn2
+ in
+ case c1
+ of
+ EQ -> t1 `compare` t2
+ _ -> c1
+
+instance Ord QName where
+ q1 `compare` q2 =
+ let
+ c1 = (localPart q1) `compare` (localPart q2)
+ c2 = (namePrefix q1) `compare` (namePrefix q2)
+ c3 = (namespaceUri q1) `compare` (namespaceUri q2)
+ in
+ case c1 of
+ EQ ->
+ case c2 of
+ EQ -> c3
+ _ -> c2
+ _ -> c1
+
+instance Data XNode where
+ gfoldl k z (XText a) = z XText `k` a
+ gfoldl k z (XBlob a) = z XBlob `k` a
+ gfoldl k z (XCharRef a) = z XCharRef `k` a
+ gfoldl k z (XEntityRef a) = z XEntityRef `k` a
+ gfoldl k z (XCmt a) = z XCmt `k` a
+ gfoldl k z (XCdata a) = z XCdata `k` a
+ gfoldl k z (XPi a b) = z XPi `k` a `k` b
+ gfoldl k z (XTag a b) = z XTag `k` a `k` b
+ gfoldl k z (XDTD a b) = z XDTD `k` a `k` b
+ gfoldl k z (XAttr a) = z XAttr `k` a
+ gfoldl k z (XError a b) = z XError `k` a `k` b
+
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z XText)
+ 2 -> k (z XBlob)
+ 3 -> k (z XCharRef)
+ 4 -> k (z XEntityRef)
+ 5 -> k (z XCmt)
+ 6 -> k (z XCdata)
+ 7 -> k (k (z XPi))
+ 8 -> k (k (z XTag))
+ 9 -> k (k (z XDTD))
+ 10 -> k (z XAttr)
+ 11 -> k (k (z XError))
+ toConstr (XText _) = con_XText
+ toConstr (XBlob _) = con_XBlob
+ toConstr (XCharRef _) = con_XCharRef
+ toConstr (XEntityRef _) = con_XEntityRef
+ toConstr (XCmt _) = con_XCmt
+ toConstr (XCdata _) = con_XCdata
+ toConstr (XPi _ _) = con_XPi
+ toConstr (XTag _ _) = con_XTag
+ toConstr (XDTD _ _) = con_XDTD
+ toConstr (XAttr _) = con_XAttr
+ toConstr (XError _ _) = con_XError
+
+ dataTypeOf _ = ty_XNode
+
+con_XText = mkConstr ty_XNode "XText" [] Prefix
+con_XBlob = mkConstr ty_XNode "XBlob" [] Prefix
+con_XCharRef = mkConstr ty_XNode "XCharRef" [] Prefix
+con_XEntityRef = mkConstr ty_XNode "XEntityRef" [] Prefix
+con_XCmt = mkConstr ty_XNode "XCmt" [] Prefix
+con_XCdata = mkConstr ty_XNode "XCdata" [] Prefix
+con_XPi = mkConstr ty_XNode "XPi" [] Prefix
+con_XTag = mkConstr ty_XNode "XTag" [] Prefix
+con_XDTD = mkConstr ty_XNode "XDTD" [] Prefix
+con_XAttr = mkConstr ty_XNode "XAttr" [] Prefix
+con_XError = mkConstr ty_XNode "XError" [] Prefix
+ty_XNode = mkDataType "Text.XML.HXT.DOM.TypeDefs.XNode" [con_XText, con_XBlob, con_XCharRef, con_XEntityRef, con_XCmt, con_XCdata, con_XPi,
+ con_XTag, con_XDTD, con_XAttr, con_XError]
+instance Data n => Data (NTree n) where
+ gfoldl k z (NTree a b) = z NTree `k` a `k` b
+ gunfold k z c = case constrIndex c of
+ 1 -> k (k (z NTree))
+ toConstr (NTree _ _) = con_NTree
+ dataTypeOf _ = ty_NTree
+con_NTree = mkConstr ty_NTree "NTree" [] Prefix
+ty_NTree = mkDataType "Data.Tree.NTree.TypeDefs.NTree" [con_NTree]
+
+instance Data DTDElem where
+ gfoldl k z v = z v
+ gunfold k z c = case constrIndex c of
+ 1 -> z DOCTYPE
+ 2 -> z ELEMENT
+ 3 -> z CONTENT
+ 4 -> z ATTLIST
+ 5 -> z ENTITY
+ 6 -> z PENTITY
+ 7 -> z NOTATION
+ 8 -> z CONDSECT
+ 9 -> z NAME
+ 10 -> z PEREF
+ toConstr DOCTYPE = con_DOCTYPE
+ toConstr ELEMENT = con_ELEMENT
+ toConstr CONTENT = con_CONTENT
+ toConstr ATTLIST = con_ATTLIST
+ toConstr ENTITY = con_ENTITY
+ toConstr PENTITY = con_PENTITY
+ toConstr NOTATION = con_NOTATION
+ toConstr CONDSECT = con_CONDSECT
+ toConstr NAME = con_NAME
+ toConstr PEREF = con_PEREF
+
+ dataTypeOf _ = ty_DTDElem
+
+con_DOCTYPE = mkConstr ty_DTDElem "DOCTYPE" [] Prefix
+con_ELEMENT = mkConstr ty_DTDElem "ELEMENT" [] Prefix
+con_CONTENT = mkConstr ty_DTDElem "CONTENT" [] Prefix
+con_ATTLIST = mkConstr ty_DTDElem "ATTLIST" [] Prefix
+con_ENTITY = mkConstr ty_DTDElem "ENTITY" [] Prefix
+con_PENTITY = mkConstr ty_DTDElem "PENTITY" [] Prefix
+con_NOTATION = mkConstr ty_DTDElem "NOTATION" [] Prefix
+con_CONDSECT = mkConstr ty_DTDElem "CONDSECT" [] Prefix
+con_NAME = mkConstr ty_DTDElem "NAME" [] Prefix
+con_PEREF = mkConstr ty_DTDElem "PEREF" [] Prefix
+
+ty_DTDElem = mkDataType "Text.XML.HXT.DOM.TypeDefs.DTDElem" [con_DOCTYPE, con_ELEMENT, con_CONTENT, con_ATTLIST, con_ENTITY, con_PENTITY, con_NOTATION, con_CONDSECT, con_NAME, con_PEREF]
+
+instance Data QName where
+ gfoldl k z v = z mkQName `k` (localPart v) `k` (namePrefix v) `k` (namespaceUri v)
+ gunfold k z c = case constrIndex c of
+ 1 -> k (k (k (z mkQName)))
+ toConstr v = con_QName
+ dataTypeOf _ = ty_QName
+
+con_QName = mkConstr ty_QName "QName" [] Prefix
+ty_QName = mkDataType "Text.XML.HXT.DOM.TypeDefs.QName" [con_QName]
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,23 @@
+Copyright (c) 2012, The University of Auckland
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cmathml3.cabal b/cmathml3.cabal
new file mode 100644
--- /dev/null
+++ b/cmathml3.cabal
@@ -0,0 +1,39 @@
+Name: cmathml3
+Version: 0.1
+Cabal-Version: >= 1.6
+Build-Type: Simple
+License: BSD3
+License-File: LICENSE
+Author: Andrew Miller
+Copyright: (C) 2012 The University of Auckland
+Maintainer: ak.miller@auckland.ac.nz
+Stability: experimental
+Synopsis: Data model, parser, serialiser and transformations for Content MathML 3
+Description: Data model, parser, serialiser and basic transformations for working with Content MathML 3
+Category: Math
+Category: XML
+Source-Repository head
+ Type: git
+ Location: https://github.com/A1kmm/cellml-testbed/
+
+Executable mathtest
+ -- Type: exitcode-stdio-1.0
+ Main-Is: tests/TestMain.hs
+ Build-Depends: base, Cabal >= 1.9.2, filepath
+
+Library
+ Exposed-Modules: Data.ContentMathML3,
+ Data.ContentMathML3.Structure,
+ Data.ContentMathML3.Parser,
+ Data.ContentMathML3.NSToS
+ Other-Modules: Data.ContentMathML3.XNodeOrd
+ Build-Depends: hxt >= 9 && <10,
+ base >= 3 && < 5,
+ arrowapply-utils == 0.2,
+ monads-tf,
+ transformers,
+ parsec,
+ containers,
+ url,
+ array,
+ syb
diff --git a/tests/TestMain.hs b/tests/TestMain.hs
new file mode 100644
--- /dev/null
+++ b/tests/TestMain.hs
@@ -0,0 +1,21 @@
+import Data.ContentMathML3.Parser
+import Data.ContentMathML3.Serialiser
+import Data.ContentMathML3.Structure
+import Text.XML.HXT.Core
+import System.FilePath
+import Control.Monad
+import Data.ContentMathML3.NSToS
+import Data.Function.Selector
+
+main = forM ["test1.xml"] $ \fn -> do
+ v <- runX $ readDocument [] ("tests" fn) /> parseMathML
+ case v of
+ [Left (InvalidMathML err)] -> putStrLn $ "Parse error: " ++ err
+ [Right m] ->
+ case (nsToStrict m) of
+ Left err -> putStrLn $ "Error converting to strict form: " ++ err
+ Right sm -> do
+ liftM head (runX $ root [] [arr (const sm) >>> serialiseMathML >>> uniqueNamespacesFromDeclAndQNames] >>>
+ writeDocumentToString []) >>= putStrLn
+ return ()
+ _ -> putStrLn "No data parsed"