{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module QueueSheet.File
(
loadYaml
, loadYaml'
) where
import Control.Exception (displayException)
import Control.Monad (forM, forM_, unless, when)
import Data.Bifunctor (first)
import System.IO.Error (tryIOError)
import qualified Data.ByteString as BS
import Data.ByteString (ByteString)
import System.Directory (makeAbsolute)
import System.FilePath ((</>), isAbsolute, normalise, takeDirectory)
import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, throwE)
import qualified Data.TTC as TTC
import qualified Data.Yaml as Yaml
import QueueSheet.Types
( Import(Import, importPath, importSection)
, ImportOrQueue(IQImport, IQQueue)
, Queue(Queue, queueName, queueSection)
, QueuesFile(QueuesFile, qfSections, qfImportOrQueues)
, QueueSheet(QueueSheet, qsSections, qsQueues)
)
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
loadYaml'
:: forall m. Monad m
=> (FilePath -> m (Either String ByteString))
-> FilePath
-> 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
}