{-# Language GADTs, OverloadedStrings, CPP #-}
module Config.Schema.Load.Error
(
ValueSpecMismatch(..)
, PrimMismatch(..)
, Problem(..)
, ErrorAnnotation(..)
, prettyValueSpecMismatch
, prettyPrimMismatch
, prettyProblem
, 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
data ValueSpecMismatch p =
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
data PrimMismatch p =
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
data Problem p
= MissingSection Text
| UnusedSections (NonEmpty Text)
| SubkeyProblem Text (ValueSpecMismatch p)
| ListElementProblem Int (ValueSpecMismatch p)
| NestedProblem (ValueSpecMismatch p)
| TypeMismatch
| CustomProblem Text
| WrongExact
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
describeSpec :: PrimValueSpec a -> Text
describeSpec :: PrimValueSpec a -> Text
describeSpec PrimValueSpec a
TextSpec = Text
"text"
describeSpec PrimValueSpec a
NumberSpec = Text
"number"
describeSpec PrimValueSpec a
AtomSpec = Text
"atom"
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
describeSpec (ExactSpec Value ()
v) = Value () -> Text
forall p. Value p -> Text
describeValue Value ()
v
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"
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
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
isTypeMismatch :: PrimMismatch p -> Bool
isTypeMismatch :: PrimMismatch p -> Bool
isTypeMismatch (PrimMismatch Text
_ Problem p
prob) =
case Problem p
prob of
Problem p
WrongExact -> 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
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
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))
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
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)
prettyProblem ::
ErrorAnnotation p =>
Problem p ->
(Doc, Doc)
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
WrongExact ->
( String -> Doc
text String
"- wrong value"
, 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 (Typeable a, Show a) => ErrorAnnotation a where
displayAnnotation :: a -> Doc
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]
instance ErrorAnnotation () where
displayAnnotation :: () -> Doc
displayAnnotation ()
_ = Doc
empty
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