module Data.OpenApi.Compare.Behavior
  ( BehaviorLevel (..),
    Behavable (..),
    IssueKind (..),
    Issuable (..),
    Orientation (..),
    toggleOrientation,
    Behavior,
    AnIssue (..),
    withClass,
    anIssueKind,
    relatedAnIssues,
  )
where

import Data.Aeson
import Data.Kind
import Data.OpenApi.Compare.Paths
import Data.Typeable
import Text.Pandoc.Builder

-- | Kind
data BehaviorLevel
  = APILevel
  | ServerLevel
  | SecurityRequirementLevel
  | SecuritySchemeLevel
  | PathLevel
  | OperationLevel
  | PathFragmentLevel
  | RequestLevel
  | ResponseLevel
  | HeaderLevel
  | -- | either request or response data
    PayloadLevel
  | SchemaLevel
  | TypedSchemaLevel
  | LinkLevel
  | CallbackLevel

class
  (Ord (Behave a b), Show (Behave a b)) =>
  Behavable (a :: BehaviorLevel) (b :: BehaviorLevel)
  where
  data Behave a b
  describeBehavior :: Behave a b -> Inlines

type instance AdditionalQuiverConstraints Behave a b = Behavable a b

data IssueKind
  = -- | This is certainly an issue, we can demonstrate a "counterexample"
    CertainIssue
  | -- | Change looks breaking but we don't have a complete comprehension of the problem
    ProbablyIssue
  | -- | We don't really support this feature at all, outside structural comparison
    Unsupported
  | -- | This is not an issue in itself, but a clarifying comment providing context for some other issues
    Comment
  | -- | We detected an issue with one of the input schemata itself
    SchemaInvalid
  deriving stock (IssueKind -> IssueKind -> Bool
(IssueKind -> IssueKind -> Bool)
-> (IssueKind -> IssueKind -> Bool) -> Eq IssueKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IssueKind -> IssueKind -> Bool
$c/= :: IssueKind -> IssueKind -> Bool
== :: IssueKind -> IssueKind -> Bool
$c== :: IssueKind -> IssueKind -> Bool
Eq, Eq IssueKind
Eq IssueKind
-> (IssueKind -> IssueKind -> Ordering)
-> (IssueKind -> IssueKind -> Bool)
-> (IssueKind -> IssueKind -> Bool)
-> (IssueKind -> IssueKind -> Bool)
-> (IssueKind -> IssueKind -> Bool)
-> (IssueKind -> IssueKind -> IssueKind)
-> (IssueKind -> IssueKind -> IssueKind)
-> Ord IssueKind
IssueKind -> IssueKind -> Bool
IssueKind -> IssueKind -> Ordering
IssueKind -> IssueKind -> IssueKind
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IssueKind -> IssueKind -> IssueKind
$cmin :: IssueKind -> IssueKind -> IssueKind
max :: IssueKind -> IssueKind -> IssueKind
$cmax :: IssueKind -> IssueKind -> IssueKind
>= :: IssueKind -> IssueKind -> Bool
$c>= :: IssueKind -> IssueKind -> Bool
> :: IssueKind -> IssueKind -> Bool
$c> :: IssueKind -> IssueKind -> Bool
<= :: IssueKind -> IssueKind -> Bool
$c<= :: IssueKind -> IssueKind -> Bool
< :: IssueKind -> IssueKind -> Bool
$c< :: IssueKind -> IssueKind -> Bool
compare :: IssueKind -> IssueKind -> Ordering
$ccompare :: IssueKind -> IssueKind -> Ordering
$cp1Ord :: Eq IssueKind
Ord, Int -> IssueKind -> ShowS
[IssueKind] -> ShowS
IssueKind -> String
(Int -> IssueKind -> ShowS)
-> (IssueKind -> String)
-> ([IssueKind] -> ShowS)
-> Show IssueKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IssueKind] -> ShowS
$cshowList :: [IssueKind] -> ShowS
show :: IssueKind -> String
$cshow :: IssueKind -> String
showsPrec :: Int -> IssueKind -> ShowS
$cshowsPrec :: Int -> IssueKind -> ShowS
Show)

