cmathml3 (empty) → 0.1
raw patch · 9 files changed
+1868/−0 lines, 9 filesdep +Cabaldep +arraydep +arrowapply-utilssetup-changed
Dependencies added: Cabal, array, arrowapply-utils, base, containers, filepath, hxt, monads-tf, parsec, syb, transformers, url
Files
- Data/ContentMathML3.hs +6/−0
- Data/ContentMathML3/NSToS.hs +705/−0
- Data/ContentMathML3/Parser.hs +485/−0
- Data/ContentMathML3/Structure.hs +389/−0
- Data/ContentMathML3/XNodeOrd.hs +198/−0
- LICENSE +23/−0
- Setup.hs +2/−0
- cmathml3.cabal +39/−0
- tests/TestMain.hs +21/−0
+ Data/ContentMathML3.hs view
@@ -0,0 +1,6 @@+module Data.ContentMathML3+where++import Data.ContentMathML3.Structure+import Data.ContentMathML3.Parser+import Data.ContentMathML3.Serialiser
+ Data/ContentMathML3/NSToS.hs view
@@ -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' }
+ Data/ContentMathML3/Parser.hs view
@@ -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 <sep/>"+ _ -> fail "No <sep/> found in cn element type requiring a <sep/>"+ )++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))
+ Data/ContentMathML3/Structure.hs view
@@ -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
+ Data/ContentMathML3/XNodeOrd.hs view
@@ -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]
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cmathml3.cabal view
@@ -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
+ tests/TestMain.hs view
@@ -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"