{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Utilities for dealing with YAML config files which contain relative file
-- paths.
module Keter.Yaml.FilePath
    ( decodeFileRelative
    , lookupBase
    , lookupBaseMaybe
    , BaseDir
    , ParseYamlFile (..)
    , NonEmptyVector (..)
    ) where

import Control.Applicative ((<$>))
import Data.Yaml (decodeFileEither, ParseException (AesonException), parseJSON)
import Prelude (($!), ($), Either (..), return, IO, (.), (>>=), Maybe (..), maybe, mapM, Ord, fail, FilePath)
import Keter.Aeson.KeyHelper as AK
import Data.Aeson.Types ((.:), (.:?), Object, Parser, Value, parseEither)
import Data.Text (Text, unpack)
import qualified Data.Set as Set
import qualified Data.Vector as V
import System.FilePath (takeDirectory, (</>))

-- | The directory from which we're reading the config file.
newtype BaseDir = BaseDir FilePath

-- | Parse a config file, using the 'ParseYamlFile' typeclass.
decodeFileRelative :: ParseYamlFile a
                   => FilePath
                   -> IO (Either ParseException a)
decodeFileRelative :: FilePath -> IO (Either ParseException a)
decodeFileRelative FilePath
fp = do
    Either ParseException Value
evalue <- FilePath -> IO (Either ParseException Value)
forall a. FromJSON a => FilePath -> IO (Either ParseException a)
decodeFileEither FilePath
fp
    Either ParseException a -> IO (Either ParseException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseException a -> IO (Either ParseException a))
-> Either ParseException a -> IO (Either ParseException a)
forall a b. (a -> b) -> a -> b
$! case Either ParseException Value
evalue of
        Left ParseException
e -> ParseException -> Either ParseException a
forall a b. a -> Either a b
Left ParseException
e
        Right Value
value ->
            case (Value -> Parser a) -> Value -> Either FilePath a
forall a b. (a -> Parser b) -> a -> Either FilePath b
parseEither (BaseDir -> Value -> Parser a
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir) Value
value of
                Left FilePath
s -> ParseException -> Either ParseException a
forall a b. a -> Either a b
Left (ParseException -> Either ParseException a)
-> ParseException -> Either ParseException a
forall a b. (a -> b) -> a -> b
$! FilePath -> ParseException
AesonException FilePath
s
                Right a
x -> a -> Either ParseException a
forall a b. b -> Either a b
Right (a -> Either ParseException a) -> a -> Either ParseException a
forall a b. (a -> b) -> a -> b
$! a
x
  where
    basedir :: BaseDir
basedir = FilePath -> BaseDir
BaseDir (FilePath -> BaseDir) -> FilePath -> BaseDir
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
fp

-- | A replacement for the @.:@ operator which will both parse a file path and
-- apply the relative file logic.
lookupBase :: ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase :: BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
k = (Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
k') Parser Value -> (Value -> Parser a) -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BaseDir -> Value -> Parser a
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir
  where
    k' :: Key
k' = Text -> Key
AK.toKey Text
k

-- | A replacement for the @.:?@ operator which will both parse a file path and
-- apply the relative file logic.
lookupBaseMaybe :: ParseYamlFile a => BaseDir -> Object -> Text -> Parser (Maybe a)
lookupBaseMaybe :: BaseDir -> Object -> Text -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Text
k = (Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
k') Parser (Maybe Value)
-> (Maybe Value -> Parser (Maybe a)) -> Parser (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser (Maybe a)
-> (Value -> Parser (Maybe a)) -> Maybe Value -> Parser (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a -> Parser (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) ((a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Parser a -> Parser (Maybe a))
-> (Value -> Parser a) -> Value -> Parser (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseDir -> Value -> Parser a
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir)
  where
    k' :: Key
k' = Text -> Key
AK.toKey Text
k

-- | A replacement for the standard @FromJSON@ typeclass which can handle relative filepaths.
class ParseYamlFile a where
    parseYamlFile :: BaseDir -> Value -> Parser a

instance ParseYamlFile FilePath where
    parseYamlFile :: BaseDir -> Value -> Parser FilePath
parseYamlFile (BaseDir FilePath
dir) Value
o = ((FilePath
dir FilePath -> FilePath -> FilePath
</>) (FilePath -> FilePath) -> (Text -> FilePath) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
unpack) (Text -> FilePath) -> Parser Text -> Parser FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
o
instance (ParseYamlFile a, Ord a) => ParseYamlFile (Set.Set a) where
    parseYamlFile :: BaseDir -> Value -> Parser (Set a)
parseYamlFile BaseDir
base Value
o = Value -> Parser [Value]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
o Parser [Value] -> ([Value] -> Parser (Set a)) -> Parser (Set a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> Set a) -> Parser [a] -> Parser (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Parser [a] -> Parser (Set a))
-> ([Value] -> Parser [a]) -> [Value] -> Parser (Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser a) -> [Value] -> Parser [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BaseDir -> Value -> Parser a
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
base))
instance ParseYamlFile a => ParseYamlFile (V.Vector a) where
    parseYamlFile :: BaseDir -> Value -> Parser (Vector a)
parseYamlFile BaseDir
base Value
o = Value -> Parser [Value]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
o Parser [Value]
-> ([Value] -> Parser (Vector a)) -> Parser (Vector a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (([a] -> Vector a
forall a. [a] -> Vector a
V.fromList ([a] -> Vector a) -> Parser [a] -> Parser (Vector a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Parser [a] -> Parser (Vector a))
-> ([Value] -> Parser [a]) -> [Value] -> Parser (Vector a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser a) -> [Value] -> Parser [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BaseDir -> Value -> Parser a
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
base))

data NonEmptyVector a = NonEmptyVector !a !(V.Vector a)
instance ParseYamlFile a => ParseYamlFile (NonEmptyVector a) where
    parseYamlFile :: BaseDir -> Value -> Parser (NonEmptyVector a)
parseYamlFile BaseDir
base Value
o = do
        Vector a
v <- BaseDir -> Value -> Parser (Vector a)
forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
base Value
o
        if Vector a -> Bool
forall a. Vector a -> Bool
V.null Vector a
v
            then FilePath -> Parser (NonEmptyVector a)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"NonEmptyVector: Expected at least one value"
            else NonEmptyVector a -> Parser (NonEmptyVector a)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmptyVector a -> Parser (NonEmptyVector a))
-> NonEmptyVector a -> Parser (NonEmptyVector a)
forall a b. (a -> b) -> a -> b
$ a -> Vector a -> NonEmptyVector a
forall a. a -> Vector a -> NonEmptyVector a
NonEmptyVector (Vector a -> a
forall a. Vector a -> a
V.head Vector a
v) (Vector a -> Vector a
forall a. Vector a -> Vector a
V.tail Vector a
v)