Deep embedding simulating simple Arduino

Client.hs

{-# LANGUAGE GADTs              #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances  #-}
module Client where
import           Prelude hiding (read)
import qualified Prelude
import           Data.List
import           Control.Monad

import           Server

import Debug.Trace

read :: Read a => String -> a
read s = case reads s of
  [(x, "")] -> x
  _ -> error $ "read: Cannot parse " ++ show s

data Action a where
  Button :: Int -> Action (E Bool)
  Led    :: Int -> E Bool -> Action ()
  Wait   :: Int -> Action ()

data R a where
  Action :: Action a -> R a
  Bind   :: R a -> (a -> R b) -> R b
  Return :: a -> R a
  Loop   :: R () -> R ()

instance Functor R where
  fmap = liftM

instance Applicative R where
  pure  = return
  (<*>) = ap

instance Monad R where
  return = Return
  (>>=)  = Bind

buttonE :: Int -> R (E Bool)
buttonE = Action . Button

ledE :: Int -> E Bool -> R ()
ledE i b = Action $ Led i b

loop :: R () -> R ()
loop = Loop

-- waitE :: E Int -> R ()
-- waitE = Action . Wait

wait :: Int -> R ()
wait = Action . Wait

data E a where
  Lit :: Bool -> E Bool
  Not :: E Bool -> E Bool

lit :: Bool -> E Bool
lit = Lit

notE :: E Bool -> E Bool
notE = Not

deriving instance Show a => Show (E a)
deriving instance Show (Action a)

readEBool :: String -> Maybe (E Bool)
readEBool s = case stripPrefix "Not " s of
  Just s' -> readEBool s'
  _       -> case stripPrefix "Lit " s of
    Just s' -> Just . Lit $ read s'
    Nothing -> Nothing

readActionReply :: Action a -> String -> a
readActionReply (Button {}) s  = case readEBool s of
  Just b -> b
  _      -> error $ "Invalid reply for Button: " ++ show s

readActionReply (Led {}) "()"  = ()
readActionReply (Led {}) s     = error $ "Invalid reply for Led: " ++ show s
readActionReply (Wait {}) "()" = ()
readActionReply (Wait {}) s    = error $ "Invalid reply for Wait: " ++ show s

sendAction :: Action a -> Remote a
sendAction a = fmap (readActionReply a) $ runCommand $ show a

send :: R a -> Remote a
send (Return x) = return x
send (Bind m f) = send m >>= send . f
send (Action a) = sendAction a
send (Loop m  ) = forever (send m)

Main.hs

import Server
import Client

main :: IO ()
main = runServer . send $ do
  loop $ do
    bE <- buttonE 0
    ledE 0 bE
    ledE 1 (notE bE)
    wait 100

Server.hs

{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs              #-}

module Server (Remote, runServer, runCommand) where

import           Prelude hiding (read)
import qualified Prelude

import           Graphics.Blank hiding (send, wait)
import qualified Graphics.Blank as Blank

import           Web.KeyCode

import           Control.Monad.Reader
import           Control.Monad.State.Strict

import           Control.Concurrent

import           Control.Lens

import           Data.Maybe (fromMaybe)
import           Data.List

import Debug.Trace

read :: Read a => String -> a
read s = case reads s of
  [(x, "")] -> x
  _ -> error $ "read: Cannot parse " ++ show s
type Remote = StateT ([Bool], [Bool]) (ReaderT DeviceContext IO)

data R
  = Button Int
  | Led Int (E Bool)
  | Loop R
  | Wait Int
  deriving (Read)

data E a where
  Lit :: Bool -> E Bool
  Not :: E Bool -> E Bool

deriving instance a ~ Bool => Read (E a)
deriving instance Show a => Show (E a)

runCommand :: String -> Remote String
runCommand = runRCommand . read

evalE :: E a -> a
evalE (Lit b) = b
evalE (Not e) = not (evalE e)

runRCommand :: R -> Remote String
runRCommand (Button i) = fmap (traceId . show . Lit) $ button i
runRCommand (Led i b ) = fmap show $ led i (evalE b)
runRCommand (Loop r  ) = fmap show $ loop r
runRCommand (Wait ms ) = fmap show $ wait ms


buttons :: Lens' ([Bool], [Bool]) [Bool]
buttons = _1

leds :: Lens' ([Bool], [Bool]) [Bool]
leds = _2

runServer :: Remote () -> IO ()
runServer r = blankCanvas (3000 { events = ["keyup", "keydown"] })
    $ \context -> do
  Blank.send context initUI
  runReaderT (evalStateT r ([False, False, False, False], [False, False, False, False])) context

initUI :: Canvas ()
initUI = do
  drawLEDs [False, False, False, False]
  -- drawButtons
  stroke ()

drawLEDs :: [Bool] -> Canvas ()
drawLEDs [a, b, c, d] = do
  beginPath ()
  arc (100+offset, 75, 20, 0, 2*pi, False)
  closePath ()
  when a $ fill ()
  stroke()

  beginPath ()
  moveTo (220+offset, 75)
  arc (200+offset, 75, 20, 0, 2*pi, False)
  closePath ()
  when b $ fill ()
  stroke()

  beginPath ()
  moveTo (320+offset, 75)
  arc (300+offset, 75, 20, 0, 2*pi, False)
  closePath ()
  when c $ fill ()
  stroke()

  beginPath()
  moveTo (420+offset, 75)
  arc (400+offset, 75, 20, 0, 2*pi, False)
  closePath()
  when d $ fill ()
  stroke()
  where
    offset = 35

-- drawButtons :: Canvas ()
-- drawButtons = do
--   strokeRect (60,300,100,50)
--   strokeRect (60 + 120,300,100,50)
--   strokeRect (60*2 + 180,300,100,50)
--   strokeRect (60*3 + 240,300,100,50)

button :: Int -> Remote Bool
button buttonNum = do
  updateButtons
  bs <- use buttons
  return $ fromMaybe False $ bs ^? ix buttonNum

readButtonNum :: Key -> Maybe Int
readButtonNum KeyH = Just 0
readButtonNum KeyJ = Just 1
readButtonNum KeyK = Just 2
readButtonNum KeyL = Just 3
readButtonNum _    = Nothing


updateButtons :: Remote ()
updateButtons = do
  event <- lift $ lift . Blank.wait =<< ask
  case readButtonNum =<< keyCodeLookup <$> eWhich event of
      Just buttonNum ->
        buttons . ix buttonNum .= (eType event == "keydown")
      _              -> return ()

led :: Int -> Bool -> Remote ()
led ledNum state = do
  leds . ix ledNum .= state
  ledStates <- use leds
  runBlank $ clearCanvas >> drawLEDs ledStates
  where
    runBlank :: Canvas a -> Remote a
    runBlank c = do
      context <- ask
      liftIO $ Blank.send context c

loop :: R -> Remote ()
loop r = forever $ do
  runRCommand r
  return ()

wait :: Int -> Remote ()
wait ms = liftIO . threadDelay $ ms*10