Lib.hs

{-# LANGUAGE DoAndIfThenElse, FlexibleInstances , MultiParamTypeClasses,GADTs, TypeOperators, TupleSections, ScopedTypeVariables,ConstraintKinds,FlexibleContexts,UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.FRPNow.Lib
-- Copyright   :  (c) Atze van der Ploeg 2015
-- License     :  BSD-style
-- Maintainer  :  atzeus@gmail.org
-- Stability   :  provisional
-- Portability :  portable
-- 
-- Utility FRPNow functions
module Control.FRPNow.Lib(
   -- * Behavior construction
   step,
   cstep,
   -- * Getting events from behaviors 
   when,
   change,
   edge,
   -- * Events and their ordering
   tryGetEv,
   hasOccured,
   first,
   cmpTime,
   EvOrd(..),
   -- * Fold and state
   prev,
   foldB,
   sampleUntil,
   -- * Sample behaviors on events
   planB,
   snapshot,
   (<@>),
   -- * Type classes for uniform interface
   Plan(..),
   Sample(..),
   -- * Debugging 
   traceChanges )
   
 where


import Control.FRPNow.Core
import Control.Applicative
import Control.Monad hiding (when)
import Prelude hiding (until)
import Debug.Trace


-- | Start with a constant and then switch 
-- 
-- Defined as: 
--
-- > step a s = pure a `switch` s
step :: a -> Event (Behavior a) -> Behavior a
step a s = pure a `switch` s


-- | Start with a constant, and switch to another constant when the event arrives.
--
-- Defined as:
-- 
-- >  cstep x e y = pure x `switch` (pure y <$ e)
cstep :: a -> Event x -> a -> Behavior a
cstep x e y = pure x `switch` (pure y <$ e)

-- | Like 'Control.FRPNow.whenJust' but on behaviors of type @Bool@ instead of @Maybe@. 
-- 
--  Gives the event that the input behavior is @True@
when :: Behavior Bool -> Behavior (Event ())
when b = whenJust (boolToMaybe <$> b) where
  boolToMaybe True   = Just ()
  boolToMaybe False  = Nothing


-- | Gives the previous value of the behavior, starting with given value. 
-- 
--  This /cannot/ be used to prevent immediate feedback loop! Use 'Control.FRPNow.EvStream.delay' instead!
prev :: Eq a => a -> Behavior a -> Behavior (Behavior a)
prev i b = loop i where
  loop i = do e <- nxtCur
              return (i `step` e)
  nxtCur = futuristic $ 
             do cur <- b
                e <- change b
                planB (loop cur <$ e)

-- | Gives at any point in time the event that the input behavior changes, and the new value of the input behavior.
change :: Eq a => Behavior a -> Behavior (Event a)
change b = futuristic $ 
           do v <- b ;
              whenJust (notSame v <$> b) where
    notSame v v' | v /= v'   = Just v'
                 | otherwise = Nothing
               


-- | The resulting behavior gives at any point in time, the event that the input
-- behavior next /becomes/ true. I.e. the next event that there is an edge from False to True. If the input behavior is True already, the event gives the
-- time that it is True again, after first being False for a period of time.
edge :: Behavior Bool -> Behavior (Event ())
edge b = futuristic $ 
             b >>= \v -> 
              if v then (do e <- when (not <$> b)
                            join <$> plan (when b <$ e))
              else when b

-- | A (left) fold over a behavior.
--
-- The inital value of the resulting behavior is @f i x@ where @i@ the initial value given, and @x@ is the current value of the behavior.
--
foldB :: Eq a => (b -> a -> b) -> b -> Behavior a -> Behavior (Behavior b)
foldB f i b = loop i where
  loop i = do  c   <- b
               let i' = f i c
               e   <-  change b
               e'  <-  snapshot (loop i') (() <$ e)
               return (pure i' `switch` e')

