{-# 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
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
class ToFramework t where
toFramework :: t -> Framework
type Behavior t = Stream t -> Spec
data Output t = Output
{ setupOutput :: [CLine]
, 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
}
type Input t = Sketch (Stream t)
data InputSource t = InputSource
{ defineVar :: [CLine]
, setupInput :: [CLine]
, inputPinmode :: M.Map PinId PinMode
, readInput :: [CLine]
, 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)
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)
type MicroSeconds = Int16