{-# Language GADTs, OverloadedStrings, CPP #-}
{-|
Module      : Config.Schema.Load.Error
Description : Error types and rendering for Load module
Copyright   : (c) Eric Mertens, 2019
License     : ISC
Maintainer  : emertens@gmail.com

This module provides a complete skeleton of the failures that
occurred when trying to match a 'Value' against a 'ValueSpec'
allowing custom error rendering to be implemented.

The structure is you get a single value and a list of one-or-more
primitive specifications that it failed to match along with
an enumeration of why that specification failed to match. Some
failures are due to failures in nested specifications, so the
whole error structure can form a tree.

-}
module Config.Schema.Load.Error
  (
  -- * Error types
    ValueSpecMismatch(..)
  , PrimMismatch(..)
  , Problem(..)
  , ErrorAnnotation(..)

  -- * Detailed rendering
  , prettyValueSpecMismatch
  , prettyPrimMismatch
  , prettyProblem

  -- * Summaries
  , describeSpec
  , describeValue
  , simplifyValueSpecMismatch
  ) where

import           Control.Exception
import           Data.Text (Text)
import           Data.Foldable (toList)
import qualified Data.Text as Text
import           Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Typeable (Typeable)
import           Text.PrettyPrint
                    (Doc, fsep, ($+$), nest, text, vcat, (<+>), empty,
                     punctuate, comma, int, colon, hcat)

import           Config
import           Config.Macro (FilePosition(..))
import           Config.Schema.Types

#if !MIN_VERSION_base(4,11,0)
import           Data.Monoid ((<>))
#endif

-- | Newtype wrapper for schema load errors.
--
-- @since 1.2.0.0
data ValueSpecMismatch p =
  -- | Problem value and list of specification failures
  ValueSpecMismatch p Text (NonEmpty (PrimMismatch p))
  deriving Int -> ValueSpecMismatch p -> ShowS
[ValueSpecMismatch p] -> ShowS
ValueSpecMismatch p -> String
(Int -> ValueSpecMismatch p -> ShowS)
-> (ValueSpecMismatch p -> String)
-> ([ValueSpecMismatch p] -> ShowS)
-> Show (ValueSpecMismatch p)
forall p. Show p => Int -> ValueSpecMismatch p -> ShowS
forall p. Show p => [ValueSpecMismatch p] -> ShowS
forall p. Show p => ValueSpecMismatch p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValueSpecMismatch p] -> ShowS
$cshowList :: forall p. Show p => [ValueSpecMismatch p] -> ShowS
show :: ValueSpecMismatch p -> String
$cshow :: forall p. Show p => ValueSpecMismatch p -> String
showsPrec :: Int -> ValueSpecMismatch p -> ShowS
$cshowsPrec :: forall p. Show p => Int -> ValueSpecMismatch p -> ShowS
Show

-- | Type for errors that can be encountered while decoding a value according
-- to a specification. The error includes a key path indicating where in
-- the configuration file the error occurred.
--
-- @since 1.2.0.0
data PrimMismatch p =
  -- | spec description and problem
  PrimMismatch Text (Problem p)
  deriving Int -> PrimMismatch p -> ShowS
[PrimMismatch p] -> ShowS
PrimMismatch p -> String
(Int -> PrimMismatch p -> ShowS)
-> (PrimMismatch p -> String)
-> ([PrimMismatch p] -> ShowS)
-> Show (PrimMismatch p)
forall p. Show p => Int -> PrimMismatch p -> ShowS
forall p. Show p => [PrimMismatch p] -> ShowS
forall p. Show p => PrimMismatch p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrimMismatch p] -> ShowS
$cshowList :: forall p. Show p => [PrimMismatch p] -> ShowS
show :: PrimMismatch p -> String
$cshow :: forall p. Show p => PrimMismatch p -> String
showsPrec :: Int -> PrimMismatch p -> ShowS
$cshowsPrec :: forall p. Show p => Int -> PrimMismatch p -> ShowS
Show


