{-# LANGUAGE CPP #-}

#if defined(MIN_VERSION_GLASGOW_HASKELL)
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
{-# LANGUAGE QualifiedDo #-}
#endif
#endif
module Test.Plan
  ( planTests
  )
where

import qualified Control.Exception as Exception
import qualified Control.Monad.IO.Class as MIO
import qualified Data.Either as Either
import Data.Foldable (traverse_)
import qualified Data.List as List
import qualified Data.List.NonEmpty as NEL
import qualified Data.String as String
import Hedgehog ((===))
import qualified Hedgehog as HH
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import qualified Orville.PostgreSQL as Orville
import qualified Orville.PostgreSQL.Plan as Plan
import qualified Orville.PostgreSQL.Plan.Many as Many

#if defined(MIN_VERSION_GLASGOW_HASKELL)
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import qualified Orville.PostgreSQL.Plan.Syntax as PlanSyntax
#endif
#endif

import qualified Test.Entities.Foo as Foo
import qualified Test.Entities.FooChild as FooChild
import qualified Test.Property as Property

{- ORMOLU_DISABLE -}
{- disable formatting so fourmolu doesn't go haywire with the cpp within the list -}
planTests :: Orville.ConnectionPool -> Property.Group
planTests pool =
  Property.group "Plan" $
    [ prop_askParam pool
    , prop_findMaybeOne pool
    , prop_findMaybeOneWhere pool
    , prop_findAll pool
    , prop_findAllWhere pool
    , prop_planMany_findMaybeOne pool
    , prop_planMany_findMaybeOneWhere pool
    , prop_planMany_findAll pool
    , prop_planMany_findAllWhere pool
    , prop_planEither pool
    , prop_planMany_planEither pool
    , prop_bindAndUse pool
    , prop_planMany_bindAndUse pool
    , prop_planMany_findOne_dedupesInClauses pool
#if defined(MIN_VERSION_GLASGOW_HASKELL)
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
    , prop_bindAndUse_qualifiedDo pool
    , prop_planMany_bindAndUse_qualifiedDo pool
#endif
#endif
    , prop_assert pool
    , prop_explain
    ]
{- ORMOLU_ENABLE -}

prop_askParam :: Property.NamedDBProperty
prop_askParam =
  Property.namedDBProperty "askParam returns the plan's parameter" $ \pool -> do
    let
      plan :: Plan.Plan scope Int Int
      plan = Plan.askParam

    inputParam <- HH.forAll $ Gen.integral (Range.constant minBound maxBound)
    resultParam <- MIO.liftIO $ Orville.runOrville pool (Plan.execute plan inputParam)
    resultParam === inputParam

prop_findMaybeOne :: Property.NamedDBProperty
prop_findMaybeOne =
  Property.namedDBProperty "findMaybeOne finds a row where the field matches (if any)" $ \pool -> do
    let
      plan :: Plan.Plan scope Foo.FooName (Maybe Foo.Foo)
      plan = Plan.findMaybeOne Foo.table Foo.fooNameField

    (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects
    maybeResult <-
      Foo.withTable pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)
        Plan.execute plan targetName

    let
      isMatch = Foo.hasName targetName

    coverSearchResultCases isMatch foos
    assertMatchIsFromPredicate maybeResult isMatch foos

prop_planMany_findMaybeOne :: Property.NamedDBProperty
prop_planMany_findMaybeOne =
  Property.namedDBProperty "(planMany findMaybeOne) finds a row where the field matches for each input" $ \pool -> do
    let
      plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName (Maybe Foo.Foo))
      plan = Plan.planMany $ Plan.findMaybeOne Foo.table Foo.fooNameField

    (targetNames, foos) <- HH.forAll generateSearchTargetListAndSubjects
    results <-
      Foo.withTable pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)
        Plan.execute plan targetNames

    let
      isMatch foo = elem (Foo.fooName foo) targetNames

    coverSearchResultCases isMatch foos

    assertEachManyResult targetNames results $ \targetName maybeFoo ->
      assertMatchIsFromPredicate
        maybeFoo
        (\foo -> Foo.hasName targetName foo && isMatch foo)
        foos

prop_findMaybeOneWhere :: Property.NamedDBProperty
prop_findMaybeOneWhere =
  Property.namedDBProperty "findMaybeOneWhere finds a row where the field matches (if any), with the given condition" $ \pool -> do
    let
      plan :: Plan.Plan scope Foo.FooName (Maybe Foo.Foo)
      plan =
        Plan.findMaybeOneWhere
          Foo.table
          Foo.fooNameField
          (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge)

    (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects
    maybeResult <-
      Foo.withTable pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)
        Plan.execute plan targetName

    let
      isMatch foo = Foo.hasName targetName foo && Foo.fooAge foo > Foo.averageFooAge

    coverSearchResultCases isMatch foos
    assertMatchIsFromPredicate maybeResult isMatch foos

prop_planMany_findMaybeOneWhere :: Property.NamedDBProperty
prop_planMany_findMaybeOneWhere =
  Property.namedDBProperty "(planMany findMaybeOneWhere) finds a row where the field matches for each input, with the given condition" $ \pool -> do
    let
      plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName (Maybe Foo.Foo))
      plan =
        Plan.planMany $
          Plan.findMaybeOneWhere
            Foo.table
            Foo.fooNameField
            (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge)

    (targetNames, foos) <- HH.forAll generateSearchTargetListAndSubjects
    results <-
      Foo.withTable pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)
        Plan.execute plan targetNames

    let
      isMatch foo =
        elem (Foo.fooName foo) targetNames
          && Foo.fooAge foo > Foo.averageFooAge

    coverSearchResultCases isMatch foos

    assertEachManyResult targetNames results $ \targetName maybeFoo ->
      assertMatchIsFromPredicate
        maybeFoo
        (\foo -> Foo.hasName targetName foo && isMatch foo)
        foos

