Yaml.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
module Hpack.Yaml (
-- | /__NOTE:__/ This module is exposed to allow integration of Hpack into
-- other tools.  It is not meant for general use by end users.  The following
-- caveats apply:
--
-- * The API is undocumented, consult the source instead.
--
-- * The exposed types and functions primarily serve Hpack's own needs, not
-- that of a public API.  Breaking changes can happen as Hpack evolves.
--
-- As an Hpack user you either want to use the @hpack@ executable or a build
-- tool that supports Hpack (e.g. @stack@ or @cabal2nix@).

  decodeYaml
, decodeYamlWithParseError
, ParseException
, formatYamlParseError
, formatWarning
, module Data.Aeson.Config.FromValue
) where

import           Imports

import           Data.Yaml hiding (decodeFile, decodeFileWithWarnings)
import           Data.Yaml.Include
import           Data.Yaml.Internal (Warning(..))
import           Data.Aeson.Config.FromValue
import           Data.Aeson.Config.Parser (fromAesonPath, formatPath)

decodeYaml :: FilePath -> IO (Either String ([String], Value))
decodeYaml file = first (formatYamlParseError file) <$> decodeYamlWithParseError file

decodeYamlWithParseError :: FilePath -> IO (Either ParseException ([String], Value))
decodeYamlWithParseError file = do
  result <- decodeFileWithWarnings file
  return $ fmap (first (map $ formatWarning file)) result

formatYamlParseError :: FilePath -> ParseException -> String
formatYamlParseError file err = file ++ case err of
  AesonException e -> ": " ++ e
  InvalidYaml (Just (YamlException s)) -> ": " ++ s
  InvalidYaml (Just (YamlParseException{..})) -> ":" ++ show yamlLine ++ ":" ++ show yamlColumn ++ ": " ++ yamlProblem ++ " " ++ yamlContext
    where YamlMark{..} = yamlProblemMark
  _ -> ": " ++ displayException err

formatWarning :: FilePath -> Warning -> String
formatWarning file = \ case
  DuplicateKey path -> file ++ ": Duplicate field " ++ formatPath (fromAesonPath path)