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 GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Copilot.Arduino.Internals where

import Language.Copilot
import Control.Monad.Writer
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Type.Bool
import GHC.TypeLits

-- | An Arduino sketch, implemented using Copilot.
--
-- It's best to think of the `Sketch` as a description of the state of the
-- Arduino at any point in time.
--
-- Under the hood, the `Sketch` is run in a loop. On each iteration, it first
-- reads all 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.
newtype Sketch t = Sketch (Writer [(Spec, Framework)] t)
	deriving (Monad, Applicative, Functor, MonadWriter [(Spec, Framework)])

instance Monoid (Sketch ()) where
	mempty = Sketch (return ())

instance Semigroup (Sketch t) where
	(Sketch a) <> (Sketch b) = Sketch (a >> b)

-- | The framework of an Arduino sketch.
data Framework = Framework
	{ defines :: [CLine]
	-- ^ Things that come before the C code generated by Copilot.
	, setups :: [CLine]
	-- ^ Things to do at setup, not including configuring pins.
	, pinmodes :: M.Map PinId (S.Set PinMode)
	-- ^ How pins are used.
	, loops :: [CLine]
	-- ^ Things to run in `loop`.
	}

-- | A line of C code.
newtype CLine = CLine { fromCLine :: String }

instance Semigroup Framework where
	a <> b = Framework
		{ defines = defines a <> defines b
		, setups = setups a <> setups b
		, pinmodes = M.unionWith S.union (pinmodes a) (pinmodes b)
		, loops = loops a  <> loops b
		}

instance Monoid Framework where
	mempty = Framework mempty mempty mempty mempty

class ToFramework t where
	toFramework :: t -> Framework

type Behavior t = Stream t -> Spec

-- | Somewhere that a Stream can be directed to, in order to control the
-- Arduino.
data Output t = Output
	{ setupOutput :: [CLine]
	-- ^ How to set up the output, not including pin mode.
	, outputPinmode :: M.Map PinId PinMode
	, outputCond :: Stream Bool
	, outputBehavior :: Stream Bool -> Behavior t
	}

instance ToFramework (Output t) where
	toFramework o = Framework
		{ defines = mempty
		, setups = setupOutput o
		, pinmodes = M.map S.singleton (outputPinmode o)
		, loops = mempty
		}

-- | A source of a `Stream` of values input from the Arduino.
--
-- Runs in the `Sketch` monad.
type Input t = Sketch (Stream t)

data InputSource t = InputSource
	{ defineVar :: [CLine]
	-- ^ Added to the `Framework`'s `defines`, this typically
	-- defines a C variable.
	, setupInput :: [CLine]
	-- ^ How to set up the input, not including pin mode.
	, inputPinmode :: M.Map PinId PinMode
	, readInput :: [CLine]
	-- ^ How to read a value from the input, this typically
	-- reads a value into a C variable.
	, inputStream :: Stream t
	}

instance ToFramework (InputSource t) where
	toFramework i = Framework
		{ defines = defineVar i
		, setups = setupInput i
		, pinmodes = M.map S.singleton (inputPinmode i)
		, loops = readInput i
		}

mkInput :: InputSource t -> Input t
mkInput i = do
	tell [(return (), toFramework i)]
	return (inputStream i)

-- | 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.
--
-- Some pins can only be used for digital IO, while others support
-- analog input and/or digital IO. A type-level list of PinCapabilties
-- indicates how a Pin can be used.
newtype Pin t = Pin PinId
	deriving (Show, Eq, Ord)

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

data PinCapabilities
	= DigitalIO
	| AnalogInput
	| PWM
	deriving (Show, Eq, Ord)

type family IsDigitalIOPin t where
	IsDigitalIOPin t = 
		'True ~ If (HasPinCapability 'DigitalIO t)
			('True)
			(TypeError ('Text "This Pin does not support digital IO"))

type family IsAnalogInputPin t where
	IsAnalogInputPin t = 
		'True ~ If (HasPinCapability 'AnalogInput t)
			('True)
			(TypeError ('Text "This Pin does not support analog input"))

type family IsPWMPin t where
	IsPWMPin t = 
		'True ~ If (HasPinCapability 'PWM t)
			('True)
			(TypeError ('Text "This Pin does not support PWM"))

type family HasPinCapability (c :: t) (list :: [t]) :: Bool where
	HasPinCapability c '[] = 'False
	HasPinCapability c (x ': xs) = SameCapability c x || HasPinCapability c xs

type family SameCapability (a :: PinCapabilities) (b :: PinCapabilities) :: Bool where
	SameCapability 'DigitalIO 'DigitalIO = 'True
	SameCapability 'AnalogInput 'AnalogInput = 'True
	SameCapability 'PWM 'PWM = 'True
	SameCapability _ _ = 'False

data PinMode = InputMode | InputPullupMode | OutputMode
	deriving (Show, Eq, Ord)

-- FIXME should be a newtype, but how to make a stream of a newtype?
type MicroSeconds = Int16