{-# 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"