{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}

module Data.API.Error
    ( -- * Representation of JSON parsing errors
      JSONError(..)
    , JSONWarning
    , Expected(..)
    , FormatExpected(..)
    , Position
    , Step(..)
    , inField
    , prettyJSONErrorPositions
    , prettyJSONError
    , prettyStep

      -- * JSON parse error construction
    , expectedArray
    , expectedBool
    , expectedInt
    , expectedObject
    , expectedString
    , badFormat

      -- * Validation and migration errors
    , 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


----------------------------------------------------------
-- Representation of JSON parsing errors and positions
--

-- | Represents an error that can be encountered while parsing
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
(JSONError -> JSONError -> Bool)
-> (JSONError -> JSONError -> Bool) -> Eq JSONError
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 -> String
(Int -> JSONError -> ShowS)
-> (JSONError -> String)
-> ([JSONError] -> ShowS)
-> Show JSONError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JSONError] -> ShowS
$cshowList :: [JSONError] -> ShowS
show :: JSONError -> String
$cshow :: JSONError -> String
showsPrec :: Int -> JSONError -> ShowS
$cshowsPrec :: Int -> JSONError -> ShowS
Show)

-- | At present, we do not distinguish between errors and warnings
type JSONWarning = JSONError

-- | JSON type expected at a particular position, when a value of a
-- different type was encountered
data Expected = ExpArray
              | ExpBool
              | ExpInt
              | ExpObject
              | ExpString
  deriving (Expected -> Expected -> Bool
(Expected -> Expected -> Bool)
-> (Expected -> Expected -> Bool) -> Eq Expected
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 -> String
(Int -> Expected -> ShowS)
-> (Expected -> String) -> ([Expected] -> ShowS) -> Show Expected
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expected] -> ShowS
$cshowList :: [Expected] -> ShowS
show :: Expected -> String
$cshow :: Expected -> String
showsPrec :: Int -> Expected -> ShowS
$cshowsPrec :: Int -> Expected -> ShowS
Show)

-- | Special format expected of a string
data FormatExpected = FmtBinary
                    | FmtUTC
                    | FmtOther
  deriving (FormatExpected -> FormatExpected -> Bool
(FormatExpected -> FormatExpected -> Bool)
-> (FormatExpected -> FormatExpected -> Bool) -> Eq FormatExpected
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 -> String
(Int -> FormatExpected -> ShowS)
-> (FormatExpected -> String)
-> ([FormatExpected] -> ShowS)
-> Show FormatExpected
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FormatExpected] -> ShowS
$cshowList :: [FormatExpected] -> ShowS
show :: FormatExpected -> String
$cshow :: FormatExpected -> String
showsPrec :: Int -> FormatExpected -> ShowS
$cshowsPrec :: Int -> FormatExpected -> ShowS
Show)

expectedArray, expectedBool, expectedInt, expectedObject, expectedString
  :: JS.Value -> JSONError
expectedArray :: Value -> JSONError
expectedArray  = Expected -> String -> Value -> JSONError
Expected Expected
ExpArray    String
"Array"
expectedBool :: Value -> JSONError
expectedBool   = Expected -> String -> Value -> JSONError
Expected Expected
ExpBool     String
"Bool"
expectedInt :: Value -> JSONError
expectedInt    = Expected -> String -> Value -> JSONError
Expected Expected
ExpInt      String
"Int"
expectedObject :: Value -> JSONError
expectedObject = Expected -> String -> Value -> JSONError
Expected Expected
ExpObject   String
"Object"
expectedString :: Value -> JSONError
expectedString = Expected -> String -> Value -> JSONError
Expected Expected
ExpString   String
"String"

badFormat :: String -> T.Text -> JSONError
badFormat :: String -> Text -> JSONError
badFormat = FormatExpected -> String -> Text -> JSONError
BadFormat FormatExpected
FmtOther

