FilePath.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | 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.Aeson.Types (Object, Parser, Value, parseEither, (.:), (.:?))
import Data.Set qualified as Set
import Data.Text (Text, unpack)
import Data.Vector qualified as V
import Data.Yaml (ParseException(AesonException), decodeFileEither, parseJSON)
import Keter.Aeson.KeyHelper as AK
import Prelude
       ( Either(..)
       , FilePath
       , IO
       , Maybe(..)
       , Ord
       , fail
       , mapM
       , maybe
       , return
       , ($!)
       , ($)
       , (.)
       , (>>=)
       )
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 fp = do
    evalue <- decodeFileEither fp
    return $! case evalue of
        Left e -> Left e
        Right value ->
            case parseEither (parseYamlFile basedir) value of
                Left s -> Left $! AesonException s
                Right x -> Right $! x
  where
    basedir = BaseDir $ takeDirectory 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 o k = (o .: k') >>= parseYamlFile basedir
  where
    k' = AK.toKey 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 o k = (o .:? k') >>= maybe (return Nothing) ((Just <$>) . parseYamlFile basedir)
  where
    k' = AK.toKey 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 dir) o =
    (dir </>) . unpack <$> parseJSON o

instance (ParseYamlFile a, Ord a) => ParseYamlFile (Set.Set a) where
    parseYamlFile base o = parseJSON o >>= ((Set.fromList <$>) . mapM (parseYamlFile base))
instance ParseYamlFile a => ParseYamlFile (V.Vector a) where
    parseYamlFile base o = parseJSON o >>= ((V.fromList <$>) . mapM (parseYamlFile base))

data NonEmptyVector a = NonEmptyVector !a !(V.Vector a)
instance ParseYamlFile a => ParseYamlFile (NonEmptyVector a) where
    parseYamlFile base o = do
        v <- parseYamlFile base o
        if V.null v
            then fail "NonEmptyVector: Expected at least one value"
            else return $ NonEmptyVector (V.head v) (V.tail v)