{-# 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 :: forall a.
ParseYamlFile a =>
FilePath -> IO (Either ParseException a)
decodeFileRelative FilePath
fp = do
    Either ParseException Value
evalue <- forall a. FromJSON a => FilePath -> IO (Either ParseException a)
decodeFileEither FilePath
fp
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! case Either ParseException Value
evalue of
        Left ParseException
e -> forall a b. a -> Either a b
Left ParseException
e
        Right Value
value ->
            case forall a b. (a -> Parser b) -> a -> Either FilePath b
parseEither (forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
basedir) Value
value of
                Left FilePath
s -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$! FilePath -> ParseException
AesonException FilePath
s
                Right a
x -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! a
x
  where
    basedir :: BaseDir
basedir = FilePath -> BaseDir
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 :: forall a. ParseYamlFile a => BaseDir -> Object -> Text -> Parser a
lookupBase BaseDir
basedir Object
o Text
k = (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
k') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 :: forall a.
ParseYamlFile a =>
BaseDir -> Object -> Text -> Parser (Maybe a)
lookupBaseMaybe BaseDir
basedir Object
o Text
k = (Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
k') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) ((forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
unpack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. FromJSON a => Value -> Parser a
parseJSON Value
o forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 = forall a. FromJSON a => Value -> Parser a
parseJSON Value
o forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((forall a. [a] -> Vector a
V.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 <- forall a. ParseYamlFile a => BaseDir -> Value -> Parser a
parseYamlFile BaseDir
base Value
o
        if forall a. Vector a -> Bool
V.null Vector a
v
            then forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"NonEmptyVector: Expected at least one value"
            else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Vector a -> NonEmptyVector a
NonEmptyVector (forall a. Vector a -> a
V.head Vector a
v) (forall a. Vector a -> Vector a
V.tail Vector a
v)