JSON-formatted commands

1 files changed, 20 insertions, 4 deletions

diff --git a/Handler/Home.hs b/Handler/Home.hs
index 42dde92..1eff93d 100644
--- a/Handler/Home.hs
+++ b/Handler/Home.hs
@@ -3,7 +3,10 @@ module Handler.Home where
 
 import Import
 
+import Control.Monad (mzero)
 import qualified Data.Text as T
+import Data.Aeson
+import Data.Aeson.Types (Parser)
 import Text.Julius
 import Yesod.WebSockets
 import Turing.Examples
@@ -11,14 +14,27 @@ import Turing.Machine
 
 data Cmd = Beginning | Backward | Forward | Poll deriving Read
 
+data UpdM = UpdTape String | UpdTrans String
+instance FromJSON UpdM where
+  parseJSON (Object v) = cons =<< (v .: "type")
+    where cons :: String -> Parser UpdM
+          cons t = (if t == "tape" then UpdTape else UpdTrans) <$> v .: "value"
+  parseJSON _ = mzero
+instance ToJSON UpdM where
+  toJSON um = object ["type" .= ty, "value" .= v]
+    where (ty, v) = case um of
+                     UpdTape s -> ("tape"::String, s)
+                     UpdTrans s -> ("trans", s)
+
 wsTuring :: WebSocketsT Handler ()
-wsTuring = do sendTextData . T.pack $ showTrans (trans defaultMachine)
+wsTuring = do sendTextData . encode . UpdTrans . showTrans . trans $
+                defaultMachine
               evalLoop defaultMachine [defaultConfig]
     where defaultMachine = mWriteStr "Hello!"
           defaultConfig = mkConfig . map charToSym $  "_"
           evalLoop m [] = evalLoop m [defaultConfig]
           evalLoop m cfgs@(c:cs) = do
-            sendTextData . T.pack . show $ c
+            sendTextData . encode . UpdTape . show $ c
             cmd <- receiveData
             case (read . T.unpack $ cmd) of
               Beginning -> evalLoop defaultMachine [defaultConfig]
@@ -42,11 +58,11 @@ getHomeR = do
     addScriptRemote "https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/js/bootstrap.min.js"
 
     -- Identifiers used in HTML/JS code
-    results <- newIdent
-    state <- newIdent
     butBeginning <- newIdent
     butBackward <- newIdent
     butTogglePlay <- newIdent
     butForward <- newIdent
+    prTape <- newIdent
+    prTrans <- newIdent
 
     $(widgetFile "home")