-- | Human-readable description of a JSON parse error
prettyJSONError :: JSONError -> String
prettyJSONError :: JSONError -> String
prettyJSONError (Expected Expected
_ String
s Value
v)      = String
"When expecting " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", encountered "
                                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" instead"
  where
    x :: String
x = case Value
v of
          JS.Object Object
_ -> String
"Object"
          JS.Array Array
_  -> String
"Array"
          JS.String Text
_ -> String
"String"
          JS.Number Scientific
_ -> String
"Number"
          JS.Bool Bool
_   -> String
"Boolean"
          Value
JS.Null     -> String
"Null"
prettyJSONError (BadFormat FormatExpected
_ String
s Text
t)     = String
"Could not parse as " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" the string " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t
prettyJSONError JSONError
MissingField          = String
"Field missing from Object"
prettyJSONError (MissingAlt [String]
xs)       = String
"Missing alternative, expecting one of: "
                                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
xs
prettyJSONError JSONError
UnexpectedField       = String
"Unexpected field in Object"
prettyJSONError (UnexpectedEnumVal [Text]
xs Text
t) = String
"Unexpected enum value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
t
                                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", expecting one of: "
                                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
xs)
prettyJSONError (IntRangeError String
s Int
i IntRange
r) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not in range " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IntRange -> String
forall a. Show a => a -> String
show IntRange
r
prettyJSONError (UTCRangeError String
s UTCTime
u UTCRange
r) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
u String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not in range " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UTCRange -> String
forall a. Show a => a -> String
show UTCRange
r
prettyJSONError (RegexError String
s Text
_ RegEx
t)    = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": failed to match RE: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RegEx -> String
forall a. Show a => a -> String
show RegEx
t
prettyJSONError (SyntaxError String
e)       = String
"JSON syntax error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e

-- | A position inside a JSON value is a list of steps, ordered
-- innermost first (so going inside an object prepends a step).
type Position = [Step]

-- | Each step may be into a field of an object, or a specific element
-- of an array.
data Step = InField T.Text | InElem Int
  deriving (Step -> Step -> Bool
(Step -> Step -> Bool) -> (Step -> Step -> Bool) -> Eq Step
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
[Step] -> ShowS
Step -> String
(Int -> Step -> ShowS)
-> (Step -> String) -> ([Step] -> ShowS) -> Show Step
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Step] -> ShowS
$cshowList :: [Step] -> ShowS
show :: Step -> String
$cshow :: Step -> String
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)

-- | Human-readable description of a single step in a position
prettyStep :: Step -> String
prettyStep :: Step -> String
prettyStep (InField Text
f) = String
"  in the field " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
f
prettyStep (InElem Int
i)  = String
"  in array index " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

instance PPLines Step where
  ppLines :: Step -> [String]
ppLines Step
s = [Step -> String
prettyStep Step
s]

-- | Human-readable presentation of a list of parse errors with their
-- positions
prettyJSONErrorPositions :: [(JSONError, Position)] -> String
prettyJSONErrorPositions :: [(JSONError, [Step])] -> String
prettyJSONErrorPositions [(JSONError, [Step])]
xs = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((JSONError, [Step]) -> [String])
-> [(JSONError, [Step])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (JSONError, [Step]) -> [String]
help [(JSONError, [Step])]
xs
  where
    help :: (JSONError, [Step]) -> [String]
help (JSONError
e, [Step]
pos) = JSONError -> String
prettyJSONError JSONError
e String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Step -> String) -> [Step] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Step -> String
prettyStep [Step]
pos



----------------------------------------------------------
-- Validation and data migration errors
--

-- | Errors that can be discovered when migrating data values
data ValueError
    = JSONError JSONError                  -- ^ Data doesn't match schema
    | CustomMigrationError String JS.Value -- ^ Error generated during custom migration
    | InvalidAPI ApplyFailure              -- ^ An API change was invalid
    deriving (ValueError -> ValueError -> Bool
(ValueError -> ValueError -> Bool)
-> (ValueError -> ValueError -> Bool) -> Eq ValueError
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 -> String
(Int -> ValueError -> ShowS)
-> (ValueError -> String)
-> ([ValueError] -> ShowS)
-> Show ValueError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValueError] -> ShowS
$cshowList :: [ValueError] -> ShowS
show :: ValueError -> String
$cshow :: ValueError -> String
showsPrec :: Int -> ValueError -> ShowS
$cshowsPrec :: Int -> ValueError -> ShowS
Show)

