ogma-language-xmlspec-1.10.0/0000755000000000000000000000000015064246131014136 5ustar0000000000000000ogma-language-xmlspec-1.10.0/ogma-language-xmlspec.cabal0000644000000000000000000000456715064246131021313 0ustar0000000000000000-- Copyright 2024 United States Government as represented by the Administrator -- of the National Aeronautics and Space Administration. All Rights Reserved. -- -- Disclaimers -- -- Licensed under the Apache License, Version 2.0 (the "License"); you may -- not use this file except in compliance with the License. You may obtain a -- copy of the License at -- -- https://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT -- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the -- License for the specific language governing permissions and limitations -- under the License. cabal-version: 2.0 build-type: Simple name: ogma-language-xmlspec version: 1.10.0 homepage: http://nasa.gov license: Apache-2.0 license-file: LICENSE author: Ivan Perez, Alwyn Goodloe maintainer: ivan.perezdominguez@nasa.gov category: Aerospace extra-source-files: CHANGELOG.md synopsis: Ogma: Runtime Monitor translator: XML Frontend description: Ogma is a tool to facilitate the integration of safe runtime monitors into other systems. Ogma extends , a high-level runtime verification framework that generates hard real-time C99 code. . This library contains a frontend to read specifications from XML files. -- Ogma packages should be uncurated so that only the official maintainers make -- changes. -- -- Because this is a NASA project, we want to make sure that users obtain -- exactly what we publish, unmodified by anyone external to our project. x-curation: uncurated library exposed-modules: Language.XMLSpec.Parser Language.XMLSpec.PrintTrees build-depends: base >= 4.11.0.0 && < 5 , mtl >= 2.2.2 && < 2.4 , hxt >= 9.3.1.4 && < 9.4 , hxt-regex-xmlschema >= 9.0 && < 9.3 , hxt-xpath >= 8.5 && < 9.2 , pretty >= 1.1 && < 1.2 , ogma-spec >= 1.10.0 && < 1.11 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall ogma-language-xmlspec-1.10.0/LICENSE0000644000000000000000000002613715064246131015154 0ustar0000000000000000 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at https://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. ogma-language-xmlspec-1.10.0/CHANGELOG.md0000644000000000000000000000077715064246131015762 0ustar0000000000000000# Revision history for ogma-language-xmlspec ## [1.10.0] - 2025-09-21 * Version bump 1.10.0 (#310). * Replace NOSA license with Apache license (#293). ## [1.9.0] - 2025-08-06 * Version bump 1.9.0 (#284). ## [1.8.0] - 2025-07-13 * Version bump 1.8.0 (#275). ## [1.7.0] - 2025-03-21 * Version bump 1.7.0 (#269). * Remove extraneous EOL character (#224). * Extend XMLSpec with additional data associated with results (#219). ## [1.6.0] - 2025-01-21 * Version bump 1.6.0 (#208). * Initial release (#202). ogma-language-xmlspec-1.10.0/Setup.hs0000644000000000000000000000005615064246131015573 0ustar0000000000000000import Distribution.Simple main = defaultMain ogma-language-xmlspec-1.10.0/src/0000755000000000000000000000000015064246131014725 5ustar0000000000000000ogma-language-xmlspec-1.10.0/src/Language/0000755000000000000000000000000015064246131016450 5ustar0000000000000000ogma-language-xmlspec-1.10.0/src/Language/XMLSpec/0000755000000000000000000000000015064246131017723 5ustar0000000000000000ogma-language-xmlspec-1.10.0/src/Language/XMLSpec/Parser.hs0000644000000000000000000003611315064246131021517 0ustar0000000000000000-- Copyright 2024 United States Government as represented by the Administrator -- of the National Aeronautics and Space Administration. All Rights Reserved. -- -- Licensed under the Apache License, Version 2.0 (the "License"); you may -- not use this file except in compliance with the License. You may obtain a -- copy of the License at -- -- https://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT -- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the -- License for the specific language governing permissions and limitations -- under the License. -- | Parser for Ogma specs stored in XML files. module Language.XMLSpec.Parser where -- External imports import Control.Monad.Except (ExceptT (..), liftEither, throwError, runExceptT) import Control.Monad.IO.Class (liftIO) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe, listToMaybe) import Text.XML.HXT.Core (configSysVars, no, readString, runX, withCanonicalize, withOutputPLAIN, withRedirect, withRemoveWS, withSubstDTDEntities, withSubstHTMLEntities, withValidate, yes, (>>>)) import Text.XML.HXT.XPath (getXPathTrees, parseXPathExpr) -- External imports: ogma-spec import Data.OgmaSpec (ExternalVariableDef (..), InternalVariableDef (..), Requirement (..), Spec (Spec)) -- Internal imports import Language.XMLSpec.PrintTrees (pretty, flattenDoc) -- | List of XPath routes to the elements we need to parse. -- -- The optional paths denote elements that may not exist. If they are nothing, -- those elements are not parsed in the input file. -- -- The subfields are applied on each string matching the parent element. That -- is, the internal var ID XPath will be a applied to the strings returned when -- applying the internal vars XPath (if it exists). Paths whose names are -- plural denote expected lists of elements. -- -- The components of a tuple (String, Maybe (String, String)) mean the -- following: if a string is present but the second component is Nothing, then -- the string is the XPath expression to be used. If a Just value is present, -- the first element of its inner tuple represents a key, and the second -- element represents an XPath expression that will produce a value when -- evaluated globally in the file. After evaluating that expression, the key -- must be found in the first string of the three and replaced with the result -- of evaluating the expression. data XMLFormat = XMLFormat { specInternalVars :: Maybe String , specInternalVarId :: (String, Maybe (String, String)) , specInternalVarExpr :: (String, Maybe (String, String)) , specInternalVarType :: Maybe (String, Maybe (String, String)) , specExternalVars :: Maybe String , specExternalVarId :: (String, Maybe (String, String)) , specExternalVarType :: Maybe (String, Maybe (String, String)) , specRequirements :: (String, Maybe (String, String)) , specRequirementId :: (String, Maybe (String, String)) , specRequirementDesc :: Maybe (String, Maybe (String, String)) , specRequirementExpr :: (String, Maybe (String, String)) , specRequirementResultType :: Maybe (String, Maybe (String, String)) , specRequirementResultExpr :: Maybe (String, Maybe (String, String)) } deriving (Show, Read) -- | Parse an XML file and extract a Spec from it. -- -- An auxiliary function must be provided to parse the requirement expressions. -- -- Fails if any of the XPaths in the argument XMLFormat are not valid -- expressions, of the XML is malformed, or if the elements are not found with -- the frequency expected (e.g., an external variable id is not found even -- though external variables are found). parseXMLSpec :: (String -> IO (Either String a)) -- ^ Parser for expressions. -> a -> XMLFormat -- ^ XPaths for spec locations. -> String -- ^ String containing XML -> IO (Either String (Spec a)) parseXMLSpec parseExpr defA xmlFormat value = runExceptT $ do xmlFormatInternal <- parseXMLFormat xmlFormat value -- Internal variables -- intVarStrings :: [String] intVarStrings <- liftIO $ maybe (return []) (`executeXPath` value) (xfiInternalVars xmlFormatInternal) let internalVarDef :: String -> ExceptT String IO InternalVariableDef internalVarDef def = do let msgI = "internal variable name" varId <- ExceptT $ listToEither msgI <$> executeXPath (xfiInternalVarId xmlFormatInternal) def let msgT = "internal variable type" varType <- maybe (liftEither $ Right "") (\e -> ExceptT $ listToEither msgT <$> executeXPath e def) (xfiInternalVarType xmlFormatInternal) let msgE = "internal variable expr" varExpr <- ExceptT $ listToEither msgE <$> executeXPath (xfiInternalVarExpr xmlFormatInternal) def return $ InternalVariableDef { internalVariableName = varId , internalVariableType = varType , internalVariableExpr = varExpr } internalVariableDefs <- mapM internalVarDef intVarStrings -- External variables -- extVarStrings :: [String] extVarStrings <- liftIO $ maybe (return []) (`executeXPath` value) (xfiExternalVars xmlFormatInternal) let externalVarDef :: String -> ExceptT String IO ExternalVariableDef externalVarDef def = do let msgI = "external variable name" varId <- ExceptT $ listToEither msgI <$> executeXPath (xfiExternalVarId xmlFormatInternal) def let msgT = "external variable type" varType <- maybe (liftEither $ Right "") (\e -> ExceptT $ listToEither msgT <$> executeXPath e def) (xfiExternalVarType xmlFormatInternal) return $ ExternalVariableDef { externalVariableName = varId , externalVariableType = varType } externalVariableDefs <- mapM externalVarDef extVarStrings -- Requirements -- reqStrings :: [String] reqStrings <- liftIO $ executeXPath (xfiRequirements xmlFormatInternal) value let -- requirementDef :: String -> ExceptT String (Requirement a) requirementDef def = do -- let msgI = "Requirement name: " ++ take 160 def reqId <- liftIO $ fromMaybe "" . listToMaybe <$> executeXPath (xfiRequirementId xmlFormatInternal) def -- let msgE = "Requirement expression: " ++ take 160 def reqExpr <- liftIO $ listToMaybe <$> concatMapM (`executeXPath` def) (xfiRequirementExpr xmlFormatInternal) reqExpr' <- maybe (return defA) (ExceptT . parseExpr . textUnescape) reqExpr -- let msgD = "Requirement description" reqDesc <- maybe (liftEither $ Right "") (\e -> liftIO $ fromMaybe "" . listToMaybe <$> executeXPath e def) (xfiRequirementDesc xmlFormatInternal) reqResType <- case xfiRequirementResultType xmlFormatInternal of Nothing -> return Nothing Just e -> liftIO $ listToMaybe <$> executeXPath e def reqResExpr <- case xfiRequirementResultExpr xmlFormatInternal of Nothing -> return Nothing Just e -> liftIO $ listToMaybe <$> executeXPath e def reqResExpr' <- maybe (return Nothing) (fmap Just . ExceptT . parseExpr . textUnescape) reqResExpr return $ Requirement { requirementName = reqId , requirementExpr = reqExpr' , requirementDescription = reqDesc , requirementResultType = reqResType , requirementResultExpr = reqResExpr' } requirements <- mapM requirementDef reqStrings -- Complete spec return $ Spec internalVariableDefs externalVariableDefs requirements -- | Internal representation of an XML Format specification. data XMLFormatInternal = XMLFormatInternal { xfiInternalVars :: Maybe XPathExpr , xfiInternalVarId :: XPathExpr , xfiInternalVarExpr :: XPathExpr , xfiInternalVarType :: Maybe XPathExpr , xfiExternalVars :: Maybe XPathExpr , xfiExternalVarId :: XPathExpr , xfiExternalVarType :: Maybe XPathExpr , xfiRequirements :: XPathExpr , xfiRequirementId :: XPathExpr , xfiRequirementDesc :: Maybe XPathExpr , xfiRequirementExpr :: [XPathExpr] , xfiRequirementResultType :: Maybe XPathExpr , xfiRequirementResultExpr :: Maybe XPathExpr } -- | Internal representation of an XPath expression. type XPathExpr = String -- | Resolve an indirect XPath query, returning an XPath expression. resolveIndirectly :: String -> (String, Maybe (String, String)) -> ExceptT String IO XPathExpr resolveIndirectly _ (query, Nothing) = liftEither $ checkXPathExpr query resolveIndirectly xml (query, Just (key, val)) = do -- Check that the given query string parses correctly. _ <- liftEither $ checkXPathExpr val v <- liftIO $ executeXPath val xml case v of (f:_) -> do let query' = replace query key f liftEither $ checkXPathExpr query' _ -> throwError $ "Substitution path " ++ show val ++ " not found in file." -- | Resolve an indirect XPath query, returning a list of XPath expressions. resolveIndirectly' :: String -> (String, Maybe (String, String)) -> ExceptT String IO [XPathExpr] resolveIndirectly' _ (query, Nothing) = fmap (:[]) $ liftEither $ checkXPathExpr query resolveIndirectly' xml (query, Just (key, val)) = do -- Check that the given query string parses correctly. _ <- liftEither $ checkXPathExpr val v <- liftIO $ executeXPath val xml case v of [] -> throwError $ "Substitution path " ++ show val ++ " not found in file." fs -> do let queries = map (replace query key) fs liftEither $ mapM checkXPathExpr queries -- | Check that an XPath expression is syntactically correct. checkXPathExpr :: String -> Either String XPathExpr checkXPathExpr s = s <$ parseXPathExpr s -- | Check an XMLFormat and return an internal representation. -- -- Fails with an error message if any of the given expressions are not a valid -- XPath expression. parseXMLFormat :: XMLFormat -> String -> ExceptT String IO XMLFormatInternal parseXMLFormat xmlFormat file = do xfi2 <- liftEither $ swapMaybeEither $ checkXPathExpr <$> specInternalVars xmlFormat xfi3 <- resolveIndirectly file $ specInternalVarId xmlFormat xfi4 <- resolveIndirectly file $ specInternalVarExpr xmlFormat xfi5 <- swapMaybeExceptT $ resolveIndirectly file <$> specInternalVarType xmlFormat xfi6 <- liftEither $ swapMaybeEither $ checkXPathExpr <$> specExternalVars xmlFormat xfi7 <- resolveIndirectly file $ specExternalVarId xmlFormat xfi8 <- swapMaybeExceptT $ resolveIndirectly file <$> specExternalVarType xmlFormat xfi9 <- resolveIndirectly file $ specRequirements xmlFormat xfi10 <- resolveIndirectly file $ specRequirementId xmlFormat xfi11 <- swapMaybeExceptT $ resolveIndirectly file <$> specRequirementDesc xmlFormat xfi12 <- resolveIndirectly' file $ specRequirementExpr xmlFormat xfi13 <- swapMaybeExceptT $ resolveIndirectly file <$> specRequirementResultType xmlFormat xfi14 <- swapMaybeExceptT $ resolveIndirectly file <$> specRequirementResultExpr xmlFormat return $ XMLFormatInternal { xfiInternalVars = xfi2 , xfiInternalVarId = xfi3 , xfiInternalVarExpr = xfi4 , xfiInternalVarType = xfi5 , xfiExternalVars = xfi6 , xfiExternalVarId = xfi7 , xfiExternalVarType = xfi8 , xfiRequirements = xfi9 , xfiRequirementId = xfi10 , xfiRequirementDesc = xfi11 , xfiRequirementExpr = xfi12 , xfiRequirementResultType = xfi13 , xfiRequirementResultExpr = xfi14 } -- | Execute an XPath query in an XML string, returning the list of strings -- that match the path. executeXPath :: String -> String -> IO [String] executeXPath query string = do let config = [ withValidate no , withRedirect no , withCanonicalize no , withRemoveWS yes , withSubstDTDEntities no , withOutputPLAIN , withSubstHTMLEntities no ] v <- runX $ configSysVars config >>> (readString config string >>> getXPathTrees query) let u = map (flattenDoc . pretty . (:[])) v return u -- * Auxiliary -- | Unescape @'<'@, @'>'@ and @'&'@ in a string. textUnescape :: String -> String textUnescape ('&':'l':'t':';':xs) = '<' : textUnescape xs textUnescape ('&':'g':'t':';':xs) = '>' : textUnescape xs textUnescape ('&':'a':'m': 'p' : ';':xs) = '&' : textUnescape xs textUnescape (x:xs) = x : textUnescape xs textUnescape [] = [] -- | Swap the Maybe and Either layers of a value. swapMaybeEither :: Maybe (Either a b) -> Either a (Maybe b) swapMaybeEither Nothing = Right Nothing swapMaybeEither (Just (Left s)) = Left s swapMaybeEither (Just (Right x)) = Right $ Just x -- | Swap the Maybe and Either layers of a value. swapMaybeExceptT :: Monad m => Maybe (ExceptT a m b) -> ExceptT a m (Maybe b) swapMaybeExceptT Nothing = return Nothing swapMaybeExceptT (Just e) = Just <$> e -- | Convert a list to an Either, failing if the list provided does not have -- exactly one value. listToEither :: String -> [String] -> Either String String listToEither _ [x] = Right x listToEither msg [] = Left $ "Failed to find a value for " ++ msg listToEither msg _ = Left $ "Unexpectedly found multiple values for " ++ msg -- | Replace a string by another string replace :: String -> String -> String -> String replace [] _k _v = [] replace string@(h:t) key value | key `isPrefixOf` string = value ++ replace (drop (length key) string) key value | otherwise = h : replace t key value -- | Map a monadic action over the elements of a container and concatenate the -- resulting lists. concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f = fmap concat . mapM f ogma-language-xmlspec-1.10.0/src/Language/XMLSpec/PrintTrees.hs0000644000000000000000000002547315064246131022371 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} -- Copyright 2024 United States Government as represented by the Administrator -- of the National Aeronautics and Space Administration. All Rights Reserved. -- -- Licensed under the Apache License, Version 2.0 (the "License"); you may -- not use this file except in compliance with the License. You may obtain a -- copy of the License at -- -- https://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT -- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the -- License for the specific language governing permissions and limitations -- under the License. -- | Print XML trees. -- -- This variant of the function to show XML trees available in HXT is needed -- because of issues with values being quoted by HXT's default function. -- -- It's based on the same ideas, but it's been implemented using the -- pretty-library instead of using plain string functions. module Language.XMLSpec.PrintTrees where -- External imports import Data.Maybe (fromMaybe, isNothing) import Data.Tree.NTree.TypeDefs (NTree (NTree)) import Prelude hiding (quot, (<>)) import Text.PrettyPrint.HughesPJ (Doc, Mode (..), Style (..), brackets, char, colon, doubleQuotes, empty, equals, hcat, int, isEmpty, parens, renderStyle, space, text, vcat, (<+>), (<>)) import Text.Regex.XMLSchema.Generic (sed) import Text.XML.HXT.Core hiding (getDTDAttrl, getNode, mkDTDElem, xshow, (<+>), txt) import Text.XML.HXT.DOM.ShowXml (xshow) import Text.XML.HXT.DOM.XmlNode (getDTDAttrl, getNode, mkDTDElem) -- | Render a document into a string. flattenDoc :: Doc -> String flattenDoc = renderStyle (Style LeftMode 0 0) -- | Class for values that can be converted into a document. class Pretty x where pretty :: x -> Doc instance Pretty [XmlTree] where pretty = hcat . map pretty instance Pretty XmlTree where pretty (NTree (XText s) _) = text (textEscapeXml' s) where -- | Auxiliary function to escape certain XML characters textEscapeXml' :: String -> String textEscapeXml' = concatMap textEscapeChar where textEscapeChar '<' = "<" textEscapeChar '>' = ">" textEscapeChar '&' = "&" textEscapeChar x = [x] pretty (NTree (XBlob blob) _) = text (blobToString blob) pretty (NTree (XCharRef ref) _) = text "&#" <> int ref <> char ';' pretty (NTree (XEntityRef ref) _) = text "&" <> text ref <> char ';' pretty (NTree (XCmt comment) _) = text "" pretty (NTree (XCdata txt) _) = text " text txt' <> text "]]>" where -- Escape "]]>" if present in the data contents txt' = sed (const "]]>") "\\]\\]>" txt pretty (NTree (XPi iName attributes) _) = text " pretty iName <> hcat (map prettyPIAttr attributes) <> text "?>" where -- Print an attribute of a processing instruction. prettyPIAttr :: XmlTree -> Doc prettyPIAttr attrs | (NTree (XAttr attrQName) children) <- attrs , qualifiedName attrQName == a_value = space <> pretty children -- | otherwise = pretty attrs pretty (NTree (XTag tagQName attributeList) []) = angles (pretty tagQName <> pretty attributeList <> slash) pretty (NTree (XTag tagQName attributeList) children) = angles (pretty tagQName <> pretty attributeList) <> pretty children <> angles (slash <> pretty tagQName) pretty (NTree (XDTD dtdElem attributeList) children) = pretty (dtdElem, attributeList, children) pretty (NTree (XAttr attrQName) children) = space <> pretty attrQName <> equals <> doubleQuotes (pretty children) pretty (NTree (XError level txt) _) = text "" instance Pretty (DTDElem, Attributes, XmlTrees) where pretty (DOCTYPE, attributeList, children) = text " pretty (a_name, attributeList) <> prettyExternalId attributeList <+> prettyInternalDTD children <> text ">" where prettyInternalDTD [] = empty prettyInternalDTD ds = brackets $ nl <> vcat (map pretty ds) pretty (ELEMENT, attributeList, children) = text " pretty (a_name, attributeList) <+> prettyElemType (lookup1 a_type attributeList) children <> text " >" pretty (CONTENT, attributeList, children) = prettyContent (mkDTDElem CONTENT attributeList children) pretty (ATTLIST, attributeList, children) = text " ( if isNothing (lookup a_name attributeList) then pretty children else pretty (a_name, attributeList) <+> prettyValue attributeList children ) <> text " >" pretty (ENTITY, attributeList, children) = prettyEntity "" attributeList children pretty (PENTITY, attributeList, children) = prettyEntity "% " attributeList children pretty (NOTATION, attributeList, _children) = text " pretty (a_name, attributeList) <> prettyExternalId attributeList <> text " >" pretty (CONDSECT, _, child:children) = text " pretty child <> text " [\n" <> pretty children <> text "]]>" pretty (CONDSECT, _, []) = empty pretty (NAME, attributeList, _children) = pretty (a_name, attributeList) pretty (PEREF, attributeList, _children) = prettyPEAttr attributeList instance Pretty QName where pretty = text . qualifiedName instance Pretty (String, Attributes) where pretty (k, attributeList) = text (lookup1 k attributeList) -- * Auxiliary functions related to pretty printing XML trees. -- | Pretty print an attribute followed by its value. prettyAttr :: String -> Attributes -> Doc prettyAttr k attributeList | Just v <- lookup k attributeList = text k <+> text v | otherwise = empty -- | Pretty print a content element. prettyContent :: XmlTree -> Doc prettyContent (NTree (XDTD NAME attributeList) _) = pretty (a_name, attributeList) prettyContent (NTree (XDTD PEREF attributeList) _) = prettyPEAttr attributeList prettyContent (NTree (XDTD CONTENT attributeList) children) = parens (sepBy separator (map prettyContent children)) <> pretty (a_modifier, attributeList) where separator = text (if a_kind == v_seq then ", " else " | ") prettyContent (NTree (XDTD n _) _) = error $ "prettyContent " ++ show n ++ " is undefined" prettyContent tree = pretty tree -- | Pretty print the type of an element. prettyElemType :: String -> XmlTrees -> Doc prettyElemType elemType children | elemType == v_pcdata = parens (text v_pcdata) | elemType == v_mixed && not (null children) , let [NTree (XDTD CONTENT attributeList') children'] = children = parens ( sepBy (text " | ") ( text v_pcdata : map (prettyEnum . treeElemAttributes. getNode) children' ) ) <> pretty (a_modifier, attributeList') | elemType == v_mixed -- incorrect tree = parens empty | elemType == v_children && not (null children) = prettyContent (head children) | elemType == v_children = parens empty | elemType == k_peref = hcat $ map prettyContent children | otherwise = text elemType where treeElemAttributes (XDTD _ attributeList') = attributeList' treeElemAttributes (XText txt) = [(a_name, txt)] treeElemAttributes _ = [] -- | Pretty print an entity. prettyEntity :: String -> Attributes -> XmlTrees -> Doc prettyEntity kind attributeList children = text " text kind <> pretty (a_name, attributeList) <> prettyExternalId attributeList <+> prettyAttr k_ndata attributeList <+> prettyLiteralTrees children <> text " >" -- | Pretty print trees as text, quoting them. prettyLiteralTrees :: XmlTrees -> Doc prettyLiteralTrees [] = empty prettyLiteralTrees children = doubleQuotes $ text $ xshow children -- | Pretty print an external ID. prettyExternalId :: Attributes -> Doc prettyExternalId attributeList = case (lookup k_system attributeList, lookup k_public attributeList) of (Nothing, Nothing) -> empty (Just s, Nothing) -> text k_system <+> doubleQuotes (text s) (Nothing, Just p ) -> space <> text k_public <+> doubleQuotes (text p) (Just s, Just p ) -> space <> text k_public <+> doubleQuotes (text p) <+> doubleQuotes (text s) -- | Pretty print a Parameter Entity Reference. prettyPEAttr :: Attributes -> Doc prettyPEAttr = maybe empty (\pe -> char '%' <> text pe <> char ';') . lookup a_peref -- | Given a list of attributes, pretty print the value in them. prettyValue :: Attributes -> XmlTrees -> Doc prettyValue attributeList children | Just aValue <- lookup a_value attributeList = text aValue <+> prettyAttrType (lookup1 a_type attributeList) <+> prettyAttrKind (lookup1 a_kind attributeList) | otherwise = prettyPEAttr $ fromMaybe [] $ getDTDAttrl $ head children where prettyAttrType attrType | attrType == k_peref = prettyPEAttr attributeList | attrType == k_enumeration = prettyAttrEnum | attrType == k_notation = text k_notation <+> prettyAttrEnum | otherwise = text attrType prettyAttrEnum = parens $ sepBy (text " | ") $ map (prettyEnum . fromMaybe [] . getDTDAttrl) children where prettyAttrKind kind | kind == k_default = doubleQuotes (text (lookup1 a_default attributeList)) | kind == k_fixed = text k_fixed <+> doubleQuotes (text (lookup1 a_default attributeList)) | otherwise = text kind -- Pretty print the name of an attribute, followed by the PE Reference. prettyEnum :: Attributes -> Doc prettyEnum attributes = pretty (a_name, attributes) <> prettyPEAttr attributes -- ** Generic document constructors -- | Forward slash character. slash :: Doc slash = char '/' -- | New line character. nl :: Doc nl = char '\n' -- | Enclose document in angle brackets. angles :: Doc -> Doc angles s = char '<' <> s <> char '>' -- | Compose two documents, separating them by a new line. -- -- The new line is not inserted if either document is empty. (<|>) :: Doc -> Doc -> Doc (<|>) x y | isEmpty x = y | isEmpty y = x | otherwise = x <> nl <> y -- | Concatenate a list od documents, separating them by a given separator. sepBy :: Doc -- ^ Separator -> [Doc] -- ^ List of documents -> Doc sepBy _ [] = empty sepBy _ [x] = x sepBy sep (x:xs) = x <> sep <> sepBy sep xs