------------------------------------------------------------------------------
-- |
-- Module      : QueueSheet.File
-- Description : queue sheet file loading
-- Copyright   : Copyright (c) 2020-2025 Travis Cardwell
-- License     : MIT
------------------------------------------------------------------------------

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module QueueSheet.File
  ( -- * YAML
    loadYaml
  , loadYaml'
  ) where

-- https://hackage.haskell.org/package/base
import Control.Exception (displayException)
import Control.Monad (forM, forM_, unless, when)
import Data.Bifunctor (first)
import System.IO.Error (tryIOError)

-- https://hackage.haskell.org/package/bytestring
import qualified Data.ByteString as BS
import Data.ByteString (ByteString)

-- https://hackage.haskell.org/package/directory
import System.Directory (makeAbsolute)

-- https://hackage.haskell.org/package/filepath
import System.FilePath ((</>), isAbsolute, normalise, takeDirectory)

-- https://hackage.haskell.org/package/transformers
import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, throwE)

-- https://hackage.haskell.org/package/ttc
import qualified Data.TTC as TTC

-- https://hackage.haskell.org/package/yaml
import qualified Data.Yaml as Yaml

-- (queue-sheet)
import QueueSheet.Types
  ( Import(Import, importPath, importSection)
  , ImportOrQueue(IQImport, IQQueue)
  , Queue(Queue, queueName, queueSection)
  , QueuesFile(QueuesFile, qfSections, qfImportOrQueues)
  , QueueSheet(QueueSheet, qsSections, qsQueues)
  )

------------------------------------------------------------------------------
-- $Yaml

-- | Load a queues YAML file, resolving imports
--
-- @since 0.3.0.0
loadYaml
  :: FilePath
  -> IO (Either String QueueSheet)
loadYaml :: String -> IO (Either String QueueSheet)
loadYaml String
path = ExceptT String IO QueueSheet -> IO (Either String QueueSheet)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO QueueSheet -> IO (Either String QueueSheet))
-> ExceptT String IO QueueSheet -> IO (Either String QueueSheet)
forall a b. (a -> b) -> a -> b
$ do
    let tryIOError' :: IO c -> IO (Either String c)
tryIOError' = (Either IOError c -> Either String c)
-> IO (Either IOError c) -> IO (Either String c)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IOError -> String) -> Either IOError c -> Either String c
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first IOError -> String
forall e. Exception e => e -> String
displayException) (IO (Either IOError c) -> IO (Either String c))
-> (IO c -> IO (Either IOError c)) -> IO c -> IO (Either String c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO c -> IO (Either IOError c)
forall a. IO a -> IO (Either IOError a)
tryIOError
    String
absPath <- 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 String -> IO (Either String String))
-> IO String
-> ExceptT String IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO String -> IO (Either String String)
forall {c}. IO c -> IO (Either String c)
tryIOError' (IO String -> ExceptT String IO String)
-> IO String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
makeAbsolute String
path
    IO (Either String QueueSheet) -> ExceptT String IO QueueSheet
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String QueueSheet) -> ExceptT String IO QueueSheet)
-> IO (Either String QueueSheet) -> ExceptT String IO QueueSheet
forall a b. (a -> b) -> a -> b
$ (String -> IO (Either String ByteString))
-> String -> IO (Either String QueueSheet)
forall (m :: * -> *).
Monad m =>
(String -> m (Either String ByteString))
-> String -> m (Either String QueueSheet)
loadYaml' (IO ByteString -> IO (Either String ByteString)
forall {c}. IO c -> IO (Either String c)
tryIOError' (IO ByteString -> IO (Either String ByteString))
-> (String -> IO ByteString)
-> String
-> IO (Either String ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
BS.readFile) String
absPath

-- | Load a queues YAML file using the given file loader, resolving imports
--
-- This function defines the logic for 'loadYaml' using an arbitrary monad.
-- It is exposed for testing purposes.
--
-- @since 0.3.0.0
loadYaml'
  :: forall m. Monad m
  => (FilePath -> m (Either String ByteString))  -- ^ file loader
  -> FilePath                                    -- ^ absolute path
  -> m (Either String QueueSheet)