-- | Errors that may be discovered when validating a changelog
data ValidateFailure
        -- | the changelog must be in descending order of versions
    = ChangelogOutOfOrder { ValidateFailure -> VersionExtra
vfLaterVersion   :: VersionExtra
                          , ValidateFailure -> VersionExtra
vfEarlierVersion :: VersionExtra }
        -- | forbid migrating from one version to an earlier version
    | CannotDowngrade { ValidateFailure -> VersionExtra
vfFromVersion :: VersionExtra
                      , ValidateFailure -> VersionExtra
vfToVersion   :: VersionExtra }
        -- | an API uses types that are not declared
    | ApiInvalid { ValidateFailure -> VersionExtra
vfInvalidVersion      :: VersionExtra
                 , ValidateFailure -> Set TypeName
vfMissingDeclarations :: Set TypeName }
        -- | changelog entry does not apply
    | ChangelogEntryInvalid { ValidateFailure -> [APITableChange]
vfSuccessfullyApplied :: [APITableChange]
                            , ValidateFailure -> APIChange
vfFailedToApply       :: APIChange
                            , ValidateFailure -> ApplyFailure
vfApplyFailure        :: ApplyFailure }
        -- | changelog is incomplete
        --   (ie all entries apply ok but result isn't the target api)
    | 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
(ValidateFailure -> ValidateFailure -> Bool)
-> (ValidateFailure -> ValidateFailure -> Bool)
-> Eq ValidateFailure
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 -> String
(Int -> ValidateFailure -> ShowS)
-> (ValidateFailure -> String)
-> ([ValidateFailure] -> ShowS)
-> Show ValidateFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidateFailure] -> ShowS
$cshowList :: [ValidateFailure] -> ShowS
show :: ValidateFailure -> String
$cshow :: ValidateFailure -> String
showsPrec :: Int -> ValidateFailure -> ShowS
$cshowsPrec :: Int -> ValidateFailure -> ShowS
Show)

data ValidateWarning = ValidateWarning -- add warnings about bits we cannot check (opaque custom)
  deriving Int -> ValidateWarning -> ShowS
[ValidateWarning] -> ShowS
ValidateWarning -> String
(Int -> ValidateWarning -> ShowS)
-> (ValidateWarning -> String)
-> ([ValidateWarning] -> ShowS)
-> Show ValidateWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidateWarning] -> ShowS
$cshowList :: [ValidateWarning] -> ShowS
show :: ValidateWarning -> String
$cshow :: ValidateWarning -> String
showsPrec :: Int -> ValidateWarning -> ShowS
$cshowsPrec :: Int -> ValidateWarning -> ShowS
Show

