{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Copilot.Arduino (
arduino,
Sketch,
Pin,
Behavior,
TypedBehavior(..),
Event,
(@:),
Input,
input,
input',
pullup,
millis,
micros,
Output,
led,
(=:),
pwm,
delay,
ADC,
MilliSeconds(..),
MicroSeconds(..),
ClockMillis,
ClockMicros,
IsDigitalIOPin,
IsAnalogInputPin,
IsPWMPin,
blinking,
firstIteration,
frequency,
sketchSpec,
liftB,
liftB2,
whenB,
scheduleB,
ifThenElse,
IfThenElse,
Stream,
module X,
) where
import Language.Copilot as X hiding (Stream, ifThenElse)
import Language.Copilot (Stream)
import qualified Language.Copilot
import Copilot.Arduino.Internals
import Copilot.Arduino.Main
import Control.Monad.Writer
import Data.Proxy
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as S
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))
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
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)
data MilliSeconds = MilliSeconds (Stream Word32)
data MicroSeconds = MicroSeconds (Stream Word32)
delay :: Delay
delay :: Delay
delay = Delay
Delay
data Delay = Delay
instance Output Delay MilliSeconds where
Delay
Delay =: :: Delay -> MilliSeconds -> Sketch ()
=: (MilliSeconds Stream Word32
n) = do
(Framework
f, String
triggername) <- String -> Framework -> Sketch (Framework, String)
defineTriggerAlias String
"delay" Framework
forall a. Monoid a => a
mempty
[(TriggerLimit -> Spec, TriggerLimit -> Framework)] -> Sketch ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(String -> TriggerLimit -> Spec
go String
triggername, \TriggerLimit
_ -> Framework
f)]
where
go :: String -> TriggerLimit -> Spec
go String
triggername TriggerLimit
tl =
let c :: Behavior Bool
c = TriggerLimit -> Behavior Bool
getTriggerLimit TriggerLimit
tl
in String -> Behavior Bool -> [Arg] -> Spec
trigger String
triggername Behavior Bool
c [Stream Word32 -> Arg
forall a. Typed a => Stream a -> Arg
arg Stream Word32
n]
instance Output Delay MicroSeconds where
Delay
Delay =: :: Delay -> MicroSeconds -> Sketch ()
=: (MicroSeconds Stream Word32
n) = do
(Framework
f, String
triggername) <- String -> Framework -> Sketch (Framework, String)
defineTriggerAlias String
"delayMicroseconds" Framework
forall a. Monoid a => a
mempty
[(TriggerLimit -> Spec, TriggerLimit -> Framework)] -> Sketch ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(String -> TriggerLimit -> Spec
go String
triggername, \TriggerLimit
_ -> Framework
f)]
where
go :: String -> TriggerLimit -> Spec
go String
triggername TriggerLimit
tl =
let c :: Behavior Bool
c = TriggerLimit -> Behavior Bool
getTriggerLimit TriggerLimit
tl
in String -> Behavior Bool -> [Arg] -> Spec
trigger String
triggername Behavior Bool
c [Stream Word32 -> Arg
forall a. Typed a => Stream a -> Arg
arg Stream Word32
n]
millis :: ClockMillis
millis :: ClockMillis
millis = ClockMillis
ClockMillis
micros :: ClockMicros
micros :: ClockMicros
micros = ClockMicros
ClockMicros
data ClockMillis = ClockMillis
data ClockMicros = ClockMicros
instance Input ClockMillis Word32 where
input' :: ClockMillis -> [Word32] -> Sketch (Stream Word32)
input' ClockMillis
ClockMillis = String -> [Word32] -> Sketch (Stream Word32)
inputClock String
"millis"
instance Input ClockMicros Word32 where
input' :: ClockMicros -> [Word32] -> Sketch (Stream Word32)
input' ClockMicros
ClockMicros = String -> [Word32] -> Sketch (Stream Word32)
inputClock String
"micros"
inputClock :: [Char] -> [Word32] -> Sketch (Behavior Word32)
inputClock :: String -> [Word32] -> Sketch (Stream Word32)
inputClock String
src [Word32]
interpretvalues = InputSource Word32 -> Sketch (Stream Word32)
forall t. InputSource t -> Sketch (Behavior t)
mkInput (InputSource Word32 -> Sketch (Stream Word32))
-> InputSource Word32 -> Sketch (Stream Word32)
forall a b. (a -> b) -> a -> b
$ InputSource :: forall t.
[CChunk]
-> [CChunk]
-> Map PinId PinMode
-> [CChunk]
-> Stream t
-> InputSource t
InputSource
{ setupInput :: [CChunk]
setupInput = []
, defineVar :: [CChunk]
defineVar = [CLine] -> [CChunk]
mkCChunk
[String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ Proxy Word32 -> String
forall k (t :: k). ShowCType t => Proxy t -> String
showCType (Proxy Word32
forall k (t :: k). Proxy t
Proxy @Word32) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
varname String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
";"]
, inputPinmode :: Map PinId PinMode
inputPinmode = Map PinId PinMode
forall a. Monoid a => a
mempty
, readInput :: [CChunk]
readInput = [CLine] -> [CChunk]
mkCChunk
[String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
varname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
src String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"();"]
, inputStream :: Stream Word32
inputStream = String -> Maybe [Word32] -> Stream Word32
forall a. Typed a => String -> Maybe [a] -> Stream a
extern String
varname Maybe [Word32]
interpretvalues'
}
where
varname :: String
varname = String
"clock_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
src
interpretvalues' :: Maybe [Word32]
interpretvalues'
| [Word32] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Word32]
interpretvalues = Maybe [Word32]
forall a. Maybe a
Nothing
| Bool
otherwise = [Word32] -> Maybe [Word32]
forall a. a -> Maybe a
Just [Word32]
interpretvalues
pullup :: IsDigitalIOPin t => Pin t -> Sketch ()
pullup :: Pin t -> Sketch ()
pullup (Pin PinId
p) = [(TriggerLimit -> Spec, TriggerLimit -> Framework)] -> Sketch ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(\TriggerLimit
_ -> () -> Spec
forall (m :: * -> *) a. Monad m => a -> m a
return (), \TriggerLimit
_ -> Framework
f)]
where
f :: Framework
f = Framework
forall a. Monoid a => a
mempty
{ pinmodes :: Map PinId (Set PinMode)
pinmodes = PinId -> Set PinMode -> Map PinId (Set PinMode)
forall k a. k -> a -> Map k a
M.singleton PinId
p (PinMode -> Set PinMode
forall a. a -> Set a
S.singleton PinMode
InputPullupMode)
}
pwm :: Behavior Word8 -> TypedBehavior 'PWM Word8
pwm :: Behavior Word8 -> TypedBehavior 'PWM Word8
pwm = Behavior Word8 -> TypedBehavior 'PWM Word8
forall k (p :: k) t. Behavior t -> TypedBehavior p t
TypedBehavior
led :: Pin '[ 'DigitalIO ]
led :: Pin '[ 'DigitalIO]
led = PinId -> Pin '[ 'DigitalIO]
forall k (t :: k). PinId -> Pin t
Pin (Int16 -> PinId
PinId Int16
13)
class IfThenElse t a where
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 IfThenElse Sketch () where
ifThenElse :: Behavior Bool -> Sketch () -> Sketch () -> Sketch ()
ifThenElse Behavior Bool
c Sketch ()
a Sketch ()
b = do
Behavior Bool -> Sketch () -> Sketch ()
forall t. Behavior Bool -> Sketch t -> Sketch t
whenB Behavior Bool
c Sketch ()
a
Behavior Bool -> Sketch () -> Sketch ()
forall t. Behavior Bool -> Sketch t -> Sketch t
whenB (Behavior Bool -> Behavior Bool
not Behavior Bool
c) Sketch ()
b
instance Typed a => IfThenElse Sketch (Behavior a) where
ifThenElse :: Behavior Bool
-> Sketch (Behavior a)
-> Sketch (Behavior a)
-> Sketch (Behavior a)
ifThenElse Behavior Bool
c Sketch (Behavior a)
a Sketch (Behavior a)
b = do
Behavior a
ra <- Behavior Bool -> Sketch (Behavior a) -> Sketch (Behavior a)
forall t. Behavior Bool -> Sketch t -> Sketch t
whenB Behavior Bool
c Sketch (Behavior a)
a
Behavior a
rb <- Behavior Bool -> Sketch (Behavior a) -> Sketch (Behavior a)
forall t. Behavior Bool -> Sketch t -> Sketch t
whenB (Behavior Bool -> Behavior Bool
not Behavior Bool
c) Sketch (Behavior a)
b
Behavior a -> Sketch (Behavior a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Behavior a -> Sketch (Behavior a))
-> Behavior a -> Sketch (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
scheduleB :: (Typed t, Eq t) => Behavior t -> [(t, Sketch ())] -> Sketch ()
scheduleB :: Behavior t -> [(t, Sketch ())] -> Sketch ()
scheduleB Behavior t
b = [Sketch ()] -> Sketch ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Sketch ()] -> Sketch ())
-> ([(t, Sketch ())] -> [Sketch ()])
-> [(t, Sketch ())]
-> Sketch ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((t, Sketch ()) -> Sketch ()) -> [(t, Sketch ())] -> [Sketch ()]
forall a b. (a -> b) -> [a] -> [b]
map (t, Sketch ()) -> Sketch ()
forall t. (t, Sketch t) -> Sketch t
go
where
go :: (t, Sketch t) -> Sketch t
go (t
v, Sketch t
s) = Behavior Bool -> Sketch t -> Sketch t
forall t. Behavior Bool -> Sketch t -> Sketch 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) Sketch t
s
sketchSpec :: Sketch a -> Spec
sketchSpec :: Sketch a -> Spec
sketchSpec = Spec -> Maybe Spec -> Spec
forall a. a -> Maybe a -> a
fromMaybe (() -> Spec
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Maybe Spec -> Spec)
-> (Sketch a -> Maybe Spec) -> Sketch a -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Spec, Framework) -> Maybe Spec
forall a b. (a, b) -> a
fst ((Maybe Spec, Framework) -> Maybe Spec)
-> (Sketch a -> (Maybe Spec, Framework)) -> Sketch a -> Maybe Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sketch a -> (Maybe Spec, Framework)
forall a. Sketch a -> (Maybe Spec, Framework)
evalSketch
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
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