-- 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 XLSX files.
module Language.XLSXSpec.Parser (XLSXFormat(..), parseXLSXSpec) where

-- External imports
import           Codec.Xlsx           (Cell, CellValue (..), ColumnIndex (..),
                                       ParseError (..), _cellValue, _wsCells,
                                       _xlSheets, toRows, toXlsxEither)
import           Control.Monad        (forM, sequence)
import qualified Data.ByteString.Lazy as L
import           Data.List            (lookup)
import           Data.Maybe           (catMaybes, fromJust, isNothing)
import qualified Data.Text            as T
import qualified Data.Text.Encoding   as T

-- External imports: ogma-spec
import Data.OgmaSpec (Requirement (..), Spec (Spec))

-- | Area of the CSV file that contains the information of interest.
data XLSXFormat = XLSXFormat
    { XLSXFormat -> Bool
skipHeaders               :: Bool
    , XLSXFormat -> String
specRequirementSheet      :: String
    , XLSXFormat -> Int
specRequirementId         :: Int
    , XLSXFormat -> Maybe Int
specRequirementDesc       :: Maybe Int
    , XLSXFormat -> Int
specRequirementExpr       :: Int
    , XLSXFormat -> Maybe Int
specRequirementResultType :: Maybe Int
    , XLSXFormat -> Maybe Int
specRequirementResultExpr :: Maybe Int
    }
  deriving (ReadPrec [XLSXFormat]
ReadPrec XLSXFormat
Int -> ReadS XLSXFormat
ReadS [XLSXFormat]
(Int -> ReadS XLSXFormat)
-> ReadS [XLSXFormat]
-> ReadPrec XLSXFormat
-> ReadPrec [XLSXFormat]
-> Read XLSXFormat
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS XLSXFormat
readsPrec :: Int -> ReadS XLSXFormat
$creadList :: ReadS [XLSXFormat]
readList :: ReadS [XLSXFormat]
$creadPrec :: ReadPrec XLSXFormat
readPrec :: ReadPrec XLSXFormat
$creadListPrec :: ReadPrec [XLSXFormat]
readListPrec :: ReadPrec [XLSXFormat]
Read)

-- | Parse a XLSX file and extract a Spec from it.
--
-- An auxiliary function must be provided to parse the requirement expressions.
--
-- Fails if the sheet does not exist, any of the columns indicate a column out
-- of range, if the XLSX is malformed.
parseXLSXSpec :: (String -> IO (Either String a)) -- ^ Parser for expressions.
              -> a                                -- ^ Default property value.
              -> XLSXFormat                       -- ^ Spec format.
              -> L.ByteString                     -- ^ String containing XLSX.
              -> IO (Either String (Spec a))
parseXLSXSpec :: forall a.
(String -> IO (Either String a))
-> a -> XLSXFormat -> ByteString -> IO (Either String (Spec a))
parseXLSXSpec String -> IO (Either String a)
parseExpr a
_defA XLSXFormat
xlsxFormat ByteString
value = do

  -- The XLSX spec parser does not current support reading lists of internal or
  -- external variables from the XLSX file.
  let internalVariableDefs :: [a]
internalVariableDefs = []
      externalVariableDefs :: [a]
externalVariableDefs = []

  -- Obtain sheets and locate sheet needed.
  let sheets :: Either ParseError [(Text, Worksheet)]
sheets = Xlsx -> [(Text, Worksheet)]
_xlSheets (Xlsx -> [(Text, Worksheet)])
-> Either ParseError Xlsx -> Either ParseError [(Text, Worksheet)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either ParseError Xlsx
toXlsxEither ByteString
value

  case Either ParseError [(Text, Worksheet)]
sheets of
    Left ParseError
err      -> Either String (Spec a) -> IO (Either String (Spec a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Spec a) -> IO (Either String (Spec a)))
-> Either String (Spec a) -> IO (Either String (Spec a))
forall a b. (a -> b) -> a -> b
$ String -> Either String (Spec a)
forall a b. a -> Either a b
Left (String -> Either String (Spec a))
-> String -> Either String (Spec a)
forall a b. (a -> b) -> a -> b
$ ParseError -> String
showParseError ParseError
err
    Right [(Text, Worksheet)]
sheets' -> do

      let sheet :: Worksheet
sheet = Maybe Worksheet -> Worksheet
forall a. HasCallStack => Maybe a -> a
fromJust
                (Maybe Worksheet -> Worksheet) -> Maybe Worksheet -> Worksheet
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Worksheet)] -> Maybe Worksheet
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> Text
T.pack (XLSXFormat -> String
specRequirementSheet XLSXFormat
xlsxFormat)) [(Text, Worksheet)]
sheets'

      -- Obtain rows, discarding the header row if needed.
      let rows :: [(RowIndex, [(ColumnIndex, Cell)])]