-- | Errors that may occur applying a single API change
data ApplyFailure
    = TypeExists           { ApplyFailure -> TypeName
afExistingType  :: TypeName }     -- ^ for adding or renaming type
    | TypeDoesNotExist     { ApplyFailure -> TypeName
afMissingType   :: TypeName }     -- ^ for deleting or renaming a type
    | TypeWrongKind        { ApplyFailure -> TypeName
afTypeName      :: TypeName
                           , ApplyFailure -> TypeKind
afExpectedKind  :: TypeKind }     -- ^ e.g. it's not a record type
    | TypeInUse            { afTypeName      :: TypeName }     -- ^ cannot delete/modify types that are still used
    | TypeMalformed        { ApplyFailure -> APIType
afType          :: APIType
                           , ApplyFailure -> Set TypeName
afMissingTypes  :: Set TypeName } -- ^ type refers to a non-existent type
    | DeclMalformed        { afTypeName      :: TypeName
                           , ApplyFailure -> NormTypeDecl
afDecl          :: NormTypeDecl
                           , afMissingTypes  :: Set TypeName } -- ^ decl refers to a non-existent type
    | FieldExists          { afTypeName      :: TypeName
                           , ApplyFailure -> TypeKind
afTypeKind      :: TypeKind
                           , ApplyFailure -> FieldName
afExistingField :: FieldName }    -- ^ for adding or renaming a field
    | FieldDoesNotExist    { afTypeName      :: TypeName
                           , afTypeKind      :: TypeKind
                           , ApplyFailure -> FieldName
afMissingField  :: FieldName }    -- ^ for deleting or renaming a field
    | FieldBadDefaultValue { afTypeName      :: TypeName
                           , ApplyFailure -> FieldName
afFieldName     :: FieldName
                           , ApplyFailure -> APIType
afFieldType     :: APIType
                           , ApplyFailure -> DefaultValue
afBadDefault    :: DefaultValue } -- ^ for adding a field, must be a default
                                                               --   value compatible with the type
    | DefaultMissing       { afTypeName      :: TypeName
                           , afFieldName     :: FieldName }    -- ^ for adding a field to a table
    | TableChangeError     { ApplyFailure -> String
afCustomMessage :: String }       -- ^ custom error in tableChange
  deriving (ApplyFailure -> ApplyFailure -> Bool
(ApplyFailure -> ApplyFailure -> Bool)
-> (ApplyFailure -> ApplyFailure -> Bool) -> Eq ApplyFailure
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 -> String
(Int -> ApplyFailure -> ShowS)
-> (ApplyFailure -> String)
-> ([ApplyFailure] -> ShowS)
-> Show ApplyFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApplyFailure] -> ShowS
$cshowList :: [ApplyFailure] -> ShowS
show :: ApplyFailure -> String
$cshow :: ApplyFailure -> String
showsPrec :: Int -> ApplyFailure -> ShowS
$cshowsPrec :: Int -> ApplyFailure -> ShowS
Show)

data TypeKind = TKRecord | TKUnion | TKEnum | TKNewtype | TKTypeSynonym
  deriving (TypeKind -> TypeKind -> Bool
(TypeKind -> TypeKind -> Bool)
-> (TypeKind -> TypeKind -> Bool) -> Eq TypeKind
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 -> String
(Int -> TypeKind -> ShowS)
-> (TypeKind -> String) -> ([TypeKind] -> ShowS) -> Show TypeKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeKind] -> ShowS
$cshowList :: [TypeKind] -> ShowS
show :: TypeKind -> String
$cshow :: TypeKind -> String
showsPrec :: Int -> TypeKind -> ShowS
$cshowsPrec :: Int -> TypeKind -> ShowS
Show)


data MigrateFailure
    = ValidateFailure ValidateFailure
    | ValueError ValueError Position
    deriving (MigrateFailure -> MigrateFailure -> Bool
(MigrateFailure -> MigrateFailure -> Bool)
-> (MigrateFailure -> MigrateFailure -> Bool) -> Eq MigrateFailure
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 -> String
(Int -> MigrateFailure -> ShowS)
-> (MigrateFailure -> String)
-> ([MigrateFailure] -> ShowS)
-> Show MigrateFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MigrateFailure] -> ShowS
$cshowList :: [MigrateFailure] -> ShowS
show :: MigrateFailure -> String
$cshow :: MigrateFailure -> String
showsPrec :: Int -> MigrateFailure -> ShowS
$cshowsPrec :: Int -> MigrateFailure -> ShowS
Show)

type MigrateWarning = ValidateWarning


-------------------------------------
-- Pretty-printing
--

prettyMigrateFailure :: MigrateFailure -> String
prettyMigrateFailure :: MigrateFailure -> String
prettyMigrateFailure = [String] -> String
unlines ([String] -> String)
-> (MigrateFailure -> [String]) -> MigrateFailure -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrateFailure -> [String]
forall t. PPLines t => t -> [String]
ppLines

