{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

module Sketch.FRP.Copilot where

import Sketch.FRP.Copilot.Types
import Language.Copilot hiding (ifThenElse)
import qualified Language.Copilot
import Control.Monad.Writer
import Control.Monad.State.Strict
import Data.Functor.Identity

-- | Use this to make a LED blink on and off.
--
-- On each iteration of the `Sketch`, this changes to the opposite of its
-- previous value.
--
-- This is implemented using Copilot's `clk`, so to get other blinking
-- behaviors, just pick different numbers, or use Copilot `Stream`
-- combinators.
--
-- > blinking = clk (period 2) (phase 1)
blinking :: Behavior Bool
blinking :: Behavior Bool
blinking = Period Integer -> Phase Integer -> Behavior Bool
forall a. Integral a => Period a -> Phase a -> Behavior Bool
clk (Integer -> Period Integer
forall a. Integral a => a -> Period a
period (Integer
2 :: Integer)) (Integer -> Phase Integer
forall a. Integral a => a -> Phase a
phase (Integer
1 :: Integer))

-- | True on the first iteration of the `Sketch`, and False thereafter.
firstIteration :: Behavior Bool
firstIteration :: Behavior Bool
firstIteration = [Bool
True][Bool] -> Behavior Bool -> Behavior Bool
forall a. Typed a => [a] -> Stream a -> Stream a
++Behavior Bool
false

-- | Use this to make an event occur 1 time out of n.
--
-- This is implemented using Copilot's `clk`:
--
-- > frequency = clk (period n) (phase 1)
frequency :: Integer -> Behavior Bool
frequency :: Integer -> Behavior Bool
frequency Integer
n = Period Integer -> Phase Integer -> Behavior Bool
forall a. Integral a => Period a -> Phase a -> Behavior Bool
clk (Integer -> Period Integer
forall a. Integral a => a -> Period a
period Integer
n) (Integer -> Phase Integer
forall a. Integral a => a -> Phase a
phase Integer
1)

-- | Schedule when to perform different Sketches.
scheduleB
	:: (Typed t, Eq t, Context ctx)
	=> Behavior t
	-> [(t, GenSketch ctx ())]
	-> GenSketch ctx ()
scheduleB :: Behavior t -> [(t, GenSketch ctx ())] -> GenSketch ctx ()
scheduleB Behavior t
b = [GenSketch ctx ()] -> GenSketch ctx ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([GenSketch ctx ()] -> GenSketch ctx ())
-> ([(t, GenSketch ctx ())] -> [GenSketch ctx ()])
-> [(t, GenSketch ctx ())]
-> GenSketch ctx ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((t, GenSketch ctx ()) -> GenSketch ctx ())
-> [(t, GenSketch ctx ())] -> [GenSketch ctx ()]
forall a b. (a -> b) -> [a] -> [b]
map (t, GenSketch ctx ()) -> GenSketch ctx ()
forall ctx t.
Context ctx =>
(t, GenSketch ctx t) -> GenSketch ctx t
go
  where
	go :: (t, GenSketch ctx t) -> GenSketch ctx t
go (t
v, GenSketch ctx t
s) = Behavior Bool -> GenSketch ctx t -> GenSketch ctx t
forall ctx t.
Context ctx =>
Behavior Bool -> GenSketch ctx t -> GenSketch ctx t
whenB (Behavior t
b Behavior t -> Behavior t -> Behavior Bool
forall a. (Eq a, Typed a) => Stream a -> Stream a -> Behavior Bool
== t -> Behavior t
forall a. Typed a => a -> Stream a
constant t
v) GenSketch ctx t
s

-- | Apply a Copilot DSL function to a `TypedBehavior`.
liftB
	:: (Behavior a -> Behavior r)
	-> TypedBehavior t a
	-> Behavior r
liftB :: (Behavior a -> Behavior r) -> TypedBehavior t a -> Behavior r
liftB Behavior a -> Behavior r
f (TypedBehavior Behavior a
b) = Behavior a -> Behavior r
f Behavior a
b

-- | Apply a Copilot DSL function to two `TypedBehavior`s.
liftB2
	:: (Behavior a -> Behavior b -> Behavior r)
	-> TypedBehavior t a
	-> TypedBehavior t b
	-> Behavior r
liftB2 :: (Behavior a -> Behavior b -> Behavior r)
-> TypedBehavior t a -> TypedBehavior t b -> Behavior r
liftB2 Behavior a -> Behavior b -> Behavior r
f (TypedBehavior Behavior a
a) (TypedBehavior Behavior b
b) = Behavior a -> Behavior b -> Behavior r
f Behavior a
a Behavior b
b

-- | Limit the effects of a `Sketch` to times when a `Behavior` `Bool` is True.
--
-- When applied to `=:`, this does the same thing as `@:` but without
-- the FRP style conversion the input `Behavior` into an `Event`. So `@:`
-- is generally better to use than this.
--
-- But, this can also be applied to `input`, to limit how often input
-- gets read. Useful to avoid performing slow input operations on every
-- iteration of a Sketch.
--
-- > v <- whenB (frequency 10) $ input pin12
--
-- (It's best to think of the value returned by that as an Event,
-- but it's currently represented as a Behavior, since the Copilot DSL
-- cannot operate on Events.)
whenB :: Context ctx => Behavior Bool -> GenSketch ctx t -> GenSketch ctx t
whenB :: Behavior Bool -> GenSketch ctx t -> GenSketch ctx t
whenB Behavior Bool
c (GenSketch WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
  (State UniqueIds)
  t
s) = do
	UniqueIds
ids <- GenSketch ctx UniqueIds
forall s (m :: * -> *). MonadState s m => m s
get
	let ((t
r, [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
w), UniqueIds
ids') = Identity
  ((t, [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]),
   UniqueIds)
-> ((t,
     [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]),
    UniqueIds)
forall a. Identity a -> a
runIdentity (Identity
   ((t, [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]),
    UniqueIds)
 -> ((t,
      [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]),
     UniqueIds))
-> Identity
     ((t, [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]),
      UniqueIds)
-> ((t,
     [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]),
    UniqueIds)
forall a b. (a -> b) -> a -> b
$ StateT
  UniqueIds
  Identity
  (t, [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)])
-> UniqueIds
-> Identity
     ((t, [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]),
      UniqueIds)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
  (State UniqueIds)
  t
-> StateT
     UniqueIds
     Identity
     (t, [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
  (State UniqueIds)
  t
s) UniqueIds
ids
	UniqueIds -> GenSketch ctx ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put UniqueIds
ids'
	let ([TriggerLimit -> Spec]
is, [TriggerLimit -> GenFramework ctx]
fs) = [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
-> ([TriggerLimit -> Spec], [TriggerLimit -> GenFramework ctx])
forall a b. [(a, b)] -> ([a], [b])
unzip [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
w
	let spec :: TriggerLimit -> Spec
spec = (TriggerLimit -> Spec) -> TriggerLimit -> Spec
forall a. (TriggerLimit -> a) -> TriggerLimit -> a
combinetl ((TriggerLimit -> Spec) -> TriggerLimit -> Spec)
-> (TriggerLimit -> Spec) -> TriggerLimit -> Spec
forall a b. (a -> b) -> a -> b
$ \TriggerLimit
c' -> [Spec] -> Spec
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (((TriggerLimit -> Spec) -> Spec)
-> [TriggerLimit -> Spec] -> [Spec]
forall a b. (a -> b) -> [a] -> [b]
map (\TriggerLimit -> Spec
i -> TriggerLimit -> Spec
i TriggerLimit
c') [TriggerLimit -> Spec]
is)
	[(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
-> GenSketch ctx ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(TriggerLimit -> Spec
spec, TriggerLimit -> GenFramework ctx
forall a. Monoid a => a
mempty)]
	[TriggerLimit -> GenFramework ctx]
-> ((TriggerLimit -> GenFramework ctx) -> GenSketch ctx ())
-> GenSketch ctx ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TriggerLimit -> GenFramework ctx]
fs (((TriggerLimit -> GenFramework ctx) -> GenSketch ctx ())
 -> GenSketch ctx ())
-> ((TriggerLimit -> GenFramework ctx) -> GenSketch ctx ())
-> GenSketch ctx ()
forall a b. (a -> b) -> a -> b
$ \TriggerLimit -> GenFramework ctx
f -> [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
-> GenSketch ctx ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(\TriggerLimit
_tl -> (() -> Spec
forall (m :: * -> *) a. Monad m => a -> m a
return ()), (TriggerLimit -> GenFramework ctx)
-> TriggerLimit -> GenFramework ctx
forall a. (TriggerLimit -> a) -> TriggerLimit -> a
combinetl TriggerLimit -> GenFramework ctx
f)]
	t -> GenSketch ctx t
forall (m :: * -> *) a. Monad m => a -> m a
return t
r
  where
	combinetl :: (TriggerLimit -> a) -> TriggerLimit -> a
	combinetl :: (TriggerLimit -> a) -> TriggerLimit -> a
combinetl TriggerLimit -> a
g TriggerLimit
tl = TriggerLimit -> a
g (Behavior Bool -> TriggerLimit
TriggerLimit Behavior Bool
c TriggerLimit -> TriggerLimit -> TriggerLimit
forall a. Semigroup a => a -> a -> a
<> TriggerLimit
tl)

class IfThenElse t a where
	-- | This allows "if then else" expressions to be written
	-- that choose between two Streams, or Behaviors, or TypedBehaviors,
	-- or Sketches, when the RebindableSyntax language extension is
	-- enabled.
	--
	-- > {-# LANGUAGE RebindableSyntax #-}
	-- > buttonpressed <- input pin3
	-- > if buttonpressed then ... else ...
	ifThenElse :: Behavior Bool -> t a -> t a -> t a

instance Typed a => IfThenElse Stream a where
	ifThenElse :: Behavior Bool -> Stream a -> Stream a -> Stream a
ifThenElse = Behavior Bool -> Stream a -> Stream a -> Stream a
forall a.
Typed a =>
Behavior Bool -> Stream a -> Stream a -> Stream a
Language.Copilot.ifThenElse

instance Typed a => IfThenElse (TypedBehavior p) a where
	ifThenElse :: Behavior Bool
-> TypedBehavior p a -> TypedBehavior p a -> TypedBehavior p a
ifThenElse Behavior Bool
c (TypedBehavior Behavior a
a) (TypedBehavior Behavior a
b) =
		Behavior a -> TypedBehavior p a
forall k (p :: k) t. Behavior t -> TypedBehavior p t
TypedBehavior (Behavior Bool -> Behavior a -> Behavior a -> Behavior a
forall (t :: * -> *) a.
IfThenElse t a =>
Behavior Bool -> t a -> t a -> t a
ifThenElse Behavior Bool
c Behavior a
a Behavior a
b)

instance Context ctx => IfThenElse (GenSketch ctx) () where
	ifThenElse :: Behavior Bool
-> GenSketch ctx () -> GenSketch ctx () -> GenSketch ctx ()
ifThenElse Behavior Bool
c GenSketch ctx ()
a GenSketch ctx ()
b = do
		Behavior Bool -> GenSketch ctx () -> GenSketch ctx ()
forall ctx t.
Context ctx =>
Behavior Bool -> GenSketch ctx t -> GenSketch ctx t
whenB Behavior Bool
c GenSketch ctx ()
a
		Behavior Bool -> GenSketch ctx () -> GenSketch ctx ()
forall ctx t.
Context ctx =>
Behavior Bool -> GenSketch ctx t -> GenSketch ctx t
whenB (Behavior Bool -> Behavior Bool
not Behavior Bool
c) GenSketch ctx ()
b

instance (Context ctx, Typed a) => IfThenElse (GenSketch ctx) (Behavior a) where
	ifThenElse :: Behavior Bool
-> GenSketch ctx (Behavior a)
-> GenSketch ctx (Behavior a)
-> GenSketch ctx (Behavior a)
ifThenElse Behavior Bool
c GenSketch ctx (Behavior a)
a GenSketch ctx (Behavior a)
b = do
		Behavior a
ra <- Behavior Bool
-> GenSketch ctx (Behavior a) -> GenSketch ctx (Behavior a)
forall ctx t.
Context ctx =>
Behavior Bool -> GenSketch ctx t -> GenSketch ctx t
whenB Behavior Bool
c GenSketch ctx (Behavior a)
a
		Behavior a
rb <- Behavior Bool
-> GenSketch ctx (Behavior a) -> GenSketch ctx (Behavior a)
forall ctx t.
Context ctx =>
Behavior Bool -> GenSketch ctx t -> GenSketch ctx t
whenB (Behavior Bool -> Behavior Bool
not Behavior Bool
c) GenSketch ctx (Behavior a)
b
		Behavior a -> GenSketch ctx (Behavior a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Behavior a -> GenSketch ctx (Behavior a))
-> Behavior a -> GenSketch ctx (Behavior a)
forall a b. (a -> b) -> a -> b
$ Behavior Bool -> Behavior a -> Behavior a -> Behavior a
forall a.
Typed a =>
Behavior Bool -> Stream a -> Stream a -> Stream a
Language.Copilot.ifThenElse Behavior Bool
c Behavior a
ra Behavior a
rb

-- | Use this to read a value from a component of the board.
--
-- For example, to read a digital value from pin12 and turn on the 
-- led when the pin is high:
--
-- > buttonpressed <- input pin12
-- > led =: buttonpressed
--
-- Some pins support multiple types of reads, for example a pin may
-- support a digital read (`Bool`), and an analog to digital converter
-- read (`ADC`). In such cases you may need to specify the type of
-- data to read:
--
-- > v <- input a0 :: Sketch (Behavior ADC)
input :: Input ctx o t => o -> GenSketch ctx (Behavior t)
input :: o -> GenSketch ctx (Behavior t)
input o
o = o -> [t] -> GenSketch ctx (Behavior t)
forall ctx o t.
Input ctx o t =>
o -> [t] -> GenSketch ctx (Behavior t)
input' o
o []

-- | A stream of milliseconds.
data MilliSeconds = MilliSeconds (Stream Word32)

-- | A stream of microseconds.
data MicroSeconds = MicroSeconds (Stream Word32)

data Delay = Delay

-- | Use this to add a delay between each iteration of the `Sketch`.
-- A `Sketch` with no delay will run as fast as the hardware can run it.
--
-- > delay := MilliSeconds (constant 100)
delay :: Delay
delay :: Delay
delay = Delay
Delay