-- | You should not need to import this module unless you're adding support
-- for a new model of Arduino, or an Arduino library.

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

module Copilot.Arduino.Internals (
	module Copilot.Arduino.Internals,
	module X
) where

import Sketch.FRP.Copilot as X
import Sketch.FRP.Copilot.Types as X
import Sketch.FRP.Copilot.Internals as X
import Language.Copilot
import Control.Monad.Writer
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Proxy

-- | An Arduino sketch, implemented using Copilot.
--
-- It's best to think of the `Sketch` as a description of the state of the
-- board at any point in time.
--
-- Under the hood, the `Sketch` is run in a loop. On each iteration, it first
-- reads inputs and then updates outputs as needed.
--
-- While it is a monad, a Sketch's outputs are not updated in any
-- particular order, because Copilot does not guarantee any order.
type Sketch = GenSketch PinId

-- | The framework of a sketch.
type Framework = GenFramework PinId

-- | A pin on the Arduino board.
--
-- For definitions of pins like `Copilot.Arduino.Uno.pin12`, 
-- load a module such as Copilot.Arduino.Uno, which provides the pins of a
-- particular board.
--
-- A type-level list indicates how a Pin can be used, so the haskell
-- compiler will detect impossible uses of pins.
newtype Pin t = Pin PinId
	deriving (Int -> Pin t -> ShowS
[Pin t] -> ShowS
Pin t -> String
(Int -> Pin t -> ShowS)
-> (Pin t -> String) -> ([Pin t] -> ShowS) -> Show (Pin t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (t :: k). Int -> Pin t -> ShowS
forall k (t :: k). [Pin t] -> ShowS
forall k (t :: k). Pin t -> String
showList :: [Pin t] -> ShowS
$cshowList :: forall k (t :: k). [Pin t] -> ShowS
show :: Pin t -> String
$cshow :: forall k (t :: k). Pin t -> String
showsPrec :: Int -> Pin t -> ShowS
$cshowsPrec :: forall k (t :: k). Int -> Pin t -> ShowS
Show, Pin t -> Pin t -> Bool
(Pin t -> Pin t -> Bool) -> (Pin t -> Pin t -> Bool) -> Eq (Pin t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (t :: k). Pin t -> Pin t -> Bool
/= :: Pin t -> Pin t -> Bool
$c/= :: forall k (t :: k). Pin t -> Pin t -> Bool
== :: Pin t -> Pin t -> Bool
$c== :: forall k (t :: k). Pin t -> Pin t -> Bool
Eq, Eq (Pin t)
Eq (Pin t)
-> (Pin t -> Pin t -> Ordering)
-> (Pin t -> Pin t -> Bool)
-> (Pin t -> Pin t -> Bool)
-> (Pin t -> Pin t -> Bool)
-> (Pin t -> Pin t -> Bool)
-> (Pin t -> Pin t -> Pin t)
-> (Pin t -> Pin t -> Pin t)
-> Ord (Pin t)
Pin t -> Pin t -> Bool
Pin t -> Pin t -> Ordering
Pin t -> Pin t -> Pin t
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall k (t :: k). Eq (Pin t)
forall k (t :: k). Pin t -> Pin t -> Bool
forall k (t :: k). Pin t -> Pin t -> Ordering
forall k (t :: k). Pin t -> Pin t -> Pin t
min :: Pin t -> Pin t -> Pin t
$cmin :: forall k (t :: k). Pin t -> Pin t -> Pin t
max :: Pin t -> Pin t -> Pin t
$cmax :: forall k (t :: k). Pin t -> Pin t -> Pin t
>= :: Pin t -> Pin t -> Bool
$c>= :: forall k (t :: k). Pin t -> Pin t -> Bool
> :: Pin t -> Pin t -> Bool
$c> :: forall k (t :: k). Pin t -> Pin t -> Bool
<= :: Pin t -> Pin t -> Bool
$c<= :: forall k (t :: k). Pin t -> Pin t -> Bool
< :: Pin t -> Pin t -> Bool
$c< :: forall k (t :: k). Pin t -> Pin t -> Bool
compare :: Pin t -> Pin t -> Ordering
$ccompare :: forall k (t :: k). Pin t -> Pin t -> Ordering
$cp1Ord :: forall k (t :: k). Eq (Pin t)
Ord)

newtype PinId = PinId Int16
	deriving (Int -> PinId -> ShowS
[PinId] -> ShowS
PinId -> String
(Int -> PinId -> ShowS)
-> (PinId -> String) -> ([PinId] -> ShowS) -> Show PinId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PinId] -> ShowS
$cshowList :: [PinId] -> ShowS
show :: PinId -> String
$cshow :: PinId -> String
showsPrec :: Int -> PinId -> ShowS
$cshowsPrec :: Int -> PinId -> ShowS
Show, PinId -> PinId -> Bool
(PinId -> PinId -> Bool) -> (PinId -> PinId -> Bool) -> Eq PinId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PinId -> PinId -> Bool
$c/= :: PinId -> PinId -> Bool
== :: PinId -> PinId -> Bool
$c== :: PinId -> PinId -> Bool
Eq, Eq PinId
Eq PinId
-> (PinId -> PinId -> Ordering)
-> (PinId -> PinId -> Bool)
-> (PinId -> PinId -> Bool)
-> (PinId -> PinId -> Bool)
-> (PinId -> PinId -> Bool)
-> (PinId -> PinId -> PinId)
-> (PinId -> PinId -> PinId)
-> Ord PinId
PinId -> PinId -> Bool
PinId -> PinId -> Ordering
PinId -> PinId -> PinId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PinId -> PinId -> PinId
$cmin :: PinId -> PinId -> PinId
max :: PinId -> PinId -> PinId
$cmax :: PinId -> PinId -> PinId
>= :: PinId -> PinId -> Bool
$c>= :: PinId -> PinId -> Bool
> :: PinId -> PinId -> Bool
$c> :: PinId -> PinId -> Bool
<= :: PinId -> PinId -> Bool
$c<= :: PinId -> PinId -> Bool
< :: PinId -> PinId -> Bool
$c< :: PinId -> PinId -> Bool
compare :: PinId -> PinId -> Ordering
$ccompare :: PinId -> PinId -> Ordering
$cp1Ord :: Eq PinId
Ord)

instance IsDigitalIOPin t => Output PinId (Pin t) (Event () (Stream Bool)) where
	(Pin p :: PinId
p@(PinId Int16
n)) =: :: Pin t -> Event () (Stream Bool) -> GenSketch PinId ()
=: (Event Stream Bool
b Stream Bool
c) = do
		(GenFramework PinId
f, String
triggername) <- String
-> String
-> GenFramework PinId
-> GenSketch PinId (GenFramework PinId, String)
forall pinid.
String
-> String
-> GenFramework pinid
-> GenSketch pinid (GenFramework pinid, String)
defineTriggerAlias' (String
"pin_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n) String
"digitalWrite" (GenFramework PinId
 -> GenSketch PinId (GenFramework PinId, String))
-> GenFramework PinId
-> GenSketch PinId (GenFramework PinId, String)
forall a b. (a -> b) -> a -> b
$
			(Ord PinId => GenFramework PinId
forall pinid. Ord pinid => GenFramework pinid
emptyFramework @PinId)
				{ 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
OutputMode)
				}
		[(TriggerLimit -> Spec, TriggerLimit -> GenFramework PinId)]
