------------------------------------------------------------------------------
-- |
-- Module      : QueueSheet.File
-- Description : queue sheet file loading
-- Copyright   : Copyright (c) 2020-2022 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 :: FilePath -> IO (Either FilePath QueueSheet)
loadYaml FilePath
path = ExceptT FilePath IO QueueSheet -> IO (Either FilePath QueueSheet)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT FilePath IO QueueSheet -> IO (Either FilePath QueueSheet))
-> ExceptT FilePath IO QueueSheet
-> IO (Either FilePath QueueSheet)
forall a b. (a -> b) -> a -> b
$ do
    let tryIOError' :: IO c -> IO (Either FilePath c)
tryIOError' = (Either IOError c -> Either FilePath c)
-> IO (Either IOError c) -> IO (Either FilePath c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IOError -> FilePath) -> Either IOError c -> Either FilePath c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first IOError -> FilePath
forall e. Exception e => e -> FilePath
displayException) (IO (Either IOError c) -> IO (Either FilePath c))
-> (IO c -> IO (Either IOError c))
-> IO c
-> IO (Either FilePath 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
    FilePath
absPath <- IO (Either FilePath FilePath) -> ExceptT FilePath IO FilePath
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either FilePath FilePath) -> ExceptT FilePath IO FilePath)
-> (IO FilePath -> IO (Either FilePath FilePath))
-> IO FilePath
-> ExceptT FilePath IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO FilePath -> IO (Either FilePath FilePath)
forall c. IO c -> IO (Either FilePath c)
tryIOError' (IO FilePath -> ExceptT FilePath IO FilePath)
-> IO FilePath -> ExceptT FilePath IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
makeAbsolute FilePath
path
    IO (Either FilePath QueueSheet) -> ExceptT FilePath IO QueueSheet
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either FilePath QueueSheet) -> ExceptT FilePath IO QueueSheet)
-> IO (Either FilePath QueueSheet)
-> ExceptT FilePath IO QueueSheet
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO (Either FilePath ByteString))
-> FilePath -> IO (Either FilePath QueueSheet)
forall (m :: * -> *).
Monad m =>
(FilePath -> m (Either FilePath ByteString))
-> FilePath -> m (Either FilePath QueueSheet)
loadYaml' (IO ByteString -> IO (Either FilePath ByteString)
forall c. IO c -> IO (Either FilePath c)
tryIOError' (IO ByteString -> IO (Either FilePath ByteString))
-> (FilePath -> IO ByteString)
-> FilePath
-> IO (Either FilePath ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
BS.readFile) FilePath
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' :: (FilePath -> m (Either FilePath ByteString))
-> FilePath -> m (Either FilePath QueueSheet)
loadYaml' FilePath -> m (Either FilePath ByteString)
loadFile = ExceptT FilePath m QueueSheet -> m (Either FilePath QueueSheet)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT FilePath m QueueSheet -> m (Either FilePath QueueSheet))
-> (FilePath -> ExceptT FilePath m QueueSheet)
-> FilePath
-> m (Either FilePath QueueSheet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath -> ExceptT FilePath m QueueSheet
go []
  where
    go :: [FilePath] -> FilePath -> ExceptT String m QueueSheet
    go :: [FilePath] -> FilePath -> ExceptT FilePath m QueueSheet
go [FilePath]
seenPaths FilePath
path = do
      let error' :: FilePath -> ExceptT FilePath m a
error' = FilePath -> ExceptT FilePath m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (FilePath -> ExceptT FilePath m a)
-> (FilePath -> FilePath) -> FilePath -> ExceptT FilePath m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath
"error loading " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": ") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
          yamlError :: ParseException -> ExceptT FilePath m a
yamlError = FilePath -> ExceptT FilePath m a
forall a. FilePath -> ExceptT FilePath m a
error' (FilePath -> ExceptT FilePath m a)
-> (ParseException -> FilePath)
-> ParseException
-> ExceptT FilePath m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> FilePath
Yaml.prettyPrintParseException
      ByteString
