-- 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
    { XMLFormat -> Maybe String
specInternalVars          :: Maybe String
    , XMLFormat -> (String, Maybe (String, String))
specInternalVarId         :: (String, Maybe (String, String))
    , XMLFormat -> (String, Maybe (String, String))
specInternalVarExpr       :: (String, Maybe (String, String))
    , XMLFormat -> Maybe (String, Maybe (String, String))
specInternalVarType       :: Maybe (String, Maybe (String, String))
    , XMLFormat -> Maybe String
specExternalVars          :: Maybe String
    , XMLFormat -> (String, Maybe (String, String))
specExternalVarId         :: (String, Maybe (String, String))
    , XMLFormat -> Maybe (String, Maybe (String, String))
specExternalVarType       :: Maybe (String, Maybe (String, String))
    , XMLFormat -> (String, Maybe (String, String))
specRequirements          :: (String, Maybe (String, String))
    , XMLFormat -> (String, Maybe (String, String))
specRequirementId         :: (String, Maybe (String, String))
    , XMLFormat -> Maybe (String, Maybe (String, String))
specRequirementDesc       :: Maybe (String, Maybe (String, String))
    , XMLFormat -> (String, Maybe (String, String))
specRequirementExpr       :: (String, Maybe (String, String))
    , XMLFormat -> Maybe (String, Maybe (String, String))
specRequirementResultType :: Maybe (String, Maybe (String, String))
    , XMLFormat -> Maybe (String, Maybe (String, String))
specRequirementResultExpr :: Maybe (String, Maybe (String, String))
    }
  deriving (Int -> XMLFormat -> ShowS
[XMLFormat] -> ShowS
XMLFormat -> String
(Int -> XMLFormat -> ShowS)
-> (XMLFormat -> String)
-> ([XMLFormat] -> ShowS)
-> Show XMLFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XMLFormat -> ShowS
showsPrec :: Int -> XMLFormat -> ShowS
$cshow :: XMLFormat -> String
show :: XMLFormat -> String
$cshowList :: [XMLFormat] -> ShowS
showList :: [XMLFormat] -> ShowS
Show, ReadPrec [XMLFormat]
ReadPrec XMLFormat
Int -> ReadS XMLFormat
ReadS [XMLFormat]
(Int -> ReadS XMLFormat)
-> ReadS [XMLFormat]
-> ReadPrec XMLFormat
-> ReadPrec [XMLFormat]
-> Read XMLFormat
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS XMLFormat
readsPrec :: Int -> ReadS XMLFormat
$creadList :: ReadS [XMLFormat]
readList :: ReadS [XMLFormat]
$creadPrec :: ReadPrec XMLFormat
readPrec :: ReadPrec XMLFormat
$creadListPrec :: ReadPrec [XMLFormat]
readListPrec :: ReadPrec [XMLFormat]
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 :: forall a.
(String -> IO (Either String a))
-> a -> XMLFormat -> String -> IO (Either String (Spec a))
parseXMLSpec String -> IO (Either String a)
parseExpr a
defA XMLFormat
xmlFormat String
value = ExceptT String IO (Spec a) -> IO (Either String (Spec a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO (Spec a) -> IO (Either String (Spec a)))
-> ExceptT String IO (Spec a) -> IO (Either String (Spec a))
forall a b. (a -> b) -> a -> b
$ do
  xmlFormatInternal <- XMLFormat -> String -> ExceptT String IO XMLFormatInternal
parseXMLFormat XMLFormat
xmlFormat String
value

  -- Internal variables

  -- intVarStrings :: [String]
  intVarStrings <- liftIO $ maybe
                              (return [])
                              (`executeXPath` value)
                              (xfiInternalVars xmlFormatInternal)

  let internalVarDef :: String -> ExceptT String IO InternalVariableDef
      internalVarDef String
def = do
        let msgI :: String
msgI = String
"internal variable name"
        varId <- IO (Either String String) -> ExceptT String IO String
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String String) -> ExceptT String IO String)
-> IO (Either String String) -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$
                   String -> [String] -> Either String String
listToEither String
msgI ([String] -> Either String String)
-> IO [String] -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                   String -> String -> IO [String]
executeXPath (XMLFormatInternal -> String
xfiInternalVarId XMLFormatInternal
xmlFormatInternal) String
def

        let msgT = String
