ogma-language-xmlspec (empty) → 1.6.0

raw patch · 6 files changed

+805/−0 lines, 6 filesdep +basedep +hxtdep +hxt-regex-xmlschemasetup-changedbinary-added

Dependencies added: base, hxt, hxt-regex-xmlschema, hxt-xpath, mtl, ogma-spec, pretty

Files

CHANGELOG.md +6/−0
LICENSE.pdf binary
Setup.hs +2/−0
ogma-language-xmlspec.cabal +83/−0
src/Language/XMLSpec/Parser.hs +362/−0
src/Language/XMLSpec/PrintTrees.hs +352/−0

+ CHANGELOG.md view

@@ -0,0 +1,6 @@+# Revision history for ogma-language-xmlspec++## [1.6.0] - 2025-01-21++* Version bump 1.6.0 (#208).+* Initial release (#202).

+ LICENSE.pdf view

binary file changed (absent → 117991 bytes)

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ ogma-language-xmlspec.cabal view

@@ -0,0 +1,83 @@+-- Copyright 2024 United States Government as represented by the Administrator+-- of the National Aeronautics and Space Administration. All Rights Reserved.+--+-- Disclaimers+--+-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY+-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT+-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO+-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A+-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE+-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF+-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN+-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR+-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR+-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER,+-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING+-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES+-- IT "AS IS." +--+-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST+-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS+-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN+-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE,+-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S+-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE+-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY+-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY+-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS+-- AGREEMENT.++cabal-version:       2.0+build-type:          Simple++name:                ogma-language-xmlspec+version:             1.6.0+homepage:            http://nasa.gov+license:             OtherLicense+license-file:        LICENSE.pdf+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+                     <https://github.com/Copilot-Language/copilot Copilot>, 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.6.0 && < 1.7++  hs-source-dirs:+    src++  default-language:+    Haskell2010++  ghc-options:+    -Wall

+ src/Language/XMLSpec/Parser.hs view

@@ -0,0 +1,362 @@+-- Copyright 2024 United States Government as represented by the Administrator+-- of the National Aeronautics and Space Administration. All Rights Reserved.+--+-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY+-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT+-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO+-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A+-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE+-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF+-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN+-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR+-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR+-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER,+-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING+-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES+-- IT "AS IS."+--+-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST+-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS+-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN+-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE,+-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S+-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE+-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY+-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY+-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS+-- AGREEMENT.++-- | 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))+    }+  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)++        return $ Requirement+                   { requirementName        = reqId+                   , requirementExpr        = reqExpr'+                   , requirementDescription = reqDesc+                   }++  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]+  }++-- | 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++  return $ XMLFormatInternal+             { xfiInternalVars    = xfi2+             , xfiInternalVarId   = xfi3+             , xfiInternalVarExpr = xfi4+             , xfiInternalVarType = xfi5+             , xfiExternalVars    = xfi6+             , xfiExternalVarId   = xfi7+             , xfiExternalVarType = xfi8+             , xfiRequirements    = xfi9+             , xfiRequirementId   = xfi10+             , xfiRequirementDesc = xfi11+             , xfiRequirementExpr = xfi12+             }++-- | 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

+ src/Language/XMLSpec/PrintTrees.hs view

@@ -0,0 +1,352 @@+{-# LANGUAGE FlexibleInstances #-}+-- Copyright 2024 United States Government as represented by the Administrator+-- of the National Aeronautics and Space Administration. All Rights Reserved.+--+-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY+-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT+-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO+-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A+-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE+-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF+-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN+-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR+-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR+-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER,+-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING+-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES+-- IT "AS IS."+--+-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST+-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS+-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN+-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE,+-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S+-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE+-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY+-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY+-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS+-- AGREEMENT.++-- | 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 '<' = "&lt;"+          textEscapeChar '>' = "&gt;"+          textEscapeChar '&' = "&amp;"+          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 "<!--" <> text comment <> text "-->"++  pretty (NTree (XCdata txt) _) =+      text "<![CDATA[" <> text txt' <> text "]]>"+    where+      -- Escape "]]>" if present in the data contents+      txt' = sed (const "]]&gt;") "\\]\\]>" 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++        -- <?xml version="..." ... ?>+        | 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 "<!-- ERROR" <+> parens (int level) <> colon+    <|> text txt <|> text "-->"++instance Pretty (DTDElem, Attributes, XmlTrees) where+  pretty (DOCTYPE, attributeList, children) =+          text "<!DOCTYPE "+      <>  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 "<!ELEMENT "+    <>  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 "<!ATTLIST "+      <> ( 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 "<!NOTATION "+    <> 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 "<!ENTITY "+  <>  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