prettyValidateFailure :: ValidateFailure -> String
prettyValidateFailure :: ValidateFailure -> String
prettyValidateFailure = [String] -> String
unlines ([String] -> String)
-> (ValidateFailure -> [String]) -> ValidateFailure -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidateFailure -> [String]
forall t. PPLines t => t -> [String]
ppLines

prettyValueError :: ValueError -> String
prettyValueError :: ValueError -> String
prettyValueError = [String] -> String
unlines ([String] -> String)
-> (ValueError -> [String]) -> ValueError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueError -> [String]
forall t. PPLines t => t -> [String]
ppLines

prettyValueErrorPosition :: (ValueError, Position) -> String
prettyValueErrorPosition :: (ValueError, [Step]) -> String
prettyValueErrorPosition = [String] -> String
unlines ([String] -> String)
-> ((ValueError, [Step]) -> [String])
-> (ValueError, [Step])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValueError, [Step]) -> [String]
forall t. PPLines t => t -> [String]
ppLines


instance PP TypeKind where
  pp :: TypeKind -> String
pp TypeKind
TKRecord      = String
"record"
  pp TypeKind
TKUnion       = String
"union"
  pp TypeKind
TKEnum        = String
"enum"
  pp TypeKind
TKNewtype     = String
"newtype"
  pp TypeKind
TKTypeSynonym = String
"type"

ppATypeKind :: TypeKind -> String
ppATypeKind :: TypeKind -> String
ppATypeKind TypeKind
TKRecord      = String
"a record"
ppATypeKind TypeKind
TKUnion       = String
"a union"
ppATypeKind TypeKind
TKEnum        = String
"an enum"
ppATypeKind TypeKind
TKNewtype     = String
"a newtype"
ppATypeKind TypeKind
TKTypeSynonym = String
"a type synonym"

ppMemberWord :: TypeKind -> String
ppMemberWord :: TypeKind -> String
ppMemberWord TypeKind
TKRecord      = String
"field"
ppMemberWord TypeKind
TKUnion       = String
"alternative"
ppMemberWord TypeKind
TKEnum        = String
"value"
ppMemberWord TypeKind
TKNewtype     = String
"member"
ppMemberWord TypeKind
TKTypeSynonym = String
"member"


instance PPLines MigrateFailure where
  ppLines :: MigrateFailure -> [String]
ppLines (ValidateFailure ValidateFailure
x) = ValidateFailure -> [String]
forall t. PPLines t => t -> [String]
ppLines ValidateFailure
x
  ppLines (ValueError ValueError
x [Step]
ps)   = ValueError -> [String]
forall t. PPLines t => t -> [String]
ppLines ValueError
x [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Step -> String) -> [Step] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Step -> String
prettyStep [Step]
ps

instance PPLines ValidateFailure where
  ppLines :: ValidateFailure -> [String]
ppLines (ChangelogOutOfOrder VersionExtra
later VersionExtra
earlier) =
      [String
"Changelog out of order: version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ VersionExtra -> String
forall t. PP t => t -> String
pp VersionExtra
later
           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" appears after version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ VersionExtra -> String
forall t. PP t => t -> String
pp VersionExtra
earlier]
  ppLines (CannotDowngrade VersionExtra
from VersionExtra
to) =
      [String
"Cannot downgrade from version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ VersionExtra -> String
forall t. PP t => t -> String
pp VersionExtra
from
           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ VersionExtra -> String
forall t. PP t => t -> String
pp VersionExtra
to]
  ppLines (ApiInvalid VersionExtra
ver Set TypeName
missing) =
      [String
"Missing declarations in API version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ VersionExtra -> String
forall t. PP t => t -> String
pp VersionExtra
ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set TypeName -> String
forall t. PP t => t -> String
pp Set TypeName
missing]
  ppLines (ChangelogEntryInvalid [APITableChange]
succs APIChange
change ApplyFailure
af) =
      ApplyFailure -> [String]