rows  = if XLSXFormat -> Bool
skipHeaders XLSXFormat
xlsxFormat then [(RowIndex, [(ColumnIndex, Cell)])]
-> [(RowIndex, [(ColumnIndex, Cell)])]
forall a. HasCallStack => [a] -> [a]
tail [(RowIndex, [(ColumnIndex, Cell)])]
rows' else [(RowIndex, [(ColumnIndex, Cell)])]
rows'
          rows' :: [(RowIndex, [(ColumnIndex, Cell)])]
rows' = CellMap -> [(RowIndex, [(ColumnIndex, Cell)])]
toRows (CellMap -> [(RowIndex, [(ColumnIndex, Cell)])])
-> CellMap -> [(RowIndex, [(ColumnIndex, Cell)])]
forall a b. (a -> b) -> a -> b
$ Worksheet -> CellMap
_wsCells Worksheet
sheet

      -- Turn each row into a requirement, skipping rows without the necessary
      -- information.
      [Either String (Maybe (Requirement a))]
rs <- [(RowIndex, [(ColumnIndex, Cell)])]
-> ((RowIndex, [(ColumnIndex, Cell)])
    -> IO (Either String (Maybe (Requirement a))))
-> IO [Either String (Maybe (Requirement a))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(RowIndex, [(ColumnIndex, Cell)])]
rows (((RowIndex, [(ColumnIndex, Cell)])
  -> IO (Either String (Maybe (Requirement a))))
 -> IO [Either String (Maybe (Requirement a))])
-> ((RowIndex, [(ColumnIndex, Cell)])
    -> IO (Either String (Maybe (Requirement a))))
-> IO [Either String (Maybe (Requirement a))]
forall a b. (a -> b) -> a -> b
$ \(RowIndex
_, [(ColumnIndex, Cell)]
row) -> do
        if XLSXFormat -> [(ColumnIndex, Cell)] -> Bool
emptyRow XLSXFormat
xlsxFormat [(ColumnIndex, Cell)]
row
          then Either String (Maybe (Requirement a))
-> IO (Either String (Maybe (Requirement a)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Maybe (Requirement a))
 -> IO (Either String (Maybe (Requirement a))))
-> Either String (Maybe (Requirement a))
-> IO (Either String (Maybe (Requirement a)))
forall a b. (a -> b) -> a -> b
$ Maybe (Requirement a) -> Either String (Maybe (Requirement a))
forall a b. b -> Either a b
Right Maybe (Requirement a)
forall a. Maybe a
Nothing
          else do

            -- Read the two expressions in each row (the condition expression
            -- and the result expression), and return a requirement.
            Either String a
expr <- String -> IO (Either String a)
parseExpr (String -> IO (Either String a)) -> String -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ Int -> [(ColumnIndex, Cell)] -> String
rowCell (XLSXFormat -> Int
specRequirementExpr XLSXFormat
xlsxFormat) [(ColumnIndex, Cell)]
row
            Either String (Maybe a)
