Internals.hs

-- | You should not need to import this module unless you're adding support
-- for a specific board supported by Zephyr, or a Zephyr library.

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

module Copilot.Zephyr.Internals (
	module Copilot.Zephyr.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.Char (toLower, toUpper)

-- | A 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 Zephyr

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

-- | A pin on the board.
--
-- For definitions of specific pins, load a module 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 Zephyr
	deriving (Show, Eq, Ord)

-- | Indicates that you're programming a board with Zephyr.
-- The similar library arduino-copilot allows programming
-- Arduinos in a very similar style to this one.
data Zephyr = Zephyr GPIOAlias GPIOAddress
	deriving (Show, Eq, Ord)

instance Context Zephyr

newtype GPIOAlias = GPIOAlias String
	deriving (Show, Eq, Ord)

data GPIOAddress
	= GPIOAddress String
	-- ^ Eg "porta 17"
	| GPIOAddressBuiltIn
	-- ^ Use when Zephyr defines the GPIO address for a GPIOAlias.
	deriving (Show, Eq, Ord)

instance IsDigitalIOPin t => Output Zephyr (Pin t) (Event () (Stream Bool)) where
	(Pin p@(Zephyr (GPIOAlias n) _)) =: (Event b c) = do
		(f, triggername) <- defineTriggerAlias pinsetfunc basef
		tell [(go triggername, const f)]
	  where
		go triggername tl = 
			let c' = addTriggerLimit tl c
			in trigger triggername c' [arg b]
		basef = (emptyFramework @Zephyr)
				{ pinmodes = M.singleton p (S.singleton OutputMode)
				, defines = (\v -> [CChunk v])
					[ CLine $ "static inline int " 
						<> pinsetfunc
						<> "(int value) {"
					, CLine $ "  return gpio_pin_set"
						<> "(" <> pinDevVar n
						<> ", " <> pinDevDef n
						<> ", value);"
					, CLine "}"
					]
				}
		pinsetfunc = "gpio_pin_set_" <> map toLower n

pinDevVar :: String -> String
pinDevVar n = "pin_dev_" <> map toLower n

pinDevDef :: String -> String
pinDevDef n = "PIN_DEV_" <> map toUpper n

pinDevNode :: String -> String
pinDevNode n = pinDevDef n <> "_NODE"

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

instance IsDigitalIOPin t => Input Zephyr (Pin t) Bool where
	input' (Pin p@(Zephyr (GPIOAlias n) _)) interpretvalues = mkInput $ InputSource
		{ defineVar = mkCChunk 
			[ CLine $ "bool " <> varname <> ";"
			, CLine $ "static const struct gpio_dt_spec " <> specname
				<> " = GPIO_DT_SPEC_GET_OR(" <> nodename <> ", gpios, {0});"
			]
		, setupInput = mempty
		, inputPinmode = M.singleton p InputMode
		, readInput = mkCChunk
			[CLine $ varname <> " = gpio_pin_get_dt(&" <> specname <> ");"]
		, inputStream = extern varname interpretvalues'
		}
	  where
		varname = "zephyr_digital_pin_input_" <> n
		specname = "zephyr_digital_pin_dt_spec_" <> n
		nodename = pinDevNode n
		interpretvalues'
			| null interpretvalues = Nothing
			| otherwise = Just interpretvalues

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

-- FIXME for zephyr
instance IsAnalogInputPin t => Input Zephyr (Pin t) ADC where
	input' (Pin (Zephyr (GPIOAlias 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 = "zephyr_analog_pin_input_" <> show n
		interpretvalues'
			| null interpretvalues = Nothing
			| otherwise = Just interpretvalues

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

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