{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
type Behavior t = Stream t
data TypedBehavior p t = TypedBehavior (Behavior t)
data Event p v = Event v (Stream Bool)
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)
data Framework = Framework
{ defines :: [CLine]
, setups :: [CLine]
, pinmodes :: M.Map PinId (S.Set PinMode)
, loops :: [CLine]
}
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
defineTriggerAlias :: String -> String -> Framework -> (Framework, String)
defineTriggerAlias suffix cfuncname f =
(f { defines = define : defines f }, triggername)
where
triggername = cfuncname <> "_" <> suffix
define = CLine $ "#define " <> triggername <> " " <> cfuncname
data InputSource t = InputSource
{ defineVar :: [CLine]
, setupInput :: [CLine]
, inputPinmode :: M.Map PinId PinMode
, readInput :: [CLine]
, inputStream :: Stream t
}
mkInput :: InputSource t -> Sketch (Behavior t)
mkInput i = do
tell [(return (), f)]
return (inputStream i)
where
f = Framework
{ defines = defineVar i
, setups = setupInput i
, pinmodes = M.map S.singleton (inputPinmode i)
, loops = readInput i
}
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 b :: 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)
class Output o t where
(=:) :: o -> t -> Sketch ()
infixr 1 =:
instance Output o (Event () (Stream v)) => Output o (Behavior v) where
(=:) o b = o =: te
where
te :: Event () (Stream v)
te = Event b true
instance Output o (Event p (Stream v)) => Output o (TypedBehavior p v) where
(=:) o (TypedBehavior b) = o =: te
where
te :: Event p (Stream v)
te = Event b true
type family BehaviorToEvent a
type instance BehaviorToEvent (Behavior v) = Event () (Stream v)
type instance BehaviorToEvent (TypedBehavior p v) = Event p (Stream v)
class IsBehavior behavior where
(@:) :: behavior -> Behavior Bool -> BehaviorToEvent behavior
instance IsBehavior (Behavior v) where
b @: c = Event b c
instance IsBehavior (TypedBehavior p v) where
(@:) (TypedBehavior b) c = Event b c
instance IsDigitalIOPin t => Output (Pin t) (Event () (Stream Bool)) where
(Pin p@(PinId n)) =: (Event b c) = tell [(go, f)]
where
go = trigger triggername c [arg (constant n), arg b]
(f, triggername) =
defineTriggerAlias (show n) "digitalWrite" $
mempty { pinmodes = M.singleton p (S.singleton OutputMode) }
instance IsPWMPin t => Output (Pin t) (Event 'PWM (Stream Word8)) where
(Pin (PinId n)) =: (Event v c) = tell [(go, f)]
where
go = trigger triggername c [arg (constant n), arg v]
(f, triggername) = defineTriggerAlias (show n) "analogWrite" mempty
class Input o t where
input' :: o -> [t] -> Sketch (Behavior t)
instance IsDigitalIOPin t => Input (Pin t) Bool where
input' (Pin p@(PinId n)) interpretvalues = mkInput $ InputSource
{ defineVar = [CLine $ "bool " <> varname <> ";"]
, setupInput = []
, inputPinmode = M.singleton p InputMode
, readInput = [CLine $ varname <> " = digitalRead(" <> show n <> ");"]
, inputStream = extern varname interpretvalues'
}
where
varname = "arduino_digital_pin_input" <> show n
interpretvalues'
| null interpretvalues = Nothing
| otherwise = Just interpretvalues
type Voltage = Int16
instance IsAnalogInputPin t => Input (Pin t) Voltage where
input' (Pin (PinId n)) interpretvalues = mkInput $ InputSource
{ defineVar = [CLine $ "int " <> varname <> ";"]
, setupInput = []
, inputPinmode = mempty
, readInput = [CLine $ varname <> " = analogRead(" <> show n <> ");"]
, inputStream = extern varname interpretvalues'
}
where
varname = "arduino_analog_pin_input" <> show n
interpretvalues'
| null interpretvalues = Nothing
| otherwise = Just interpretvalues