exprR <- IO (Either String (Maybe a))
-> (Int -> IO (Either String (Maybe a)))
-> Maybe Int
-> IO (Either String (Maybe a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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)
                           (\Int
ix -> (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 (Int -> [(ColumnIndex, Cell)] -> String
rowCell Int
ix [(ColumnIndex, Cell)]
row))
                           (XLSXFormat -> Maybe Int
specRequirementResultExpr XLSXFormat
xlsxFormat)

            case (Either String a
expr, Either String (Maybe a)
exprR) of
              (Left String
e,  Either String (Maybe a)
_) ->
                 Either String (Maybe (Requirement a))
-> IO (Either String (Maybe (Requirement a)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Maybe (Requirement a))
 -> IO (Either String (Maybe (Requirement a))))
-> Either String (Maybe (Requirement a))
-> IO (Either String (Maybe (Requirement a)))
forall a b. (a -> b) -> a -> b
$ String -> Either String (Maybe (Requirement a))
forall a b. a -> Either a b
Left (String -> Either String (Maybe (Requirement a)))
-> String -> Either String (Maybe (Requirement a))
forall a b. (a -> b) -> a -> b
$ String
"The XLSX data could not be parsed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e

              (Either String a
_, Left String
e) ->
                 Either String (Maybe (Requirement a))
-> IO (Either String (Maybe (Requirement a)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Maybe (Requirement a))
 -> IO (Either String (Maybe (Requirement a))))
-> Either String (Maybe (Requirement a))
-> IO (Either String (Maybe (Requirement a)))
forall a b. (a -> b) -> a -> b
$ String -> Either String (Maybe (Requirement a))
forall a b. a -> Either a b
Left (String -> Either String (Maybe (Requirement a)))
-> String -> Either String (Maybe (Requirement a))
forall a b. (a -> b) -> a -> b
$ String
"The XLSX data could not be parsed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e

              (Right a
e, Right Maybe a
rE) -> Either String (Maybe (Requirement a))
-> IO (Either String (Maybe (Requirement a)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Maybe (Requirement a))
 -> IO (Either String (Maybe (Requirement a))))
-> Either String (Maybe (Requirement a))
-> IO (Either String (Maybe (Requirement a)))
forall a b. (a -> b) -> a -> b
$ Maybe (Requirement a) -> Either String (Maybe (Requirement a))
forall a b. b -> Either a b
Right (Maybe (Requirement a) -> Either String (Maybe (Requirement a)))
-> Maybe (Requirement a) -> Either String (Maybe (Requirement a))
forall a b. (a -> b) -> a -> b
$ Requirement a -> Maybe (Requirement a)
forall a. a -> Maybe a
Just
                Requirement
                  { requirementName :: String
requirementName =
                      Int -> [(ColumnIndex, Cell)] -> String
rowCell (XLSXFormat -> Int
specRequirementId XLSXFormat
xlsxFormat) [(ColumnIndex, Cell)]
row
                  , requirementDescription :: String
requirementDescription =
                      String -> (Int -> String) -> Maybe Int -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (Int -> [(ColumnIndex, Cell)] -> String
`rowCell` [(ColumnIndex, Cell)]
row) (XLSXFormat -> Maybe Int
specRequirementDesc XLSXFormat
xlsxFormat)
                  , requirementExpr :: a
requirementExpr = a
e
                  , requirementResultType :: Maybe String
requirementResultType =
                      (Int -> String) -> Maybe Int -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                        (Int -> [(ColumnIndex, Cell)] -> String
`rowCell` [(ColumnIndex, Cell)]
row)
                        (XLSXFormat -> Maybe Int
specRequirementResultType XLSXFormat
xlsxFormat)
                  , requirementResultExpr :: Maybe a
requirementResultExpr = Maybe a
rE
                  }

      case ([Maybe (Requirement a)] -> [Requirement a])
-> Either String [Maybe (Requirement a)]
-> Either String [Requirement 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 [Maybe (Requirement a)] -> [Requirement a]
forall a. [Maybe a] -> [a]
catMaybes ([Either String (Maybe (Requirement a))]
-> Either String [Maybe (Requirement a)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Either String (Maybe (Requirement a))]
rs) of
        Left String
err  -> Either String (Spec a) -> IO (Either String (Spec a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Spec a) -> IO (Either String (Spec a)))
-> Either String (Spec a) -> IO (Either String (Spec a))
forall a b. (a -> b) -> a -> b
$ String -> Either String (Spec a)
forall a b. a -> Either a b
Left String
err
        Right [Requirement a]
rs' -> Either String (Spec a) -> IO (Either String (Spec a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Spec a) -> IO (Either String (Spec a)))
-> Either String (Spec a) -> IO (Either String (Spec a))
forall a b. (a -> b) -> a -> b
$ Spec a -> Either String (Spec a)
forall a b. b -> Either a b
Right (Spec a -> Either String (Spec a))
-> Spec a -> Either String (Spec a)
forall a b. (a -> b) -> a -> b
$
                       [InternalVariableDef]
-> [ExternalVariableDef] -> [Requirement a] -> Spec a
forall a.
[InternalVariableDef]
-> [ExternalVariableDef] -> [Requirement a] -> Spec a
Spec [InternalVariableDef]
forall a. [a]
internalVariableDefs [ExternalVariableDef]
forall a. [a]
externalVariableDefs [Requirement a]
rs'

-- * Auxiliary functions

-- | A row is empty if any of the cells needed is empty.
emptyRow :: XLSXFormat -> [(ColumnIndex, Cell)] -> Bool
emptyRow :: XLSXFormat -> [(ColumnIndex, Cell)] -> Bool
emptyRow XLSXFormat
xlsxFormat [(ColumnIndex, Cell)]
row =
     Int -> [(ColumnIndex, Cell)] -> Bool
emptyCell (XLSXFormat -> Int
specRequirementExpr XLSXFormat
xlsxFormat) [(ColumnIndex, Cell)]
row
  Bool -> Bool -> Bool
|| Int -> [(ColumnIndex, Cell)] -> Bool
emptyCell (XLSXFormat -> Int
specRequirementId XLSXFormat
xlsxFormat) [(ColumnIndex, Cell)]
row
  Bool -> Bool -> Bool
|| Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> [(ColumnIndex, Cell)] -> Bool
`emptyCell` [(ColumnIndex, Cell)]
row)
       (XLSXFormat -> Maybe Int
specRequirementDesc XLSXFormat
xlsxFormat)
  Bool -> Bool -> Bool
|| Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> [(ColumnIndex, Cell)] -> Bool
`emptyCell` [(ColumnIndex, Cell)]
row)
       (XLSXFormat -> Maybe Int
specRequirementResultExpr XLSXFormat
xlsxFormat)
  Bool -> Bool -> Bool
|| Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> [(ColumnIndex, Cell)] -> Bool
`emptyCell` [(ColumnIndex, Cell)]
row)
       (XLSXFormat -> Maybe Int
specRequirementResultType XLSXFormat
xlsxFormat)

