{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
module Copilot.Arduino.Internals where
import Language.Copilot
import Control.Monad.Writer
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 :: [CFragment]
, setups :: [CFragment]
, loops :: [CFragment]
}
type CFragment = String
instance Semigroup Framework where
a <> b = Framework
{ defines = defines a <> defines b
, setups = setups a <> setups b
, loops = loops a <> loops b
}
instance Monoid Framework where
mempty = Framework mempty mempty mempty
class ToFramework t where
toFramework :: t -> Framework
type Behavior t = Stream t -> Spec
data Output t = Output
{ setupOutput :: [CFragment]
, outputCond :: Stream Bool
, outputBehavior :: Stream Bool -> Behavior t
}
instance ToFramework (Output t) where
toFramework o = Framework
{ defines = mempty
, setups = setupOutput o
, loops = mempty
}
type Input t = Sketch (Stream t)
data InputSource t = InputSource
{ defineVar :: [CFragment]
, setupInput :: [CFragment]
, readInput :: [CFragment]
, inputStream :: Stream t
}
instance ToFramework (InputSource t) where
toFramework i = Framework
{ defines = defineVar i
, setups = setupInput i
, loops = readInput i
}
mkInput :: InputSource t -> Input t
mkInput i = do
tell [(return (), toFramework i)]
return (inputStream i)
newtype GPIO = GPIO Int16
type MicroSeconds = Int16
sketchFramework :: Framework -> [String] -> [CFragment]
sketchFramework f ccode = concat
[
[ "/* automatically generated, do not edit */"
, blank
, "#include <stdbool.h>"
, "#include <stdint.h>"
, blank
]
, map statement (defines f)
, [blank]
, ccode
, [blank]
,
[ "void setup()"
]
, codeblock $ map statement (setups f)
, [blank]
,
[ "void loop()"
]
, codeblock $ map statement $ (loops f) <>
[ "step()"
]
]
where
blank = ""
indent l = " " <> l
statement d = d <> ";"
codeblock l = ["{"] <> map indent l <> ["}"]