loadYaml' :: forall (m :: * -> *).
Monad m =>
(String -> m (Either String ByteString))
-> String -> m (Either String QueueSheet)
loadYaml' String -> m (Either String ByteString)
loadFile = ExceptT String m QueueSheet -> m (Either String QueueSheet)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String m QueueSheet -> m (Either String QueueSheet))
-> (String -> ExceptT String m QueueSheet)
-> String
-> m (Either String QueueSheet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String -> ExceptT String m QueueSheet
go []
  where
    go :: [FilePath] -> FilePath -> ExceptT String m QueueSheet
    go :: [String] -> String -> ExceptT String m QueueSheet
go [String]
seenPaths String
path = do
      let error' :: String -> ExceptT String m a
error' = String -> ExceptT String m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String m a)
-> (String -> String) -> String -> ExceptT String m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"error loading " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": ") String -> String -> String
forall a. [a] -> [a] -> [a]
++)
          yamlError :: ParseException -> ExceptT String m a
yamlError = String -> ExceptT String m a
forall {a}. String -> ExceptT String m a
error' (String -> ExceptT String m a)
-> (ParseException -> String)
-> ParseException
-> ExceptT String m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> String
Yaml.prettyPrintParseException
      ByteString
content <- m (Either String ByteString) -> ExceptT String m ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either String ByteString) -> ExceptT String m ByteString)
-> m (Either String ByteString) -> ExceptT String m ByteString
forall a b. (a -> b) -> a -> b
$ String -> m (Either String ByteString)
loadFile String
path
      QueuesFile{[ImportOrQueue]
[Section]
qfSections :: QueuesFile -> [Section]
qfImportOrQueues :: QueuesFile -> [ImportOrQueue]
qfSections :: [Section]
qfImportOrQueues :: [ImportOrQueue]
..} <- (ParseException -> ExceptT String m QueuesFile)
-> (QueuesFile -> ExceptT String m QueuesFile)
-> Either ParseException QueuesFile
-> ExceptT String m QueuesFile
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> ExceptT String m QueuesFile
forall {a}. ParseException -> ExceptT String m a
yamlError QueuesFile -> ExceptT String m QueuesFile
forall a. a -> ExceptT String m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseException QueuesFile -> ExceptT String m QueuesFile)
-> Either ParseException QueuesFile -> ExceptT String m QueuesFile
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ParseException QueuesFile
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' ByteString
content
      [Queue]
queues <- ([[Queue]] -> [Queue])
-> ExceptT String m [[Queue]] -> ExceptT String m [Queue]
forall a b. (a -> b) -> ExceptT String m a -> ExceptT String m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Queue]] -> [Queue]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (ExceptT String m [[Queue]] -> ExceptT String m [Queue])
-> ((ImportOrQueue -> ExceptT String m [Queue])
    -> ExceptT String m [[Queue]])
-> (ImportOrQueue -> ExceptT String m [Queue])
-> ExceptT String m [Queue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ImportOrQueue]
-> (ImportOrQueue -> ExceptT String m [Queue])
-> ExceptT String m [[Queue]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ImportOrQueue]
qfImportOrQueues ((ImportOrQueue -> ExceptT String m [Queue])
 -> ExceptT String m [Queue])
-> (ImportOrQueue -> ExceptT String m [Queue])
-> ExceptT String m [Queue]
forall a b. (a -> b) -> a -> b
$ \case
        IQImport Import{String
Maybe Section
importPath :: Import -> String
importSection :: Import -> Maybe Section
importPath :: String
importSection :: Maybe Section
..} -> do
          let seenPaths' :: [String]
seenPaths' = String
path String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
seenPaths
              importAbsPath :: String
importAbsPath
                | String -> Bool
isAbsolute String
importPath = String
importPath
                | Bool
otherwise = String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
path String -> String -> String
</> String
importPath
          Bool -> ExceptT String m () -> ExceptT String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
importAbsPath String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
seenPaths') (ExceptT String m () -> ExceptT String m ())
-> (String -> ExceptT String m ()) -> String -> ExceptT String m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExceptT String m ()
forall {a}. String -> ExceptT String m a
error' (String -> ExceptT String m ()) -> String -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$
            String