"internal variable type"
        varType <- maybe
                     (liftEither $ Right "")
                     (\String
e -> IO (Either String String) -> ExceptT String IO String
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String String) -> ExceptT String IO String)
-> IO (Either String String) -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Either String String
listToEither String
msgT ([String] -> Either String String)
-> IO [String] -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO [String]
executeXPath String
e String
def)
                     (xfiInternalVarType xmlFormatInternal)

        let msgE = String
"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 String
def = do

        let msgI :: String
msgI = String
"external variable name"
        varId <- IO (Either String String) -> ExceptT String IO String
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String String) -> ExceptT String IO String)
-> IO (Either String String) -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$
                   String -> [String] -> Either String String
listToEither String
msgI ([String] -> Either String String)
-> IO [String] -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                   String -> String -> IO [String]
executeXPath (XMLFormatInternal -> String
xfiExternalVarId XMLFormatInternal
xmlFormatInternal) String
def

        let msgT = String
"external variable type"
        varType <- maybe
                     (liftEither $ Right "")
                     (\String
e -> IO (Either String String) -> ExceptT String IO String
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String String) -> ExceptT String IO String)
-> IO (Either String String) -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Either String String
listToEither String
msgT ([String] -> Either String String)
-> IO [String] -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO [String]
executeXPath String
e String
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 String
def = do
        -- let msgI = "Requirement name: " ++ take 160 def
        reqId <- IO String -> ExceptT String IO String
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT String IO String)
-> IO String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ([String] -> Maybe String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> String) -> IO [String] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                   String -> String -> IO [String]
executeXPath (XMLFormatInternal -> String
xfiRequirementId XMLFormatInternal
xmlFormatInternal) String
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 "")
                     (\String
e -> IO String -> ExceptT String IO String
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT String IO String)
-> IO String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ([String] -> Maybe String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> String) -> IO [String] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO [String]
executeXPath String
e String
def)
                     (xfiRequirementDesc xmlFormatInternal)

        reqResType <- case xfiRequirementResultType xmlFormatInternal of
                        Maybe String
Nothing -> Maybe String -> ExceptT String IO (Maybe String)
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                        Just String
e  -> IO (Maybe String) -> ExceptT String IO (Maybe String)
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> ExceptT String IO (Maybe String))
-> IO (Maybe String) -> ExceptT String IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> IO [String] -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO [String]
executeXPath String
e String
def

        reqResExpr <- case xfiRequirementResultExpr xmlFormatInternal of
                        Maybe String
Nothing -> Maybe String -> ExceptT String IO (Maybe String)
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                        Just String
e  -> IO (Maybe String) -> ExceptT String IO (Maybe String)
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> ExceptT String IO (Maybe String))
-> IO (Maybe String) -> ExceptT String IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> IO [String] -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO [String]
executeXPath String
e String
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
  { XMLFormatInternal -> Maybe String
xfiInternalVars          :: Maybe XPathExpr
  , XMLFormatInternal -> String
xfiInternalVarId         :: XPathExpr
  , XMLFormatInternal -> String
xfiInternalVarExpr       :: XPathExpr
  , XMLFormatInternal -> Maybe String
xfiInternalVarType       :: Maybe XPathExpr
  , XMLFormatInternal -> Maybe String
xfiExternalVars          :: Maybe XPathExpr
  , XMLFormatInternal -> String
xfiExternalVarId         :: XPathExpr
  , XMLFormatInternal -> Maybe String
xfiExternalVarType       :: Maybe XPathExpr
  , XMLFormatInternal -> String
xfiRequirements          :: XPathExpr
  , XMLFormatInternal -> String
xfiRequirementId         :: XPathExpr
  , XMLFormatInternal -> Maybe String
xfiRequirementDesc       :: Maybe XPathExpr
  , XMLFormatInternal -> [String]
xfiRequirementExpr       :: [XPathExpr]
  , XMLFormatInternal -> Maybe String
xfiRequirementResultType :: Maybe XPathExpr
  , XMLFormatInternal -> Maybe String
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 :: String
-> (String, Maybe (String, String)) -> ExceptT String IO String
resolveIndirectly String
_ (String
query, Maybe (String, String)
Nothing) =
  Either String String -> ExceptT String IO String
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String String -> ExceptT String IO String)
-> Either String String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> Either String String
checkXPathExpr String
query

