Internals.hs

-- | 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 (Show, Eq, Ord)

newtype PinId = PinId Int16
	deriving (Show, Eq, Ord)

instance IsDigitalIOPin t => Output PinId (Pin t) (Event () (Stream Bool)) where
	(Pin p@(PinId n)) =: (Event b c) = do
		(f, triggername) <- defineTriggerAlias' ("pin_" <> show n) "digitalWrite" $
			(emptyFramework @PinId)
				{ pinmodes = M.singleton p (S.singleton OutputMode)
				}
		tell [(go triggername, const f)]
	  where
		go triggername tl = 
			let c' = addTriggerLimit tl c
			in trigger triggername c' [arg (constant n), arg b]

instance IsPWMPin t => Output PinId (Pin t) (Event 'PWM (Stream Word8)) where
	(Pin (PinId n)) =: (Event v c) = do
		(f, triggername) <- defineTriggerAlias' ("pin_" <> show n) "analogWrite" mempty
		tell [(go triggername, const f)]
	  where
		go triggername tl = 
			let c' = addTriggerLimit tl c
			in trigger triggername c' [arg (constant n), arg v]
		-- analogWrite does not need any pinmodes set up

instance IsDigitalIOPin t => Input PinId (Pin t) Bool where
	input' (Pin p@(PinId n)) interpretvalues = mkInput $ InputSource
		{ defineVar = mkCChunk [CLine $ "bool " <> varname <> ";"]
		, setupInput = mempty
		, inputPinmode = M.singleton p InputMode
		, readInput = mkCChunk
			[CLine $ varname <> " = digitalRead(" <> show n <> ");"]
		, inputStream = extern varname interpretvalues'
		}
	  where
		varname = "arduino_digital_pin_input" <> show n
		interpretvalues'
			| null interpretvalues = Nothing
			| otherwise = Just 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 (PinId n)) interpretvalues = mkInput $ InputSource
		{ defineVar = mkCChunk [CLine $ "int " <> varname <> ";"]
		, setupInput = mempty
		, inputPinmode = mempty
		, readInput = mkCChunk
			[CLine $ varname <> " = analogRead(" <> show n <> ");"]
		, inputStream = extern varname interpretvalues'
		}
	  where
		varname = "arduino_analog_pin_input" <> show n
		interpretvalues'
			| null interpretvalues = Nothing
			| otherwise = Just interpretvalues

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

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

instance Output PinId Delay MilliSeconds where
	Delay =: (MilliSeconds n) = do
		(f, triggername) <- defineTriggerAlias "delay" mempty
		tell [(go triggername, \_ -> f)]
	  where
		go triggername tl =
			let c = getTriggerLimit tl
			in trigger triggername c [arg n]

instance Output PinId Delay MicroSeconds where
	Delay =: (MicroSeconds n) = do
		(f, triggername) <- defineTriggerAlias "delayMicroseconds" mempty
		tell [(go triggername, \_ -> f)]
	  where
		go triggername tl = 
			let c = getTriggerLimit tl
			in trigger triggername c [arg n]