-> GenSketch PinId ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(String -> TriggerLimit -> Spec
go String
triggername, GenFramework PinId -> TriggerLimit -> GenFramework PinId
forall a b. a -> b -> a
const GenFramework PinId
f)]
	  where
		go :: String -> TriggerLimit -> Spec
go String
triggername TriggerLimit
tl = 
			let c' :: Stream Bool
c' = TriggerLimit -> Stream Bool -> Stream Bool
addTriggerLimit TriggerLimit
tl Stream Bool
c
			in String -> Stream Bool -> [Arg] -> Spec
trigger String
triggername Stream Bool
c' [Stream Int16 -> Arg
forall a. Typed a => Stream a -> Arg
arg (Int16 -> Stream Int16
forall a. Typed a => a -> Stream a
constant Int16
n), Stream Bool -> Arg
forall a. Typed a => Stream a -> Arg
arg Stream Bool
b]

instance IsPWMPin t => Output PinId (Pin t) (Event 'PWM (Stream Word8)) where
	(Pin (PinId Int16
n)) =: :: Pin t -> Event 'PWM (Stream Word8) -> GenSketch PinId ()
=: (Event Stream Word8
v Stream Bool
c) = do
		(GenFramework PinId
f, String
triggername) <- String
-> String
-> GenFramework PinId
-> GenSketch PinId (GenFramework PinId, String)
forall pinid.
String
-> String
-> GenFramework pinid
-> GenSketch pinid (GenFramework pinid, String)
defineTriggerAlias' (String
"pin_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n) String
"analogWrite" GenFramework PinId
forall a. Monoid a => a
mempty
		[(TriggerLimit -> Spec, TriggerLimit -> GenFramework PinId)]
-> GenSketch PinId ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(String -> TriggerLimit -> Spec
go String
triggername, GenFramework PinId -> TriggerLimit -> GenFramework PinId
forall a b. a -> b -> a
const GenFramework PinId
f)]
	  where
		go :: String -> TriggerLimit -> Spec
