-- | 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 MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Copilot.Arduino.Internals where

import Language.Copilot
import Control.Monad.Writer
import Control.Monad.State.Strict
import Data.Functor.Identity
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Type.Bool
import Data.Proxy
import GHC.TypeLits

-- | A value that changes over time.
--
-- This is implemented as a `Stream` in the Copilot DSL.
-- Copilot provides many operations on streams, for example
-- `Language.Copilot.&&` to combine two streams of Bools.
-- 
-- For documentation on using the Copilot DSL, see
-- <https://copilot-language.github.io/>
type Behavior t = Stream t

-- | A Behavior with an additional phantom type `p`.
--
-- The Compilot DSL only lets a Stream contain basic C types,
-- a limitation that `Behavior` also has. When more type safely
-- is needed, this can be used.
data TypedBehavior p t = TypedBehavior (Behavior t)

-- | A discrete event, that occurs at particular points in time.
data Event p v = Event v (Stream Bool)

-- | 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 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 (WriterT [(TriggerLimit -> Spec, TriggerLimit -> Framework)] (State UniqueIds) t)
	deriving 
		( Applicative Sketch
a -> Sketch a
Applicative Sketch
-> (forall a b. Sketch a -> (a -> Sketch b) -> Sketch b)
-> (forall a b. Sketch a -> Sketch b -> Sketch b)
-> (forall a. a -> Sketch a)
-> Monad Sketch
Sketch a -> (a -> Sketch b) -> Sketch b
Sketch a -> Sketch b -> Sketch b
forall a. a -> Sketch a
forall a b. Sketch a -> Sketch b -> Sketch b
forall a b. Sketch a -> (a -> Sketch b) -> Sketch b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Sketch a
$creturn :: forall a. a -> Sketch a
>> :: Sketch a -> Sketch b -> Sketch b
$c>> :: forall a b. Sketch a -> Sketch b -> Sketch b
>>= :: Sketch a -> (a -> Sketch b) -> Sketch b
$c>>= :: forall a b. Sketch a -> (a -> Sketch b) -> Sketch b
$cp1Monad :: Applicative Sketch
Monad
		, Functor Sketch
a -> Sketch a
Functor Sketch
-> (forall a. a -> Sketch a)
-> (forall a b. Sketch (a -> b) -> Sketch a -> Sketch b)
-> (forall a b c.
    (a -> b -> c) -> Sketch a -> Sketch b -> Sketch c)
-> (forall a b. Sketch a -> Sketch b -> Sketch b)
-> (forall a b. Sketch a -> Sketch b -> Sketch a)
-> Applicative Sketch
Sketch a -> Sketch b -> Sketch b
Sketch a -> Sketch b -> Sketch a
Sketch (a -> b) -> Sketch a -> Sketch b
(a -> b -> c) -> Sketch a -> Sketch b -> Sketch c
forall a. a -> Sketch a
forall a b. Sketch a -> Sketch b -> Sketch a
forall a b. Sketch a -> Sketch b -> Sketch b
forall a b. Sketch (a -> b) -> Sketch a -> Sketch b
forall a b c. (a -> b -> c) -> Sketch a -> Sketch b -> Sketch c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Sketch a -> Sketch b -> Sketch a
$c<* :: forall a b. Sketch a -> Sketch b -> Sketch a
*> :: Sketch a -> Sketch b -> Sketch b
$c*> :: forall a b. Sketch a -> Sketch b -> Sketch b
liftA2 :: (a -> b -> c) -> Sketch a -> Sketch b -> Sketch c
$cliftA2 :: forall a b c. (a -> b -> c) -> Sketch a -> Sketch b -> Sketch c
<*> :: Sketch (a -> b) -> Sketch a -> Sketch b
$c<*> :: forall a b. Sketch (a -> b) -> Sketch a -> Sketch b
pure :: a -> Sketch a
$cpure :: forall a. a -> Sketch a
$cp1Applicative :: Functor Sketch
Applicative
		, a -> Sketch b -> Sketch a
(a -> b) -> Sketch a -> Sketch b
(forall a b. (a -> b) -> Sketch a -> Sketch b)
-> (forall a b. a -> Sketch b -> Sketch a) -> Functor Sketch
forall a b. a -> Sketch b -> Sketch a
forall a b. (a -> b) -> Sketch a -> Sketch b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Sketch b -> Sketch a
$c<$ :: forall a b. a -> Sketch b -> Sketch a
fmap :: (a -> b) -> Sketch a -> Sketch b
$cfmap :: forall a b. (a -> b) -> Sketch a -> Sketch b
Functor
		, MonadWriter [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
		, MonadState UniqueIds
		)

instance Monoid (Sketch ()) where
	mempty :: Sketch ()
mempty = WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  ()
-> Sketch ()
forall t.
WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
-> Sketch t
Sketch (()
-> WriterT
     [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
     (State UniqueIds)
     ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

instance Semigroup (Sketch t) where
	(Sketch WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
a) <> :: Sketch t -> Sketch t -> Sketch t
<> (Sketch WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
b) = WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
-> Sketch t
forall t.
WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
-> Sketch t
Sketch (WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
a WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
-> WriterT
     [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
     (State UniqueIds)
     t
-> WriterT
     [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
     (State UniqueIds)
     t
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
b)

newtype UniqueIds = UniqueIds (M.Map String Integer)

newtype UniqueId = UniqueId Integer

data TriggerLimit
	= TriggerLimit (Behavior Bool)
	| NoTriggerLimit

getTriggerLimit :: TriggerLimit -> Behavior Bool
getTriggerLimit :: TriggerLimit -> Behavior Bool
getTriggerLimit (TriggerLimit Behavior Bool
b) = Behavior Bool
b
getTriggerLimit TriggerLimit
NoTriggerLimit = Behavior Bool
true

addTriggerLimit :: TriggerLimit -> Behavior Bool -> Behavior Bool
addTriggerLimit :: TriggerLimit -> Behavior Bool -> Behavior Bool
addTriggerLimit TriggerLimit
tl Behavior Bool
c = TriggerLimit -> Behavior Bool
getTriggerLimit (TriggerLimit
tl TriggerLimit -> TriggerLimit -> TriggerLimit
forall a. Semigroup a => a -> a -> a
<> Behavior Bool -> TriggerLimit
TriggerLimit Behavior Bool
c)

instance Monoid TriggerLimit where
	mempty :: TriggerLimit
mempty = TriggerLimit
NoTriggerLimit

instance Semigroup TriggerLimit where
	TriggerLimit Behavior Bool
a <> :: TriggerLimit -> TriggerLimit -> TriggerLimit
<> TriggerLimit Behavior Bool
b =
		Behavior Bool -> TriggerLimit
TriggerLimit (Behavior Bool
a Behavior Bool -> Behavior Bool -> Behavior Bool
Language.Copilot.&& Behavior Bool
b)
	TriggerLimit
a <> TriggerLimit
NoTriggerLimit = TriggerLimit
a
	TriggerLimit
NoTriggerLimit <> TriggerLimit
b = TriggerLimit
b

evalSketch :: Sketch a -> (Maybe Spec, Framework)
evalSketch :: Sketch a -> (Maybe Spec, Framework)
evalSketch (Sketch WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  a
s) = (Maybe Spec
spec, Framework
f)
  where
	([TriggerLimit -> Spec]
is, [TriggerLimit -> Framework]
fs) = [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
-> ([TriggerLimit -> Spec], [TriggerLimit -> Framework])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(TriggerLimit -> Spec, TriggerLimit -> Framework)]
 -> ([TriggerLimit -> Spec], [TriggerLimit -> Framework]))
-> [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
-> ([TriggerLimit -> Spec], [TriggerLimit -> Framework])
forall a b. (a -> b) -> a -> b
$ 
		Identity [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
-> [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
forall a. Identity a -> a
runIdentity (Identity [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
 -> [(TriggerLimit -> Spec, TriggerLimit -> Framework)])
-> Identity [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
-> [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
forall a b. (a -> b) -> a -> b
$ StateT
  UniqueIds
  Identity
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
-> UniqueIds
-> Identity [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  a
-> StateT
     UniqueIds
     Identity
     [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  a
s) (Map String Integer -> UniqueIds
UniqueIds Map String Integer
forall a. Monoid a => a
mempty)
	f :: Framework
f = [Framework] -> Framework
forall a. Monoid a => [a] -> a
mconcat (((TriggerLimit -> Framework) -> Framework)
-> [TriggerLimit -> Framework] -> [Framework]
forall a b. (a -> b) -> [a] -> [b]
map (\TriggerLimit -> Framework
f' -> TriggerLimit -> Framework
f' TriggerLimit
NoTriggerLimit) [TriggerLimit -> Framework]
fs)
	-- Copilot will throw an ugly error if given a spec that does
	-- nothing at all, so return Nothing to avoid that.
	spec :: Maybe Spec
	spec :: Maybe Spec
spec = if [TriggerLimit -> Spec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TriggerLimit -> Spec]
is
		then Maybe Spec
forall a. Maybe a
Nothing
		else Spec -> Maybe Spec
forall a. a -> Maybe a
Just (Spec -> Maybe Spec) -> Spec -> Maybe Spec
forall a b. (a -> b) -> a -> b
$ [Spec] -> Spec
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Spec] -> Spec) -> [Spec] -> Spec
forall a b. (a -> b) -> a -> b
$ ((TriggerLimit -> Spec) -> Spec)
-> [TriggerLimit -> Spec] -> [Spec]
forall a b. (a -> b) -> [a] -> [b]
map (\TriggerLimit -> Spec
i -> TriggerLimit -> Spec
i TriggerLimit
NoTriggerLimit) [TriggerLimit -> Spec]
is

-- | Limit the effects of a `Sketch` to times when a `Behavior` `Bool` is True.
--
-- When applied to `=:`, this does the same thing as `@:` but without
-- the FRP style conversion the input `Behavior` into an `Event`. So `@:`
-- is generally better to use than this.
--
-- But, this can also be applied to `input`, to limit how often input
-- gets read. Useful to avoid performing slow input operations on every
-- iteration of a Sketch.
--
-- > v <- whenB (frequency 10) $ input pin12
--
-- (It's best to think of the value returned by that as an Event,
-- but it's currently represented as a Behavior, since the Copilot DSL
-- cannot operate on Events.)
whenB :: Behavior Bool -> Sketch t -> Sketch t
whenB :: Behavior Bool -> Sketch t -> Sketch t
whenB Behavior Bool
c (Sketch WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
s) = do
	UniqueIds
ids <- Sketch UniqueIds
forall s (m :: * -> *). MonadState s m => m s
get
	let ((t
r, [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
w), UniqueIds
ids') = Identity
  ((t, [(TriggerLimit -> Spec, TriggerLimit -> Framework)]),
   UniqueIds)
-> ((t, [(TriggerLimit -> Spec, TriggerLimit -> Framework)]),
    UniqueIds)
forall a. Identity a -> a
runIdentity (Identity
   ((t, [(TriggerLimit -> Spec, TriggerLimit -> Framework)]),
    UniqueIds)
 -> ((t, [(TriggerLimit -> Spec, TriggerLimit -> Framework)]),
     UniqueIds))
-> Identity
     ((t, [(TriggerLimit -> Spec, TriggerLimit -> Framework)]),
      UniqueIds)
-> ((t, [(TriggerLimit -> Spec, TriggerLimit -> Framework)]),
    UniqueIds)
forall a b. (a -> b) -> a -> b
$ StateT
  UniqueIds
  Identity
  (t, [(TriggerLimit -> Spec, TriggerLimit -> Framework)])
-> UniqueIds
-> Identity
     ((t, [(TriggerLimit -> Spec, TriggerLimit -> Framework)]),
      UniqueIds)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
-> StateT
     UniqueIds
     Identity
     (t, [(TriggerLimit -> Spec, TriggerLimit -> Framework)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT
  [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
  (State UniqueIds)
  t
s) UniqueIds
ids
	UniqueIds -> Sketch ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put UniqueIds
ids'
	let ([TriggerLimit -> Spec]
is, [TriggerLimit -> Framework]
fs) = [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
-> ([TriggerLimit -> Spec], [TriggerLimit -> Framework])
forall a b. [(a, b)] -> ([a], [b])
unzip [(TriggerLimit -> Spec, TriggerLimit -> Framework)]
w
	let spec :: TriggerLimit -> Spec
spec = (TriggerLimit -> Spec) -> TriggerLimit -> Spec
forall a. (TriggerLimit -> a) -> TriggerLimit -> a
combinetl ((TriggerLimit -> Spec) -> TriggerLimit -> Spec)
-> (TriggerLimit -> Spec) -> TriggerLimit -> Spec
forall a b. (a -> b) -> a -> b
$ \TriggerLimit
c' -> [Spec] -> Spec
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (((TriggerLimit -> Spec) -> Spec)
-> [TriggerLimit -> Spec] -> [Spec]
forall a b. (a -> b) -> [a] -> [b]
map (\TriggerLimit -> Spec
i -> TriggerLimit -> Spec
i TriggerLimit
c') [TriggerLimit -> Spec]
is)
	[(TriggerLimit -> Spec, TriggerLimit -> Framework)] -> Sketch ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(TriggerLimit -> Spec
spec, TriggerLimit -> Framework
forall a. Monoid a => a
mempty)]
	[TriggerLimit -> Framework]
-> ((TriggerLimit -> Framework) -> Sketch ()) -> Sketch ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TriggerLimit -> Framework]
fs (((TriggerLimit -> Framework) -> Sketch ()) -> Sketch ())
-> ((TriggerLimit -> Framework) -> Sketch ()) -> Sketch ()
forall a b. (a -> b) -> a -> b
$ \TriggerLimit -> Framework
f -> [(TriggerLimit -> Spec, TriggerLimit -> Framework)] -> Sketch ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Spec -> TriggerLimit -> Spec
forall a b. a -> b -> a
const (() -> Spec
forall (m :: * -> *) a. Monad m => a -> m a
return ()), (TriggerLimit -> Framework) -> TriggerLimit -> Framework
forall a. (TriggerLimit -> a) -> TriggerLimit -> a
combinetl TriggerLimit -> Framework
f)]
	t -> Sketch t
forall (m :: * -> *) a. Monad m => a -> m a
return t
r
  where
	combinetl :: (TriggerLimit -> a) -> TriggerLimit -> a
	combinetl :: (TriggerLimit -> a) -> TriggerLimit -> a
combinetl TriggerLimit -> a
g TriggerLimit
tl = TriggerLimit -> a
g (Behavior Bool -> TriggerLimit
TriggerLimit Behavior Bool
c TriggerLimit -> TriggerLimit -> TriggerLimit
forall a. Semigroup a => a -> a -> a
<> TriggerLimit
tl)

-- | Gets a unique id.
getUniqueId :: String -> Sketch UniqueId
getUniqueId :: String -> Sketch UniqueId
getUniqueId String
s = do
	UniqueIds Map String Integer
m <- Sketch UniqueIds
forall s (m :: * -> *). MonadState s m => m s
get
	let u :: Integer
u = Integer -> (Integer -> Integer) -> Maybe Integer -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
1 Integer -> Integer
forall a. Enum a => a -> a
succ (String -> Map String Integer -> Maybe Integer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
s Map String Integer
m)
	UniqueIds -> Sketch ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (UniqueIds -> Sketch ()) -> UniqueIds -> Sketch ()
forall a b. (a -> b) -> a -> b
$ Map String Integer -> UniqueIds
UniqueIds (Map String Integer -> UniqueIds)
-> Map String Integer -> UniqueIds
forall a b. (a -> b) -> a -> b
$ String -> Integer -> Map String Integer -> Map String Integer
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
s Integer
u Map String Integer
m
	UniqueId -> Sketch UniqueId
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> UniqueId
UniqueId Integer
u)

-- | Generates a unique name.
uniqueName :: String -> UniqueId -> String
uniqueName :: String -> UniqueId -> String
uniqueName String
s (UniqueId Integer
i)
	| Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
Prelude.== Integer
1 = String
s
	| Bool
otherwise = String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>  Integer -> String
forall a. Show a => a -> String
show Integer
i

uniqueName' :: String -> UniqueId -> String
uniqueName' :: String -> UniqueId -> String
uniqueName' String
s (UniqueId Integer
i) = String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>  Integer -> String
forall a. Show a => a -> String
show Integer
i

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

instance Semigroup Framework where
	Framework
a <> :: Framework -> Framework -> Framework
<> Framework
b = Framework :: [CChunk]
-> [CChunk]
-> [CChunk]
-> Map PinId (Set PinMode)
-> [CChunk]
-> Framework
Framework
		{ defines :: [CChunk]
defines = Framework -> [CChunk]
defines Framework
a [CChunk] -> [CChunk] -> [CChunk]
forall a. Semigroup a => a -> a -> a
<> Framework -> [CChunk]
defines Framework
b
		, setups :: [CChunk]
setups = Framework -> [CChunk]
setups Framework
a [CChunk] -> [CChunk] -> [CChunk]
forall a. Semigroup a => a -> a -> a
<> Framework -> [CChunk]
setups Framework
b
		, earlySetups :: [CChunk]
earlySetups = Framework -> [CChunk]
earlySetups Framework
a [CChunk] -> [CChunk] -> [CChunk]
forall a. Semigroup a => a -> a -> a
<> Framework -> [CChunk]
earlySetups Framework
b
		, pinmodes :: Map PinId (Set PinMode)
pinmodes = (Set PinMode -> Set PinMode -> Set PinMode)
-> Map PinId (Set PinMode)
-> Map PinId (Set PinMode)
-> Map PinId (Set PinMode)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Set PinMode -> Set PinMode -> Set PinMode
forall a. Ord a => Set a -> Set a -> Set a
S.union (Framework -> Map PinId (Set PinMode)
pinmodes Framework
a) (Framework -> Map PinId (Set PinMode)
pinmodes Framework
b)
		, loops :: [CChunk]
loops = Framework -> [CChunk]
loops Framework
a  [CChunk] -> [CChunk] -> [CChunk]
forall a. Semigroup a => a -> a -> a
<> Framework -> [CChunk]
loops Framework
b
		}

instance Monoid Framework where
	mempty :: Framework
mempty = [CChunk]
-> [CChunk]
-> [CChunk]
-> Map PinId (Set PinMode)
-> [CChunk]
-> Framework
Framework [CChunk]
forall a. Monoid a => a
mempty [CChunk]
forall a. Monoid a => a
mempty [CChunk]
forall a. Monoid a => a
mempty Map PinId (Set PinMode)
forall a. Monoid a => a
mempty [CChunk]
forall a. Monoid a => a
mempty

-- | A line of C code.
newtype CLine = CLine { CLine -> String
fromCLine :: String }
	deriving (CLine -> CLine -> Bool
(CLine -> CLine -> Bool) -> (CLine -> CLine -> Bool) -> Eq CLine
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CLine -> CLine -> Bool
$c/= :: CLine -> CLine -> Bool
== :: CLine -> CLine -> Bool
$c== :: CLine -> CLine -> Bool
Eq, Int -> CLine -> String -> String
[CLine] -> String -> String
CLine -> String
(Int -> CLine -> String -> String)
-> (CLine -> String) -> ([CLine] -> String -> String) -> Show CLine
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CLine] -> String -> String
$cshowList :: [CLine] -> String -> String
show :: CLine -> String
$cshow :: CLine -> String
showsPrec :: Int -> CLine -> String -> String
$cshowsPrec :: Int -> CLine -> String -> String
Show, Eq CLine
Eq CLine
-> (CLine -> CLine -> Ordering)
-> (CLine -> CLine -> Bool)
-> (CLine -> CLine -> Bool)
-> (CLine -> CLine -> Bool)
-> (CLine -> CLine -> Bool)
-> (CLine -> CLine -> CLine)
-> (CLine -> CLine -> CLine)
-> Ord CLine
CLine -> CLine -> Bool
CLine -> CLine -> Ordering
CLine -> CLine -> CLine
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CLine -> CLine -> CLine
$cmin :: CLine -> CLine -> CLine
max :: CLine -> CLine -> CLine
$cmax :: CLine -> CLine -> CLine
>= :: CLine -> CLine -> Bool
$c>= :: CLine -> CLine -> Bool
> :: CLine -> CLine -> Bool
$c> :: CLine -> CLine -> Bool
<= :: CLine -> CLine -> Bool
$c<= :: CLine -> CLine -> Bool
< :: CLine -> CLine -> Bool
$c< :: CLine -> CLine -> Bool
compare :: CLine -> CLine -> Ordering
$ccompare :: CLine -> CLine -> Ordering
$cp1Ord :: Eq CLine
Ord)

-- | A chunk of C code. Identical chunks get deduplicated.
newtype CChunk = CChunk [CLine]
	deriving (CChunk -> CChunk -> Bool
(CChunk -> CChunk -> Bool)
-> (CChunk -> CChunk -> Bool) -> Eq CChunk
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CChunk -> CChunk -> Bool
$c/= :: CChunk -> CChunk -> Bool
== :: CChunk -> CChunk -> Bool
$c== :: CChunk -> CChunk -> Bool
Eq, Int -> CChunk -> String -> String
[CChunk] -> String -> String
CChunk -> String
(Int -> CChunk -> String -> String)
-> (CChunk -> String)
-> ([CChunk] -> String -> String)
-> Show CChunk
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CChunk] -> String -> String
$cshowList :: [CChunk] -> String -> String
show :: CChunk -> String
$cshow :: CChunk -> String
showsPrec :: Int -> CChunk -> String -> String
$cshowsPrec :: Int -> CChunk -> String -> String
Show, Eq CChunk
Eq CChunk
-> (CChunk -> CChunk -> Ordering)
-> (CChunk -> CChunk -> Bool)
-> (CChunk -> CChunk -> Bool)
-> (CChunk -> CChunk -> Bool)
-> (CChunk -> CChunk -> Bool)
-> (CChunk -> CChunk -> CChunk)
-> (CChunk -> CChunk -> CChunk)
-> Ord CChunk
CChunk -> CChunk -> Bool
CChunk -> CChunk -> Ordering
CChunk -> CChunk -> CChunk
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CChunk -> CChunk -> CChunk
$cmin :: CChunk -> CChunk -> CChunk
max :: CChunk -> CChunk -> CChunk
$cmax :: CChunk -> CChunk -> CChunk
>= :: CChunk -> CChunk -> Bool
$c>= :: CChunk -> CChunk -> Bool
> :: CChunk -> CChunk -> Bool
$c> :: CChunk -> CChunk -> Bool
<= :: CChunk -> CChunk -> Bool
$c<= :: CChunk -> CChunk -> Bool
< :: CChunk -> CChunk -> Bool
$c< :: CChunk -> CChunk -> Bool
compare :: CChunk -> CChunk -> Ordering
$ccompare :: CChunk -> CChunk -> Ordering
$cp1Ord :: Eq CChunk
Ord, b -> CChunk -> CChunk
NonEmpty CChunk -> CChunk
CChunk -> CChunk -> CChunk
(CChunk -> CChunk -> CChunk)
-> (NonEmpty CChunk -> CChunk)
-> (forall b. Integral b => b -> CChunk -> CChunk)
-> Semigroup CChunk
forall b. Integral b => b -> CChunk -> CChunk
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> CChunk -> CChunk
$cstimes :: forall b. Integral b => b -> CChunk -> CChunk
sconcat :: NonEmpty CChunk -> CChunk
$csconcat :: NonEmpty CChunk -> CChunk
<> :: CChunk -> CChunk -> CChunk
$c<> :: CChunk -> CChunk -> CChunk
Semigroup, Semigroup CChunk
CChunk
Semigroup CChunk
-> CChunk
-> (CChunk -> CChunk -> CChunk)
-> ([CChunk] -> CChunk)
-> Monoid CChunk
[CChunk] -> CChunk
CChunk -> CChunk -> CChunk
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [CChunk] -> CChunk
$cmconcat :: [CChunk] -> CChunk
mappend :: CChunk -> CChunk -> CChunk
$cmappend :: CChunk -> CChunk -> CChunk
mempty :: CChunk
$cmempty :: CChunk
$cp1Monoid :: Semigroup CChunk
Monoid)

mkCChunk :: [CLine] -> [CChunk]
mkCChunk :: [CLine] -> [CChunk]
mkCChunk [CLine]
l = [[CLine] -> CChunk
CChunk [CLine]
l]

-- | Copilot only supports calling a trigger with a given name once
-- per Spec; the generated C code will fail to build if the same name is
-- used in two triggers. This generates a unique alias that can be 
-- used in a trigger.
defineTriggerAlias :: String -> Framework -> Sketch (Framework, String)
defineTriggerAlias :: String -> Framework -> Sketch (Framework, String)
defineTriggerAlias = String -> String -> Framework -> Sketch (Framework, String)
defineTriggerAlias' String
""

defineTriggerAlias' :: String -> String -> Framework -> Sketch (Framework, String)
defineTriggerAlias' :: String -> String -> Framework -> Sketch (Framework, String)
defineTriggerAlias' String
suffix String
cfuncname Framework
f = do
	let basetname :: String
basetname = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
suffix 
		then String
cfuncname
		else String
cfuncname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
suffix
	UniqueId
u <- String -> Sketch UniqueId
getUniqueId String
basetname
	let triggername :: String
triggername = String -> UniqueId -> String
uniqueName String
basetname UniqueId
u
	let define :: [CChunk]
define = if String
cfuncname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
Prelude./= String
triggername
		then [CLine] -> [CChunk]
mkCChunk [ String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"#define " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
triggername String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cfuncname	]
		else [CChunk]
forall a. Monoid a => a
mempty
	(Framework, String) -> Sketch (Framework, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Framework
f { defines :: [CChunk]
defines = [CChunk]
define [CChunk] -> [CChunk] -> [CChunk]
forall a. Semigroup a => a -> a -> a
<> Framework -> [CChunk]
defines Framework
f }, String
triggername)

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

mkInput :: InputSource t -> Sketch (Behavior t)
mkInput :: InputSource t -> Sketch (Behavior t)
mkInput InputSource t
i = do
	UniqueId
u <- String -> Sketch UniqueId
getUniqueId String
"input"
	[(TriggerLimit -> Spec, TriggerLimit -> Framework)] -> Sketch ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(UniqueId -> TriggerLimit -> Spec
mkspec UniqueId
u, UniqueId -> TriggerLimit -> Framework
f UniqueId
u)]
	Behavior t -> Sketch (Behavior t)
forall (m :: * -> *) a. Monad m => a -> m a
return (InputSource t -> Behavior t
forall t. InputSource t -> Stream t
inputStream InputSource t
i)
  where
	f :: UniqueId -> TriggerLimit -> Framework
f UniqueId
u TriggerLimit
ratelimited = Framework :: [CChunk]
-> [CChunk]
-> [CChunk]
-> Map PinId (Set PinMode)
-> [CChunk]
-> Framework
Framework
		{ defines :: [CChunk]
defines = InputSource t -> [CChunk]
forall t. InputSource t -> [CChunk]
defineVar InputSource t
i [CChunk] -> [CChunk] -> [CChunk]
forall a. Semigroup a => a -> a -> a
<> UniqueId -> TriggerLimit -> [CChunk]
mkdefine UniqueId
u TriggerLimit
ratelimited
		, setups :: [CChunk]
setups = InputSource t -> [CChunk]
forall t. InputSource t -> [CChunk]
setupInput InputSource t
i
		, earlySetups :: [CChunk]
earlySetups = [CChunk]
forall a. Monoid a => a
mempty
		, pinmodes :: Map PinId (Set PinMode)
pinmodes = (PinMode -> Set PinMode)
-> Map PinId PinMode -> Map PinId (Set PinMode)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map PinMode -> Set PinMode
forall a. a -> Set a
S.singleton (InputSource t -> Map PinId PinMode
forall t. InputSource t -> Map PinId PinMode
inputPinmode InputSource t
i)
		, loops :: [CChunk]
loops = UniqueId -> TriggerLimit -> [CChunk] -> [CChunk]
mkloops UniqueId
u TriggerLimit
ratelimited (InputSource t -> [CChunk]
forall t. InputSource t -> [CChunk]
readInput InputSource t
i)
		}

	varname :: UniqueId -> String
varname = String -> UniqueId -> String
uniqueName String
"update_input"
	triggername :: UniqueId -> String
triggername = String -> UniqueId -> String
uniqueName String
"input"
	
	mkdefine :: UniqueId -> TriggerLimit -> [CChunk]
mkdefine UniqueId
_ TriggerLimit
NoTriggerLimit = []
	mkdefine UniqueId
u (TriggerLimit Behavior Bool
_) = [CLine] -> [CChunk]
mkCChunk ([CLine] -> [CChunk]) -> [CLine] -> [CChunk]
forall a b. (a -> b) -> a -> b
$ (String -> CLine) -> [String] -> [CLine]
forall a b. (a -> b) -> [a] -> [b]
map String -> CLine
CLine
		[ String
"bool " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UniqueId -> String
varname UniqueId
u String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = true;"
		, String
"void " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UniqueId -> String
triggername UniqueId
u String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (bool v) {"
		, String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UniqueId -> String
varname UniqueId
u String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = v;"
		, String
"}"
		]
	
	mkloops :: UniqueId -> TriggerLimit -> [CChunk] -> [CChunk]
mkloops UniqueId
_ TriggerLimit
NoTriggerLimit [CChunk]
reader = [CChunk]
reader
	mkloops UniqueId
u (TriggerLimit Behavior Bool
_) [CChunk]
reader = [CLine] -> [CChunk]
mkCChunk ([CLine] -> [CChunk]) -> [CLine] -> [CChunk]
forall a b. (a -> b) -> a -> b
$ [[CLine]] -> [CLine]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
		[ [ String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"if (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UniqueId -> String
varname UniqueId
u String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") {" ]
		, (CLine -> CLine) -> [CLine] -> [CLine]
forall a b. (a -> b) -> [a] -> [b]
map (\(CLine String
l) -> String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
l ) [CLine]
readerlines
		, [ String -> CLine
CLine String
"}" ]
		]
	  where
		readerlines :: [CLine]
readerlines = (CChunk -> [CLine]) -> [CChunk] -> [CLine]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(CChunk [CLine]
l) -> [CLine]
l) [CChunk]
reader

	mkspec :: UniqueId -> TriggerLimit -> Spec
mkspec UniqueId
_ TriggerLimit
NoTriggerLimit = () -> Spec
forall (m :: * -> *) a. Monad m => a -> m a
return ()
	mkspec UniqueId
u (TriggerLimit Behavior Bool
c) = String -> Behavior Bool -> [Arg] -> Spec
trigger (UniqueId -> String
triggername UniqueId
u) Behavior Bool
true [Behavior Bool -> Arg
forall a. Typed a => Stream a -> Arg
arg Behavior Bool
c]

-- | 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 (Int -> Pin t -> String -> String
[Pin t] -> String -> String
Pin t -> String
(Int -> Pin t -> String -> String)
-> (Pin t -> String)
-> ([Pin t] -> String -> String)
-> Show (Pin t)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall k (t :: k). Int -> Pin t -> String -> String
forall k (t :: k). [Pin t] -> String -> String
forall k (t :: k). Pin t -> String
showList :: [Pin t] -> String -> String
$cshowList :: forall k (t :: k). [Pin t] -> String -> String
show :: Pin t -> String
$cshow :: forall k (t :: k). Pin t -> String
showsPrec :: Int -> Pin t -> String -> String
$cshowsPrec :: forall k (t :: k). Int -> Pin t -> String -> String
Show, Pin t -> Pin t -> Bool
(Pin t -> Pin t -> Bool) -> (Pin t -> Pin t -> Bool) -> Eq (Pin t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (t :: k). Pin t -> Pin t -> Bool
/= :: Pin t -> Pin t -> Bool
$c/= :: forall k (t :: k). Pin t -> Pin t -> Bool
== :: Pin t -> Pin t -> Bool
$c== :: forall k (t :: k). Pin t -> Pin t -> Bool
Eq, Eq (Pin t)
Eq (Pin t)
-> (Pin t -> Pin t -> Ordering)
-> (Pin t -> Pin t -> Bool)
-> (Pin t -> Pin t -> Bool)
-> (Pin t -> Pin t -> Bool)
-> (Pin t -> Pin t -> Bool)
-> (Pin t -> Pin t -> Pin t)
-> (Pin t -> Pin t -> Pin t)
-> Ord (Pin t)
Pin t -> Pin t -> Bool
Pin t -> Pin t -> Ordering
Pin t -> Pin t -> Pin t
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall k (t :: k). Eq (Pin t)
forall k (t :: k). Pin t -> Pin t -> Bool
forall k (t :: k). Pin t -> Pin t -> Ordering
forall k (t :: k). Pin t -> Pin t -> Pin t
min :: Pin t -> Pin t -> Pin t
$cmin :: forall k (t :: k). Pin t -> Pin t -> Pin t
max :: Pin t -> Pin t -> Pin t
$cmax :: forall k (t :: k). Pin t -> Pin t -> Pin t
>= :: Pin t -> Pin t -> Bool
$c>= :: forall k (t :: k). Pin t -> Pin t -> Bool
> :: Pin t -> Pin t -> Bool
$c> :: forall k (t :: k). Pin t -> Pin t -> Bool
<= :: Pin t -> Pin t -> Bool
$c<= :: forall k (t :: k). Pin t -> Pin t -> Bool
< :: Pin t -> Pin t -> Bool
$c< :: forall k (t :: k). Pin t -> Pin t -> Bool
compare :: Pin t -> Pin t -> Ordering
$ccompare :: forall k (t :: k). Pin t -> Pin t -> Ordering
$cp1Ord :: forall k (t :: k). Eq (Pin t)
Ord)

newtype PinId = PinId Int16
	deriving (Int -> PinId -> String -> String
[PinId] -> String -> String
PinId -> String
(Int -> PinId -> String -> String)
-> (PinId -> String) -> ([PinId] -> String -> String) -> Show PinId
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PinId] -> String -> String
$cshowList :: [PinId] -> String -> String
show :: PinId -> String
$cshow :: PinId -> String
showsPrec :: Int -> PinId -> String -> String
$cshowsPrec :: Int -> PinId -> String -> String
Show, PinId -> PinId -> Bool
(PinId -> PinId -> Bool) -> (PinId -> PinId -> Bool) -> Eq PinId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PinId -> PinId -> Bool
$c/= :: PinId -> PinId -> Bool
== :: PinId -> PinId -> Bool
$c== :: PinId -> PinId -> Bool
Eq, Eq PinId
Eq PinId
-> (PinId -> PinId -> Ordering)
-> (PinId -> PinId -> Bool)
-> (PinId -> PinId -> Bool)
-> (PinId -> PinId -> Bool)
-> (PinId -> PinId -> Bool)
-> (PinId -> PinId -> PinId)
-> (PinId -> PinId -> PinId)
-> Ord PinId
PinId -> PinId -> Bool
PinId -> PinId -> Ordering
PinId -> PinId -> PinId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PinId -> PinId -> PinId
$cmin :: PinId -> PinId -> PinId
max :: PinId -> PinId -> PinId
$cmax :: PinId -> PinId -> PinId
>= :: PinId -> PinId -> Bool
$c>= :: PinId -> PinId -> Bool
> :: PinId -> PinId -> Bool
$c> :: PinId -> PinId -> Bool
<= :: PinId -> PinId -> Bool
$c<= :: PinId -> PinId -> Bool
< :: PinId -> PinId -> Bool
$c< :: PinId -> PinId -> Bool
compare :: PinId -> PinId -> Ordering
$ccompare :: PinId -> PinId -> Ordering
$cp1Ord :: Eq PinId
Ord)

data PinCapabilities
	= DigitalIO
	| AnalogInput
	| PWM
	deriving (Int -> PinCapabilities -> String -> String
[PinCapabilities] -> String -> String
PinCapabilities -> String
(Int -> PinCapabilities -> String -> String)
-> (PinCapabilities -> String)
-> ([PinCapabilities] -> String -> String)
-> Show PinCapabilities
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PinCapabilities] -> String -> String
$cshowList :: [PinCapabilities] -> String -> String
show :: PinCapabilities -> String
$cshow :: PinCapabilities -> String
showsPrec :: Int -> PinCapabilities -> String -> String
$cshowsPrec :: Int -> PinCapabilities -> String -> String
Show, PinCapabilities -> PinCapabilities -> Bool
(PinCapabilities -> PinCapabilities -> Bool)
-> (PinCapabilities -> PinCapabilities -> Bool)
-> Eq PinCapabilities
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PinCapabilities -> PinCapabilities -> Bool
$c/= :: PinCapabilities -> PinCapabilities -> Bool
== :: PinCapabilities -> PinCapabilities -> Bool
$c== :: PinCapabilities -> PinCapabilities -> Bool
Eq, Eq PinCapabilities
Eq PinCapabilities
-> (PinCapabilities -> PinCapabilities -> Ordering)
-> (PinCapabilities -> PinCapabilities -> Bool)
-> (PinCapabilities -> PinCapabilities -> Bool)
-> (PinCapabilities -> PinCapabilities -> Bool)
-> (PinCapabilities -> PinCapabilities -> Bool)
-> (PinCapabilities -> PinCapabilities -> PinCapabilities)
-> (PinCapabilities -> PinCapabilities -> PinCapabilities)
-> Ord PinCapabilities
PinCapabilities -> PinCapabilities -> Bool
PinCapabilities -> PinCapabilities -> Ordering
PinCapabilities -> PinCapabilities -> PinCapabilities
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PinCapabilities -> PinCapabilities -> PinCapabilities
$cmin :: PinCapabilities -> PinCapabilities -> PinCapabilities
max :: PinCapabilities -> PinCapabilities -> PinCapabilities
$cmax :: PinCapabilities -> PinCapabilities -> PinCapabilities
>= :: PinCapabilities -> PinCapabilities -> Bool
$c>= :: PinCapabilities -> PinCapabilities -> Bool
> :: PinCapabilities -> PinCapabilities -> Bool
$c> :: PinCapabilities -> PinCapabilities -> Bool
<= :: PinCapabilities -> PinCapabilities -> Bool
$c<= :: PinCapabilities -> PinCapabilities -> Bool
< :: PinCapabilities -> PinCapabilities -> Bool
$c< :: PinCapabilities -> PinCapabilities -> Bool
compare :: PinCapabilities -> PinCapabilities -> Ordering
$ccompare :: PinCapabilities -> PinCapabilities -> Ordering
$cp1Ord :: Eq PinCapabilities
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 (Int -> PinMode -> String -> String
[PinMode] -> String -> String
PinMode -> String
(Int -> PinMode -> String -> String)
-> (PinMode -> String)
-> ([PinMode] -> String -> String)
-> Show PinMode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PinMode] -> String -> String
$cshowList :: [PinMode] -> String -> String
show :: PinMode -> String
$cshow :: PinMode -> String
showsPrec :: Int -> PinMode -> String -> String
$cshowsPrec :: Int -> PinMode -> String -> String
Show, PinMode -> PinMode -> Bool
(PinMode -> PinMode -> Bool)
-> (PinMode -> PinMode -> Bool) -> Eq PinMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PinMode -> PinMode -> Bool
$c/= :: PinMode -> PinMode -> Bool
== :: PinMode -> PinMode -> Bool
$c== :: PinMode -> PinMode -> Bool
Eq, Eq PinMode
Eq PinMode
-> (PinMode -> PinMode -> Ordering)
-> (PinMode -> PinMode -> Bool)
-> (PinMode -> PinMode -> Bool)
-> (PinMode -> PinMode -> Bool)
-> (PinMode -> PinMode -> Bool)
-> (PinMode -> PinMode -> PinMode)
-> (PinMode -> PinMode -> PinMode)
-> Ord PinMode
PinMode -> PinMode -> Bool
PinMode -> PinMode -> Ordering
PinMode -> PinMode -> PinMode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PinMode -> PinMode -> PinMode
$cmin :: PinMode -> PinMode -> PinMode
max :: PinMode -> PinMode -> PinMode
$cmax :: PinMode -> PinMode -> PinMode
>= :: PinMode -> PinMode -> Bool
$c>= :: PinMode -> PinMode -> Bool
> :: PinMode -> PinMode -> Bool
$c> :: PinMode -> PinMode -> Bool
<= :: PinMode -> PinMode -> Bool
$c<= :: PinMode -> PinMode -> Bool
< :: PinMode -> PinMode -> Bool
$c< :: PinMode -> PinMode -> Bool
compare :: PinMode -> PinMode -> Ordering
$ccompare :: PinMode -> PinMode -> Ordering
$cp1Ord :: Eq PinMode
Ord)

-- | Things that can have a `Behavior` or `Event` output to them.
class Output o t where
	(=:) :: o -> t -> Sketch ()
	-- ^ Connect a `Behavior` or `Event` to an `Output`
	-- 
	-- > led =: blinking
	-- 
	-- When a `Behavior` is used, its current value is written on each
	-- iteration of the `Sketch`. 
	-- 
	-- For example, this constantly turns on the LED, even though it will
	-- already be on after the first iteration, because `true`
	-- is a `Behavior` (that is always True).
	-- 
	-- > led =: true
	-- 
	-- To avoid unncessary work being done, you can use an `Event`
	-- instead. Then the write only happens at the points in time
	-- when the `Event` occurs. To turn a `Behavior` into an `Event`,
	-- use `@:`
	-- 
	-- So to make the LED only be turned on in the first iteration,
	-- and allow it to remain on thereafter without doing extra work:
	-- 
	-- > led =: true @: firstIteration

-- Same fixity as =<<
infixr 1 =:

instance Output o (Event () (Stream v)) => Output o (Behavior v) where
	=: :: o -> Behavior v -> Sketch ()
(=:) o
o Behavior v
b = o
o o -> Event () (Behavior v) -> Sketch ()
forall o t. Output o t => o -> t -> Sketch ()
=: Event () (Behavior v)
te
	  where
	  	te :: Event () (Stream v)
		te :: Event () (Behavior v)
te = Behavior v -> Behavior Bool -> Event () (Behavior v)
forall k (p :: k) v. v -> Behavior Bool -> Event p v
Event Behavior v
b Behavior Bool
true

instance Output o (Event p (Stream v)) => Output o (TypedBehavior p v) where
	=: :: o -> TypedBehavior p v -> Sketch ()
(=:) o
o (TypedBehavior Stream v
b) = o
o o -> Event p (Stream v) -> Sketch ()
forall o t. Output o t => o -> t -> Sketch ()
=: Event p (Stream v)
te
	  where
		te :: Event p (Stream v)
		te :: Event p (Stream v)
te = Stream v -> Behavior Bool -> Event p (Stream v)
forall k (p :: k) v. v -> Behavior Bool -> Event p v
Event Stream v
b Behavior Bool
true

-- | This type family is open, so it can be extended when adding other data
-- types to the IsBehavior class.
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
	-- | Generate an Event, from some type of behavior,
	-- that only occurs when the `Behavior` Bool is True.
	(@:) :: behavior -> Behavior Bool -> BehaviorToEvent behavior

instance IsBehavior (Behavior v) where
	Behavior v
b @: :: Behavior v -> Behavior Bool -> BehaviorToEvent (Behavior v)
@: Behavior Bool
c = Behavior v -> Behavior Bool -> Event () (Behavior v)
forall k (p :: k) v. v -> Behavior Bool -> Event p v
Event Behavior v
b Behavior Bool
c

instance IsBehavior (TypedBehavior p v) where
	@: :: TypedBehavior p v
-> Behavior Bool -> BehaviorToEvent (TypedBehavior p v)
(@:) (TypedBehavior Behavior v
b) Behavior Bool
c = Behavior v -> Behavior Bool -> Event p (Behavior v)
forall k (p :: k) v. v -> Behavior Bool -> Event p v
Event Behavior v
b Behavior Bool
c

instance IsDigitalIOPin t => Output (Pin t) (Event () (Stream Bool)) where
	(Pin p :: PinId
p@(PinId Int16
n)) =: :: Pin t -> Event () (Behavior Bool) -> Sketch ()
=: (Event Behavior Bool
b Behavior Bool
c) = do
		(Framework
f, String
triggername) <- String -> String -> Framework -> Sketch (Framework, String)
defineTriggerAlias' (String
"pin_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n) String
"digitalWrite" (Framework -> Sketch (Framework, String))
-> Framework -> Sketch (Framework, String)
forall a b. (a -> b) -> a -> b
$
			Framework
forall a. Monoid a => a
mempty { pinmodes :: Map PinId (Set PinMode)
pinmodes = PinId -> Set PinMode -> Map PinId (Set PinMode)
forall k a. k -> a -> Map k a
M.singleton PinId
p (PinMode -> Set PinMode
forall a. a -> Set a
S.singleton PinMode
OutputMode) }
		[(TriggerLimit -> Spec, TriggerLimit -> Framework)] -> Sketch ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(String -> TriggerLimit -> Spec
go String
triggername, Framework -> TriggerLimit -> Framework
forall a b. a -> b -> a
const Framework
f)]
	  where
		go :: String -> TriggerLimit -> Spec
go String
triggername TriggerLimit
tl = 
			let c' :: Behavior Bool
c' = TriggerLimit -> Behavior Bool -> Behavior Bool
addTriggerLimit TriggerLimit
tl Behavior Bool
c
			in String -> Behavior Bool -> [Arg] -> Spec
trigger String
triggername Behavior Bool
c' [Stream Int16 -> Arg
forall a. Typed a => Stream a -> Arg
arg (Int16 -> Stream Int16
forall a. Typed a => a -> Stream a
constant Int16
n), Behavior Bool -> Arg
forall a. Typed a => Stream a -> Arg
arg Behavior Bool
b]

instance IsPWMPin t => Output (Pin t) (Event 'PWM (Stream Word8)) where
	(Pin (PinId Int16
n)) =: :: Pin t -> Event 'PWM (Stream Word8) -> Sketch ()
=: (Event Stream Word8
v Behavior Bool
c) = do
		(Framework
f, String
triggername) <- String -> String -> Framework -> Sketch (Framework, String)
defineTriggerAlias' (String
"pin_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n) String
"analogWrite" Framework
forall a. Monoid a => a
mempty
		[(TriggerLimit -> Spec, TriggerLimit -> Framework)] -> Sketch ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(String -> TriggerLimit -> Spec
go String
triggername, Framework -> TriggerLimit -> Framework
forall a b. a -> b -> a
const Framework
f)]
	  where
		go :: String -> TriggerLimit -> Spec
go String
triggername TriggerLimit
tl = 
			let c' :: Behavior Bool
c' = TriggerLimit -> Behavior Bool -> Behavior Bool
addTriggerLimit TriggerLimit
tl Behavior Bool
c
			in String -> Behavior Bool -> [Arg] -> Spec
trigger String
triggername Behavior Bool
c' [Stream Int16 -> Arg
forall a. Typed a => Stream a -> Arg
arg (Int16 -> Stream Int16
forall a. Typed a => a -> Stream a
constant Int16
n), Stream Word8 -> Arg
forall a. Typed a => Stream a -> Arg
arg Stream Word8
v]
		-- analogWrite does not need any pinmodes set up

class Input o t where
	-- | The list is input to use when simulating the Sketch.
	input' :: o -> [t] -> Sketch (Behavior t)

-- | Use this to read a value from a component of the Arduino.
--
-- For example, to read a digital value from pin12 and turn on the 
-- led when the pin is high:
--
-- > buttonpressed <- input pin12
-- > led =: buttonpressed
--
-- Some pins support multiple types of reads, for example pin a0
-- supports a digital read (`Bool`), and an analog to digital converter
-- read (`ADC`). In such cases you may need to specify the type of
-- data to read:
--
-- > v <- input a0 :: Sketch (Behavior ADC)
input :: Input o t => o -> Sketch (Behavior t)
input :: o -> Sketch (Behavior t)
input o
o = o -> [t] -> Sketch (Behavior t)
forall o t. Input o t => o -> [t] -> Sketch (Behavior t)
input' o
o []

instance IsDigitalIOPin t => Input (Pin t) Bool where
	input' :: Pin t -> [Bool] -> Sketch (Behavior Bool)
input' (Pin p :: PinId
p@(PinId Int16
n)) [Bool]
interpretvalues = InputSource Bool -> Sketch (Behavior Bool)
forall t. InputSource t -> Sketch (Behavior t)
mkInput (InputSource Bool -> Sketch (Behavior Bool))
-> InputSource Bool -> Sketch (Behavior Bool)
forall a b. (a -> b) -> a -> b
$ InputSource :: forall t.
[CChunk]
-> [CChunk]
-> Map PinId PinMode
-> [CChunk]
-> Stream t
-> InputSource t
InputSource
		{ defineVar :: [CChunk]
defineVar = [CLine] -> [CChunk]
mkCChunk [String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"bool " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
varname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
";"]
		, setupInput :: [CChunk]
setupInput = [CChunk]
forall a. Monoid a => a
mempty
		, inputPinmode :: Map PinId PinMode
inputPinmode = PinId -> PinMode -> Map PinId PinMode
forall k a. k -> a -> Map k a
M.singleton PinId
p PinMode
InputMode
		, readInput :: [CChunk]
readInput = [CLine] -> [CChunk]
mkCChunk
			[String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
varname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = digitalRead(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
");"]
		, inputStream :: Behavior Bool
inputStream = String -> Maybe [Bool] -> Behavior Bool
forall a. Typed a => String -> Maybe [a] -> Stream a
extern String
varname Maybe [Bool]
interpretvalues'
		}
	  where
		varname :: String
varname = String
"arduino_digital_pin_input" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n
		interpretvalues' :: Maybe [Bool]
interpretvalues'
			| [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bool]
interpretvalues = Maybe [Bool]
forall a. Maybe a
Nothing
			| Bool
otherwise = [Bool] -> Maybe [Bool]
forall a. a -> Maybe a
Just [Bool]
interpretvalues

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

instance IsAnalogInputPin t => Input (Pin t) ADC where
	input' :: Pin t -> [Int16] -> Sketch (Stream Int16)
input' (Pin (PinId Int16
n)) [Int16]
interpretvalues = InputSource Int16 -> Sketch (Stream Int16)
forall t. InputSource t -> Sketch (Behavior t)
mkInput (InputSource Int16 -> Sketch (Stream Int16))
-> InputSource Int16 -> Sketch (Stream Int16)
forall a b. (a -> b) -> a -> b
$ InputSource :: forall t.
[CChunk]
-> [CChunk]
-> Map PinId PinMode
-> [CChunk]
-> Stream t
-> InputSource t
InputSource
		{ defineVar :: [CChunk]
defineVar = [CLine] -> [CChunk]
mkCChunk [String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"int " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
varname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
";"]
		, setupInput :: [CChunk]
setupInput = [CChunk]
forall a. Monoid a => a
mempty
		, inputPinmode :: Map PinId PinMode
inputPinmode = Map PinId PinMode
forall a. Monoid a => a
mempty
		, readInput :: [CChunk]
readInput = [CLine] -> [CChunk]
mkCChunk
			[String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
varname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = analogRead(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
");"]
		, inputStream :: Stream Int16
inputStream = String -> Maybe [Int16] -> Stream Int16
forall a. Typed a => String -> Maybe [a] -> Stream a
extern String
varname Maybe [Int16]
interpretvalues'
		}
	  where
		varname :: String
varname = String
"arduino_analog_pin_input" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int16 -> String
forall a. Show a => a -> String
show Int16
n
		interpretvalues' :: Maybe [Int16]
interpretvalues'
			| [Int16] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int16]
interpretvalues = Maybe [Int16]
forall a. Maybe a
Nothing
			| Bool
otherwise = [Int16] -> Maybe [Int16]
forall a. a -> Maybe a
Just [Int16]
interpretvalues

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

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