prop_findAll :: Property.NamedDBProperty
prop_findAll =
  Property.namedDBProperty "findAll finds all rows where the field matches" $ \pool -> do
    let
      plan :: Plan.Plan scope Foo.FooName [Foo.Foo]
      plan = Plan.findAll Foo.table Foo.fooNameField

    (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects
    results <-
      Foo.withTable pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)
        Plan.execute plan targetName

    let
      isMatch = Foo.hasName targetName

    coverSearchResultCases isMatch foos
    assertAllMatchesFound Foo.fooId results isMatch foos

prop_planMany_findAll :: Property.NamedDBProperty
prop_planMany_findAll =
  Property.namedDBProperty "(planMany findAll) finds all rows where the field matches for each list of inputs" $ \pool -> do
    let
      plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName [Foo.Foo])
      plan = Plan.planMany (Plan.findAll Foo.table Foo.fooNameField)

    (targetNames, foos) <- HH.forAll generateSearchTargetListAndSubjects
    results <-
      Foo.withTable pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)
        Plan.execute plan targetNames

    let
      isMatch foo = elem (Foo.fooName foo) targetNames

    coverSearchResultCases isMatch foos
    assertEachManyResult targetNames results $ \targetName foundFoos ->
      assertAllMatchesFound Foo.fooId foundFoos (\foo -> Foo.hasName targetName foo && isMatch foo) foos

prop_findAllWhere :: Property.NamedDBProperty
prop_findAllWhere =
  Property.namedDBProperty "findAllWhere finds all rows where the field matches, with the given condition" $ \pool -> do
    let
      plan :: Plan.Plan scope Foo.FooName [Foo.Foo]
      plan =
        Plan.findAllWhere
          Foo.table
          Foo.fooNameField
          (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge)

    (targetName, foos) <- HH.forAll generateSearchTargetAndSubjects
    results <-
      Foo.withTable pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)
        Plan.execute plan targetName

    let
      isMatch foo = Foo.hasName targetName foo && Foo.fooAge foo > Foo.averageFooAge

    coverSearchResultCases isMatch foos
    assertAllMatchesFound Foo.fooId results isMatch foos

prop_planMany_findAllWhere :: Property.NamedDBProperty
prop_planMany_findAllWhere =
  Property.namedDBProperty "(planMany findAllWhere) finds all rows where the field matches for each list of inputs, with the given condition" $ \pool -> do
    let
      plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName [Foo.Foo])
      plan =
        Plan.planMany $
          Plan.findAllWhere
            Foo.table
            Foo.fooNameField
            (Orville.fieldGreaterThan Foo.fooAgeField Foo.averageFooAge)

    (targetNames, foos) <- HH.forAll generateSearchTargetListAndSubjects
    results <-
      Foo.withTable pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)
        Plan.execute plan targetNames

    let
      isMatch foo = elem (Foo.fooName foo) targetNames && Foo.fooAge foo > Foo.averageFooAge

    coverSearchResultCases isMatch foos
    assertEachManyResult targetNames results $ \targetName foundFoos ->
      assertAllMatchesFound Foo.fooId foundFoos (\foo -> Foo.hasName targetName foo && isMatch foo) foos