resolveIndirectly String
xml (String
query, Just (String
key, String
val)) = do
  -- Check that the given query string parses correctly.
  _ <- Either String String -> ExceptT String IO String
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String String -> ExceptT String IO String)
-> Either String String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> Either String String
checkXPathExpr String
val

  v  <- liftIO $ executeXPath val xml
  case v of
    (String
f:[String]
_) -> do let query' :: String
query' = String -> String -> ShowS
replace String
query String
key String
f
                Either String String -> ExceptT String IO String
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String String -> ExceptT String IO String)
-> Either String String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> Either String String
checkXPathExpr String
query'
    [String]
_     -> String -> ExceptT String IO String
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String IO String)
-> String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$
               String
"Substitution path " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
val String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" 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' :: String
-> (String, Maybe (String, String)) -> ExceptT String IO [String]
resolveIndirectly' String
_ (String
query, Maybe (String, String)
Nothing) =
  (String -> [String])
-> ExceptT String IO String -> ExceptT String IO [String]
forall a b. (a -> b) -> ExceptT String IO a -> ExceptT String IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (ExceptT String IO String -> ExceptT String IO [String])
-> ExceptT String IO String -> ExceptT String IO [String]
forall a b. (a -> b) -> a -> b
$ Either String String -> ExceptT String IO String
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String String -> ExceptT String IO String)
-> Either String String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> Either String String
checkXPathExpr String
query

resolveIndirectly' String
xml (String
query, Just (String
key, String
val)) = do
  -- Check that the given query string parses correctly.
  _ <- Either String String -> ExceptT String IO String
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String String -> ExceptT String IO String)
-> Either String String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> Either String String
checkXPathExpr String
val

  v  <- liftIO $ executeXPath val xml
  case v of
    [] -> String -> ExceptT String IO [String]
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String IO [String])
-> String -> ExceptT String IO [String]
forall a b. (a -> b) -> a -> b
$ String
"Substitution path " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
val String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not found in file."
    [String]
fs -> do let queries :: [String]
queries = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> ShowS
replace String
query String
key) [String]
fs
             Either String [String] -> ExceptT String IO [String]
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String [String] -> ExceptT String IO [String])
-> Either String [String] -> ExceptT String IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Either String String)
-> [String] -> Either String [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> Either String String
checkXPathExpr [String]
queries

-- | Check that an XPath expression is syntactically correct.
checkXPathExpr :: String -> Either String XPathExpr
checkXPathExpr :: String -> Either String String
checkXPathExpr String
s = String
s String -> Either String Expr -> Either String String
forall a b. a -> Either String b -> Either String a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Either String Expr
parseXPathExpr String
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 -> String -> ExceptT String IO XMLFormatInternal
parseXMLFormat XMLFormat
xmlFormat String
file = do
  xfi2  <- Either String (Maybe String) -> ExceptT String IO (Maybe String)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String (Maybe String) -> ExceptT String IO (Maybe String))
-> Either String (Maybe String) -> ExceptT String IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Maybe (Either String String) -> Either String (Maybe String)
forall a b. Maybe (Either a b) -> Either a (Maybe b)
swapMaybeEither
                      (Maybe (Either String String) -> Either String (Maybe String))