"cyclic import: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
importAbsPath
          QueueSheet
queueSheet <- [String] -> String -> ExceptT String m QueueSheet
go [String]
seenPaths' String
importAbsPath
          let queues' :: [Queue]
queues' = QueueSheet -> [Queue]
qsQueues QueueSheet
queueSheet
          case Maybe Section
importSection of
            Just Section
section -> do
              Bool -> ExceptT String m () -> ExceptT String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Section
section Section -> [Section] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Section]
qfSections) (ExceptT String m () -> ExceptT String m ())
-> ([String] -> ExceptT String m ())
-> [String]
-> ExceptT String m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExceptT String m ()
forall {a}. String -> ExceptT String m a
error' (String -> ExceptT String m ())
-> ([String] -> String) -> [String] -> ExceptT String m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> ExceptT String m ())
-> [String] -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$
                [ String
"import", String
importPath
                , String
"has unknown section", Section -> String
forall a t. (Render a, Textual t) => a -> t
forall t. Textual t => Section -> t
TTC.render Section
section
                ]
              [Queue] -> ExceptT String m [Queue]
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Queue
queue{ queueSection = section } | Queue
queue <- [Queue]
queues']
            Maybe Section
Nothing -> do
              [Queue] -> (Queue -> ExceptT String m ()) -> ExceptT String m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Queue]
queues' ((Queue -> ExceptT String m ()) -> ExceptT String m ())
-> (Queue -> ExceptT String m ()) -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$ \Queue{Section
Name
queueName :: Queue -> Name
queueSection :: Queue -> Section
queueName :: Name
queueSection :: Section
..} ->
                Bool -> ExceptT String m () -> ExceptT String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Section
queueSection Section -> [Section] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Section]
qfSections) (ExceptT String m () -> ExceptT String m ())
-> ([String] -> ExceptT String m ())
-> [String]
-> ExceptT String m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExceptT String m ()
forall {a}. String -> ExceptT String m a
error' (String -> ExceptT String m ())
-> ([String] -> String) -> [String] -> ExceptT String m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> ExceptT String m ())
-> [String] -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$
                  [ String
"queue", Name -> String
forall a t. (Render a, Textual t) => a -> t
forall t. Textual t => Name -> t
TTC.render Name
queueName
                  , String
"imported from", String
importPath
                  , String
"has unknown section", Section -> String
forall a t. (Render a, Textual t) => a -> t
forall t. Textual t => Section -> t
TTC.render Section
queueSection
                  ]
              [Queue] -> ExceptT String m [Queue]
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Queue]
queues'
        IQQueue queue :: Queue
queue@Queue{Section
Name
queueName :: Queue -> Name
queueSection :: Queue -> Section
queueName :: Name
queueSection :: Section
..} -> do
          Bool -> ExceptT String m () -> ExceptT String m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Section
queueSection Section -> [Section] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Section]
qfSections) (ExceptT String m () -> ExceptT String m ())
-> ([String] -> ExceptT String m ())
-> [String]
-> ExceptT String m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ExceptT String m ()
forall {a}. String -> ExceptT String m a
error' (String -> ExceptT String m ())
-> ([String] -> String) -> [String] -> ExceptT String m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> ExceptT String m ())
-> [String] -> ExceptT String m ()
forall a b. (a -> b) -> a -> b
$
            [ String
"queue", Name -> String
forall a t. (Render a, Textual t) => a -> t
forall t. Textual t => Name -> t
TTC.render Name
queueName
            , String
"has unknown section", Section -> String
forall a t. (Render a, Textual t) => a -> t
forall t. Textual t => Section -> t
TTC.render Section
queueSection
            ]
          [Queue] -> ExceptT String m [Queue]
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Queue
queue]
      QueueSheet -> ExceptT String m QueueSheet
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (QueueSheet -> ExceptT String m QueueSheet)
-> QueueSheet -> ExceptT String m QueueSheet
forall a b. (a -> b) -> a -> b
$ QueueSheet
        { qsSections :: [Section]
qsSections = [Section]
qfSections
        , qsQueues :: [Queue]
qsQueues   = [Queue]
queues
        }