prop_planEither :: Property.NamedDBProperty
prop_planEither =
  Property.namedDBProperty "planEither executes either the right or left plan based on input" $ \pool -> do
    let
      plan :: Plan.Plan scope (Either Foo.FooId Foo.FooName) Foo.Foo
      plan =
        either id id
          <$> Plan.planEither
            (Plan.findOne Foo.table Foo.fooIdField)
            (Plan.findOne Foo.table Foo.fooNameField)

    foo <- HH.forAll Foo.generate
    param <-
      HH.forAll . Gen.element $
        [ Left (Foo.fooId foo)
        , Right (Foo.fooName foo)
        ]

    foundFoo <-
      Foo.withTable pool $ do
        _ <- Orville.insertEntity Foo.table foo
        Plan.execute plan param

    foundFoo === foo

prop_planMany_planEither :: Property.NamedDBProperty
prop_planMany_planEither =
  Property.namedDBProperty "(planMany planEither) executes either the right and left plans with appropriate inputs" $ \pool -> do
    let
      plan :: Plan.Plan scope [Either Foo.FooId Foo.FooName] (Many.Many (Either Foo.FooId Foo.FooName) Foo.Foo)
      plan =
        Plan.planMany $
          either id id
            <$> Plan.planEither
              (Plan.findOne Foo.table Foo.fooIdField)
              (Plan.findOne Foo.table Foo.fooNameField)

    foos <- HH.forAll $ Foo.generateList (Range.linear 0 10)

    let
      pickInput :: Foo.Foo -> HH.PropertyT IO (Either Foo.FooId Foo.FooName)
      pickInput foo =
        HH.forAll . Gen.element $
          [ Left (Foo.fooId foo)
          , Right (Foo.fooName foo)
          ]

    params <- traverse pickInput foos

    foundFoos <-
      Foo.withTable pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty foos)
        Plan.execute plan params

    assertEachManyResult params foundFoos $ \input foo ->
      case input of
        Left fooId ->
          Foo.fooId foo === fooId
        Right fooName ->
          Foo.fooName foo === fooName

prop_bindAndUse :: Property.NamedDBProperty
prop_bindAndUse =
  Property.namedDBProperty "bind/use allows caller to use plan output as input for another plan" $ \pool -> do
    let
      plan :: Plan.Plan scope Foo.FooName (Foo.Foo, [FooChild.FooChild])
      plan =
        Plan.bind (Plan.findOne Foo.table Foo.fooNameField) $ \foo ->
          let
            fooId = Foo.fooId <$> foo
          in
            (,)
              <$> Plan.use foo
              <*> Plan.using fooId (Plan.findAll FooChild.table FooChild.fooChildFooIdField)

    foo <- HH.forAll Foo.generate
    fooChild <- HH.forAll $ FooChild.generate [foo]

    result <-
      FooChild.withTables pool $ do
        _ <- Orville.insertEntity Foo.table foo
        _ <- Orville.insertEntity FooChild.table fooChild
        Plan.execute plan (Foo.fooName foo)

    result === (foo, [fooChild])

prop_planMany_bindAndUse :: Property.NamedDBProperty
prop_planMany_bindAndUse =
  Property.namedDBProperty "(planMany bind/use) allows caller to use plan output as input for another plan" $ \pool -> do
    let
      plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName (Foo.Foo, [FooChild.FooChild]))
      plan =
        Plan.planMany $
          Plan.bind (Plan.findOne Foo.table Foo.fooNameField) $ \foo ->
            let
              fooId = Foo.fooId <$> foo
            in
              (,)
                <$> Plan.use foo
                <*> Plan.using fooId (Plan.findAll FooChild.table FooChild.fooChildFooIdField)

    allFoos <- HH.forAll $ Foo.generateList (Range.linear 1 5)
    allChildren <- HH.forAll $ FooChild.generateList (Range.linear 0 20) allFoos

    let
      allFooNames = Foo.fooName <$> allFoos

    results <-
      FooChild.withTables pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty allFoos)
        traverse_ (Orville.insertEntities FooChild.table) (NEL.nonEmpty allChildren)
        Plan.execute plan allFooNames

    assertEachManyResult allFooNames results $ \fooName (foo, children) -> do
      Foo.fooName foo === fooName
      assertAllMatchesFound FooChild.fooChildId children (FooChild.isChildOf foo) allChildren

