{-# OPTIONS_GHC -Wno-orphans #-}

module Main where

import Control.Selective
import Data.Bifunctor (bimap)
import Data.Foldable (traverse_)
import Data.Int (Int8)
import Data.Monoid (Any)
import Data.Set (Set)
import GHC.Generics (Generic)
import Lasercutter
import Lasercutter.Types
import Test.QuickCheck
import Test.QuickCheck.Checkers hiding (Test)
import Test.QuickCheck.Classes


type Test = Parser (Set Four) DebugTree


main :: IO ()
main = do
  traverse_ quickCheck
    [ -- expect is a left identity to optional
      property $ expect . optional =-= id @(Test Int8)

    , -- optional is a left identity to expect
      property $ optional . expect =-= id @(Test (Maybe Int8))

    , -- expect nothing is equivalent to fail
      property $ expect (pure Nothing) =-= (Fail :: Test Int8)

      -- expect distributes over liftA2
    , property $ \(f :: Int8 -> Four -> Bool) a b ->
        expect (liftA2 (liftA2 f) a b) =-= liftA2 @Test f (expect a) (expect b)

      -- optional equivalent to try
    , property $ optional @(Test) @Int8 =-= try
    ]

  quickBatch $ functor     $ undefined @_ @(Test (Int8, Int8, Int8))
  quickBatch $ applicative $ undefined @_ @(Test (Int8, Int8, Int8))
  quickBatch $ selective   $ undefined @_ @(Test (Int8, Int8, Int8))
  quickBatch $ alternative $ undefined @_ @(Test Int8)
  quickBatch $ semigroup   $ undefined @_ @(Test Any, Int8)
  quickBatch $ monoid      $ undefined @_ @(Test Any)


------------------------------------------------------------------------------

instance {-# OVERLAPPABLE #-}
    ( CoArbitrary t
    , Arbitrary a
    , Arbitrary bc
    , CoArbitrary bc
    , CoArbitrary a
    ) =>
    Arbitrary (Parser bc t a)
      where
  arbitrary
    = let terminal
            = [ Pure <$> arbitrary
              , pure Fail
              ]
      in sized $ \ n ->
          case n <= 1 of
            True -> oneof terminal
            False -> oneof $
              [ liftA2
                  <$> (arbitrary @(bc -> Int8 -> a))
                  <*> scale (flip div 2) arbitrary
                  <*> scale (flip div 2) arbitrary
              , liftA2
                  <$> (arbitrary @(Bool -> Bool -> a))
                  <*> scale (flip div 2) arbitrary
                  <*> scale (flip div 2) arbitrary
              , liftA2
                  <$> (arbitrary @(a -> a -> a))
                  <*> scale (flip div 2) arbitrary
                  <*> scale (flip div 2) arbitrary
              , fmap <$> arbitrary <*> pure Current
              , expect <$> scale (subtract 1) arbitrary
               ] <> terminal
  shrink (Pure a)         = Fail : (fmap Pure $ shrink a)
  shrink GetCrumbs        = [Fail]
  shrink (LiftA2 _ _ _)   = [Fail]
  shrink (Target _ pa')   = Fail : (pure $ fmap pure pa')
  shrink (OnChildren pa') = Fail : (pure $ fmap pure pa')
  shrink Current          = [Fail]
  shrink (Expect pa')     = Fail : (fmap expect $ shrink pa')
  shrink Fail = []


instance
    ( CoArbitrary t
    , Arbitrary a
    , Arbitrary (Parser bc t a)
    , CoArbitrary bc
    , CoArbitrary a
    , Arbitrary bc
    ) =>
    Arbitrary (Parser bc t [a])
      where
  arbitrary
    = let terminal
            = [ Pure <$> arbitrary
              , pure Fail
              ]
      in sized $ \ n ->
          case n <= 1 of
            True -> oneof terminal
            False -> oneof $
              [ liftA2
                  <$> arbitrary @(bc -> Int8 -> [a])
                  <*> scale (flip div 2) arbitrary
                  <*> scale (flip div 2) arbitrary
              , liftA2
                  <$> arbitrary @(Bool -> Bool -> [a])
                  <*> scale (flip div 2) arbitrary
                  <*> scale (flip div 2) arbitrary
              , liftA2
                  <$> arbitrary @(a -> a -> [a])
                  <*> scale (flip div 2) arbitrary
                  <*> scale (flip div 2) arbitrary
              , fmap <$> arbitrary <*> pure Current
              , Target <$> arbitrary <*> scale (subtract 1) arbitrary
              , OnChildren <$> scale (subtract 1) arbitrary
              , expect <$> scale (subtract 1) arbitrary
              ] <> terminal
  shrink (Pure a)         = Fail : (fmap Pure $ shrink a)
  shrink Current          = [Fail]
  shrink GetCrumbs        = [Fail]
  shrink (LiftA2 _ _ _)   = [Fail]
  shrink (Target _ pa')   = Fail : (pure $ fmap pure pa')
  shrink (OnChildren pa') = Fail : (pure $ fmap pure pa')
  shrink (Expect pa')     = Fail : (fmap expect $ shrink pa')
  shrink Fail = []


instance
    ( CoArbitrary t
    , Arbitrary a
    , Arbitrary (Parser bc t a)
    , CoArbitrary bc
    , CoArbitrary a
    , Arbitrary bc
    ) =>
    Arbitrary (Parser bc t (Maybe a))
      where
  arbitrary
    = let terminal
            = [ Pure <$> arbitrary
              , pure Fail
              ]
      in sized $ \ n ->
          case n <= 1 of
            True -> oneof terminal
            False -> oneof $
              [ liftA2
                  <$> arbitrary @(bc -> Int8 -> Maybe a)
                  <*> scale (flip div 2) arbitrary
                  <*> scale (flip div 2) arbitrary
              , liftA2
                  <$> arbitrary @(Bool -> Bool -> Maybe a)
                  <*> scale (flip div 2) arbitrary
                  <*> scale (flip div 2) arbitrary
              , liftA2
                  <$> arbitrary @(a -> a -> Maybe a)
                  <*> scale (flip div 2) arbitrary
                  <*> scale (flip div 2) arbitrary
              , fmap <$> arbitrary <*> pure Current
              , try <$> scale (subtract 1) arbitrary
              , expect <$> scale (subtract 1) arbitrary
              ] <> terminal
  shrink (Pure a)         = Fail : (fmap Pure $ shrink a)
  shrink GetCrumbs        = [Fail]
  shrink Current          = [Fail]
  shrink (LiftA2 _ _ _)   = [Fail]
  shrink (Expect pa')     = Fail : (fmap expect $ shrink pa')
  shrink Fail = []


------------------------------------------------------------------------------

data Four = A | B | C | D
  deriving (Eq, Ord, Show, Enum, Bounded, Generic)

instance Arbitrary Four where
  arbitrary = elements $ enumFromTo minBound maxBound

instance CoArbitrary Four

instance EqProp Four


------------------------------------------------------------------------------

data DebugTree
  = Leaf Int8
  | Branch Four [DebugTree]
  deriving (Eq, Ord, Show, Generic)

instance Arbitrary DebugTree where
  arbitrary
    = let terminal = [Leaf <$> arbitrary]
      in sized $ \ n ->
          case n <= 1 of
            True -> oneof terminal
            False -> oneof $
              [ Branch <$> arbitrary <*> scale (flip div 2) arbitrary
              ] <> terminal

instance CoArbitrary DebugTree

instance EqProp DebugTree

instance IsTree DebugTree where
  getChildren (Leaf _) = []
  getChildren (Branch _ x) = x


------------------------------------------------------------------------------

instance (EqProp a) => EqProp (Parser (Set Four) DebugTree a) where
  p1 =-= p2 = property $ do
    t <- arbitrary
    f <- arbitrary
    pure $ runParser f t p1 =-= runParser f t p2


------------------------------------------------------------------------------

instance EqProp Int8 where
  (=-=) = (===)


------------------------------------------------------------------------------

selective :: forall m a b c.
               ( Selective m
               , Arbitrary a, Arbitrary b
               , Arbitrary (m (Either a a)), Show (m (Either a a))
               , Arbitrary (m (Either a b)), Show (m (Either a b))
               , Arbitrary (m (Either c (a -> b))), Show (m (Either c (a -> b)))
               , Arbitrary (m (a -> b)), Show (m (a -> b))
               , Arbitrary (m (c -> a -> b)), Show (m (c -> a -> b))
               , Show a, Show b
               , EqProp (m a), EqProp (m b)
               ) =>
               m (a,b,c) -> TestBatch
selective = const ( "selective"
                  , [ ("identity"    , property identityP)
                    , ("distributivity" , property distributivityP)
                    , ("associativity", property associativityP)
                    ]
                  )
 where
   identityP     :: m (Either a a) -> Property
   distributivityP  :: Either a b -> m (a -> b) -> m (a -> b) -> Property
   associativityP :: m (Either a b) -> m (Either c (a -> b)) -> m (c -> a -> b) -> Property

   identityP x = (x <*? pure id) =-= fmap (either id id) x
   distributivityP x y z = (pure x <*? (y *> z)) =-= ((pure x <*? y) *> (pure x <*? z))
   associativityP x y z = (x <*? (y <*? z)) =-= ((fmap Right <$> x) <*? (g <$> y) <*? (uncurry <$> z))
    where
     g y' a = bimap (,a) ($a) y'