-- | A cell is empty if the cell cannot be found in the row.
emptyCell :: Int -> [(ColumnIndex, Cell)] -> Bool
emptyCell :: Int -> [(ColumnIndex, Cell)] -> Bool
emptyCell Int
i [(ColumnIndex, Cell)]
row = Maybe Cell -> Bool
forall a. Maybe a -> Bool
isNothing (ColumnIndex -> [(ColumnIndex, Cell)] -> Maybe Cell
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Int -> ColumnIndex
ColumnIndex Int
i) [(ColumnIndex, Cell)]
row)

-- | Obtain a cell from a row, as a 'String'.
--
-- PRE: The cell exists and has a value.
rowCell :: Int -> [(ColumnIndex, Cell)] -> String
rowCell :: Int -> [(ColumnIndex, Cell)] -> String
rowCell Int
i [(ColumnIndex, Cell)]
row = CellValue -> String
cellValueToString
              (CellValue -> String) -> CellValue -> String
forall a b. (a -> b) -> a -> b
$ Maybe CellValue -> CellValue
forall a. HasCallStack => Maybe a -> a
fromJust
              (Maybe CellValue -> CellValue) -> Maybe CellValue -> CellValue
forall a b. (a -> b) -> a -> b
$ Cell -> Maybe CellValue
_cellValue
              (Cell -> Maybe CellValue) -> Cell -> Maybe CellValue
forall a b. (a -> b) -> a -> b
$ Maybe Cell -> Cell
forall a. HasCallStack => Maybe a -> a
fromJust
              (Maybe Cell -> Cell) -> Maybe Cell -> Cell
forall a b. (a -> b) -> a -> b
$ ColumnIndex -> [(ColumnIndex, Cell)] -> Maybe Cell
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Int -> ColumnIndex
ColumnIndex Int
i) [(ColumnIndex, Cell)]
row

-- | Convert a cell value into a 'String'.
cellValueToString :: CellValue -> String
cellValueToString :: CellValue -> String
cellValueToString (CellText Text
txt) = Text -> String
T.unpack Text
txt
cellValueToString (CellDouble Double
n) = Double -> String
forall a. Show a => a -> String
show Double
n
cellValueToString (CellBool Bool
b)   = Bool -> String
forall a. Show a => a -> String
show Bool
b
cellValueToString (CellRich [RichTextRun]
_)   = String
"(unsupported)"
cellValueToString (CellError ErrorType
_)  = String
"(error)"

-- | Show a parse error message.
showParseError :: ParseError -> String
showParseError :: ParseError -> String
showParseError (InvalidZipArchive String
string) = String
"Invalid zip archive: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
string
showParseError (MissingFile String
fp)           = String
"Missing file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp
showParseError (InvalidFile String
fp Text
txt)       = String
"Invalid file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp
showParseError (InvalidRef String
fp RefId
refId)      = String
"Invalid reference in file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp
showParseError (InconsistentXlsx Text
txt)     = String
"Inconsistent XLSX file"