forall t. PPLines t => t -> [String]
ppLines ApplyFailure
af [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String
"when applying the change" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
indent (APIChange -> [String]
forall t. PPLines t => t -> [String]
ppLines APIChange
change))
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ if Bool -> Bool
not ([APITableChange] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [APITableChange]
succs)
             then String
"after successfully applying the changes:"
                  String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
indent ([APITableChange] -> [String]
forall t. PPLines t => t -> [String]
ppLines [APITableChange]
succs)
             else []
  ppLines (ChangelogIncomplete VersionExtra
ver VersionExtra
ver' Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
diffs) =
      (String
"Changelog incomplete! Differences between log version ("
           String -> ShowS
forall a. [a] -> [a] -> [a]
++ VersionExtra -> String
showVersionExtra VersionExtra
ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") and latest version (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ VersionExtra -> String
showVersionExtra VersionExtra
ver' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"):")
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
indent (Map TypeName (MergeResult NormTypeDecl NormTypeDecl) -> [String]
ppDiffs Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
diffs)


ppDiffs :: Map TypeName (MergeResult NormTypeDecl NormTypeDecl) -> [String]
ppDiffs :: Map TypeName (MergeResult NormTypeDecl NormTypeDecl) -> [String]
ppDiffs  = ((TypeName, MergeResult NormTypeDecl NormTypeDecl) -> [String])
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((TypeName -> MergeResult NormTypeDecl NormTypeDecl -> [String])
-> (TypeName, MergeResult NormTypeDecl NormTypeDecl) -> [String]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TypeName -> MergeResult NormTypeDecl NormTypeDecl -> [String]
ppDiff) ([(TypeName, MergeResult NormTypeDecl NormTypeDecl)] -> [String])
-> (Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
    -> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)])
-> Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
sortDiffs ([(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
 -> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)])
-> (Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
    -> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)])
-> Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
forall k a. Map k a -> [(k, a)]
Map.toList

