{-# LANGUAGE RebindableSyntax #-}
module Arduino (
module X,
-- * Arduino sketch generation
Sketch,
Input,
Output,
arduino,
-- * Combinators
(=:),
(@:),
-- * Inputs
boolInput,
boolInput',
-- TODO enumerate all avail pins, don't export constructor
Pin(..),
-- * Outputs
led,
MicroSeconds,
delay,
-- * Utilities
firstIteration,
sketchSpec,
) where
import Language.Copilot as X
import Copilot.Compile.C99
import System.Environment
import System.Directory
import System.Posix.Temp (mkdtemp)
import System.FilePath
import Text.Read
import Control.Monad.Writer
import Data.List (isInfixOf)
import qualified Prelude
-- | An Arduino sketch, implemented using copilot.
--
-- On each iteration of a Sketch, all inputs used by it are first
-- collected, before any outputs are performed.
--
-- Like a copilot `Spec`, a Sketch's outputs are not run in any
-- particular order.
type Sketch = Sketch' ()
type Sketch' t = Writer [(Spec, Framework)] t
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
-- | Somewhere that a Stream can be directed to, in order to control the
-- Arduino.
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
}
-- | A source of a `Stream` of values input from the Arduino.
type Input t = Sketch' (Stream t)
data Input' t = Input'
{ defineVar :: [CFragment]
, setupInput :: [CFragment]
, readInput :: [CFragment]
, inputStream :: Stream t
}
instance ToFramework (Input' t) where
toFramework i = Framework
{ defines = defineVar i
, setups = setupInput i
, loops = readInput i
}
-- | A GPIO pin
newtype Pin = Pin Int
mkInput :: Input' t -> Input t
mkInput i = do
tell [(return (), toFramework i)]
return (inputStream i)
-- | Connect a `Stream` to an `Output`.
(=:) :: Output t -> Stream t -> Sketch
o =: s = tell [(go, toFramework o)]
where
go = (outputBehavior o) (outputCond o) s
-- Same fixity as =<<
infixr 1 =:
-- | By default, an `Output` is written to 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.
--
-- > led =: true
--
-- To avoid unnecessary work being done, this combinator can make an
-- `Output` only be written to when the current value of the provided
-- `Stream` is True.
--
-- 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 @: firstIteration =: true
(@:) :: Output t -> Stream Bool -> Output t
(@:) o c = o { outputCond = c }
-- | True on the first iteration of the Sketch, and False thereafter.
firstIteration :: Stream Bool
firstIteration = [True]++false
-- FIXME should be a newtype, but how to make a stream of a newtype?
type MicroSeconds = Int16
-- | The on-board LED.
led :: Output Bool
led = Output
{ setupOutput = ["pinMode(13, OUTPUT)"]
, outputBehavior =
\c v -> trigger "digitalWrite" c [arg (constI16 13), arg v]
, outputCond = true
}
-- | Use this to add a delay between each iteration of the Sketch.
delay :: Output MicroSeconds
delay = Output
{ setupOutput = []
, outputBehavior = \c n -> trigger "delay" c [arg n]
, outputCond = true
}
-- | Reading from a GPIO pin.
boolInput :: Pin -> Input Bool
boolInput n = boolInput' n []
-- | The optional list is used as simulated input
-- when interpreting the program.
boolInput' :: Pin -> [Bool] -> Input Bool
boolInput' (Pin n) interpretvalues = mkInput $ Input'
{ defineVar = ["bool " <> varname]
, setupInput = ["pinMode(" <> show n <> ", INPUT)"]
, readInput = [varname <> " = digitalRead(" <> show n <> ")"]
, inputStream = extern varname interpretvalues'
}
where
varname = "arduino_boolinput" <> show n
interpretvalues'
| null interpretvalues = Nothing
| otherwise = Just interpretvalues
-- | Typically your Arduino program's main will use this. For example:
--
-- > main = arduino $ do
-- > led =: clk (period 2) (phase 1)
-- > delay =: const16 100
--
-- The `Sketch` is compiled into C code using copilot, and written
-- to a .ino file. That can be built and uploaded to your Arduino
-- using the Arduino IDE, or any other toolchain for Arduino sketches.
arduino :: Sketch -> IO ()
arduino s = do
let (is, fs) = unzip (execWriter s)
let spec = sequence_ is
-- TODO optparse-applicative
ps <- getArgs
case ps of
[] -> writeIno spec (mconcat fs)
["-i", n] -> case readMaybe n of
Just n' -> interpret n' spec
Nothing -> error "expected a number after -i"
_ -> error "bad parameters"
-- | Extracts a copilot `Spec` from a `Sketch`.
--
-- This can be useful to intergrate with other libraries
-- such as copilot-theorem.
sketchSpec :: Sketch -> Spec
sketchSpec s = sequence_ is
where
(is, _fs) = unzip (execWriter s)
writeIno :: Spec -> Framework -> IO ()
writeIno spec framework = do
-- This could be a lot prettier, unfortunately copilot only exports
-- an interface that writes the generated code to a file.
-- And, the .c file includes a .h file that will make it fail to
-- build when used in the .ino file, so that include has to be
-- filtered out.
toptmpdir <- getTemporaryDirectory
mytmpdir <- mkdtemp (toptmpdir </> "copilot")
reify spec >>= compile (mytmpdir </> "copilot")
c <- lines <$> readFile (mytmpdir </> "copilot.c")
let c' = filter (Prelude.not . isInfixOf "#include \"") c
-- Use a name for the ino file that will let the Arduino IDE find it.
d <- getCurrentDirectory
let dirbase = takeFileName d
writeFile (addExtension dirbase "ino") $
sketchFramework framework c'
removeDirectoryRecursive mytmpdir
sketchFramework :: Framework -> [String] -> String
sketchFramework f ccode = unlines $ 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 <> ["}"]