From 92c6f13bbe48a47f932ac94677cd61f4c97ab090 Mon Sep 17 00:00:00 2001 From: Guillermo Ramos Date: Thu, 5 Feb 2015 16:50:43 +0100 Subject: JSON-formatted commands --- Handler/Home.hs | 24 ++++++++++++++++++++---- templates/home.hamlet | 4 ++-- templates/home.julius | 15 +++++++-------- 3 files changed, 29 insertions(+), 14 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") diff --git a/templates/home.hamlet b/templates/home.hamlet index 4155dbb..9b429b5 100644 --- a/templates/home.hamlet +++ b/templates/home.hamlet @@ -4,7 +4,7 @@
-
+