-> Maybe (Either String String) -> Either String (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
checkXPathExpr (String -> Either String String)
-> Maybe String -> Maybe (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XMLFormat -> Maybe String
specInternalVars XMLFormat
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 :: String -> String -> IO [String]
executeXPath String
query String
string = do
  let config :: [SysConfig]
config = [ Bool -> SysConfig
withValidate Bool
no
               , Bool -> SysConfig
withRedirect Bool
no
               , Bool -> SysConfig
withCanonicalize Bool
no
               , Bool -> SysConfig
withRemoveWS Bool
yes
               , Bool -> SysConfig
withSubstDTDEntities Bool
no
               , SysConfig
withOutputPLAIN
               , Bool -> SysConfig
withSubstHTMLEntities Bool
no
               ]
  v <- IOSArrow XmlTree XmlTree -> IO [XmlTree]
forall c. IOSArrow XmlTree c -> IO [c]
runX (IOSArrow XmlTree XmlTree -> IO [XmlTree])
-> IOSArrow XmlTree XmlTree -> IO [XmlTree]
forall a b. (a -> b) -> a -> b
$ [SysConfig] -> IOSArrow XmlTree XmlTree
forall s c. [SysConfig] -> IOStateArrow s c c
configSysVars [SysConfig]
config
              IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ([SysConfig] -> String -> IOSArrow XmlTree XmlTree
forall s b. [SysConfig] -> String -> IOStateArrow s b XmlTree
readString [SysConfig]
config String
string IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
getXPathTrees String
query)

  let u = (XmlTree -> String) -> [XmlTree] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> String
flattenDoc (Doc -> String) -> (XmlTree -> Doc) -> XmlTree -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XmlTree] -> Doc
forall x. Pretty x => x -> Doc
pretty ([XmlTree] -> Doc) -> (XmlTree -> [XmlTree]) -> XmlTree -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XmlTree -> [XmlTree] -> [XmlTree]
forall a. a -> [a] -> [a]
:[])) [XmlTree]
v

  return u

-- * Auxiliary

-- | Unescape @'<'@, @'>'@ and @'&'@ in a string.
textUnescape :: String -> String
textUnescape :: ShowS
textUnescape (Char
'&':Char
'l':Char
't':Char
';':String
xs)        = Char
'<' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
textUnescape String
xs
textUnescape (Char
'&':Char
'g':Char
't':Char
';':String
xs)        = Char
'>' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
textUnescape String
xs
textUnescape (Char
'&':Char
'a':Char
'm': Char
'p' : Char
';':String
xs) = Char
'&' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
textUnescape String
xs
textUnescape (Char
x:String
xs)                      = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
textUnescape String
xs
textUnescape []                          = []

-- | Swap the Maybe and Either layers of a value.
swapMaybeEither :: Maybe (Either a b) -> Either a (Maybe b)
swapMaybeEither :: forall a b. Maybe (Either a b) -> Either a (Maybe b)
swapMaybeEither Maybe (Either a b)
Nothing          = Maybe b -> Either a (Maybe b)
forall a b. b -> Either a b
Right Maybe b
forall a. Maybe a
Nothing
swapMaybeEither (Just (Left a
s))  = a -> Either a (Maybe b)
forall a b. a -> Either a b
Left a
s
swapMaybeEither (Just (Right b
x)) = Maybe b -> Either a (Maybe b)
forall a b. b -> Either a b
Right (Maybe b -> Either a (Maybe b)) -> Maybe b -> Either a (Maybe b)
forall a b. (a -> b) -> a -> b
$ b -> Maybe b
forall a. a -> Maybe a
Just b
x

-- | Swap the Maybe and Either layers of a value.
swapMaybeExceptT :: Monad m => Maybe (ExceptT a m b) -> ExceptT a m (Maybe b)
swapMaybeExceptT :: forall (m :: * -> *) a b.
Monad m =>
Maybe (ExceptT a m b) -> ExceptT a m (Maybe b)
swapMaybeExceptT Maybe (ExceptT a m b)
Nothing  = Maybe b -> ExceptT a m (Maybe b)
forall a. a -> ExceptT a m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
swapMaybeExceptT (Just ExceptT a m b
e) = b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> ExceptT a m b -> ExceptT a m (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT a m b
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 :: String -> [String] -> Either String String
listToEither String
_   [String
x] = String -> Either String String
forall a b. b -> Either a b
Right String
x
listToEither String
msg []  = String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"Failed to find a value for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
listToEither String
msg [String]
_   = String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"Unexpectedly found multiple values for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

-- | Replace a string by another string
replace :: String -> String -> String -> String
replace :: String -> String -> ShowS
replace []           String
_k  String
_v    = []
replace string :: String
string@(Char
h:String
t) String
key String
value
  | String
key String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
string
  = String
value String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> String -> ShowS
replace (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
key) String
string) String
key String
value
  | Bool
otherwise
  = Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: String -> String -> ShowS
replace String
t String
key String
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 :: forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
f = ([[b]] -> [b]) -> m [[b]] -> m [b]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[b]] -> m [b]) -> ([a] -> m [[b]]) -> [a] -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m [b]) -> [a] -> m [[b]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m [b]
f