{-# 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
  ) 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.Schema.Types

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

-- | Newtype wrapper for schema load errors.
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.
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'.
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'
describeSpec :: PrimValueSpec a -> Text
describeSpec :: PrimValueSpec a -> Text
describeSpec TextSpec                   = "text"
describeSpec NumberSpec                 = "number"
describeSpec AnyAtomSpec                = "atom"
describeSpec (AtomSpec a :: Text
a)               = "atom `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`"
describeSpec (ListSpec _)               = "list"
describeSpec (SectionsSpec name :: Text
name _)      = Text
name
describeSpec (AssocSpec _)              = "sections"
describeSpec (CustomSpec name :: Text
name _)        = Text
name
describeSpec (NamedSpec name :: Text
name _)         = Text
name

-- | Describe outermost shape of a 'Value'
describeValue :: Value p -> Text
describeValue :: Value p -> Text
describeValue Text{}     = "text"
describeValue Number{}   = "number"
describeValue (Atom _ a :: Atom
a) = "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
<> "`"
describeValue Sections{} = "sections"
describeValue List{}     = "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 f :: ValueSpecMismatch p -> ValueSpecMismatch p
f (ValueSpecMismatch p :: p
p v :: Text
v prims :: 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 spec :: Text
spec prob :: 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      x :: Text
x y :: 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 x :: Int
x y :: 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        y :: 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 prob :: 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
p v :: Text
v xs :: NonEmpty (PrimMismatch p)
xs)
  | Just xs' :: 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 v :: ValueSpecMismatch p
v = ValueSpecMismatch p
v

isTypeMismatch :: PrimMismatch p -> Bool
isTypeMismatch :: PrimMismatch p -> Bool
isTypeMismatch (PrimMismatch _ prob :: Problem p
prob) =
  case Problem p
prob of
    WrongAtom -> Bool
True
    TypeMismatch -> Bool
True
    NestedProblem x :: ValueSpecMismatch p
x -> ValueSpecMismatch p -> Bool
forall p. ValueSpecMismatch p -> Bool
go ValueSpecMismatch p
x
    SubkeyProblem _ x :: ValueSpecMismatch p
x -> ValueSpecMismatch p -> Bool
forall p. ValueSpecMismatch p -> Bool
go ValueSpecMismatch p
x
    ListElementProblem _ x :: ValueSpecMismatch p
x -> ValueSpecMismatch p -> Bool
forall p. ValueSpecMismatch p -> Bool
go ValueSpecMismatch p
x
    _ -> Bool
False
  where
    go :: ValueSpecMismatch p -> Bool
go (ValueSpecMismatch _ _ xs :: 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

-- | 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 _ _ prims :: NonEmpty (PrimMismatch p)
prims)
  | PrimMismatch _ problem :: Problem p
problem :| [] <- NonEmpty (PrimMismatch p)
prims
  , Just sub :: 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      _ p :: ValueSpecMismatch p
p) = ValueSpecMismatch p -> Maybe (ValueSpecMismatch p)
forall a. a -> Maybe a
Just ValueSpecMismatch p
p
    simplify1 (ListElementProblem _ p :: ValueSpecMismatch p
p) = ValueSpecMismatch p -> Maybe (ValueSpecMismatch p)
forall a. a -> Maybe a
Just ValueSpecMismatch p
p
    simplify1 (NestedProblem        p :: ValueSpecMismatch p
p) = ValueSpecMismatch p -> Maybe (ValueSpecMismatch p)
forall a. a -> Maybe a
Just ValueSpecMismatch p
p
    simplify1 _                        = 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.
prettyValueSpecMismatch :: ErrorAnnotation p => ValueSpecMismatch p -> Doc
prettyValueSpecMismatch :: ValueSpecMismatch p -> Doc
prettyValueSpecMismatch (ValueSpecMismatch p :: p
p v :: Text
v es :: 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.
prettyPrimMismatch :: ErrorAnnotation p => PrimMismatch p -> Doc
prettyPrimMismatch :: PrimMismatch p -> Doc
prettyPrimMismatch (PrimMismatch spec :: Text
spec problem :: Problem p
problem) =
  case Problem p -> (Doc, Doc)
forall p. ErrorAnnotation p => Problem p -> (Doc, Doc)
prettyProblem Problem p
problem of
    (summary :: Doc
summary, detail :: Doc
detail) ->
      (String -> Doc
text "*" Doc -> Doc -> Doc
<+> String -> Doc
text (Text -> String
Text.unpack Text
spec) Doc -> Doc -> Doc
<+> Doc
summary) Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest 4 Doc
detail

-- | Pretty-printer for 'Problem' that generates a summary line
-- as well as a detailed description (depending on the error)
prettyProblem ::
  ErrorAnnotation p =>
  Problem p ->
  (Doc, Doc) {- ^ summary, detailed -}
prettyProblem :: Problem p -> (Doc, Doc)
prettyProblem p :: Problem p
p =
  case Problem p
p of
    TypeMismatch ->
      ( String -> Doc
text "- type mismatch"
      , Doc
empty)
    WrongAtom ->
      ( String -> Doc
text "- wrong atom"
      , Doc
empty)
    MissingSection name :: Text
name ->
      ( String -> Doc
text "- missing section:" Doc -> Doc -> Doc
<+> String -> Doc
text (Text -> String
Text.unpack Text
name)
      , Doc
empty)
    UnusedSections names :: NonEmpty Text
names ->
      ( String -> Doc
text "- 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 e :: Text
e ->
      ( String -> Doc
text "-" Doc -> Doc -> Doc
<+> String -> Doc
text (Text -> String
Text.unpack Text
e)
      , Doc
empty)
    SubkeyProblem name :: Text
name e :: ValueSpecMismatch p
e ->
      ( String -> Doc
text "- 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 e :: ValueSpecMismatch p
e ->
      ( Doc
empty
      , ValueSpecMismatch p -> Doc
forall p. ErrorAnnotation p => ValueSpecMismatch p -> Doc
prettyValueSpecMismatch ValueSpecMismatch p
e)
    ListElementProblem i :: Int
i e :: ValueSpecMismatch p
e ->
      ( String -> Doc
text "- 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'
class (Typeable a, Show a) => ErrorAnnotation a where
  displayAnnotation :: a -> Doc

-- | Renders a 'Position' as @line:column:@
instance ErrorAnnotation Position where
  displayAnnotation :: Position -> Doc
displayAnnotation pos :: 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]

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

-- | 'displayException' implemented with 'prettyValueSpecMismatch'
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)
-> 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)