{-# LANGUAGE RebindableSyntax #-}
module Arduino (
module X,
Sketch,
Input,
Output,
arduino,
(=:),
(@:),
boolInput,
boolInput',
Pin(..),
led,
MicroSeconds,
delay,
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
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
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 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
}
newtype Pin = Pin Int
mkInput :: Input' t -> Input t
mkInput i = do
tell [(return (), toFramework i)]
return (inputStream i)
(=:) :: Output t -> Stream t -> Sketch
o =: s = tell [(go, toFramework o)]
where
go = (outputBehavior o) (outputCond o) s
infixr 1 =:
(@:) :: Output t -> Stream Bool -> Output t
(@:) o c = o { outputCond = c }
firstIteration :: Stream Bool
firstIteration = [True]++false
type MicroSeconds = Int16
led :: Output Bool
led = Output
{ setupOutput = ["pinMode(13, OUTPUT)"]
, outputBehavior =
\c v -> trigger "digitalWrite" c [arg (constI16 13), arg v]
, outputCond = true
}
delay :: Output MicroSeconds
delay = Output
{ setupOutput = []
, outputBehavior = \c n -> trigger "delay" c [arg n]
, outputCond = true
}
boolInput :: Pin -> Input Bool
boolInput n = boolInput' n []
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
arduino :: Sketch -> IO ()
arduino s = do
let (is, fs) = unzip (execWriter s)
let spec = sequence_ is
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"
sketchSpec :: Sketch -> Spec
sketchSpec s = sequence_ is
where
(is, _fs) = unzip (execWriter s)
writeIno :: Spec -> Framework -> IO ()
writeIno spec framework = do
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
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 <> ["}"]