{-# LANGUAGE BangPatterns #-}
module Copilot.Arduino.Main (arduino) where
import Language.Copilot (Spec, interpret, reify)
import Copilot.Compile.C99 (compile)
import Copilot.Arduino.Internals
import System.IO
import System.Directory
import System.IO.Temp (withSystemTempDirectory, createTempDirectory)
import System.FilePath
import System.Exit
import Data.List (isInfixOf)
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as S
import Options.Applicative
arduino :: Sketch () -> IO ()
arduino :: Sketch () -> IO ()
arduino Sketch ()
s = CmdLine -> IO ()
go (CmdLine -> IO ()) -> IO CmdLine -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParserInfo CmdLine -> IO CmdLine
forall a. ParserInfo a -> IO a
execParser ParserInfo CmdLine
opts
where
opts :: ParserInfo CmdLine
opts = Parser CmdLine -> InfoMod CmdLine -> ParserInfo CmdLine
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser CmdLine
parseCmdLine Parser CmdLine -> Parser (CmdLine -> CmdLine) -> Parser CmdLine
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (CmdLine -> CmdLine)
forall a. Parser (a -> a)
helper)
( InfoMod CmdLine
forall a. InfoMod a
fullDesc
InfoMod CmdLine -> InfoMod CmdLine -> InfoMod CmdLine
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod CmdLine
forall a. String -> InfoMod a
progDesc String
"Run this program with no options to generate an Arduino sketch."
)
go :: CmdLine -> IO ()
go CmdLine
o = case (Maybe Spec
mspec, CmdLine -> Maybe Integer
interpretSteps CmdLine
o) of
(Maybe Spec
Nothing, Maybe Integer
_) -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"This Sketch does not do anything."
IO ()
forall a. IO a
exitFailure
(Just Spec
spec, Just Integer
n) -> Integer -> Spec -> IO ()
interpret Integer
n Spec
spec
(Just Spec
spec, Maybe Integer
Nothing) -> Spec -> Framework -> IO ()
writeIno Spec
spec Framework
f'
(Maybe Spec
mspec, Framework
f) = Sketch () -> (Maybe Spec, Framework)
forall ctx a.
Context ctx =>
GenSketch ctx a -> (Maybe Spec, GenFramework ctx)
evalSketch Sketch ()
s
!f' :: Framework
f' = Framework -> Framework
finalizeFramework Framework
f
data CmdLine = CmdLine
{ CmdLine -> Maybe Integer
interpretSteps :: Maybe Integer
}
parseCmdLine :: Parser CmdLine
parseCmdLine :: Parser CmdLine
parseCmdLine = Maybe Integer -> CmdLine
CmdLine
(Maybe Integer -> CmdLine)
-> Parser (Maybe Integer) -> Parser CmdLine
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer -> Parser (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadM Integer -> Mod OptionFields Integer -> Parser Integer
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Integer
forall a. Read a => ReadM a
auto
( String -> Mod OptionFields Integer
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"interpret"
Mod OptionFields Integer
-> Mod OptionFields Integer -> Mod OptionFields Integer
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Integer
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'i'
Mod OptionFields Integer
-> Mod OptionFields Integer -> Mod OptionFields Integer
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Integer
forall (f :: * -> *) a. String -> Mod f a
help String
"use copilot to interpret the program, displaying what it would do"
Mod OptionFields Integer
-> Mod OptionFields Integer -> Mod OptionFields Integer
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Integer
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"NUM"
))
writeIno :: Spec -> Framework -> IO ()
writeIno :: Spec -> Framework -> IO ()
writeIno Spec
spec Framework
framework = do
String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"copilot" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
toptmpdir -> do
String
mytmpdir <- String -> String -> IO String
createTempDirectory String
toptmpdir String
"copilot"
Spec -> IO Spec
forall a. Spec' a -> IO Spec
reify Spec
spec IO Spec -> (Spec -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Spec -> IO ()
compile (String
mytmpdir String -> String -> String
</> String
"copilot")
[String]
c <- String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile (String
mytmpdir String -> String -> String
</> String
"copilot.c")
let c' :: [String]
c' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
Prelude.not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
"#include \"") [String]
c
String
d <- IO String
getCurrentDirectory
let dirbase :: String
dirbase = String -> String
takeFileName String
d
String -> String -> IO ()
writeFile (String -> String -> String
addExtension String
dirbase String
"ino") (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (CLine -> String) -> [CLine] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CLine -> String
fromCLine ([CLine] -> [String]) -> [CLine] -> [String]
forall a b. (a -> b) -> a -> b
$
Framework -> [CLine] -> [CLine]
sketchFramework Framework
framework ((String -> CLine) -> [String] -> [CLine]
forall a b. (a -> b) -> [a] -> [b]
map String -> CLine
CLine [String]
c')
sketchFramework :: Framework -> [CLine] -> [CLine]
sketchFramework :: Framework -> [CLine] -> [CLine]
sketchFramework Framework
f [CLine]
ccode = (String -> CLine) -> [String] -> [CLine]
forall a b. (a -> b) -> [a] -> [b]
map String -> CLine
CLine ([String] -> [CLine]) -> [String] -> [CLine]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[
[ String
"/* automatically generated, do not edit */"
, String
blank
, String
"#include <stdbool.h>"
, String
"#include <stdint.h>"
, String
blank
]
, (CLine -> String) -> [CLine] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CLine -> String
fromCLine ([CChunk] -> [CLine]
fromchunks (Framework -> [CChunk]
forall ctx. GenFramework ctx -> [CChunk]
defines Framework
f))
, [String
blank]
, (CLine -> String) -> [CLine] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CLine -> String
fromCLine [CLine]
ccode
, [String
blank]
,
[ String
"void setup()"
]
, [String] -> [String]
codeblock ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (CLine -> String) -> [CLine] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CLine -> String
fromCLine
([CChunk] -> [CLine]
fromchunks (Framework -> [CChunk]
forall ctx. GenFramework ctx -> [CChunk]
earlySetups Framework
f) [CLine] -> [CLine] -> [CLine]
forall a. Semigroup a => a -> a -> a
<> [CChunk] -> [CLine]
fromchunks (Framework -> [CChunk]
forall ctx. GenFramework ctx -> [CChunk]
setups Framework
f))
, [String
blank]
,
[ String
"void loop()"
]
, [String] -> [String]
codeblock ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (CLine -> String) -> [CLine] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CLine -> String
fromCLine ([CChunk] -> [CLine]
fromchunks (Framework -> [CChunk]
forall ctx. GenFramework ctx -> [CChunk]
loops Framework
f)) [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<>
[ String
"step();"
]
]
where
blank :: String
blank = String
""
indent :: String -> String
indent String
l = String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
l
codeblock :: [String] -> [String]
codeblock [String]
l = [String
"{"] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
indent [String]
l [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"}"]
fromchunks :: [CChunk] -> [CLine]
fromchunks :: [CChunk] -> [CLine]
fromchunks [CChunk]
cl = (CChunk -> [CLine]) -> [CChunk] -> [CLine]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(CChunk [CLine]
l) -> [CLine]
l) ([CChunk] -> [CLine]) -> [CChunk] -> [CLine]
forall a b. (a -> b) -> a -> b
$
Set CChunk -> [CChunk]
forall a. Set a -> [a]
S.toList (Set CChunk -> [CChunk]) -> Set CChunk -> [CChunk]
forall a b. (a -> b) -> a -> b
$ [CChunk] -> Set CChunk
forall a. Ord a => [a] -> Set a
S.fromList [CChunk]
cl
finalizeFramework :: Framework -> Framework
finalizeFramework :: Framework -> Framework
finalizeFramework Framework
f =
let pinsetups :: [CChunk]
pinsetups = [[CChunk]] -> [CChunk]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CChunk]] -> [CChunk]) -> [[CChunk]] -> [CChunk]
forall a b. (a -> b) -> a -> b
$
((Arduino, Set PinMode) -> Maybe [CChunk])
-> [(Arduino, Set PinMode)] -> [[CChunk]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Arduino, Set PinMode) -> Maybe [CChunk]
setuppinmode (Map Arduino (Set PinMode) -> [(Arduino, Set PinMode)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Arduino (Set PinMode) -> [(Arduino, Set PinMode)])
-> Map Arduino (Set PinMode) -> [(Arduino, Set PinMode)]
forall a b. (a -> b) -> a -> b
$ Framework -> Map Arduino (Set PinMode)
forall ctx. GenFramework ctx -> Map ctx (Set PinMode)
pinmodes Framework
f)
in Framework
f { setups :: [CChunk]
setups = [CChunk]
pinsetups [CChunk] -> [CChunk] -> [CChunk]
forall a. Semigroup a => a -> a -> a
<> Framework -> [CChunk]
forall ctx. GenFramework ctx -> [CChunk]
setups Framework
f }
where
setuppinmode :: (Arduino, Set PinMode) -> Maybe [CChunk]
setuppinmode (Arduino Int16
n, Set PinMode
s)
| Set PinMode
s Set PinMode -> Set PinMode -> Bool
forall a. Eq a => a -> a -> Bool
== PinMode -> Set PinMode
forall a. a -> Set a
S.singleton PinMode
OutputMode =
Int16 -> String -> Maybe [CChunk]
forall a. Show a => a -> String -> Maybe [CChunk]
setmode Int16
n String
"OUTPUT"
| Set PinMode
s Set PinMode -> Set PinMode -> Bool
forall a. Eq a => a -> a -> Bool
== PinMode -> Set PinMode
forall a. a -> Set a
S.singleton PinMode
InputMode =
Int16 -> String -> Maybe [CChunk]
forall a. Show a => a -> String -> Maybe [CChunk]
setmode Int16
n String
"INPUT"
| Set PinMode
s Set PinMode -> Set PinMode -> Bool
forall a. Eq a => a -> a -> Bool
== PinMode -> Set PinMode
forall a. a -> Set a
S.singleton PinMode
InputPullupMode =
Int16 -> String -> Maybe [CChunk]
forall a. Show a => a -> String -> Maybe [CChunk]
setmode Int16
n String
"INPUT_PULLUP"
| Set PinMode
s Set PinMode -> Set PinMode -> Bool
forall a. Eq a => a -> a -> Bool
== [PinMode] -> Set PinMode
forall a. Ord a => [a] -> Set a
S.fromList [PinMode
InputMode, PinMode
InputPullupMode] =
Int16 -> String -> Maybe [CChunk]
forall a. Show a => a -> String -> Maybe [CChunk]
setmode Int16
n String
"INPUT_PULLUP"
| Set PinMode -> Bool
forall a. Set a -> Bool
S.null Set PinMode
s = Maybe [CChunk]
forall a. Maybe a
Nothing
| Bool
otherwise = String -> Maybe [CChunk]
forall a. HasCallStack => String -> a
error (String -> Maybe [CChunk]) -> String -> Maybe [CChunk]
forall a b. (a -> b) -> a -> b
$
String
"The program uses pin " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int16 -> String
forall a. Show a => a -> String
show Int16
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" in multiple ways in different places (" String -> String -> String
forall a. [a] -> [a] -> [a]
++
[String] -> String
unwords ((PinMode -> String) -> [PinMode] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PinMode -> String
forall a. Show a => a -> String
show (Set PinMode -> [PinMode]
forall a. Set a -> [a]
S.toList Set PinMode
s)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"). " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"This is not currently supported by arduino-copilot."
setmode :: a -> String -> Maybe [CChunk]
setmode a
n String
v = [CChunk] -> Maybe [CChunk]
forall a. a -> Maybe a
Just ([CChunk] -> Maybe [CChunk]) -> [CChunk] -> Maybe [CChunk]
forall a b. (a -> b) -> a -> b
$ [CLine] -> [CChunk]
mkCChunk
[ String -> CLine
CLine (String -> CLine) -> String -> CLine
forall a b. (a -> b) -> a -> b
$ String
"pinMode(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");" ]