prop_planMany_findOne_dedupesInClauses :: Property.NamedDBProperty
prop_planMany_findOne_dedupesInClauses =
  Property.singletonNamedDBProperty "planMany/findOne dedupes in clause to avoid PostgreSQL parameter limit" $ \pool -> do
    let
      plan :: Plan.Plan scope [Foo.FooId] (Many.Many Foo.FooId Foo.Foo)
      plan =
        Plan.planMany (Plan.findOne Foo.table Foo.fooIdField)

    unsavedFoo <- HH.forAll Foo.generate

    results <-
      FooChild.withTables pool $ do
        savedFoo <- Orville.insertAndReturnEntity Foo.table unsavedFoo
        let
          fooIds =
            replicate 65536 (Foo.fooId savedFoo)

        Plan.execute plan fooIds

    length (Many.elems results) === 65536

#if defined(MIN_VERSION_GLASGOW_HASKELL)
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
prop_bindAndUse_qualifiedDo :: Property.NamedDBProperty
prop_bindAndUse_qualifiedDo =
  Property.namedDBProperty "bind/use allows caller to use plan output as input for another plan (QualifiedDo version)" $ \pool -> do
    let plan :: Plan.Plan scope Foo.FooName (Foo.Foo, [FooChild.FooChild])
        plan = PlanSyntax.do
          foo <- Plan.findOne Foo.table Foo.fooNameField

          let fooId = Foo.fooId <$> foo

          children <-
            Plan.using fooId $
              Plan.findAll FooChild.table FooChild.fooChildFooIdField

          (,)
            <$> Plan.use foo
            <*> Plan.use children

    foo <- HH.forAll Foo.generate
    fooChild <- HH.forAll $ FooChild.generate [foo]

    result <-
      FooChild.withTables pool $ do
        _ <- Orville.insertEntity Foo.table foo
        _ <- Orville.insertEntity FooChild.table fooChild
        Plan.execute plan (Foo.fooName foo)

    result === (foo, [fooChild])

prop_planMany_bindAndUse_qualifiedDo :: Property.NamedDBProperty
prop_planMany_bindAndUse_qualifiedDo =
  Property.namedDBProperty "(planMany bind/use) allows caller to use plan output as input for another plan (QualifiedDo version)" $ \pool -> do
    let plan :: Plan.Plan scope [Foo.FooName] (Many.Many Foo.FooName (Foo.Foo, [FooChild.FooChild]))
        plan =
          Plan.planMany $ PlanSyntax.do
            foo <- Plan.findOne Foo.table Foo.fooNameField

            let fooId = Foo.fooId <$> foo

            children <-
              Plan.using fooId $
                Plan.findAll FooChild.table FooChild.fooChildFooIdField

            (,)
              <$> Plan.use foo
              <*> Plan.use children

    allFoos <- HH.forAll $ Foo.generateList (Range.linear 1 5)
    allChildren <- HH.forAll $ FooChild.generateList (Range.linear 0 20) allFoos

    let allFooNames = Foo.fooName <$> allFoos

    results <-
      FooChild.withTables pool $ do
        traverse_ (Orville.insertEntities Foo.table) (NEL.nonEmpty allFoos)
        traverse_ (Orville.insertEntities FooChild.table) (NEL.nonEmpty allChildren)
        Plan.execute plan allFooNames

    assertEachManyResult allFooNames results $ \fooName (foo, children) -> do
      Foo.fooName foo === fooName
      assertAllMatchesFound FooChild.fooChildId children (FooChild.isChildOf foo) allChildren
#endif
#endif

prop_assert :: Property.NamedDBProperty
prop_assert =
  Property.namedDBProperty "assert raises an AssertionError in IO" $ \pool -> do
    let
      plan :: Plan.Plan scope (Either String ()) ()
      plan =
        Plan.assert (\_ value -> value) Plan.askParam

    input <- HH.forAll $ Gen.element [Left "Test Error", Right ()]
    result <- MIO.liftIO $ Exception.try $ Orville.runOrville pool (Plan.execute plan input)
    Either.isLeft (result :: Either Plan.AssertionFailed ()) === Either.isLeft input