-- | When sampled at a point in time t, the behavior gives an event with 
-- the list of all values of the input behavior between time t and the
-- time that the argument event occurs (including the value when the event occurs). 
sampleUntil :: Eq a => Behavior a -> Event () -> Behavior (Event [a])
sampleUntil b end  = loop [] where
  loop ss = do s <- b
               let ss' = s : ss
               e <- hasOccured end
               if e then return (pure (reverse ss'))
               else do c <- change b
                       join <$> plan (loop ss' <$ c)


-- | Convert an event into a behavior that gives 
-- @Nothing@ if the event has not occured yet, and @Just@ the value of the event if the event has already occured.
tryGetEv :: Event a -> Behavior (Maybe a)
tryGetEv e = pure Nothing `switch` ((pure . Just) <$> e)

-- | The resulting behavior states wheter the input event has already occured.
hasOccured :: Event x -> Behavior Bool
hasOccured e = False `step` (pure True <$ e)

-- | Gives the first of two events. 
-- 
-- If either of the events lies in the future, then the result will be the first of these events.
-- If both events have already occured, the left event is returned.
first :: Event a -> Event a -> Behavior (Event a)
first l r = whenJust (tryGetEv r `switch` ((pure . Just) <$> l))

-- | Compare the time of two events.
-- 
-- The resulting behavior gives an event, occuring at the same time 
-- as the earliest input event, of which the value indicates if the event where
-- simultanious, or if one was earlier. 
--
-- If at the time of sampling both event lie in the past, then 
-- the result is that they are simulatinous.
cmpTime :: Event a -> Event b -> Behavior (Event (EvOrd a b))
cmpTime l r = whenJust (outcome <$> tryGetEv l <*> tryGetEv r) where
  outcome Nothing  Nothing  = Nothing
  outcome (Just x) Nothing  = Just (LeftEarlier x)
  outcome Nothing  (Just y) = Just (RightEarlier y)
  outcome (Just x) (Just y) = Just (Simul x y)

-- | The outcome of a 'cmpTime': the events occur simultanious, left is earlier or right is earlier.
data EvOrd l r = Simul l r
               | LeftEarlier l
               | RightEarlier r


-- | Plan to sample the behavior carried by the event as soon as possible. 
-- 
-- If the resulting behavior is sampled after the event occurs,
-- then the behavior carried by the event will be sampled now.
planB :: Event (Behavior a) -> Behavior (Event a)
planB e =  whenJust 
           (pure Nothing `switch` ((Just <$>) <$> e)) 


-- | Obtain the value of the behavior at the time the event occurs
--
-- If the event has already occured when sampling the resulting behavior,
-- we sample not the past, but the current value of the input behavior.
snapshot :: Behavior a -> Event () -> Behavior (Event a)
snapshot b e =  let e' = (Just <$> b) <$ e
                in whenJust (pure Nothing `switch` e')

-- | Like 'snapshot', but feeds the result of the event to the
-- value of the given behavior at that time.
(<@>) :: Behavior (a -> b) -> Event a -> Behavior (Event b)
b <@> e = plan $ fmap (\x -> b <*> pure x) e






-- | A type class to unifying 'planNow' and 'planB'
class Monad b => Plan b where
  plan :: Event (b a) -> b (Event a)

instance Plan Now where plan = planNow
instance Plan Behavior where plan = planB

-- | A type class for behavior-like monads, such 'Now' and the monads from "Control.FRPNow.BehaviorEnd"
class Monad n => Sample n where
   sample :: Behavior a -> n a

instance Sample Behavior where sample = id
instance Sample Now where sample = sampleNow




-- | A debug function, prints all values of the behavior to stderr, prepended with the given string.
traceChanges :: (Eq a, Show a) => String -> Behavior a -> Now ()
traceChanges s b = loop where
 loop = do v <- sample b
           sync $ traceIO (s ++ show v)
           e <- sample $ change b
           planNow (loop <$ e)
           return ()