go String
triggername TriggerLimit
tl = 
			let c' :: Stream Bool
c' = TriggerLimit -> Stream Bool -> Stream Bool
addTriggerLimit TriggerLimit
tl Stream Bool
c
			in String -> Stream Bool -> [Arg] -> Spec
trigger String
triggername Stream Bool
c' [Stream Int16 -> Arg
forall a. Typed a => Stream a -> Arg
arg (Int16 -> Stream Int16
forall a. Typed a => a -> Stream a
constant Int16
n), Stream Word8 -> Arg
forall a. Typed a => Stream a -> Arg
arg Stream Word8
v]
		-- analogWrite does not need any pinmodes set up

instance IsDigitalIOPin t => Input PinId (Pin t) Bool where
	input' :: Pin t -> [Bool] -> GenSketch PinId (Stream Bool)
input' (Pin p :: PinId
p@(PinId Int16
n)) [Bool]
interpretvalues = MkInputSource PinId Bool -> GenSketch PinId (Stream Bool)
forall pinid t.
MkInputSource pinid t -> GenSketch pinid (Behavior t)
mkInput (MkInputSource PinId Bool -> GenSketch PinId (Stream Bool))
-> MkInputSource PinId Bool -> GenSketch PinId (Stream Bool)
forall a b. (a -> b) -> a -> b
$ InputSource :: forall pinid t.
[CChunk]
-> [CChunk]
-> Map pinid PinMode
-> [CChunk]
-> Stream t
-> MkInputSource pinid t
InputSource
		{ defineVar :: [CChunk]
defineVar = [CLine] -> [CChunk]
mkCChunk [String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"bool " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
varname String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
";"]
		, setupInput :: [CChunk]
setupInput = [CChunk]
forall a. Monoid a => a
mempty
		, inputPinmode :: Map PinId PinMode
inputPinmode = PinId -> PinMode -> Map PinId PinMode
forall k a. k -> a -> Map k a
M.singleton PinId
p PinMode
InputMode
		, readInput :: [CChunk]
readInput = [CLine] -> [CChunk]
mkCChunk
			[String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
varname String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" = digitalRead(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
");"]
		, inputStream :: Stream Bool
inputStream = String -> Maybe [Bool] -> Stream Bool
forall a. Typed a => String -> Maybe [a] -> Stream a
extern String
varname Maybe [Bool]
interpretvalues'
		}
	  where
		varname :: String
varname = String
"arduino_digital_pin_input" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n
		interpretvalues' :: Maybe [Bool]
interpretvalues'
			| [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bool]
interpretvalues = Maybe [Bool]
forall a. Maybe a
Nothing
			| Bool
otherwise = [Bool] -> Maybe [Bool]
forall a. a -> Maybe a
Just [Bool]
interpretvalues

-- | Value read from an Arduino's ADC. Ranges from 0-1023.
type ADC = Int16

instance IsAnalogInputPin t => Input PinId (Pin t) ADC where
	input' :: Pin t -> [Int16] -> GenSketch PinId (Stream Int16)
input' (Pin (PinId Int16
n)) [Int16]
interpretvalues = MkInputSource PinId Int16 -> GenSketch PinId (Stream Int16)
forall pinid t.
MkInputSource pinid t -> GenSketch pinid (Behavior t)
mkInput (MkInputSource PinId Int16 -> GenSketch PinId (Stream Int16))
-> MkInputSource PinId Int16 -> GenSketch PinId (Stream Int16)
forall a b. (a -> b) -> a -> b
$ InputSource :: forall pinid t.
[CChunk]
-> [CChunk]
-> Map pinid PinMode
-> [CChunk]
-> Stream t
-> MkInputSource pinid t
InputSource
		{ defineVar :: [CChunk]
defineVar = [CLine] -> [CChunk]
mkCChunk [String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"int " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
varname String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
";"]
		, setupInput :: [CChunk]
setupInput = [CChunk]
forall a. Monoid a => a
mempty
		, 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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" = analogRead(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
");"]
		, inputStream :: Stream Int16