prop_explain :: Property.NamedProperty
prop_explain =
  Property.namedProperty "explain shows the SQL steps that will be executed" $ do
    let
      plan :: Plan.Plan scope Foo.FooName [FooChild.FooChild]
      plan =
        Plan.chain
          (Plan.findOne Foo.table Foo.fooNameField)
          (Plan.focusParam Foo.fooId $ Plan.findAll FooChild.table FooChild.fooChildFooIdField)

      explanation =
        Plan.explain plan

    explanation
      === [ "SELECT \"name\",\"id\",\"name\",\"age\" FROM \"foo\" WHERE (\"name\") = ($1)"
          , "SELECT \"foo_id\",\"id\",\"foo_id\" FROM \"foo_child\" WHERE (\"foo_id\") = ($1)"
          ]

{- |
  Generates a list of Foos that along with FooName that could plausibly be
  found in the list zero, one or more times.

@since 1.0.0.0
-}
generateSearchTargetAndSubjects :: HH.Gen (Foo.FooName, [Foo.Foo])
generateSearchTargetAndSubjects = do
  targetName <- Foo.generateFooName

  let
    generatePossibleTargetFoo =
      Gen.choice
        [ Foo.generateFooWithName targetName
        , Foo.generate
        ]

  foos <- Foo.generateListUsing (Range.linear 0 5) generatePossibleTargetFoo
  pure (targetName, foos)

{- |
  Generates a list of Foos that along with FooName that could plausibly be
  found in the list zero, one or more times.

@since 1.0.0.0
-}
generateSearchTargetListAndSubjects :: HH.Gen ([Foo.FooName], [Foo.Foo])
generateSearchTargetListAndSubjects = do
  targetNames <- Gen.list (Range.linear 0 5) Foo.generateFooName

  let
    generatePossibleTargetFoo =
      Gen.choice (Foo.generate : fmap Foo.generateFooWithName targetNames)

  foos <- Foo.generateListUsing (Range.linear 0 5) generatePossibleTargetFoo
  pure (targetNames, foos)

{- |
  Uses Hedgehog's cover function to make sure common edge cases are covered
  for tests that are conducting a search. The predicate given should indicate
  whether the item would be expected to match the search being tested. The
  list of items should be the list that will be searced against.

@since 1.0.0.0
-}
coverSearchResultCases :: HH.MonadTest m => (a -> Bool) -> [a] -> m ()
coverSearchResultCases predicate subjects = do
  HH.cover 1 (String.fromString "no search subjects") (null subjects)
  HH.cover 1 (String.fromString "subjects present with no matches") (not (null subjects) && not (any predicate subjects))
  HH.cover 1 (String.fromString "at least 1 match") (length (filter predicate subjects) >= 1)

{- |
  Asserts that the given result is one that could have been produced by apply
  the predicate to the given list to find a single result. This assertion
  doesn't care which particular item from the list was found, as long as it the
  result matches the predicate and it is one from the list, or that nothing in
  the list matches if the 'Nothing' was found.

@since 1.0.0.0
-}
assertMatchIsFromPredicate ::
  (HH.MonadTest m, Eq entity) =>
  Maybe entity ->
  (entity -> Bool) ->
  [entity] ->
  m ()
assertMatchIsFromPredicate maybeEntity predicate subjects =
  case maybeEntity of
    Nothing ->
      HH.assert (not $ any predicate subjects)
    Just entity ->
      HH.assert (predicate entity && elem entity subjects)

{- |
  Asserts that the found items are all of those from the list that match the
  predicate, but without caring about order.

@since 1.0.0.0
-}
assertAllMatchesFound ::
  (HH.MonadTest m, Ord key, Eq entity, Show entity) =>
  -- | Key value to sort on to eliminate order dependencies
  (entity -> key) ->
  -- | the actual matches
  [entity] ->
  -- | the predicate to use for matching
  (entity -> Bool) ->
  -- | the full search space
  [entity] ->
  m ()
assertAllMatchesFound keyAttr foundEntities predicate allEntities =
  List.sortOn keyAttr foundEntities === List.sortOn keyAttr (filter predicate allEntities)

{- |
  Applies the given assertion for every key in the list. If any of the key
  is not found in the provided 'Many.Many' value, this assertion will fail.

@since 1.0.0.0
-}
assertEachManyResult ::
  (Show key, HH.MonadTest m) =>
  [key] ->
  Many.Many key value ->
  (key -> value -> m ()) ->
  m ()
assertEachManyResult expectedKeys manyValues assertion = do
  let
    checkResult key =
      case Many.lookup key manyValues of
        Left Many.NotAKey -> do
          HH.footnote $ "Expected " <> show key <> " to be a key in results, but it was not"
          HH.failure
        Right value ->
          assertion key value

  traverse_ checkResult expectedKeys