-- | Problems that can be encountered when matching a 'Value' against a 'ValueSpec'.
--
-- @since 1.2.0.0
data Problem p
  = MissingSection Text                          -- ^ missing section name
  | UnusedSections (NonEmpty Text)               -- ^ unused section names
  | SubkeyProblem Text     (ValueSpecMismatch p) -- ^ nested error in given section
  | ListElementProblem Int (ValueSpecMismatch p) -- ^ nested error in given list element
  | NestedProblem          (ValueSpecMismatch p) -- ^ generic nested error
  | TypeMismatch                                 -- ^ value and spec type mismatch
  | CustomProblem Text                           -- ^ custom spec error message
  | WrongAtom                                    -- ^ atoms didn't match
  deriving Int -> Problem p -> ShowS
[Problem p] -> ShowS
Problem p -> String
(Int -> Problem p -> ShowS)
-> (Problem p -> String)
-> ([Problem p] -> ShowS)
-> Show (Problem p)
forall p. Show p => Int -> Problem p -> ShowS
forall p. Show p => [Problem p] -> ShowS
forall p. Show p => Problem p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Problem p] -> ShowS
$cshowList :: forall p. Show p => [Problem p] -> ShowS
show :: Problem p -> String
$cshow :: forall p. Show p => Problem p -> String
showsPrec :: Int -> Problem p -> ShowS
$cshowsPrec :: forall p. Show p => Int -> Problem p -> ShowS
Show

-- | Describe outermost shape of a 'PrimValueSpec'
--
-- @since 1.2.0.0
describeSpec :: PrimValueSpec a -> Text
describeSpec :: PrimValueSpec a -> Text
describeSpec PrimValueSpec a
TextSpec                   = Text
"text"
describeSpec PrimValueSpec a
NumberSpec                 = Text
"number"
describeSpec PrimValueSpec a
AnyAtomSpec                = Text
"atom"
describeSpec (AtomSpec Text
a)               = Text
"atom `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
describeSpec (ListSpec ValueSpec a
_)               = Text
"list"
describeSpec (SectionsSpec Text
name SectionsSpec a
_)      = Text
name
describeSpec (AssocSpec ValueSpec a
_)              = Text
"sections"
describeSpec (CustomSpec Text
name ValueSpec (Either Text a)
_)        = Text
name
describeSpec (NamedSpec Text
name ValueSpec a
_)         = Text
name

-- | Describe outermost shape of a 'Value'
describeValue :: Value p -> Text
describeValue :: Value p -> Text
describeValue Text{}     = Text
"text"
describeValue Number{}   = Text
"number"
describeValue (Atom p
_ Atom
a) = Text
"atom `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Atom -> Text
atomName Atom
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
describeValue Sections{} = Text
"sections"
describeValue List{}     = Text
"list"

-- | Bottom-up transformation of a 'ValueSpecMismatch'
rewriteMismatch ::
  (ValueSpecMismatch p -> ValueSpecMismatch p) ->
  ValueSpecMismatch p -> ValueSpecMismatch p