inputStream = String -> Maybe [Int16] -> Stream Int16
forall a. Typed a => String -> Maybe [a] -> Stream a
extern String
varname Maybe [Int16]
interpretvalues'
		}
	  where
		varname :: String
varname = String
"arduino_analog_pin_input" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n
		interpretvalues' :: Maybe [Int16]
interpretvalues'
			| [Int16] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int16]
interpretvalues = Maybe [Int16]
forall a. Maybe a
Nothing
			| Bool
otherwise = [Int16] -> Maybe [Int16]
forall a. a -> Maybe a
Just [Int16]
interpretvalues

class ShowCType t where
	showCType :: Proxy t -> String

instance ShowCType Bool where showCType :: Proxy Bool -> String
showCType Proxy Bool
_ = String
"bool"
instance ShowCType Int8 where showCType :: Proxy Int8 -> String
showCType Proxy Int8
_ = String
"int8_t"
instance ShowCType Int16 where showCType :: Proxy Int16 -> String
showCType Proxy Int16
_ = String
"int16_t"
instance ShowCType Int32 where showCType :: Proxy Int32 -> String
showCType Proxy Int32
_ = String
"int32_t"
instance ShowCType Int64 where showCType :: Proxy Int64 -> String
showCType Proxy Int64
_ = String
"int64_t"
instance ShowCType Word8 where showCType :: Proxy Word8 -> String
showCType Proxy Word8
_ = String
"uint8_t"
instance ShowCType Word16 where showCType :: Proxy Word16 -> String
showCType Proxy Word16
_ = String
"uint16_t"
instance ShowCType Word32 where showCType :: Proxy Word32 -> String
showCType Proxy Word32
_ = String
"uint32_t"
instance ShowCType Word64 where showCType :: Proxy Word64 -> String
showCType Proxy Word64
_ = String
"uint64_t"
instance ShowCType Float where showCType :: Proxy Float -> String
showCType Proxy Float
_ = String
"float"
instance ShowCType Double where showCType :: Proxy Double -> String
showCType Proxy Double
_ = String
"double"

instance Output PinId Delay MilliSeconds where
	Delay
Delay =: :: Delay -> MilliSeconds -> GenSketch PinId ()
=: (MilliSeconds Stream Word32
n) = do
		(GenFramework PinId
f, String
triggername) <- String
-> GenFramework PinId
-> GenSketch PinId (GenFramework PinId, String)
forall pinid.
String
-> GenFramework pinid
-> GenSketch pinid (GenFramework pinid, String)
defineTriggerAlias String
"delay" GenFramework PinId
forall a. Monoid a => a
mempty
		[(TriggerLimit -> Spec, TriggerLimit -> GenFramework PinId)]
-> GenSketch PinId ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(String -> TriggerLimit -> Spec
go String
triggername, \TriggerLimit
_ -> GenFramework PinId
f)]
	  where
		go :: String -> TriggerLimit -> Spec
go String
triggername TriggerLimit
tl =
			let c :: Stream Bool
c = TriggerLimit -> Stream Bool
getTriggerLimit TriggerLimit
tl
			in String -> Stream Bool -> [Arg] -> Spec
trigger String
triggername Stream Bool
c [Stream Word32 -> Arg
forall a. Typed a => Stream a -> Arg
arg Stream Word32
n]

instance Output PinId Delay MicroSeconds where
	Delay
Delay =: :: Delay -> MicroSeconds -> GenSketch PinId ()
=: (MicroSeconds Stream Word32
n) = do
		(GenFramework PinId
f, String
triggername) <- String
-> GenFramework PinId
-> GenSketch PinId (GenFramework PinId, String)
forall pinid.
String
-> GenFramework pinid
-> GenSketch pinid (GenFramework pinid, String)
defineTriggerAlias String
"delayMicroseconds" GenFramework PinId
forall a. Monoid a => a
mempty
		[(TriggerLimit -> Spec, TriggerLimit -> GenFramework PinId)]
-> GenSketch PinId ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(String -> TriggerLimit -> Spec
go String
triggername, \TriggerLimit
_ -> GenFramework PinId
f)]
	  where
		go :: String -> TriggerLimit -> Spec
go String
triggername TriggerLimit
tl = 
			let c :: Stream Bool
c = TriggerLimit -> Stream Bool
getTriggerLimit TriggerLimit
tl
			in String -> Stream Bool -> [Arg] -> Spec
trigger String
triggername Stream Bool
c [Stream Word32 -> Arg
forall a. Typed a => Stream a -> Arg
arg Stream Word32
n]