{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Autodocodec.Yaml.IO where

import Autodocodec
import Autodocodec.Yaml.Schema
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

-- | Helper function to read a yaml file for a type in 'HasCodec'
--
-- This will output a colourful yaml schema if parsing fails.
readYamlConfigFile :: HasCodec a => Path r File -> IO (Maybe a)
readYamlConfigFile :: forall a r. HasCodec a => Path r File -> IO (Maybe a)
readYamlConfigFile Path r File
p = forall a r. HasCodec a => [Path r File] -> IO (Maybe a)
readFirstYamlConfigFile [Path r File
p]

-- | Helper function to read the first in a list of yaml files for a type is 'HasCodec'
--
-- This will output a colourful yaml schema if parsing fails.
readFirstYamlConfigFile :: forall a r. HasCodec a => [Path r File] -> IO (Maybe a)
readFirstYamlConfigFile :: forall a r. HasCodec a => [Path r File] -> IO (Maybe a)
readFirstYamlConfigFile [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
        [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        (Path r File
p : [Path r File]
ps) -> do
          Maybe ByteString
mc <- forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
SB.readFile forall a b. (a -> b) -> a -> b
$ 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 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",
                          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: " forall a. Semigroup a => a -> a -> a
<> forall b t. Path b t -> FilePath
toFilePath Path r File
f]
                        [Path r File]
fs -> FilePath
"While parsing files:" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
"* " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> FilePath
toFilePath) [Path r File]
fs
                      referenceMsgs :: [FilePath]
referenceMsgs =
                        [ FilePath
"Reference: ",
                          Text -> FilePath
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. HasCodec a => Text
renderColouredSchemaViaCodec @a
                        ]
                  forall a. FilePath -> IO a
die forall a b. (a -> b) -> a -> b
$
                    [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$
                      forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                        [ [FilePath]
failedMsgs,
                          [FilePath]
triedFilesMsgs,
                          [FilePath]
referenceMsgs
                        ]
                Right (Autodocodec a
conf) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
conf