    {-# LANGUAGE ScopedTypeVariables #-}
    -- 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.

    -- | Parser for Ogma specs stored in YAML files.
    module Language.YAMLSpec.Parser where

    -- External imports
    import           Control.Monad.Except   (ExceptT (..), runExceptT)
    import           Control.Monad.IO.Class (liftIO)
    import           Data.Aeson             (Value (..))
    import           Data.Aeson.Key         (fromString)
    import qualified Data.Aeson.KeyMap      as M
    import qualified Data.ByteString        as BS
    import           Data.Char              (isSpace)
    import           Data.List              (intercalate)
    import           Data.Text              (unpack)
    import qualified Data.Vector            as V
    import qualified Data.Yaml              as Y

    -- External imports: ogma-spec
    import Data.Either.Extra (mapLeft)
    import Data.OgmaSpec     (ExternalVariableDef (..), InternalVariableDef (..),
                              Requirement (..), Spec (..))

    -- | Field names of a spec listed in a YAML file.
    data YAMLFormat = YAMLFormat
        { YAMLFormat -> Maybe String
    specInternalVars          :: Maybe String
        , YAMLFormat -> String
    specInternalVarId         :: String
        , YAMLFormat -> String
    specInternalVarExpr       :: String
        , YAMLFormat -> Maybe String
    specInternalVarType       :: Maybe String
        , YAMLFormat -> Maybe String
    specExternalVars          :: Maybe String
        , YAMLFormat -> String
    specExternalVarId         :: String
        , YAMLFormat -> Maybe String
    specExternalVarType       :: Maybe String
        , YAMLFormat -> Maybe String
    specRequirements          :: Maybe String
        , YAMLFormat -> Maybe String
    specRequirementId         :: Maybe String
        , YAMLFormat -> Maybe String
    specRequirementDesc       :: Maybe String
        , YAMLFormat -> String
    specRequirementExpr       :: String
        , YAMLFormat -> Maybe String
    specRequirementResultType :: Maybe String
        , YAMLFormat -> Maybe String
    specRequirementResultExpr :: Maybe String
        }
      deriving (ReadPrec [YAMLFormat]
    ReadPrec YAMLFormat
    Int -> ReadS YAMLFormat
    ReadS [YAMLFormat]
    (Int -> ReadS YAMLFormat)
    -> ReadS [YAMLFormat]
    -> ReadPrec YAMLFormat
    -> ReadPrec [YAMLFormat]
    -> Read YAMLFormat
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS YAMLFormat
    readsPrec :: Int -> ReadS YAMLFormat
    $creadList :: ReadS [YAMLFormat]
    readList :: ReadS [YAMLFormat]
    $creadPrec :: ReadPrec YAMLFormat
    readPrec :: ReadPrec YAMLFormat
    $creadListPrec :: ReadPrec [YAMLFormat]
    readListPrec :: ReadPrec [YAMLFormat]
    Read)

    -- | Parse a spec from a YAML file.
    parseYAMLSpec :: forall a
                  .  (String -> IO (Either String a))
                  -> YAMLFormat
                  -> BS.ByteString
                  -> IO (Either String (Spec a))
    parseYAMLSpec :: forall a.
    (String -> IO (Either String a))
    -> YAMLFormat -> ByteString -> IO (Either String (Spec a))
    parseYAMLSpec String -> IO (Either String a)
    parseExpr YAMLFormat
    yamlFormat ByteString
    bs = 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
      value <- Either String Value -> ExceptT String IO Value
    forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
    except (Either String Value -> ExceptT String IO Value)
    -> Either String Value -> ExceptT String IO Value
    forall a b. (a -> b) -> a -> b
    $ (ParseException -> String)
    -> Either ParseException Value -> Either String Value
    forall a c b. (a -> c) -> Either a b -> Either c b
    mapLeft ParseException -> String
    Y.prettyPrintParseException (Either ParseException Value -> Either String Value)
    -> Either ParseException Value -> Either String Value
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Either ParseException Value
    forall a. FromJSON a => ByteString -> Either ParseException a
    Y.decodeEither' ByteString
    bs

      let values :: [Value]
          values = [Value] -> (String -> [Value]) -> Maybe String -> [Value]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [] (Value -> String -> [Value]
    objectFieldValueList Value
    value) (YAMLFormat -> Maybe String
    specInternalVars YAMLFormat
    yamlFormat)

          internalVarDef :: Value -> Either String InternalVariableDef
          internalVarDef Value
    value = do
            let msg :: String
    msg = String
    "internal variable name"
            varId   <- String -> Value -> Either String String
    valueToString String
    msg (Value -> Either String String)
    -> Either String Value -> Either String String
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> [Value] -> Either String Value
    forall a. String -> [a] -> Either String a
    listToEither String
    msg (String -> Value -> [Value]
    objectFieldValues (YAMLFormat -> String
    specInternalVarId YAMLFormat
    yamlFormat) Value
    value)

            let msg = String
    "internal variable type"
            varType <- maybe (Right "") (\String
    e -> String -> Value -> Either String String
    valueToString String
    msg (Value -> Either String String)
    -> Either String Value -> Either String String
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (String -> [Value] -> Either String Value
    forall a. String -> [a] -> Either String a
    listToEither String
    msg (String -> Value -> [Value]
    objectFieldValues String
    e Value
    value))) (specInternalVarType yamlFormat)

            let msg = String
    "internal variable expr"
            varExpr <- valueToString msg =<< listToEither msg (objectFieldValues (specInternalVarExpr yamlFormat) value)

            return $ InternalVariableDef
                       { internalVariableName = varId
                       , internalVariableType = varType
                       , internalVariableExpr = varExpr
                       }

      internalVariableDefs <- except $ mapM internalVarDef values

      let values :: [Value]
          values = [Value] -> (String -> [Value]) -> Maybe String -> [Value]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [] (Value -> String -> [Value]
    objectFieldValueList Value
    value) (YAMLFormat -> Maybe String
    specExternalVars YAMLFormat
    yamlFormat)

          externalVarDef :: Value -> Either String ExternalVariableDef
          externalVarDef Value
    value = do

            let msg :: String
    msg = String
    "external variable name"
            varId   <- String -> Value -> Either String String
    valueToString String
    msg
                          (Value -> Either String String)
    -> Either String Value -> Either String String
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> [Value] -> Either String Value
    forall a. String -> [a] -> Either String a
    listToEither String
    msg (String -> Value -> [Value]
    objectFieldValues (YAMLFormat -> String
    specExternalVarId YAMLFormat
    yamlFormat) Value
    value)

            let msg = String
    "external variable type"
            varType <- maybe (Right "") (\String
    e -> String -> Value -> Either String String
    valueToString String
    msg (Value -> Either String String)
    -> Either String Value -> Either String String
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (String -> [Value] -> Either String Value
    forall a. String -> [a] -> Either String a
    listToEither String
    msg (String -> Value -> [Value]
    objectFieldValues String
    e Value
    value))) (specExternalVarType yamlFormat)

            return $ ExternalVariableDef
                       { externalVariableName = varId
                       , externalVariableType = varType
                       }

      externalVariableDefs <- except $ mapM externalVarDef values

      let values :: [Value]
          values = [Value] -> (String -> [Value]) -> Maybe String -> [Value]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [Value
    value] (Value -> String -> [Value]
    objectFieldValueList Value
    value) (YAMLFormat -> Maybe String
    specRequirements YAMLFormat
    yamlFormat)

          requirementDef Value
    value = do
            let msg :: String
    msg = String
    "Requirement name"
            reqId <- Either String String -> ExceptT String IO String
    forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
    except (Either String String -> ExceptT String IO String)
    -> Either String String -> ExceptT String IO String
    forall a b. (a -> b) -> a -> b
    $ Either String String
    -> (String -> Either String String)
    -> Maybe String
    -> Either String String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (String -> Either String String
    forall a b. b -> Either a b
    Right String
    "") (\String
    e -> String -> Value -> Either String String
    valueToString String
    msg (Value -> Either String String)
    -> Either String Value -> Either String String
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (String -> [Value] -> Either String Value
    forall a. String -> [a] -> Either String a
    listToEither String
    msg (String -> Value -> [Value]
    objectFieldValues String
    e Value
    value))) (YAMLFormat -> Maybe String
    specRequirementId YAMLFormat
    yamlFormat)

            let msg = String
    "Requirement expression"
            reqExpr <- except $ valueToString msg =<< listToEither msg (objectFieldValues (specRequirementExpr yamlFormat) value)
            reqExpr' <- ExceptT $ parseExpr reqExpr

            let msg = String
    "Requirement description"
            reqDesc <- except $ maybe (Right "") (\String
    e -> String -> Value -> Either String String
    valueToString String
    msg (Value -> Either String String)
    -> Either String Value -> Either String String
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (String -> [Value] -> Either String Value
    forall a. String -> [a] -> Either String a
    listToEither String
    msg (String -> Value -> [Value]
    objectFieldValues String
    e Value
    value))) (specRequirementDesc yamlFormat)
            let reqDesc' = String -> String
    cleanString String
    reqDesc

            let msg = String
    "Requirement result type"
                ty :: Maybe (Either String String)
                ty = (\String
    e -> String -> Value -> Either String String
    valueToString String
    msg (Value -> Either String String)
    -> Either String Value -> Either String String
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (String -> [Value] -> Either String Value
    forall a. String -> [a] -> Either String a
    listToEither String
    msg (String -> Value -> [Value]
    objectFieldValues String
    e Value
    value))) (String -> Either String String)
    -> Maybe String -> Maybe (Either String String)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (YAMLFormat -> Maybe String
    specRequirementResultType YAMLFormat
    yamlFormat)
            reqResType <- except $ maybeEither ty

            let msg = String
    "Requirement result expression"
                resultExpr :: Maybe (Either String String)
                resultExpr = (\String
    e -> String -> Value -> Either String String
    valueToString String
    msg (Value -> Either String String)
    -> Either String Value -> Either String String
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (String -> [Value] -> Either String Value
    forall a. String -> [a] -> Either String a
    listToEither String
    msg (String -> Value -> [Value]
    objectFieldValues String
    e Value
    value))) (String -> Either String String)
    -> Maybe String -> Maybe (Either String String)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (YAMLFormat -> Maybe String
    specRequirementResultExpr YAMLFormat
    yamlFormat)

            reqResExpr  <- except $ maybeEither resultExpr
            reqResExpr' <- ExceptT $ case reqResExpr of
                                       Maybe String
    Nothing -> Either String (Maybe a) -> IO (Either String (Maybe a))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Either String (Maybe a) -> IO (Either String (Maybe a)))
    -> Either String (Maybe a) -> IO (Either String (Maybe a))
    forall a b. (a -> b) -> a -> b
    $ Maybe a -> Either String (Maybe a)
    forall a b. b -> Either a b
    Right Maybe a
    forall a. Maybe a
    Nothing
                                       Just String
    x  -> (a -> Maybe a) -> Either String a -> Either String (Maybe a)
    forall a b. (a -> b) -> Either String a -> Either String b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap a -> Maybe a
    forall a. a -> Maybe a
    Just (Either String a -> Either String (Maybe a))
    -> IO (Either String a) -> IO (Either String (Maybe a))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> IO (Either String a)
    parseExpr String
    x

            return $ Requirement
                       { requirementName        = reqId
                       , requirementExpr        = reqExpr'
                       , requirementDescription = reqDesc'
                       , requirementResultType  = reqResType
                       , requirementResultExpr  = reqResExpr'
                       }

      requirements <- mapM requirementDef values

      return $ Spec internalVariableDefs externalVariableDefs requirements

    -- * Auxiliary functions

    -- ** JSON functions

    -- | Convert a string JSON value into a 'String'.
    valueToString :: String -> Value -> Either String String
    valueToString :: String -> Value -> Either String String
    valueToString String
    msg (String Text
    x) = String -> Either String String
    forall a b. b -> Either a b
    Right (String -> Either String String) -> String -> Either String String
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    unpack Text
    x
    valueToString String
    msg Value
    _          = 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
    "The YAML value provided for " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    msg String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " does not contain a string"

    -- | Object the values associated to a key of an object.
    --
    -- If the values are an array, it returns the values in the array directly.
    objectFieldValueList :: Value -> String -> [Value]
    objectFieldValueList :: Value -> String -> [Value]
    objectFieldValueList (Object Object
    o) String
    key =
      case Key -> Object -> Maybe Value
    forall v. Key -> KeyMap v -> Maybe v
    M.lookup (String -> Key
    fromString String
    key) Object
    o of
        Just (Array Array
    arr) -> Array -> [Value]
    forall a. Vector a -> [a]
    V.toList Array
    arr
        Just Value
    v           -> [Value
    v]
        Maybe Value
    Nothing          -> []
    objectFieldValueList Value
    _ String
    _ = []

    -- | Object the values associated to a key of an object.
    --
    -- If the values are an array, it returns the values in the array directly.
    objectFieldValues :: String -> Value -> [Value]
    objectFieldValues :: String -> Value -> [Value]
    objectFieldValues String
    key (Object Object
    o) = [Value] -> (Value -> [Value]) -> Maybe Value -> [Value]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [] (Value -> [Value] -> [Value]
    forall a. a -> [a] -> [a]
    :[]) (Maybe Value -> [Value]) -> Maybe Value -> [Value]
    forall a b. (a -> b) -> a -> b
    $ Key -> Object -> Maybe Value
    forall v. Key -> KeyMap v -> Maybe v
    M.lookup (String -> Key
    fromString String
    key) Object
    o
    objectFieldValues String
    _   Value
    _          = []

    -- ** Either-related auxiliary functions

    -- | Convert a string into an Either value.
    --
    -- Fails if there more or less than one value in the list.
    listToEither :: String -> [a] -> Either String a
    listToEither :: forall a. String -> [a] -> Either String a
    listToEither String
    _   [a
    x] = a -> Either String a
    forall a b. b -> Either a b
    Right a
    x
    listToEither String
    msg []  = String -> Either String a
    forall a b. a -> Either a b
    Left (String -> Either String a) -> String -> Either String a
    forall a b. (a -> b) -> a -> b
    $ String
    "Failed to find a value for " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    msg
    listToEither String
    msg [a]
    _   = String -> Either String a
    forall a b. a -> Either a b
    Left (String -> Either String a) -> String -> Either String a
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpectedly found multiple values for " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    msg

    -- | Wrap an 'Either' value in an @ExceptT m@ monad.
    except :: Monad m => Either e a -> ExceptT e m a
    except :: forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
    except = m (Either e a) -> ExceptT e m a
    forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
    ExceptT (m (Either e a) -> ExceptT e m a)
    -> (Either e a -> m (Either e a)) -> Either e a -> ExceptT e m a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Either e a -> m (Either e a)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

    -- | Swap the order in a Maybe and an Either monad.
    maybeEither :: Maybe (Either a b) -> Either a (Maybe b)
    maybeEither :: forall a b. Maybe (Either a b) -> Either a (Maybe b)
    maybeEither 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
    maybeEither (Just Either a b
    e) = (b -> Maybe b) -> Either a b -> Either a (Maybe b)
    forall a b. (a -> b) -> Either a a -> Either a b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap b -> Maybe b
    forall a. a -> Maybe a
    Just Either a b
    e

    -- ** String-related auxiliary functions

    -- | Remove trailing spaces and lines from a multi-line string.
    cleanString :: String -> String
    cleanString :: String -> String
    cleanString =
          [String] -> String
    unlines'
        ([String] -> String) -> (String -> [String]) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null
        ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhileEnd String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null
        ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String
    strip
        ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    lines
      where
        strip :: String -> String
    strip          = (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhileEnd Char -> Bool
    isSpace
        dropWhileEnd :: (a -> Bool) -> [a] -> [a]
    dropWhileEnd a -> Bool
    x = [a] -> [a]
    forall a. [a] -> [a]
    reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> Bool) -> [a] -> [a]
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile a -> Bool
    x ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [a] -> [a]
    forall a. [a] -> [a]
    reverse

    -- | Concatenate a list of strings into one string, separated by a line ending.
    --
    -- This variant of 'unlines' does not add a line break at the end of the last
    -- line.
    unlines' :: [String] -> String
    unlines' :: [String] -> String
    unlines' = String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    "\n"