content <- m (Either FilePath ByteString) -> ExceptT FilePath m ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either FilePath ByteString) -> ExceptT FilePath m ByteString)
-> m (Either FilePath ByteString) -> ExceptT FilePath m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> m (Either FilePath ByteString)
loadFile FilePath
path
      QueuesFile{[ImportOrQueue]
[Section]
qfImportOrQueues :: [ImportOrQueue]
qfSections :: [Section]
qfImportOrQueues :: QueuesFile -> [ImportOrQueue]
qfSections :: QueuesFile -> [Section]
..} <- (ParseException -> ExceptT FilePath m QueuesFile)
-> (QueuesFile -> ExceptT FilePath m QueuesFile)
-> Either ParseException QueuesFile
-> ExceptT FilePath m QueuesFile
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> ExceptT FilePath m QueuesFile
forall a. ParseException -> ExceptT FilePath m a
yamlError QueuesFile -> ExceptT FilePath m QueuesFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseException QueuesFile -> ExceptT FilePath m QueuesFile)
-> Either ParseException QueuesFile
-> ExceptT FilePath 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 FilePath m [[Queue]] -> ExceptT FilePath m [Queue]
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 FilePath m [[Queue]] -> ExceptT FilePath m [Queue])
-> ((ImportOrQueue -> ExceptT FilePath m [Queue])
    -> ExceptT FilePath m [[Queue]])
-> (ImportOrQueue -> ExceptT FilePath m [Queue])
-> ExceptT FilePath m [Queue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ImportOrQueue]
-> (ImportOrQueue -> ExceptT FilePath m [Queue])
-> ExceptT FilePath m [[Queue]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ImportOrQueue]
qfImportOrQueues ((ImportOrQueue -> ExceptT FilePath m [Queue])
 -> ExceptT FilePath m [Queue])
-> (ImportOrQueue -> ExceptT FilePath m [Queue])
-> ExceptT FilePath m [Queue]
forall a b. (a -> b) -> a -> b
$ \case
        IQImport Import{FilePath
Maybe Section
importSection :: Maybe Section
importPath :: FilePath
importSection :: Import -> Maybe Section
importPath :: Import -> FilePath
..} -> do
          let seenPaths' :: [FilePath]
seenPaths' = FilePath
path FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
seenPaths
              importAbsPath :: FilePath
importAbsPath
                | FilePath -> Bool
isAbsolute FilePath
importPath = FilePath
importPath
                | Bool
otherwise = FilePath -> FilePath
normalise (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
importPath
          Bool -> ExceptT FilePath m () -> ExceptT FilePath m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
importAbsPath FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
seenPaths') (ExceptT FilePath m () -> ExceptT FilePath m ())
-> (FilePath -> ExceptT FilePath m ())
-> FilePath
-> ExceptT FilePath m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ExceptT FilePath m ()
forall a. FilePath -> ExceptT FilePath m a
error' (FilePath -> ExceptT FilePath m ())
-> FilePath -> ExceptT FilePath m ()
forall a b. (a -> b) -> a -> b
$
            FilePath
"cyclic import: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
importAbsPath
          QueueSheet
queueSheet <- [FilePath] -> FilePath -> ExceptT FilePath m QueueSheet
go [FilePath]
seenPaths' FilePath
importAbsPath
          let queues' :: [Queue]
queues' = QueueSheet -> [Queue]
qsQueues QueueSheet
queueSheet
          case Maybe Section
importSection of
            Just Section
section -> do
              Bool -> ExceptT FilePath m () -> ExceptT FilePath m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Section
section Section -> [Section] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Section]
qfSections) (ExceptT FilePath m () -> ExceptT FilePath m ())
-> ([FilePath] -> ExceptT FilePath m ())
-> [FilePath]
-> ExceptT FilePath m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ExceptT FilePath m ()
forall a. FilePath -> ExceptT FilePath m a
error' (FilePath -> ExceptT FilePath m ())
-> ([FilePath] -> FilePath) -> [FilePath] -> ExceptT FilePath m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unwords ([FilePath] -> ExceptT FilePath m ())
-> [FilePath] -> ExceptT FilePath m ()
forall a b. (a -> b) -> a -> b
$
                [ FilePath
"import", FilePath
importPath
                , FilePath
"has unknown section", Section -> FilePath
forall a t. (Render a, Textual t) => a -> t
TTC.render Section
section
                ]
              [Queue] -> ExceptT FilePath m [Queue]