class (Typeable l, Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where
  data Issue l :: Type

  -- | The same issues can be rendered in multiple places and might
  -- require different ways of represnting them to the user.
  --
  -- In practice each issue requires a maximum of two different representations:
  -- based on the context the issue might need to be rendered as "opposite" ('Backward')
  -- – for example when rendering non-breaking changes everything should be
  -- reversed (a consequence of the way we generate non-breaking changes).
  --
  -- If _consumer_ doesn't have something, the element was "removed".
  -- If _producer_ doesn't have something, the element was "added".
  describeIssue :: Orientation -> Issue l -> Blocks

  issueKind :: Issue l -> IssueKind

  -- | An equivalence relation designating whether two issues are talking about the aspect of the schema. This is used
  -- to remove duplicates from the "reverse" error tree we get when we look for non-breaking changes.
  -- Generally if checking X->Y raises issue I, and checking Y->X raises issue J, I and J should be related.
  relatedIssues :: Issue l -> Issue l -> Bool
  relatedIssues = Issue l -> Issue l -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- Utility function for 'relatedIssues'. In @withClass eq f@, @f@ attempts to partition inputs into equivalence classes,
-- and two items in the same equivalence class are related. If both items aren't assigned to a class by @f@, instead
-- @eq@ is used to compare them.
withClass :: Eq b => (a -> a -> Bool) -> (a -> Maybe b) -> a -> a -> Bool
withClass :: (a -> a -> Bool) -> (a -> Maybe b) -> a -> a -> Bool
withClass a -> a -> Bool
eq a -> Maybe b
f = \a
x a
y -> case (a -> Maybe b
f a
x, a -> Maybe b
f a
y) of
  (Just b
fx, Just b
fy) -> b
fx b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
fy
  (Maybe b
Nothing, Maybe b
Nothing) -> a -> a -> Bool
eq a
x a
y
  (Maybe b
_, Maybe b
_) -> Bool
False

data Orientation = Forward | Backward
  deriving stock (Orientation -> Orientation -> Bool
(Orientation -> Orientation -> Bool)
-> (Orientation -> Orientation -> Bool) -> Eq Orientation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Orientation -> Orientation -> Bool
$c/= :: Orientation -> Orientation -> Bool
== :: Orientation -> Orientation -> Bool
$c== :: Orientation -> Orientation -> Bool
Eq, Eq Orientation
Eq Orientation
-> (Orientation -> Orientation -> Ordering)
-> (Orientation -> Orientation -> Bool)
-> (Orientation -> Orientation -> Bool)
-> (Orientation -> Orientation -> Bool)
-> (Orientation -> Orientation -> Bool)
-> (Orientation -> Orientation -> Orientation)
-> (Orientation -> Orientation -> Orientation)
-> Ord Orientation
Orientation -> Orientation -> Bool
Orientation -> Orientation -> Ordering
Orientation -> Orientation -> Orientation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Orientation -> Orientation -> Orientation
$cmin :: Orientation -> Orientation -> Orientation
max :: Orientation -> Orientation -> Orientation
$cmax :: Orientation -> Orientation -> Orientation
>= :: Orientation -> Orientation -> Bool
$c>= :: Orientation -> Orientation -> Bool
> :: Orientation -> Orientation -> Bool
$c> :: Orientation -> Orientation -> Bool
<= :: Orientation -> Orientation -> Bool
$c<= :: Orientation -> Orientation -> Bool
< :: Orientation -> Orientation -> Bool
$c< :: Orientation -> Orientation -> Bool
compare :: Orientation -> Orientation -> Ordering
$ccompare :: Orientation -> Orientation -> Ordering
$cp1Ord :: Eq Orientation
Ord, Int -> Orientation -> ShowS
[Orientation] -> ShowS
Orientation -> String
(Int -> Orientation -> ShowS)
-> (Orientation -> String)
-> ([Orientation] -> ShowS)
-> Show Orientation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Orientation] -> ShowS
$cshowList :: [Orientation] -> ShowS
show :: Orientation -> String
$cshow :: Orientation -> String
showsPrec :: Int -> Orientation -> ShowS
$cshowsPrec :: Int -> Orientation -> ShowS
Show)

toggleOrientation :: Orientation -> Orientation
toggleOrientation :: Orientation -> Orientation
toggleOrientation Orientation
Forward = Orientation
Backward
toggleOrientation Orientation
Backward = Orientation
Forward

-- | A set of interactions having common unifying features
type Behavior = Paths Behave 'APILevel

instance Issuable l => ToJSON (Issue l) where
  toJSON :: Issue l -> Value
toJSON = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> (Issue l -> String) -> Issue l -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Issue l -> String
forall a. Show a => a -> String
show

data AnIssue (l :: BehaviorLevel) where
  AnIssue :: Issuable l => Orientation -> Issue l -> AnIssue l

deriving stock instance Show (AnIssue l)

deriving stock instance Eq (AnIssue l)

deriving stock instance Ord (AnIssue l)

instance ToJSON (AnIssue l) where
  toJSON :: AnIssue l -> Value
toJSON (AnIssue Orientation
_ Issue l
issue) = Issue l -> Value
forall a. ToJSON a => a -> Value
toJSON Issue l
issue

anIssueKind :: AnIssue l -> IssueKind
anIssueKind :: AnIssue l -> IssueKind
anIssueKind (AnIssue Orientation
_ Issue l
i) = Issue l -> IssueKind
forall (l :: BehaviorLevel). Issuable l => Issue l -> IssueKind
issueKind Issue l
i

relatedAnIssues :: AnIssue l -> AnIssue l -> Bool
relatedAnIssues :: AnIssue l -> AnIssue l -> Bool
relatedAnIssues (AnIssue Orientation
_ Issue l
x) (AnIssue Orientation
_ Issue l
y) = Issue l -> Issue l -> Bool
forall (l :: BehaviorLevel).
Issuable l =>
Issue l -> Issue l -> Bool
relatedIssues Issue l
x Issue l
y