-- | Perform a topological sort of the differences, so that the
-- pretty-printed form can be copied directly into the changelog.
sortDiffs :: [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
          -> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
sortDiffs :: [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
sortDiffs = [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
forall a. [a] -> [a]
reverse ([(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
 -> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)])
-> ([(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
    -> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)])
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SCC (TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
forall a. [SCC a] -> [a]
Graph.flattenSCCs ([SCC (TypeName, MergeResult NormTypeDecl NormTypeDecl)]
 -> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)])
-> ([(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
    -> [SCC (TypeName, MergeResult NormTypeDecl NormTypeDecl)])
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((TypeName, MergeResult NormTypeDecl NormTypeDecl), TypeName,
  [TypeName])]
-> [SCC (TypeName, MergeResult NormTypeDecl NormTypeDecl)]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
Graph.stronglyConnComp ([((TypeName, MergeResult NormTypeDecl NormTypeDecl), TypeName,
   [TypeName])]
 -> [SCC (TypeName, MergeResult NormTypeDecl NormTypeDecl)])
-> ([(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
    -> [((TypeName, MergeResult NormTypeDecl NormTypeDecl), TypeName,
         [TypeName])])
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [SCC (TypeName, MergeResult NormTypeDecl NormTypeDecl)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TypeName, MergeResult NormTypeDecl NormTypeDecl)
 -> ((TypeName, MergeResult NormTypeDecl NormTypeDecl), TypeName,
     [TypeName]))
-> [(TypeName, MergeResult NormTypeDecl NormTypeDecl)]
-> [((TypeName, MergeResult NormTypeDecl NormTypeDecl), TypeName,
     [TypeName])]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName, MergeResult NormTypeDecl NormTypeDecl)
-> ((TypeName, MergeResult NormTypeDecl NormTypeDecl), TypeName,
    [TypeName])
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, Set TypeName -> [TypeName]
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 Set TypeName -> Set TypeName -> Set TypeName
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 -> [String]
ppDiff TypeName
t (OnlyInLeft NormTypeDecl
_)  = [String
"removed " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t]
ppDiff TypeName
t (OnlyInRight NormTypeDecl
d) = (String
"added " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ") String -> [String] -> [String]
`inFrontOf` NormTypeDecl -> [String]
forall t. PPLines t => t -> [String]
ppLines NormTypeDecl
d
ppDiff TypeName
t (InBoth (NRecordType NormRecordType
flds) (NRecordType NormRecordType
flds')) =
    (String
"changed record " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t)
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (((FieldName, MergeResult APIType APIType) -> [String])
-> [(FieldName, MergeResult APIType APIType)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((FieldName -> MergeResult APIType APIType -> [String])
-> (FieldName, MergeResult APIType APIType) -> [String]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> FieldName -> MergeResult APIType APIType -> [String]
ppDiffFields String
"field")) ([(FieldName, MergeResult APIType APIType)] -> [String])
-> [(FieldName, MergeResult APIType APIType)] -> [String]
forall a b. (a -> b) -> a -> b
$ Map FieldName (MergeResult APIType APIType)
-> [(FieldName, MergeResult APIType APIType)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map FieldName (MergeResult APIType APIType)
 -> [(FieldName, MergeResult APIType APIType)])
-> Map FieldName (MergeResult APIType APIType)
-> [(FieldName, MergeResult APIType APIType)]
forall a b. (a -> b) -> a -> b
$ NormRecordType
-> NormRecordType -> Map FieldName (MergeResult APIType APIType)
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')) =
    (String
"changed union " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t)
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (((FieldName, MergeResult APIType APIType) -> [String])
-> [(FieldName, MergeResult APIType APIType)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((FieldName -> MergeResult APIType APIType -> [String])
-> (FieldName, MergeResult APIType APIType) -> [String]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> FieldName -> MergeResult APIType APIType -> [String]
ppDiffFields String
"alternative")) ([(FieldName, MergeResult APIType APIType)] -> [String])
-> [(FieldName, MergeResult APIType APIType)] -> [String]
forall a b. (a -> b) -> a -> b
$ Map FieldName (MergeResult APIType APIType)
-> [(FieldName, MergeResult APIType APIType)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map FieldName (MergeResult APIType APIType)
 -> [(FieldName, MergeResult APIType APIType)])
-> Map FieldName (MergeResult APIType APIType)
-> [(FieldName, MergeResult APIType APIType)]
forall a b. (a -> b) -> a -> b
$ NormRecordType
-> NormRecordType -> Map FieldName (MergeResult APIType APIType)
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')) =
    (String
"changed enum " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t)
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
:  ((FieldName -> String) -> [FieldName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ FieldName
x -> String
"  alternative removed " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
x) ([FieldName] -> [String]) -> [FieldName] -> [String]
forall a b. (a -> b) -> a -> b
$ NormEnumType -> [FieldName]
forall a. Set a -> [a]
Set.toList (NormEnumType -> [FieldName]) -> NormEnumType -> [FieldName]
forall a b. (a -> b) -> a -> b
$ NormEnumType
vals  NormEnumType -> NormEnumType -> NormEnumType
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ NormEnumType
vals')
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((FieldName -> String) -> [FieldName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ FieldName
x -> String
"  alternative added " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
x)   ([FieldName] -> [String]) -> [FieldName] -> [String]
forall a b. (a -> b) -> a -> b
$ NormEnumType -> [FieldName]
forall a. Set a -> [a]
Set.toList (NormEnumType -> [FieldName]) -> NormEnumType -> [FieldName]
forall a b. (a -> b) -> a -> b
$ NormEnumType
vals' NormEnumType -> NormEnumType -> NormEnumType
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ NormEnumType
vals)
ppDiff TypeName
t (InBoth NormTypeDecl
_ NormTypeDecl
_) = [String
"incompatible definitions of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t]

ppDiffFields :: String -> FieldName -> MergeResult APIType APIType -> [String]
ppDiffFields :: String -> FieldName -> MergeResult APIType APIType -> [String]
ppDiffFields String
s FieldName
f (OnlyInLeft APIType
_)   = [String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" removed " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
f]
ppDiffFields String
s FieldName
f (OnlyInRight APIType
ty) = [String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" added " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ APIType -> String
forall t. PP t => t -> String
pp APIType
ty]
ppDiffFields String
s FieldName
f (InBoth APIType
ty APIType
ty')   = [ String
"  incompatible types for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
f
                                     , String
"    changelog type:      " String -> ShowS
forall a. [a] -> [a] -> [a]
++ APIType -> String
forall t. PP t => t -> String
pp APIType
ty
                                     , String
"    latest version type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ APIType -> String
forall t. PP t => t -> String
pp APIType
ty' ]

instance PPLines ApplyFailure where
  ppLines :: ApplyFailure -> [String]
ppLines (TypeExists TypeName
t)                  = [String
"Type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" already exists"]
  ppLines (TypeDoesNotExist TypeName
t)            = [String
"Type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not exist"]
  ppLines (TypeWrongKind TypeName
t TypeKind
k)             = [String
"Type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeKind -> String
ppATypeKind TypeKind
k]
  ppLines (TypeInUse TypeName
t)                   = [String
"Type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is in use, so it cannot be modified"]
  ppLines (TypeMalformed APIType
ty Set TypeName
xs)           = [String
"Type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ APIType -> String
forall t. PP t => t -> String
pp APIType
ty
                                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is malformed, missing declarations:"
                                            , String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set TypeName -> String
forall t. PP t => t -> String
pp Set TypeName
xs]
  ppLines (DeclMalformed TypeName
t NormTypeDecl
_ Set TypeName
xs)          = [ String
"Declaration of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t
                                              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is malformed, missing declarations:"
                                            , String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set TypeName -> String
forall t. PP t => t -> String
pp Set TypeName
xs]
  ppLines (FieldExists TypeName
t TypeKind
k FieldName
f)             = [String
"Type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" already has the "
                                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeKind -> String
ppMemberWord TypeKind
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
f]
  ppLines (FieldDoesNotExist TypeName
t TypeKind
k FieldName
f)       = [String
"Type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not have the "
                                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeKind -> String
ppMemberWord TypeKind
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
f]
  ppLines (FieldBadDefaultValue TypeName
_ FieldName
_ APIType
ty DefaultValue
v) = [String
"Default value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DefaultValue -> String
forall t. PP t => t -> String
pp DefaultValue
v
                                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not compatible with the type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ APIType -> String
forall t. PP t => t -> String
pp APIType
ty]
  ppLines (DefaultMissing TypeName
t FieldName
f)            = [String
"Field " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall t. PP t => t -> String
pp FieldName
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not have a default value, but "
                                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeName -> String
forall t. PP t => t -> String
pp TypeName
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" occurs in the database"]
  ppLines (TableChangeError String
s)            = [String
"Error when detecting changed tables:", String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s]


instance PPLines ValueError where
  ppLines :: ValueError -> [String]
ppLines (JSONError JSONError
e)              = [JSONError -> String
prettyJSONError JSONError
e]
  ppLines (CustomMigrationError String
e Value
v) = [ String
"Custom migration error:", String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
                                       , String
"when migrating value"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> [String]
indent (Value -> [String]
forall t. PPLines t => t -> [String]
ppLines Value
v)
  ppLines (InvalidAPI ApplyFailure
af)            = String
"Invalid API detected during value migration:"
                                       String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
indent (ApplyFailure -> [String]
forall t. PPLines t => t -> [String]
ppLines ApplyFailure
af)


$(deriveJSON defaultOptions ''JSONError)
$(deriveJSON defaultOptions ''Expected)
$(deriveJSON defaultOptions ''FormatExpected)
$(deriveJSON defaultOptions ''Step)
$(SC.deriveSafeCopy 1 'SC.base ''Step)