rewriteMismatch :: (ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p -> ValueSpecMismatch p
rewriteMismatch ValueSpecMismatch p -> ValueSpecMismatch p
f (ValueSpecMismatch p
p Text
v NonEmpty (PrimMismatch p)
prims) = ValueSpecMismatch p -> ValueSpecMismatch p
f (p -> Text -> NonEmpty (PrimMismatch p) -> ValueSpecMismatch p
forall p.
p -> Text -> NonEmpty (PrimMismatch p) -> ValueSpecMismatch p
ValueSpecMismatch p
p Text
v ((PrimMismatch p -> PrimMismatch p)
-> NonEmpty (PrimMismatch p) -> NonEmpty (PrimMismatch p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimMismatch p -> PrimMismatch p
aux1 NonEmpty (PrimMismatch p)
prims))
  where
    aux1 :: PrimMismatch p -> PrimMismatch p
aux1 (PrimMismatch Text
spec Problem p
prob) = Text -> Problem p -> PrimMismatch p
forall p. Text -> Problem p -> PrimMismatch p
PrimMismatch Text
spec (Problem p -> Problem p
aux2 Problem p
prob)

    aux2 :: Problem p -> Problem p
aux2 (SubkeyProblem      Text
x ValueSpecMismatch p
y) = Text -> ValueSpecMismatch p -> Problem p
forall p. Text -> ValueSpecMismatch p -> Problem p
SubkeyProblem      Text
x ((ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p -> ValueSpecMismatch p
forall p.
(ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p -> ValueSpecMismatch p
rewriteMismatch ValueSpecMismatch p -> ValueSpecMismatch p
f ValueSpecMismatch p
y)
    aux2 (ListElementProblem Int
x ValueSpecMismatch p
y) = Int -> ValueSpecMismatch p -> Problem p
forall p. Int -> ValueSpecMismatch p -> Problem p
ListElementProblem Int
x ((ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p -> ValueSpecMismatch p
forall p.
(ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p -> ValueSpecMismatch p
rewriteMismatch ValueSpecMismatch p -> ValueSpecMismatch p
f ValueSpecMismatch p
y)
    aux2 (NestedProblem        ValueSpecMismatch p
y) = ValueSpecMismatch p -> Problem p
forall p. ValueSpecMismatch p -> Problem p
NestedProblem        ((ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p -> ValueSpecMismatch p
forall p.
(ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p -> ValueSpecMismatch p
rewriteMismatch ValueSpecMismatch p -> ValueSpecMismatch p
f ValueSpecMismatch p
y)
    aux2 Problem p
prob                     = Problem p
prob


-- | Single-step rewrite that removes type-mismatch problems if there
-- are non-mismatches available to focus on.
removeTypeMismatch1 :: ValueSpecMismatch p -> ValueSpecMismatch p
removeTypeMismatch1 :: ValueSpecMismatch p -> ValueSpecMismatch p
removeTypeMismatch1 (ValueSpecMismatch p
p Text
v NonEmpty (PrimMismatch p)
xs)
  | Just NonEmpty (PrimMismatch p)
xs' <- [PrimMismatch p] -> Maybe (NonEmpty (PrimMismatch p))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty ((PrimMismatch p -> Bool)
-> NonEmpty (PrimMismatch p) -> [PrimMismatch p]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NonEmpty.filter (Bool -> Bool
not (Bool -> Bool)
-> (PrimMismatch p -> Bool) -> PrimMismatch p -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimMismatch p -> Bool
forall p. PrimMismatch p -> Bool
isTypeMismatch) NonEmpty (PrimMismatch p)
xs)
  = p -> Text -> NonEmpty (PrimMismatch p) -> ValueSpecMismatch p
forall p.
p -> Text -> NonEmpty (PrimMismatch p) -> ValueSpecMismatch p
ValueSpecMismatch p
p Text
v NonEmpty (PrimMismatch p)
xs'
removeTypeMismatch1 ValueSpecMismatch p
v = ValueSpecMismatch p
v

-- | Returns 'True' for schema mismatches where the value type doesn't
-- match.
isTypeMismatch :: PrimMismatch p -> Bool
isTypeMismatch :: PrimMismatch p -> Bool
isTypeMismatch (PrimMismatch Text
_ Problem p
prob) =
  case Problem p
prob of
    Problem p
WrongAtom                                -> Bool
True
    Problem p
TypeMismatch                             -> Bool
True
    NestedProblem (ValueSpecMismatch p
_ Text
_ NonEmpty (PrimMismatch p)
xs) -> (PrimMismatch p -> Bool) -> NonEmpty (PrimMismatch p) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PrimMismatch p -> Bool
forall p. PrimMismatch p -> Bool
isTypeMismatch NonEmpty (PrimMismatch p)
xs
    Problem p
_                                        -> Bool
False

-- | Single-step rewrite that removes mismatches with only a single,
-- nested mismatch below them.
focusMismatch1 :: ValueSpecMismatch p -> ValueSpecMismatch p
focusMismatch1 :: ValueSpecMismatch p -> ValueSpecMismatch p
focusMismatch1 x :: ValueSpecMismatch p
x@(ValueSpecMismatch p
_ Text
_ NonEmpty (PrimMismatch p)
prims)
  | PrimMismatch Text
_ Problem p
problem :| [] <- NonEmpty (PrimMismatch p)
prims
  , Just ValueSpecMismatch p
sub <- Problem p -> Maybe (ValueSpecMismatch p)
forall p. Problem p -> Maybe (ValueSpecMismatch p)
simplify1 Problem p
problem = ValueSpecMismatch p
sub
  | Bool
otherwise = ValueSpecMismatch p
x
  where
    simplify1 :: Problem p -> Maybe (ValueSpecMismatch p)
simplify1 (SubkeyProblem      Text
_ ValueSpecMismatch p
p) = ValueSpecMismatch p -> Maybe (ValueSpecMismatch p)
forall a. a -> Maybe a
Just ValueSpecMismatch p
p
    simplify1 (ListElementProblem Int
_ ValueSpecMismatch p
p) = ValueSpecMismatch p -> Maybe (ValueSpecMismatch p)
forall a. a -> Maybe a
Just ValueSpecMismatch p
p
    simplify1 (NestedProblem        ValueSpecMismatch p
p) = ValueSpecMismatch p -> Maybe (ValueSpecMismatch p)
forall a. a -> Maybe a
Just ValueSpecMismatch p
p
    simplify1 Problem p
_                        = Maybe (ValueSpecMismatch p)
forall a. Maybe a
Nothing


-- | Pretty-printer for 'ValueSpecMismatch' showing the position
-- and type of value that failed to match along with details about
-- each specification that it didn't match.
--
-- @since 1.2.0.0
prettyValueSpecMismatch :: ErrorAnnotation p => ValueSpecMismatch p -> Doc
prettyValueSpecMismatch :: ValueSpecMismatch p -> Doc
prettyValueSpecMismatch (ValueSpecMismatch p
p Text
v NonEmpty (PrimMismatch p)
es) =
  Doc
heading Doc -> Doc -> Doc
$+$ Doc
errors
  where
    heading :: Doc
heading = p -> Doc
forall a. ErrorAnnotation a => a -> Doc
displayAnnotation p
p Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (Text -> String
Text.unpack Text
v)
    errors :: Doc
errors = [Doc] -> Doc
vcat ((PrimMismatch p -> Doc) -> [PrimMismatch p] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PrimMismatch p -> Doc
forall p. ErrorAnnotation p => PrimMismatch p -> Doc
prettyPrimMismatch (NonEmpty (PrimMismatch p) -> [PrimMismatch p]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (PrimMismatch p)
es))


-- | Pretty-printer for 'PrimMismatch' showing a summary of the primitive
-- specification that didn't match followed by a more detailed error when
-- appropriate.
--
-- @since 1.2.0.0
prettyPrimMismatch :: ErrorAnnotation p => PrimMismatch p -> Doc
prettyPrimMismatch :: PrimMismatch p -> Doc
prettyPrimMismatch (PrimMismatch Text
spec Problem p
problem) =
  case Problem p -> (Doc, Doc)
forall p. ErrorAnnotation p => Problem p -> (Doc, Doc)
prettyProblem Problem p
problem of
    (Doc
summary, Doc
detail) ->
      (String -> Doc
text String
"* expected" Doc -> Doc -> Doc
<+> String -> Doc
text (Text -> String
Text.unpack Text
spec) Doc -> Doc -> Doc
<+> Doc
summary) Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest Int
4 Doc
detail

-- | Simplify a 'ValueSpecMismatch' by collapsing long nested error
-- cases and by assuming that if a type matched that the other mismatched
-- type alternatives are uninteresting. This is used in the implementation
-- of 'displayException'.
--
-- @since 1.2.1.0
simplifyValueSpecMismatch :: ValueSpecMismatch p -> ValueSpecMismatch p
simplifyValueSpecMismatch :: ValueSpecMismatch p -> ValueSpecMismatch p
simplifyValueSpecMismatch = (ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p -> ValueSpecMismatch p
forall p.
(ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p -> ValueSpecMismatch p
rewriteMismatch (ValueSpecMismatch p -> ValueSpecMismatch p
forall p. ValueSpecMismatch p -> ValueSpecMismatch p
focusMismatch1 (ValueSpecMismatch p -> ValueSpecMismatch p)
-> (ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p
-> ValueSpecMismatch p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueSpecMismatch p -> ValueSpecMismatch p
forall p. ValueSpecMismatch p -> ValueSpecMismatch p
removeTypeMismatch1)

-- | Pretty-printer for 'Problem' that generates a summary line
-- as well as a detailed description (depending on the error)
--
-- @since 1.2.0.0
prettyProblem ::
  ErrorAnnotation p =>
  Problem p ->
  (Doc, Doc) {- ^ summary, detailed -}
prettyProblem :: Problem p -> (Doc, Doc)
prettyProblem Problem p
p =
  case Problem p
p of
    Problem p
TypeMismatch ->
      ( String -> Doc
text String
"- type mismatch"
      , Doc
empty)
    Problem p
WrongAtom ->
      ( String -> Doc
text String
"- wrong atom"
      , Doc
empty)
    MissingSection Text
name ->
      ( String -> Doc
text String
"- missing section:" Doc -> Doc -> Doc
<+> String -> Doc
text (Text -> String
Text.unpack Text
name)
      , Doc
empty)
    UnusedSections NonEmpty Text
names ->
      ( String -> Doc
text String
"- unexpected sections:" Doc -> Doc -> Doc
<+>
        [Doc] -> Doc
fsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((Text -> Doc) -> [Text] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> (Text -> String) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) (NonEmpty Text -> [Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Text
names)))
      , Doc
empty)
    CustomProblem Text
e ->
      ( String -> Doc
text String
"-" Doc -> Doc -> Doc
<+> String -> Doc
text (Text -> String
Text.unpack Text
e)
      , Doc
empty)
    SubkeyProblem Text
name ValueSpecMismatch p
e ->
      ( String -> Doc
text String
"- problem in section:" Doc -> Doc -> Doc
<+> String -> Doc
text (Text -> String
Text.unpack Text
name)
      , ValueSpecMismatch p -> Doc
forall p. ErrorAnnotation p => ValueSpecMismatch p -> Doc
prettyValueSpecMismatch ValueSpecMismatch p
e)
    NestedProblem ValueSpecMismatch p
e ->
      ( Doc
empty
      , ValueSpecMismatch p -> Doc
forall p. ErrorAnnotation p => ValueSpecMismatch p -> Doc
prettyValueSpecMismatch ValueSpecMismatch p
e)
    ListElementProblem Int
i ValueSpecMismatch p
e ->
      ( String -> Doc
text String
"- problem in element:" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
i
      , ValueSpecMismatch p -> Doc
forall p. ErrorAnnotation p => ValueSpecMismatch p -> Doc
prettyValueSpecMismatch ValueSpecMismatch p
e)

-- | Class for rendering position annotations within the 'prettyValueSpecMismatch'
--
-- @since 1.2.0.0
class (Typeable a, Show a) => ErrorAnnotation a where
  displayAnnotation :: a -> Doc

-- | Renders a 'Position' as @line:column:@
--
-- @since 1.2.0.0
instance ErrorAnnotation Position where
  displayAnnotation :: Position -> Doc
displayAnnotation Position
pos = [Doc] -> Doc
hcat [Int -> Doc
int (Position -> Int
posLine Position
pos), Doc
colon, Int -> Doc
int (Position -> Int
posColumn Position
pos), Doc
colon]

instance ErrorAnnotation FilePosition where
  displayAnnotation :: FilePosition -> Doc
displayAnnotation (FilePosition String
path Position
pos) = [Doc] -> Doc
hcat [String -> Doc
text String
path, Doc
colon, Int -> Doc
int (Position -> Int
posLine Position
pos), Doc
colon, Int -> Doc
int (Position -> Int
posColumn Position
pos), Doc
colon]

-- | Renders as an empty document
--
-- @since 1.2.0.0
instance ErrorAnnotation () where
  displayAnnotation :: () -> Doc
displayAnnotation ()
_ = Doc
empty

-- | 'displayException' implemented with 'prettyValueSpecMismatch'
-- and 'simplifyValueSpecMismatch'.
--
-- @since 1.2.0.0
instance ErrorAnnotation p => Exception (ValueSpecMismatch p) where
  displayException :: ValueSpecMismatch p -> String
displayException = Doc -> String
forall a. Show a => a -> String
show (Doc -> String)
-> (ValueSpecMismatch p -> Doc) -> ValueSpecMismatch p -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueSpecMismatch p -> Doc
forall p. ErrorAnnotation p => ValueSpecMismatch p -> Doc
prettyValueSpecMismatch (ValueSpecMismatch p -> Doc)
-> (ValueSpecMismatch p -> ValueSpecMismatch p)
-> ValueSpecMismatch p
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueSpecMismatch p -> ValueSpecMismatch p
forall p. ValueSpecMismatch p -> ValueSpecMismatch p
simplifyValueSpecMismatch