content: {-# LANGUAGE CPP #-}
  -- |
  -- Description : Test cases for tasks (Task)
  -- Copyright   : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004
  -- Authors     : Antony Courtney, Henrik Nilsson
  -- Very rudimentary testing of Task.
  module Test.FRP.Yampa.Task
      ( tests )
    where
  
  #if __GLASGOW_HASKELL__ < 710
  import Data.Functor ((<$>))
  #endif
  import Control.Monad (when, forever)
  
  import Test.QuickCheck
  import Test.Tasty (TestTree, testGroup)
  import Test.Tasty.QuickCheck (testProperty)
  
  import FRP.Yampa as Yampa
  
  import FRP.Yampa.LTLFuture  (TPred (Always, SP), evalT)
  import FRP.Yampa.QuickCheck (uniDistStream)
  import FRP.Yampa.Stream     (SignalSampleStream)
  
  import TestsCommon
  
  tests :: TestTree
  tests = testGroup "Regression tests for FRP.Yampa.Task"
    [ testProperty "tasks (fixed)" (property $ task_t0 ~= task_t0r)
    , testProperty "tasks (fixed)" (property $ task_t1 ~= task_t0r)  -- Intentionally! task_t0 = task_t1!
    , testProperty "tasks (fixed)" (property $ task_t2 ~= task_t2r)
    , testProperty "tasks (fixed)" (property $ task_t3 ~= task_t3r)
    , testProperty "tasks (fixed)" (property $ task_t4 ~= task_t4r)
    , testProperty "tasks (fixed)" (property $ task_t5 ~= task_t5r)
    , testProperty "tasks (fixed)" (property $ task_t6 ~= task_t6r)
    , testProperty "tasks (fixed)" (property $ task_t7 ~= task_t7r)
    , testProperty "tasks (fixed)" (property $ task_t8 ~= task_t8r)
    , testProperty "runTask_ (qc)" testRunTask_
    , testProperty "taskToSF (qc)" testTaskToSF
    , testProperty "constT (qc)"   testConstT
    ]
  
  -- * The Task type
  
  task_t0 = testSF1 (runTask (do
                                 mkTask (localTime
                                         &&&(localTime >>> arr (>=5.0) >>> edge))
                                 x <- snapT
                                 return (x * 2.0))
                    )
  
  task_t0r =
    [ Left 0.0,   Left 0.25,  Left 0.5,   Left 0.75,  Left 1.0
    , Left 1.25,  Left 1.5,   Left 1.75,  Left 2.0,   Left 2.25
    , Left 2.5,   Left 2.75,  Left 3.0,   Left 3.25,  Left 3.5
    , Left 3.75,  Left 4.0,   Left 4.25,  Left 4.5,   Left 4.75
    , Right 40.0, Right 40.0, Right 40.0, Right 40.0, Right 40.0
    ]
  
  task_t1 = testSF1 (runTask (do
                                 mkTask (localTime
                                         &&& (localTime>>>arr (>=5.0) >>> edge))
                                 return ()   -- No time should pass!
                                 return ()   -- No Time should pass!
                                 snapT       -- No time should pass!
                                 snapT       -- No time should pass!
                                 x <- snapT
                                 return (x * 2.0))
                    )
  
  task_t2 = testSF1 (runTask (do
                                 sleepT 1.51 42.0
                                 x <- snapT
                                 y <- snapT
                                 sleepT 1.51 x
                                 if x == y
                                   then sleepT 1.51 (x * 2)
                                   else sleepT 0.51 (x * 3)
                             )
                    )
  
  task_t2r =
    [ Left 42.0, Left 42.0, Left 42.0, Left 42.0  -- 0.0 s
    , Left 42.0, Left 42.0, Left 42.0, Left 7.0   -- 1.0 s
    , Left 7.0,  Left 7.0,  Left 7.0,  Left 7.0   -- 2.0 s
    , Left 7.0,  Left 7.0,  Left 14.0, Left 14.0  -- 3.0 s
    , Left 14.0, Left 14.0, Left 14.0, Left 14.0  -- 4.0 s
    , Left 14.0, Right (),  Right (),  Right ()   -- 5.0 s
    , Right ()
    ]
  
  task_t3 = testSF1 (runTask (do
                                c <- sawtooth `timeOut` 3.49
                                case c of
                                  Nothing -> sleepT 1.51 (-10.0)
                                  Just x  -> sleepT 1.51 x
                            )
                   )
    where
      sawtooth =
        forever ((mkTask (constant 2.0 >>> integral &&& never))
                 `timeOut` 1.5)
  
  task_t3r :: [Either Double ()]
  task_t3r =
    [ Left 0.0,     Left 0.5,     Left 1.0,     Left 1.5      -- 0.0 s
    , Left 2.0,     Left 2.5,     Left 0.0,     Left 0.5      -- 1.0 s
    , Left 1.0,     Left 1.5,     Left 2.0,     Left 2.5      -- 2.0 s
    , Left 0.0,     Left 0.5,     Left (-10.0), Left (-10.0)  -- 3.0 s
    , Left (-10.0), Left (-10.0), Left (-10.0), Left (-10.0)  -- 4.0 s
    , Left (-10.0), Right (),     Right (),     Right ()      -- 5.0 s
    , Right ()
    ]
  
  task_t4 = testSF1 (runTask (do
                                c <- sawtooth `timeOut` 3.49
                                case c of
                                  Nothing -> sleepT 1.51 (-10.0)
                                  Just x  -> sleepT 1.51 x
                             )
                    )
    where
      sawtooth = do
        for 1 (+1) (<=2)
            ((mkTask (constant 2.0 >>> integral &&& never))
             `timeOut` 1.5)
        return (-42.0)
  
  task_t4r :: [Either Double ()]
  task_t4r =
    [ Left 0.0,     Left 0.5,     Left 1.0,     Left 1.5      -- 0.0 s
    , Left 2.0,     Left 2.5,     Left 0.0,     Left 0.5      -- 1.0 s
    , Left 1.0,     Left 1.5,     Left 2.0,     Left 2.5      -- 2.0 s
    , Left (-42.0), Left (-42.0), Left (-42.0), Left (-42.0)  -- 3.0 s
    , Left (-42.0), Left (-42.0), Left (-42.0), Right ()      -- 4.0 s
    , Right (),     Right (),     Right (),     Right ()      -- 5.0 s
    , Right ()
    ]
  
  task_t5 = testSF1 (runTask (do
                                x<-(sawtoothCycle>>snapT) `repeatUntil` (>=20.0)
                                y<-snapT
                                return (x == y)
                             )
                    )
    where
      sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())
  
  task_t5r :: [Either Double Bool]
  task_t5r =
    [ Left 0.0, Left 0.5, Left 1.0, Left 1.5  -- 0.0 s, 0 - 3
    , Left 2.0, Left 2.5, Left 0.0, Left 0.5  -- 1.0 s, 4 - 7
    , Left 1.0, Left 1.5, Left 2.0, Left 2.5  -- 2.0 s, 8 - 11
    , Left 0.0, Left 0.5, Left 1.0, Left 1.5  -- 3.0 s, 12 - 15
    , Left 2.0, Left 2.5, Left 0.0, Left 0.5  -- 4.0 s, 16 - 19
    , Left 1.0, Left 1.5, Left 2.0, Left 2.5  -- 5.0 s, 20 - 23
    , Right True
    ]
  
  task_t6 = testSF1 $ runTask $ do
      x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0))
           `abortWhen` (localTime >>> arr (>=3.51) >>> edge)
      y <- snapT
      return (x,y)
    where
      sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())
  
  task_t6r :: [Either Double (Either Double (), Double)]
  task_t6r =
    [ Left 0.0, Left 0.5, Left 1.0, Left 1.5              -- 0.0 s, 0 - 3
    , Left 2.0, Left 2.5, Left 0.0, Left 0.5              -- 1.0 s, 4 - 7
    , Left 1.0, Left 1.5, Left 2.0, Left 2.5              -- 2.0 s, 8 - 11
    , Left 0.0, Left 0.5, Left 1.0, Right (Right (),15.0) -- 3.0 s, 12 - 15
    , Right (Right (),15.0), Right (Right (),15.0)        -- 4.0 s, 16, 17
    , Right (Right (),15.0), Right (Right (),15.0)        -- 4.5 s, 18, 19
    , Right (Right (),15.0), Right (Right (),15.0)        -- 5.0 s, 20, 21
    , Right (Right (),15.0), Right (Right (),15.0)        -- 5.5 s, 22, 23
    , Right (Right (),15.0)
    ]
  
  task_t7 = testSF1 $ runTask $ do
      x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0))
           `abortWhen` (localTime >>> arr (>=5.75) >>> edge)
      y <- snapT
      return (x,y)
    where
      sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())
  
  task_t7r :: [Either Double (Either Double (), Double)]
  task_t7r =
      [ Left 0.0, Left 0.5, Left 1.0, Left 1.5              -- 0.0 s, 0 - 3
      , Left 2.0, Left 2.5, Left 0.0, Left 0.5              -- 1.0 s, 4 - 7
      , Left 1.0, Left 1.5, Left 2.0, Left 2.5              -- 2.0 s, 8 - 11
      , Left 0.0, Left 0.5, Left 1.0, Left 1.5              -- 3.0 s, 12 - 15
      , Left 2.0, Left 2.5, Left 0.0, Left 0.5              -- 4.0 s, 16 - 19
      , Left 1.0, Left 1.5, Left 2.0, Right (Right (),23.0) -- 5.0 s, 20 - 23
      , Right (Right (),23.0)
      ]
  
  task_t8 = testSF1 $ runTask $ do
      x <- ((sawtoothCycle >> snapT) `repeatUntil` (>=20.0))
           `abortWhen` (localTime >>> arr (>=5.76) >>> edge)
      y <- snapT
      return (x,y)
    where
      sawtoothCycle = mkTask (constant 2.0 >>> integral &&& after 1.5 ())
  
  -- Since abortWhen uses lMergeEvent, the terminating event of the task
  -- gets priority over the aborting event.
  task_t8r :: [Either Double (Either Double (), Double)]
  task_t8r =
      [ Left 0.0, Left 0.5, Left 1.0, Left 1.5  -- 0.0 s, 0 - 3
      , Left 2.0, Left 2.5, Left 0.0, Left 0.5  -- 1.0 s, 4 - 7
      , Left 1.0, Left 1.5, Left 2.0, Left 2.5  -- 2.0 s, 8 - 11
      , Left 0.0, Left 0.5, Left 1.0, Left 1.5  -- 3.0 s, 12 - 15
      , Left 2.0, Left 2.5, Left 0.0, Left 0.5  -- 4.0 s, 16 - 19
      , Left 1.0, Left 1.5, Left 2.0, Left 2.5  -- 5.0 s, 20 - 23
      , Right (Left 24.0,24.0)
      ]
  
  testRunTask_ :: Property
  testRunTask_ =
      forAll arbitrary $ \i ->
      forAll myStream $
        evalT $ Always $ prop (sf i &&& sfModel i, pred)
    where
      myStream :: Gen (SignalSampleStream Float)
      myStream = uniDistStream
  
      sf :: Double -> SF Float Double
      sf x = runTask_ $ constT x
  
      sfModel :: Double -> SF Float Double
      sfModel x = constant x
  
      -- Both the SF under test and the model should behave the same way,
      -- that is, output the same result.
      pred _ = uncurry (==)
  
  testTaskToSF :: Property
  testTaskToSF =
      forAll positive $ \t ->
      forAll arbitrary $ \i ->
      forAll arbitrary $ \j ->
      forAll myStream $
        evalT (Always $ prop (sf t i j &&& sfModel t i j, pred))
    where
      myStream :: Gen (SignalSampleStream Float)
      myStream = uniDistStream
  
      positive :: Gen Double
      positive = getPositive <$> arbitrary
  
      -- Note that we use switch to abandon the Task after it terminates. Tasks
      -- do not produce correct output once they finish, they just throw an
      -- error.
      sf :: Time -> Double -> Double -> SF Float Double
      sf t x y = switch (taskToSF (sleepT t x)) (\_ -> constant y)
  
      -- Note that we use switch to abandon the Task after it terminates. Tasks
      -- do not produce correct output once they finish, they just throw an
      -- error.
      sfModel :: Time -> Double -> Double -> SF Float Double
      sfModel t x y = switch
        -- Output x, and indicate when time t is exceeded for the first time
        (constant x &&& (time >>> arr (>= t) >>> edge))
        (\_ -> constant y)
  
      -- Both the SF under test and the model should behave the same way,
      -- that is, output the same result.
      pred _ = uncurry (==)
  
  testConstT :: Property
  testConstT =
      forAll arbitrary $ \i ->
      forAll myStream $
        evalT $ Always $ prop (sf i &&& sfModel i, pred)
    where
      myStream :: Gen (SignalSampleStream Float)
      myStream = uniDistStream
  
      -- Task that constantly outputs a value. If it finishes (which it
      -- shouldn't), then return the negated value.
      sf :: Double -> SF Float (Either Double ())
      sf x = runTask (constT x)
  
      -- SF that constantly outputs a value on the Left side of an Either.
      sfModel :: Double -> SF Float (Either Double ())
      sfModel x = constant $ Left x
  
      -- Both the SF under test and the model should behave the same way,
      -- that is, output the same result.
      pred _ = uncurry (==)
  
  -- * Auxiliary
  
  -- | Repeat m until result satisfies the predicate p
  repeatUntil :: Monad m => m a -> (a -> Bool) -> m a
  m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x
  
  -- | C-style for-loop.
  --
  -- Example:
  --
  -- >>> for 0 (+1) (>=10) ...
  for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()
  for i f p m = when (p i) $ m >> for (f i) f p m
  
  prop :: (SF a b, a -> b -> Bool) -> TPred a
  prop (a, b) = SP ((identity &&& a) >>^ uncurry b)
  