{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.API.Error
(
JSONError(..)
, JSONWarning
, Expected(..)
, FormatExpected(..)
, Position
, Step(..)
, inField
, prettyJSONErrorPositions
, prettyJSONError
, prettyStep
, expectedArray
, expectedBool
, expectedInt
, expectedObject
, expectedString
, badFormat
, ValueError(..)
, ValidateFailure(..)
, ValidateWarning
, ApplyFailure(..)
, TypeKind(..)
, MigrateFailure(..)
, MigrateWarning
, prettyMigrateFailure
, prettyValidateFailure
, prettyValueError
, prettyValueErrorPosition
) where
import Data.API.Changes.Types
import Data.API.PP
import Data.API.NormalForm
import Data.API.Types
import Data.API.Utils
import qualified Data.Aeson as JS
import Data.Aeson.TH
import qualified Data.Graph as Graph
import Data.List
import Data.Map ( Map )
import qualified Data.Map as Map
import qualified Data.SafeCopy as SC
import Data.Set ( Set )
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time
data JSONError = Expected Expected String JS.Value
| BadFormat FormatExpected String T.Text
| MissingField
| MissingAlt [String]
| UnexpectedField
| UnexpectedEnumVal [T.Text] T.Text
| IntRangeError String Int IntRange
| UTCRangeError String UTCTime UTCRange
| RegexError String T.Text RegEx
| SyntaxError String
deriving (JSONError -> JSONError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JSONError -> JSONError -> Bool
$c/= :: JSONError -> JSONError -> Bool
== :: JSONError -> JSONError -> Bool
$c== :: JSONError -> JSONError -> Bool
Eq, Int -> JSONError -> ShowS
[JSONError] -> ShowS
JSONError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [JSONError] -> ShowS
$cshowList :: [JSONError] -> ShowS
show :: JSONError -> [Char]
$cshow :: JSONError -> [Char]
showsPrec :: Int -> JSONError -> ShowS
$cshowsPrec :: Int -> JSONError -> ShowS
Show)
type JSONWarning = JSONError
data Expected = ExpArray
| ExpBool
| ExpInt
| ExpObject
| ExpString
deriving (Expected -> Expected -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expected -> Expected -> Bool
$c/= :: Expected -> Expected -> Bool
== :: Expected -> Expected -> Bool
$c== :: Expected -> Expected -> Bool
Eq, Int -> Expected -> ShowS
[Expected] -> ShowS
Expected -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Expected] -> ShowS
$cshowList :: [Expected] -> ShowS
show :: Expected -> [Char]
$cshow :: Expected -> [Char]
showsPrec :: Int -> Expected -> ShowS
$cshowsPrec :: Int -> Expected -> ShowS
Show)
data FormatExpected = FmtBinary
| FmtUTC
| FmtOther
deriving (FormatExpected -> FormatExpected -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FormatExpected -> FormatExpected -> Bool
$c/= :: FormatExpected -> FormatExpected -> Bool
== :: FormatExpected -> FormatExpected -> Bool
$c== :: FormatExpected -> FormatExpected -> Bool
Eq, Int -> FormatExpected -> ShowS
[FormatExpected] -> ShowS
FormatExpected -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FormatExpected] -> ShowS
$cshowList :: [FormatExpected] -> ShowS
show :: FormatExpected -> [Char]
$cshow :: FormatExpected -> [Char]
showsPrec :: Int -> FormatExpected -> ShowS
$cshowsPrec :: Int -> FormatExpected -> ShowS
Show)
expectedArray, expectedBool, expectedInt, expectedObject, expectedString
:: JS.Value -> JSONError
expectedArray :: Value -> JSONError
expectedArray = Expected -> [Char] -> Value -> JSONError
Expected Expected
ExpArray [Char]
"Array"
expectedBool :: Value -> JSONError
expectedBool = Expected -> [Char] -> Value -> JSONError
Expected Expected
ExpBool [Char]
"Bool"
expectedInt :: Value -> JSONError
expectedInt = Expected -> [Char] -> Value -> JSONError
Expected Expected
ExpInt [Char]
"Int"
expectedObject :: Value -> JSONError
expectedObject = Expected -> [Char] -> Value -> JSONError
Expected Expected
ExpObject [Char]
"Object"
expectedString :: Value -> JSONError
expectedString = Expected -> [Char] -> Value -> JSONError
Expected Expected
ExpString [Char]
"String"
badFormat :: String -> T.Text -> JSONError
badFormat :: [Char] -> Text -> JSONError
badFormat = FormatExpected -> [Char] -> Text -> JSONError
BadFormat FormatExpected
FmtOther
prettyJSONError :: JSONError -> String
prettyJSONError :: JSONError -> [Char]
prettyJSONError (Expected Expected
_ [Char]
s Value
v) = [Char]
"When expecting " forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
", encountered "
forall a. [a] -> [a] -> [a]
++ [Char]
x forall a. [a] -> [a] -> [a]
++ [Char]
" instead"
where
x :: [Char]
x = case Value
v of
JS.Object Object
_ -> [Char]
"Object"
JS.Array Array
_ -> [Char]
"Array"
JS.String Text
_ -> [Char]
"String"
JS.Number Scientific
_ -> [Char]
"Number"
JS.Bool Bool
_ -> [Char]
"Boolean"
Value
JS.Null -> [Char]
"Null"
prettyJSONError (BadFormat FormatExpected
_ [Char]
s Text
t) = [Char]
"Could not parse as " forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
" the string " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
t
prettyJSONError JSONError
MissingField = [Char]
"Field missing from Object"
prettyJSONError (MissingAlt [[Char]]
xs) = [Char]
"Missing alternative, expecting one of: "
forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
xs
prettyJSONError JSONError
UnexpectedField = [Char]
"Unexpected field in Object"
prettyJSONError (UnexpectedEnumVal [Text]
xs Text
t) = [Char]
"Unexpected enum value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
t
forall a. [a] -> [a] -> [a]
++ [Char]
", expecting one of: "
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
xs)
prettyJSONError (IntRangeError [Char]
s Int
i IntRange
r) = [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
i forall a. [a] -> [a] -> [a]
++ [Char]
" not in range " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show IntRange
r
prettyJSONError (UTCRangeError [Char]
s UTCTime
u UTCRange
r) = [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show UTCTime
u forall a. [a] -> [a] -> [a]
++ [Char]
" not in range " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show UTCRange
r
prettyJSONError (RegexError [Char]
s Text
_ RegEx
t) = [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
": failed to match RE: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RegEx
t
prettyJSONError (SyntaxError [Char]
e) = [Char]
"JSON syntax error: " forall a. [a] -> [a] -> [a]
++ [Char]
e
type Position = [Step]
data Step = InField T.Text | InElem Int
deriving (Step -> Step -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Step -> Step -> Bool
$c/= :: Step -> Step -> Bool
== :: Step -> Step -> Bool
$c== :: Step -> Step -> Bool
Eq, Int -> Step -> ShowS
Position -> ShowS
Step -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: Position -> ShowS
$cshowList :: Position -> ShowS
show :: Step -> [Char]
$cshow :: Step -> [Char]
showsPrec :: Int -> Step -> ShowS
$cshowsPrec :: Int -> Step -> ShowS
Show)
inField :: FieldName -> Step
inField :: FieldName -> Step
inField FieldName
fn = Text -> Step
InField (FieldName -> Text
_FieldName FieldName
fn)
prettyStep :: Step -> String
prettyStep :: Step -> [Char]
prettyStep (InField Text
f) = [Char]
" in the field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
f
prettyStep (InElem Int
i) = [Char]
" in array index " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
i
instance PPLines Step where
ppLines :: Step -> [[Char]]
ppLines Step
s = [Step -> [Char]
prettyStep Step
s]
prettyJSONErrorPositions :: [(JSONError, Position)] -> String
prettyJSONErrorPositions :: [(JSONError, Position)] -> [Char]
prettyJSONErrorPositions [(JSONError, Position)]
xs = [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (JSONError, Position) -> [[Char]]
help [(JSONError, Position)]
xs
where
help :: (JSONError, Position) -> [[Char]]
help (JSONError
e, Position
pos) = JSONError -> [Char]
prettyJSONError JSONError
e forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Step -> [Char]
prettyStep Position
pos
data ValueError
= JSONError JSONError
| CustomMigrationError String JS.Value
| InvalidAPI ApplyFailure
deriving (ValueError -> ValueError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValueError -> ValueError -> Bool
$c/= :: ValueError -> ValueError -> Bool
== :: ValueError -> ValueError -> Bool
$c== :: ValueError -> ValueError -> Bool
Eq, Int -> ValueError -> ShowS
[ValueError] -> ShowS
ValueError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ValueError] -> ShowS
$cshowList :: [ValueError] -> ShowS
show :: ValueError -> [Char]
$cshow :: ValueError -> [Char]
showsPrec :: Int -> ValueError -> ShowS
$cshowsPrec :: Int -> ValueError -> ShowS
Show)
data ValidateFailure
= ChangelogOutOfOrder { ValidateFailure -> VersionExtra
vfLaterVersion :: VersionExtra
, ValidateFailure -> VersionExtra
vfEarlierVersion :: VersionExtra }
| CannotDowngrade { ValidateFailure -> VersionExtra
vfFromVersion :: VersionExtra
, ValidateFailure -> VersionExtra
vfToVersion :: VersionExtra }
| ApiInvalid { ValidateFailure -> VersionExtra
vfInvalidVersion :: VersionExtra
, ValidateFailure -> Set TypeName
vfMissingDeclarations :: Set TypeName }
| ChangelogEntryInvalid { ValidateFailure -> [APITableChange]
vfSuccessfullyApplied :: [APITableChange]
, ValidateFailure -> APIChange
vfFailedToApply :: APIChange
, ValidateFailure -> ApplyFailure
vfApplyFailure :: ApplyFailure }
| ChangelogIncomplete { ValidateFailure -> VersionExtra
vfChangelogVersion :: VersionExtra
, ValidateFailure -> VersionExtra
vfTargetVersion :: VersionExtra
, ValidateFailure
-> Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
vfDifferences :: Map TypeName (MergeResult NormTypeDecl NormTypeDecl) }
deriving (ValidateFailure -> ValidateFailure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidateFailure -> ValidateFailure -> Bool
$c/= :: ValidateFailure -> ValidateFailure -> Bool
== :: ValidateFailure -> ValidateFailure -> Bool
$c== :: ValidateFailure -> ValidateFailure -> Bool
Eq, Int -> ValidateFailure -> ShowS
[ValidateFailure] -> ShowS
ValidateFailure -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ValidateFailure] -> ShowS
$cshowList :: [ValidateFailure] -> ShowS
show :: ValidateFailure -> [Char]
$cshow :: ValidateFailure -> [Char]
showsPrec :: Int -> ValidateFailure -> ShowS
$cshowsPrec :: Int -> ValidateFailure -> ShowS
Show)
data ValidateWarning = ValidateWarning
deriving Int -> ValidateWarning -> ShowS
[ValidateWarning] -> ShowS
ValidateWarning -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ValidateWarning] -> ShowS
$cshowList :: [ValidateWarning] -> ShowS
show :: ValidateWarning -> [Char]
$cshow :: ValidateWarning -> [Char]
showsPrec :: Int -> ValidateWarning -> ShowS
$cshowsPrec :: Int -> ValidateWarning -> ShowS
Show
data ApplyFailure
= TypeExists { ApplyFailure -> TypeName
afExistingType :: TypeName }
| TypeDoesNotExist { ApplyFailure -> TypeName
afMissingType :: TypeName }
| TypeWrongKind { ApplyFailure -> TypeName
afTypeName :: TypeName
, ApplyFailure -> TypeKind
afExpectedKind :: TypeKind }
| TypeInUse { afTypeName :: TypeName }
| TypeMalformed { ApplyFailure -> APIType
afType :: APIType
, ApplyFailure -> Set TypeName
afMissingTypes :: Set TypeName }
| DeclMalformed { afTypeName :: TypeName
, ApplyFailure -> NormTypeDecl
afDecl :: NormTypeDecl
, afMissingTypes :: Set TypeName }
| FieldExists { afTypeName :: TypeName
, ApplyFailure -> TypeKind
afTypeKind :: TypeKind
, ApplyFailure -> FieldName
afExistingField :: FieldName }
| FieldDoesNotExist { afTypeName :: TypeName
, afTypeKind :: TypeKind
, ApplyFailure -> FieldName
afMissingField :: FieldName }
| FieldBadDefaultValue { afTypeName :: TypeName
, ApplyFailure -> FieldName
afFieldName :: FieldName
, ApplyFailure -> APIType
afFieldType :: APIType
, ApplyFailure -> DefaultValue
afBadDefault :: DefaultValue }
| DefaultMissing { afTypeName :: TypeName
, afFieldName :: FieldName }
| TableChangeError { ApplyFailure -> [Char]
afCustomMessage :: String }
deriving (ApplyFailure -> ApplyFailure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApplyFailure -> ApplyFailure -> Bool
$c/= :: ApplyFailure -> ApplyFailure -> Bool
== :: ApplyFailure -> ApplyFailure -> Bool
$c== :: ApplyFailure -> ApplyFailure -> Bool
Eq, Int -> ApplyFailure -> ShowS
[ApplyFailure] -> ShowS
ApplyFailure -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ApplyFailure] -> ShowS
$cshowList :: [ApplyFailure] -> ShowS
show :: ApplyFailure -> [Char]
$cshow :: ApplyFailure -> [Char]
showsPrec :: Int -> ApplyFailure -> ShowS
$cshowsPrec :: Int -> ApplyFailure -> ShowS
Show)
data TypeKind = TKRecord | TKUnion | TKEnum | TKNewtype | TKTypeSynonym
deriving (TypeKind -> TypeKind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeKind -> TypeKind -> Bool
$c/= :: TypeKind -> TypeKind -> Bool
== :: TypeKind -> TypeKind -> Bool
$c== :: TypeKind -> TypeKind -> Bool
Eq, Int -> TypeKind -> ShowS
[TypeKind] -> ShowS
TypeKind -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TypeKind] -> ShowS
$cshowList :: [TypeKind] -> ShowS
show :: TypeKind -> [Char]
$cshow :: TypeKind -> [Char]
showsPrec :: Int -> TypeKind -> ShowS
$cshowsPrec :: Int -> TypeKind -> ShowS
Show)
data MigrateFailure
= ValidateFailure ValidateFailure
| ValueError ValueError Position
deriving (MigrateFailure -> MigrateFailure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MigrateFailure -> MigrateFailure -> Bool
$c/= :: MigrateFailure -> MigrateFailure -> Bool
== :: MigrateFailure -> MigrateFailure -> Bool
$c== :: MigrateFailure -> MigrateFailure -> Bool
Eq, Int -> MigrateFailure -> ShowS
[MigrateFailure] -> ShowS
MigrateFailure -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MigrateFailure] -> ShowS
$cshowList :: [MigrateFailure] -> ShowS
show :: MigrateFailure -> [Char]
$cshow :: MigrateFailure -> [Char]
showsPrec :: Int -> MigrateFailure -> ShowS
$cshowsPrec :: Int -> MigrateFailure -> ShowS
Show)
type MigrateWarning = ValidateWarning
prettyMigrateFailure :: MigrateFailure -> String
prettyMigrateFailure :: MigrateFailure -> [Char]
prettyMigrateFailure = [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. PPLines t => t -> [[Char]]
ppLines
prettyValidateFailure :: ValidateFailure -> String
prettyValidateFailure :: ValidateFailure -> [Char]
prettyValidateFailure = [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. PPLines t => t -> [[Char]]
ppLines
prettyValueError :: ValueError -> String
prettyValueError :: ValueError -> [Char]
prettyValueError = [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. PPLines t => t -> [[Char]]
ppLines
prettyValueErrorPosition :: (ValueError, Position) -> String
prettyValueErrorPosition :: (ValueError, Position) -> [Char]
prettyValueErrorPosition = [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. PPLines t => t -> [[Char]]
ppLines
instance PP TypeKind where
pp :: TypeKind -> [Char]
pp TypeKind
TKRecord = [Char]
"record"
pp TypeKind
TKUnion = [Char]
"union"
pp TypeKind
TKEnum = [Char]
"enum"
pp TypeKind
TKNewtype = [Char]
"newtype"
pp TypeKind
TKTypeSynonym = [Char]
"type"
ppATypeKind :: TypeKind -> String
ppATypeKind :: TypeKind -> [Char]
ppATypeKind TypeKind
TKRecord = [Char]
"a record"
ppATypeKind TypeKind
TKUnion = [Char]
"a union"
ppATypeKind TypeKind
TKEnum = [Char]
"an enum"
ppATypeKind TypeKind
TKNewtype = [Char]
"a newtype"
ppATypeKind TypeKind
TKTypeSynonym = [Char]
"a type synonym"
ppMemberWord :: TypeKind -> String
ppMemberWord :: TypeKind -> [Char]
ppMemberWord TypeKind
TKRecord = [Char]
"field"
ppMemberWord TypeKind
TKUnion = [Char]
"alternative"
ppMemberWord TypeKind
TKEnum = [Char]
"value"
ppMemberWord TypeKind
TKNewtype = [Char]
"member"
ppMemberWord TypeKind
TKTypeSynonym = [Char]
"member"
instance PPLines MigrateFailure where
ppLines :: MigrateFailure -> [[Char]]
ppLines (ValidateFailure ValidateFailure
x) = forall t. PPLines t => t -> [[Char]]
ppLines ValidateFailure
x
ppLines (ValueError ValueError
x Position
ps) = forall t. PPLines t => t -> [[Char]]
ppLines ValueError
x forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Step -> [Char]
prettyStep Position
ps
instance PPLines ValidateFailure where
ppLines :: ValidateFailure -> [[Char]]
ppLines (ChangelogOutOfOrder VersionExtra
later VersionExtra
earlier) =
[[Char]
"Changelog out of order: version " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp VersionExtra
later
forall a. [a] -> [a] -> [a]
++ [Char]
" appears after version " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp VersionExtra
earlier]
ppLines (CannotDowngrade VersionExtra
from VersionExtra
to) =
[[Char]
"Cannot downgrade from version " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp VersionExtra
from
forall a. [a] -> [a] -> [a]
++ [Char]
" to version " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp VersionExtra
to]
ppLines (ApiInvalid VersionExtra
ver Set TypeName
missing) =
[[Char]
"Missing declarations in API version " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp VersionExtra
ver forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp Set TypeName
missing]
ppLines (ChangelogEntryInvalid [APITableChange]
succs APIChange
change ApplyFailure
af) =
forall t. PPLines t => t -> [[Char]]
ppLines ApplyFailure
af forall a. [a] -> [a] -> [a]
++ ([Char]
"when applying the change" forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
indent (forall t. PPLines t => t -> [[Char]]
ppLines APIChange
change))
forall a. [a] -> [a] -> [a]
++ if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [APITableChange]
succs)
then [Char]
"after successfully applying the changes:"
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
indent (forall t. PPLines t => t -> [[Char]]
ppLines [APITableChange]
succs)
else []
ppLines (ChangelogIncomplete VersionExtra
ver VersionExtra
ver' Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
diffs) =
([Char]
"Changelog incomplete! Differences between log version ("
forall a. [a] -> [a] -> [a]
++ VersionExtra -> [Char]
showVersionExtra VersionExtra
ver forall a. [a] -> [a] -> [a]
++ [Char]
") and latest version (" forall a. [a] -> [a] -> [a]
++ VersionExtra -> [Char]
showVersionExtra VersionExtra
ver' forall a. [a] -> [a] -> [a]
++ [Char]
"):")
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
indent (Map TypeName (MergeResult NormTypeDecl NormTypeDecl) -> [[Char]]
ppDiffs Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
diffs)
ppDiffs :: Map TypeName (MergeResult NormTypeDecl NormTypeDecl) -> [String]
ppDiffs :: Map TypeName (MergeResult NormTypeDecl NormTypeDecl) -> [[Char]]
ppDiffs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TypeName -> MergeResult NormTypeDecl NormTypeDecl -> [[Char]]
ppDiff) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
sortDiffs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
sortDiffs :: [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
sortDiffs :: [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
sortDiffs = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [SCC a] -> [a]
Graph.flattenSCCs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key node. Ord key => [(node, key, [key])] -> [SCC node]
Graph.stronglyConnComp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {b}.
(b, MergeResult NormTypeDecl NormTypeDecl)
-> ((b, MergeResult NormTypeDecl NormTypeDecl), b, [TypeName])
f
where
f :: (b, MergeResult NormTypeDecl NormTypeDecl)
-> ((b, MergeResult NormTypeDecl NormTypeDecl), b, [TypeName])
f (b
tn, MergeResult NormTypeDecl NormTypeDecl
mr) = ((b
tn, MergeResult NormTypeDecl NormTypeDecl
mr), b
tn, forall a. Set a -> [a]
Set.toList (MergeResult NormTypeDecl NormTypeDecl -> Set TypeName
mergeResultFreeVars MergeResult NormTypeDecl NormTypeDecl
mr))
mergeResultFreeVars :: MergeResult NormTypeDecl NormTypeDecl -> Set TypeName
mergeResultFreeVars :: MergeResult NormTypeDecl NormTypeDecl -> Set TypeName
mergeResultFreeVars (OnlyInLeft NormTypeDecl
x) = NormTypeDecl -> Set TypeName
typeDeclFreeVars NormTypeDecl
x
mergeResultFreeVars (OnlyInRight NormTypeDecl
x) = NormTypeDecl -> Set TypeName
typeDeclFreeVars NormTypeDecl
x
mergeResultFreeVars (InBoth NormTypeDecl
x NormTypeDecl
y) = NormTypeDecl -> Set TypeName
typeDeclFreeVars NormTypeDecl
x forall a. Ord a => Set a -> Set a -> Set a
`Set.union` NormTypeDecl -> Set TypeName
typeDeclFreeVars NormTypeDecl
y
ppDiff :: TypeName -> MergeResult NormTypeDecl NormTypeDecl -> [String]
ppDiff :: TypeName -> MergeResult NormTypeDecl NormTypeDecl -> [[Char]]
ppDiff TypeName
t (OnlyInLeft NormTypeDecl
_) = [[Char]
"removed " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t]
ppDiff TypeName
t (OnlyInRight NormTypeDecl
d) = ([Char]
"added " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t forall a. [a] -> [a] -> [a]
++ [Char]
" ") [Char] -> [[Char]] -> [[Char]]
`inFrontOf` forall t. PPLines t => t -> [[Char]]
ppLines NormTypeDecl
d
ppDiff TypeName
t (InBoth (NRecordType NormRecordType
flds) (NRecordType NormRecordType
flds')) =
([Char]
"changed record " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t)
forall a. a -> [a] -> [a]
: (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([Char] -> FieldName -> MergeResult APIType APIType -> [[Char]]
ppDiffFields [Char]
"field")) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall a k.
(Eq a, Ord k) =>
Map k a -> Map k a -> Map k (MergeResult a a)
diffMaps NormRecordType
flds NormRecordType
flds')
ppDiff TypeName
t (InBoth (NUnionType NormRecordType
alts) (NUnionType NormRecordType
alts')) =
([Char]
"changed union " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t)
forall a. a -> [a] -> [a]
: (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([Char] -> FieldName -> MergeResult APIType APIType -> [[Char]]
ppDiffFields [Char]
"alternative")) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall a k.
(Eq a, Ord k) =>
Map k a -> Map k a -> Map k (MergeResult a a)
diffMaps NormRecordType
alts NormRecordType
alts')
ppDiff TypeName
t (InBoth (NEnumType NormEnumType
vals) (NEnumType NormEnumType
vals')) =
([Char]
"changed enum " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t)
forall a. a -> [a] -> [a]
: (forall a b. (a -> b) -> [a] -> [b]
map (\ FieldName
x -> [Char]
" alternative removed " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp FieldName
x) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ NormEnumType
vals forall a. Ord a => Set a -> Set a -> Set a
Set.\\ NormEnumType
vals')
forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> b) -> [a] -> [b]
map (\ FieldName
x -> [Char]
" alternative added " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp FieldName
x) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ NormEnumType
vals' forall a. Ord a => Set a -> Set a -> Set a
Set.\\ NormEnumType
vals)
ppDiff TypeName
t (InBoth NormTypeDecl
_ NormTypeDecl
_) = [[Char]
"incompatible definitions of " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t]
ppDiffFields :: String -> FieldName -> MergeResult APIType APIType -> [String]
ppDiffFields :: [Char] -> FieldName -> MergeResult APIType APIType -> [[Char]]
ppDiffFields [Char]
s FieldName
f (OnlyInLeft APIType
_) = [[Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
" removed " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp FieldName
f]
ppDiffFields [Char]
s FieldName
f (OnlyInRight APIType
ty) = [[Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
" added " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp FieldName
f forall a. [a] -> [a] -> [a]
++ [Char]
" :: " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp APIType
ty]
ppDiffFields [Char]
s FieldName
f (InBoth APIType
ty APIType
ty') = [ [Char]
" incompatible types for " forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp FieldName
f
, [Char]
" changelog type: " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp APIType
ty
, [Char]
" latest version type: " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp APIType
ty' ]
instance PPLines ApplyFailure where
ppLines :: ApplyFailure -> [[Char]]
ppLines (TypeExists TypeName
t) = [[Char]
"Type " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t forall a. [a] -> [a] -> [a]
++ [Char]
" already exists"]
ppLines (TypeDoesNotExist TypeName
t) = [[Char]
"Type " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t forall a. [a] -> [a] -> [a]
++ [Char]
" does not exist"]
ppLines (TypeWrongKind TypeName
t TypeKind
k) = [[Char]
"Type " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t forall a. [a] -> [a] -> [a]
++ [Char]
" is not " forall a. [a] -> [a] -> [a]
++ TypeKind -> [Char]
ppATypeKind TypeKind
k]
ppLines (TypeInUse TypeName
t) = [[Char]
"Type " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t forall a. [a] -> [a] -> [a]
++ [Char]
" is in use, so it cannot be modified"]
ppLines (TypeMalformed APIType
ty Set TypeName
xs) = [[Char]
"Type " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp APIType
ty
forall a. [a] -> [a] -> [a]
++ [Char]
" is malformed, missing declarations:"
, [Char]
" " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp Set TypeName
xs]
ppLines (DeclMalformed TypeName
t NormTypeDecl
_ Set TypeName
xs) = [ [Char]
"Declaration of " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t
forall a. [a] -> [a] -> [a]
++ [Char]
" is malformed, missing declarations:"
, [Char]
" " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp Set TypeName
xs]
ppLines (FieldExists TypeName
t TypeKind
k FieldName
f) = [[Char]
"Type " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t forall a. [a] -> [a] -> [a]
++ [Char]
" already has the "
forall a. [a] -> [a] -> [a]
++ TypeKind -> [Char]
ppMemberWord TypeKind
k forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp FieldName
f]
ppLines (FieldDoesNotExist TypeName
t TypeKind
k FieldName
f) = [[Char]
"Type " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t forall a. [a] -> [a] -> [a]
++ [Char]
" does not have the "
forall a. [a] -> [a] -> [a]
++ TypeKind -> [Char]
ppMemberWord TypeKind
k forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp FieldName
f]
ppLines (FieldBadDefaultValue TypeName
_ FieldName
_ APIType
ty DefaultValue
v) = [[Char]
"Default value " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp DefaultValue
v
forall a. [a] -> [a] -> [a]
++ [Char]
" is not compatible with the type " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp APIType
ty]
ppLines (DefaultMissing TypeName
t FieldName
f) = [[Char]
"Field " forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp FieldName
f forall a. [a] -> [a] -> [a]
++ [Char]
" does not have a default value, but "
forall a. [a] -> [a] -> [a]
++ forall t. PP t => t -> [Char]
pp TypeName
t forall a. [a] -> [a] -> [a]
++ [Char]
" occurs in the database"]
ppLines (TableChangeError [Char]
s) = [[Char]
"Error when detecting changed tables:", [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
s]
instance PPLines ValueError where
ppLines :: ValueError -> [[Char]]
ppLines (JSONError JSONError
e) = [JSONError -> [Char]
prettyJSONError JSONError
e]
ppLines (CustomMigrationError [Char]
e Value
v) = [ [Char]
"Custom migration error:", [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
e
, [Char]
"when migrating value"] forall a. [a] -> [a] -> [a]
++ [[Char]] -> [[Char]]
indent (forall t. PPLines t => t -> [[Char]]
ppLines Value
v)
ppLines (InvalidAPI ApplyFailure
af) = [Char]
"Invalid API detected during value migration:"
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
indent (forall t. PPLines t => t -> [[Char]]
ppLines ApplyFailure
af)
$(deriveJSON defaultOptions ''Expected)
$(deriveJSON defaultOptions ''FormatExpected)
$(deriveJSON defaultOptions ''Step)
$(deriveJSON defaultOptions ''JSONError)
$(SC.deriveSafeCopy 1 'SC.base ''Step)