forall (m :: * -> *) a. Monad m => a -> m a
return [Queue
queue{ queueSection :: Section
queueSection = Section
section } | Queue
queue <- [Queue]
queues']
            Maybe Section
Nothing -> do
              [Queue]
-> (Queue -> ExceptT FilePath m ()) -> ExceptT FilePath m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Queue]
queues' ((Queue -> ExceptT FilePath m ()) -> ExceptT FilePath m ())
-> (Queue -> ExceptT FilePath m ()) -> ExceptT FilePath m ()
forall a b. (a -> b) -> a -> b
$ \Queue{Section
Name
queueSection :: Section
queueName :: Name
queueSection :: Queue -> Section
queueName :: Queue -> Name
..} ->
                Bool -> ExceptT FilePath m () -> ExceptT FilePath m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Section
queueSection Section -> [Section] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Section]
qfSections) (ExceptT FilePath m () -> ExceptT FilePath m ())
-> ([FilePath] -> ExceptT FilePath m ())
-> [FilePath]
-> ExceptT FilePath m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ExceptT FilePath m ()
forall a. FilePath -> ExceptT FilePath m a
error' (FilePath -> ExceptT FilePath m ())
-> ([FilePath] -> FilePath) -> [FilePath] -> ExceptT FilePath m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unwords ([FilePath] -> ExceptT FilePath m ())
-> [FilePath] -> ExceptT FilePath m ()
forall a b. (a -> b) -> a -> b
$
                  [ FilePath
"queue", Name -> FilePath
forall a t. (Render a, Textual t) => a -> t
TTC.render Name
queueName
                  , FilePath
"imported from", FilePath
importPath
                  , FilePath
"has unknown section", Section -> FilePath
forall a t. (Render a, Textual t) => a -> t
TTC.render Section
queueSection
                  ]
              [Queue] -> ExceptT FilePath m [Queue]
forall (m :: * -> *) a. Monad m => a -> m a
return [Queue]
queues'
        IQQueue queue :: Queue
queue@Queue{Section
Name
queueSection :: Section
queueName :: Name
queueSection :: Queue -> Section
queueName :: Queue -> Name
..} -> do
          Bool -> ExceptT FilePath m () -> ExceptT FilePath m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Section
queueSection Section -> [Section] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Section]
qfSections) (ExceptT FilePath m () -> ExceptT FilePath m ())
-> ([FilePath] -> ExceptT FilePath m ())
-> [FilePath]
-> ExceptT FilePath m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ExceptT FilePath m ()
forall a. FilePath -> ExceptT FilePath m a
error' (FilePath -> ExceptT FilePath m ())
-> ([FilePath] -> FilePath) -> [FilePath] -> ExceptT FilePath m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unwords ([FilePath] -> ExceptT FilePath m ())
-> [FilePath] -> ExceptT FilePath m ()
forall a b. (a -> b) -> a -> b
$
            [ FilePath
"queue", Name -> FilePath
forall a t. (Render a, Textual t) => a -> t
TTC.render Name
queueName
            , FilePath
"has unknown section", Section -> FilePath
forall a t. (Render a, Textual t) => a -> t
TTC.render Section
queueSection
            ]
          [Queue] -> ExceptT FilePath m [Queue]
forall (m :: * -> *) a. Monad m => a -> m a
return [Queue
queue]
      QueueSheet -> ExceptT FilePath m QueueSheet
forall (m :: * -> *) a. Monad m => a -> m a
return (QueueSheet -> ExceptT FilePath m QueueSheet)
-> QueueSheet -> ExceptT FilePath m QueueSheet
forall a b. (a -> b) -> a -> b
$ QueueSheet :: [Section] -> [Queue] -> QueueSheet
QueueSheet
        { qsSections :: [Section]
qsSections = [Section]
qfSections
        , qsQueues :: [Queue]
qsQueues   = [Queue]
queues
        }