Config.hs

-- This file is part of khph.
--
-- Copyright 2016 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE CPP, OverloadedStrings #-}

-- | Project configuration data types and parser.
module Khph.Config (
  Config,
  defaultConfig,
  configSourceDirs,
  configIgnoredPaths,
  readProjectFile,
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (unless, when)
import Data.Aeson.Types (typeMismatch)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Text (Text)
import Data.Yaml (
  (.:?),
  (.!=),
  FromJSON (parseJSON),
  Object,
  ParseException (UnexpectedEvent, _received, _expected),
  Parser,
  Value (Object),
  decodeFileEither,
  )
import Khph.Project.Base
import Khph.Util
import System.FilePath (isAbsolute)
import Text.Libyaml (Event (EventDocumentStart, EventStreamEnd))

data Config = Config
  { configSourceDirs :: Set ProjectPath
  , configIgnoredPaths :: [ProjectPath]
  } deriving (Show)

-- | Used when the config file is empty or absent.
defaultConfig :: Config
defaultConfig = Config Set.empty []

instance FromJSON Config where
  parseJSON (Object o) = do
    [sourceDirsKey, ignoredPathsKey] <- expectKeys "Config" o ["sourceDirs", "ignore"]
    sourceDirs <- map stripTrailingPathSeparators <$> o .:? sourceDirsKey .!= []
    ignoredPaths <- map stripTrailingPathSeparators <$> o .:? ignoredPathsKey .!= []

    let absoluteSourceDirs = filter isAbsolute sourceDirs
    when (not $ null absoluteSourceDirs) $
      fail $ concat
      ["sourceDirs: Source directories must be relative paths (to the project root): ",
       show absoluteSourceDirs]

    let absoluteIgnoredPaths = filter isAbsolute ignoredPaths
    when (not $ null absoluteIgnoredPaths) $
      fail $ concat
      ["ignore: Ignored paths must be relative paths (to the project root): ",
       show absoluteIgnoredPaths]

    return Config
      { configSourceDirs = Set.fromList $ map toProjectPath sourceDirs
      , configIgnoredPaths = map toProjectPath ignoredPaths
      }

  parseJSON value = typeMismatch "Config" value

readProjectFile :: FilePath -> IO (Either String Config)
readProjectFile path =
  either checkError Right <$> decodeFileEither path
  where checkError err =
          let isEmptyFile = case err of
                UnexpectedEvent {_received = r, _expected = e} ->
                  r == Just EventStreamEnd && e == Just EventDocumentStart
                _ -> False
          in if isEmptyFile then Right defaultConfig else Left $ show err

-- | Returns the given list of keys, but first checks that an object doesn't
-- contain more keys than those in the list.  If it does, then the parse is
-- failed with a message containing the extraneous keys.
expectKeys :: String -> Object -> [Text] -> Parser [Text]
expectKeys typeName o keys = do
  let extraKeys = Set.fromList (HashMap.keys o) `Set.difference` Set.fromList keys
  unless (Set.null extraKeys) $
    fail $ typeName ++ " has unknown keys: " ++ show (Set.toList extraKeys)
  return keys