{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module YamlParse.Applicative.IO where

import qualified Data.ByteString as SB
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import Path
import Path.IO
import System.Exit
import YamlParse.Applicative.Class
import YamlParse.Applicative.Explain
import YamlParse.Applicative.Parser
import YamlParse.Applicative.Pretty

-- | Helper function to read a config file for a type in 'YamlSchema'
readConfigFile :: (YamlSchema a, Yaml.FromJSON a) => Path r File -> IO (Maybe a)
readConfigFile :: Path r File -> IO (Maybe a)
readConfigFile Path r File
p = [Path r File] -> IO (Maybe a)
forall a r.
(FromJSON a, YamlSchema a) =>
[Path r File] -> IO (Maybe a)
readFirstConfigFile [Path r File
p]

-- | Helper function to read the first in a list of config files
readFirstConfigFile :: forall a r. (Yaml.FromJSON a, YamlSchema a) => [Path r File] -> IO (Maybe a)
readFirstConfigFile :: [Path r File] -> IO (Maybe a)
readFirstConfigFile [Path r File]
files = [Path r File] -> IO (Maybe a)
go [Path r File]
files
  where
    go :: [Path r File] -> IO (Maybe a)
    go :: [Path r File] -> IO (Maybe a)
go =
      \case
        [] -> Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        (Path r File
p : [Path r File]
ps) -> do
          Maybe ByteString
mc <- IO ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (IO ByteString -> IO (Maybe ByteString))
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
SB.readFile (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path r File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path r File
p
          case Maybe ByteString
mc of
            Maybe ByteString
Nothing -> [Path r File] -> IO (Maybe a)
go [Path r File]
ps
            Just ByteString
contents ->
              case ByteString -> Either ParseException (ViaYamlSchema a)
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' ByteString
contents of
                Left ParseException
err -> do
                  let failedMsgs :: [FilePath]
failedMsgs =
                        [ FilePath
"Failed to parse yaml file",
                          Path r File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path r File
p,
                          FilePath
"with error:",
                          ParseException -> FilePath
Yaml.prettyPrintParseException ParseException
err
                        ]
                      triedFilesMsgs :: [FilePath]
triedFilesMsgs = case [Path r File]
files of
                        [] -> []
                        [Path r File
f] -> [FilePath
"While parsing file: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Path r File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path r File
f]
                        [Path r File]
fs -> FilePath
"While parsing files:" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (Path r File -> FilePath) -> [Path r File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
"* " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>) (FilePath -> FilePath)
-> (Path r File -> FilePath) -> Path r File -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path r File -> FilePath
forall b t. Path b t -> FilePath
toFilePath) [Path r File]
fs
                      referenceMsgs :: [FilePath]
referenceMsgs =
                        [ FilePath
"Reference: ",
                          Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Schema -> Text
prettyColourisedSchema (Schema -> Text) -> Schema -> Text
forall a b. (a -> b) -> a -> b
$ Parser Value a -> Schema
forall i o. Parser i o -> Schema
explainParser (Parser Value a
forall a. YamlSchema a => YamlParser a
yamlSchema :: YamlParser a)
                        ]
                  FilePath -> IO (Maybe a)
forall a. FilePath -> IO a
die (FilePath -> IO (Maybe a)) -> FilePath -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$
                    [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
                      [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                        [ [FilePath]
failedMsgs,
                          [FilePath]
triedFilesMsgs,
                          [FilePath]
referenceMsgs
                        ]
                Right (ViaYamlSchema a
conf) -> Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
conf