Change WiQEE.hs to be used as a Web Worker instead of running in the application thread

capricon/exe/CaPriCon.hs

@@ -21,8 +21,8 @@ instance Format [Word8] (ReadImpl IO String [Word8]) where datum = return (ReadI
 instance Format [Word8] (WriteImpl IO String String) where datum = return (WriteImpl writeString)
 instance Format [Word8] (WriteImpl IO String [Word8]) where datum = return (WriteImpl (\x -> writeBytes x . pack))
 
-f_readString = (\x -> try (return Nothing) (Just<$>readString x))
-f_readBytes = (\x -> try (return Nothing) (Just . unpack<$>readBytes x))
+f_readString = (\x -> catch (return . Left . show) (Right<$>readString x))
+f_readBytes = (\x -> catch (return . Left . show) (Right . unpack<$>readBytes x))
 
 nativeDict = cocDict VERSION_capricon f_readString f_readBytes writeString (\x -> writeBytes x . pack)
 

capricon/exe/WiQEE.hs

-{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, DeriveGeneric #-}
 module Main where
 
 import Definitive
@@ -18,8 +18,7 @@ import qualified Haste.Events as JS
 import qualified Haste.Concurrent as JS
 import qualified Haste.Ajax as JS
 import qualified Haste.JSString as JSS
-import qualified Haste.LocalStorage as JS
-import qualified Haste.Binary as JS
+import qualified Haste.Binary as JS hiding (get)
 import qualified Prelude as P
 import qualified Data.Array.Unboxed as Arr
 
@@ -45,124 +44,213 @@ instance Monad JS.CIO where join = (P.>>=id)
 instance MonadIO JS.CIO where liftIO = JS.liftIO
 instance MonadSubIO JS.CIO JS.CIO where liftSubIO = id
 
+newtype FSIO a = FSIO (ReaderT JSFS JS.CIO a)
+  deriving (Functor,SemiApplicative,Unit,Applicative,MonadIO)
+instance P.Functor FSIO where fmap = map
+instance P.Applicative FSIO where (<*>) = (<*>)
+instance P.Monad FSIO where return = return ; (>>=) = (>>=)
+instance JS.MonadIO FSIO where liftIO = liftIO
+instance Monad FSIO where join = coerceJoin FSIO
+instance JS.MonadConc FSIO where
+  liftCIO x = FSIO (lift x)
+  fork (FSIO rx) = FSIO (rx & from readerT %~ \r x -> JS.fork (r x))
+instance MonadSubIO FSIO FSIO where liftSubIO = id
+
 instance Serializable [Word8] Char where encode _ c = ListBuilder (fromIntegral (fromEnum c):)
 instance Format [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8))
-instance Format [Word8] (ReadImpl  JS.CIO String String) where datum = return (ReadImpl getString)
-instance Format [Word8] (ReadImpl  JS.CIO String [Word8]) where datum = return (ReadImpl getBytes)
-instance Format [Word8] (WriteImpl JS.CIO String String) where datum = return (WriteImpl setString)
-instance Format [Word8] (WriteImpl JS.CIO String [Word8]) where datum = return (WriteImpl setBytes)
+instance Format [Word8] (ReadImpl  FSIO String String) where datum = return (ReadImpl getString)
+instance Format [Word8] (ReadImpl  FSIO String [Word8]) where datum = return (ReadImpl getBytes)
+instance Format [Word8] (WriteImpl FSIO String String) where datum = return (WriteImpl setString)
+instance Format [Word8] (WriteImpl FSIO String [Word8]) where datum = return (WriteImpl setBytes)
 
 runComment c = unit
 toWordList :: JS.JSString -> [Word8]
 toWordList = map (fromIntegral . fromEnum) . toString 
 
-getString :: String -> JS.CIO (Maybe String)
-getString file = do
-  mres <- liftIO $ JS.getItem (fromString file)
+type ErrorMessage = String
+
+collectConc :: (Monad m, JS.MonadConc m) => ((a -> IO ()) -> (err -> IO ()) -> IO ()) -> m (err :+: a)
+collectConc k = do
+  v <- JS.newEmptyMVar
+  JS.liftCIO $ JS.liftIO $ k (\x -> JS.concurrent $ JS.putMVar v (Right x)) (\err -> JS.concurrent $ JS.putMVar v (Left err))
+  JS.readMVar v
+
+fsSchema :: JS.JSAny -> IO ()
+fsSchema = JS.ffi "(CaPriCon.initFS)"
+
+newtype JSFS = JSFS JS.JSAny
+instance JS.ToAny JSFS where
+  toAny (JSFS fs) = fs
+  listToAny l = JS.listToAny (map (\(JSFS x) -> x) l)
+instance JS.FromAny JSFS where
+  fromAny x = return (JSFS x)
+  listFromAny x = map JSFS <$> JS.listFromAny x
+newFS_impl :: JS.JSString -> (JSFS -> IO ()) -> (JS.JSAny -> IO ()) -> IO ()
+newFS_impl = JS.ffi "(CaPriCon.newFS)" fsSchema
+
+newFS :: JS.JSString -> JS.CIO JSFS
+newFS db = do
+  ret <- collectConc (newFS_impl db)
+  case ret of
+    Left _ -> error $ "Couldn't open database backend for " + toString db
+    Right r -> return r
+
+getFSItem_impl :: JSFS -> JS.JSString -> (JS.JSString -> IO ()) -> (JS.JSAny -> IO ()) -> IO ()
+getFSItem_impl = JS.ffi "(CaPriCon.getFSItem)"
+
+getFSItem :: JS.JSString -> FSIO (JS.JSAny :+: JS.JSString)
+getFSItem file = FSIO ask >>= \fs -> collectConc (getFSItem_impl fs file)
+
+setFSItem_impl :: JSFS -> JS.JSString -> JS.JSString -> (JS.JSAny -> IO ()) -> (JS.JSAny -> IO ()) -> IO ()
+setFSItem_impl = JS.ffi "(CaPriCon.setFSItem)"
+
+setFSItem :: JS.JSString -> JS.JSString -> FSIO ()
+setFSItem file dat = void $ FSIO ask >>= \fs -> collectConc (setFSItem_impl fs file dat)
+
+getString :: String -> FSIO (ErrorMessage :+: String)
+getString fileS = do
+  let file = fromString fileS :: JS.JSString
+  mres <- getFSItem file
   case mres of
-    Right res -> return (Just $ toString (res :: JS.JSString))
+    Right res -> return (Right $ toString (res :: JS.JSString))
     Left _ -> do
-      here <- toString <$> JS.getLocationHref
+      here <- JS.getLocationHref
         
-      let url = fromString (dropFileName here</>file)
-      res <- JS.ajax JS.GET url
+      let url = JSS.replace here (JSS.regex "/[^/]*$" "") ("/"+file)
+      res <- collectConc (JS.ffi "(CaPriCon.ajaxGetString)" url)
       case res of
-        Left JS.NetworkError -> fill Nothing $ JS.alert $ "Network error while retrieving "+url
-        Left (JS.HttpError n msg) -> fill Nothing $ JS.alert $ "HTTP error "+fromString (show n)+": "+msg
-        Right val -> map Just $ liftIO $ JS.setItem (fromString file) val >> return (toString (val :: JS.JSString))
-getBytes :: String -> JS.CIO (Maybe [Word8])
-getBytes file = do
-  mres <- liftIO $ JS.getItem (fromString file)
+        Left x -> liftIO (JS.fromAny x) <&> \(n,msg) -> Left . toString $ "HTTP error "+fromString (show (n::Int))+" while retrieving "+url+": "+msg
+        Right val -> Right (toString (val :: JS.JSString)) <$ setFSItem file val
+getBytes :: String -> FSIO (ErrorMessage :+: [Word8])
+getBytes fileS = do
+  let file = fromString fileS :: JS.JSString
+  mres <- getFSItem file
   case mres of
-    Right res -> return (Just $ toWordList (res :: JS.JSString))
+    Right res -> return (Right $ toWordList (res :: JS.JSString))
     Left _ -> do
-      here <- toString <$> JS.getLocationHref
+      here <- JS.getLocationHref
         
-      let url = fromString (dropFileName here</>file)
-      res <- JS.ajax JS.GET url
+      let url = JSS.replace here (JSS.regex "/[^/]*$" "") ("/"+file)
+      res <- collectConc (JS.ffi "(CaPriCon.ajaxGetString)" url)
       case res of
-        Left JS.NetworkError -> fill Nothing $ JS.alert $ "Network error while retrieving "+url
-        Left (JS.HttpError n msg) -> fill Nothing $ JS.alert $ "HTTP error "+fromString (show n)+": "+msg
-        Right val -> map Just $ liftIO $ JS.setItem (fromString file) val >> return (toWordList val)
-setString :: String -> String -> JS.CIO ()
-setString f v = liftIO $ JS.setItem (fromString f) (fromString v :: JS.JSString)
-setBytes :: String -> [Word8] -> JS.CIO ()
+        Left x -> liftIO (JS.fromAny x) <&> \(n,msg) -> Left . toString $ "HTTP error "+fromString (show (n::Int))+" while retrieving "+url+": "+msg
+        Right val -> Right (toWordList val) <$ setFSItem file val
+setString :: String -> String -> FSIO ()
+setString f v = setFSItem (fromString f) (fromString v :: JS.JSString)
+setBytes :: String -> [Word8] -> FSIO ()
 setBytes f v = setString f (map (toEnum . fromIntegral) v)
 
-hasteDict :: COCDict JS.CIO String
+type WiQEEState = StackState (COCState String) String (COCBuiltin FSIO String) (COCValue FSIO String)
+runWordsState :: [String] -> WiQEEState -> FSIO (WiQEEState,String)
+runWordsState ws st = ($st) $ from (stateT.concatT) $^ do
+  foldr (\w tl -> do
+            x <- runExtraState (getl endState)
+            unless x $ do execSymbol runCOCBuiltin runComment w; tl) unit ws
+  out <- runExtraState (outputText <~ \x -> (id,x))
+  return (out "")
+
+runWithFS :: JS.JSString -> FSIO a -> JS.CIO a
+runWithFS fsname (FSIO r) = newFS fsname >>= r^..readerT
+
 hasteDict = cocDict ("0.11-js" :: String) getString getBytes setString setBytes
 
 main :: IO ()
-main = JS.concurrent $ void $ do
-  maybe unit JS.focus =<< JS.elemById "content-scroll"
-  JS.wait 200
-
-  let runWordsState ws st = ($st) $ from (stateT.concatT) $^ do
-        foldr (\w tl -> do
-                  x <- runExtraState (getl endState)
-                  unless x $ do execSymbol runCOCBuiltin runComment w; tl) unit ws
-        out <- runExtraState (outputText <~ \x -> (id,x))
-        return (out "")
-      withSubElem root cl = JS.withElemsQS root ('.':cl) . traverse_
-      withSubElems _ [] k = k []
-      withSubElems root (h:t) k = withSubElem root h $ \h' -> withSubElems root t $ \t' -> k (h':t')
+main = do
+  -- JS.ffi "console.log" ("hasteMain called" :: JS.JSString) :: IO ()
+  Just msg <- JS.lookupAny capriconObject "event.data"
+  (req,reqID,stateID,code) <- JS.fromAny msg
+  sts <- JS.get capriconObject "states"
+  JS.concurrent $ runWithFS "CaPriCon" $ do
+    st <- case stateID of
+      0 -> return (defaultState hasteDict (COCState False [] zero id))
+      _ -> liftIO $ map JS.fromOpaque $ JS.index sts (stateID-1) 
+    case req :: Int of
+      -- run a block of code, and return a handle to a new state
+      0 -> do
+        (st',_) <- runWordsState (map toString $ stringWords (code :: JS.JSString)) st
+        id <- appendState capriconObject st'
+        postMessage (reqID :: Int,id)
+  
+      -- run a block of code, and return its output, discarding the new state
+      1 -> do
+        (_,out) <- runWordsState (map toString $ stringWords (code :: JS.JSString)) st
+        postMessage (reqID :: Int,fromString out :: JS.JSString)
+  
+      _ -> error "Unhandled request type"
+  
+appendState :: MonadIO m => JS.JSAny -> a -> m Int
+appendState obj x = liftIO $ JS.ffi "(function (o,a) { o.states.push(a); return o.states.length; })" obj (JS.toOpaque x)
+
+postMessage :: (MonadIO m,JS.ToAny a) => a -> m ()
+postMessage msg = liftIO $ JS.ffi "(function (m) { postMessage(m); })" (JS.toAny msg)
+
+capriconObject :: JS.JSAny
+capriconObject = JS.constant "CaPriCon"
+    
+  -- maybe unit JS.focus =<< JS.elemById "content-scroll"
+  -- JS.wait 200
+
+  -- let withSubElem root cl = JS.withElemsQS root ('.':cl) . traverse_
+  --     withSubElems _ [] k = k []
+  --     withSubElems root (h:t) k = withSubElem root h $ \h' -> withSubElems root t $ \t' -> k (h':t')
   
-  prelude <- JS.withElem "capricon-prelude" (\e -> JS.getProp e "textContent")
-  (initState,_) <- runWordsState (map fromString $ stringWords prelude) (defaultState hasteDict (COCState False [] zero id))
+  -- prelude <- JS.withElem "capricon-prelude" (\e -> JS.getProp e "textContent")
+  -- (initState,_) <- runWordsState (map fromString $ stringWords prelude) (defaultState hasteDict (COCState False [] zero id))
 
-  roots <- JS.elemsByQS JS.documentBody ".capricon-steps, code.capricon"
-  Just console <- JS.elemById "capricon-console"
+  -- roots <- JS.elemsByQS JS.documentBody ".capricon-steps, code.capricon"
+  -- Just console <- JS.elemById "capricon-console"
 
-  (\k -> foldr k (\_ _ -> unit) roots initState "") $ \root next state pref -> do
-    isCode <- JS.hasClass root "capricon"
+  -- (\k -> foldr k (\_ _ -> unit) roots initState "") $ \root next state pref -> do
+  --   isCode <- JS.hasClass root "capricon"
 
-    if isCode
-      then do
-      p <- JS.getProp root "textContent"
-      next state (pref+p+" pop ")
-      else do
-        JS.wait 10
+  --   if isCode
+  --     then do
+  --     p <- JS.getProp root "textContent"
+  --     next state (pref+p+" pop ")
+  --     else do
+  --       JS.wait 10
     
-        root' <- cloneNode root
-        JS.toggleClass root' "capricon-frame"
-        rootChildren <- JS.getChildren root'
-        rootTitle <- JS.newElem "h3" <*= \head -> JS.appendChild head =<< JS.newTextElem "CaPriCon Console"
-        closeBtn <- JS.newElem "button" <*= \but -> JS.appendChild but =<< JS.newTextElem "Close"
-        JS.appendChild rootTitle closeBtn
-        JS.appendChild console root'
-        JS.setChildren root' (rootTitle:rootChildren)
-
-        withSubElems root ["capricon-trigger"] $ \[trig] -> void $ do
-          withSubElems root' ["capricon-input"] $ \[inpCons] -> void $ do
-            let toggleActive = do
-                  JS.toggleClass root' "active"
-                  JS.focus inpCons
-            JS.onEvent closeBtn JS.Click (const toggleActive)
-            JS.onEvent trig JS.Click $ \_ -> toggleActive
+  --       root' <- cloneNode root
+  --       JS.toggleClass root' "capricon-frame"
+  --       rootChildren <- JS.getChildren root'
+  --       rootTitle <- JS.newElem "h3" <*= \head -> JS.appendChild head =<< JS.newTextElem "CaPriCon Console"
+  --       closeBtn <- JS.newElem "button" <*= \but -> JS.appendChild but =<< JS.newTextElem "Close"
+  --       JS.appendChild rootTitle closeBtn
+  --       JS.appendChild console root'
+  --       JS.setChildren root' (rootTitle:rootChildren)
+
+  --       withSubElems root ["capricon-trigger"] $ \[trig] -> void $ do
+  --         withSubElems root' ["capricon-input"] $ \[inpCons] -> void $ do
+  --           let toggleActive = do
+  --                 JS.toggleClass root' "active"
+  --                 JS.focus inpCons
+  --           JS.onEvent closeBtn JS.Click (const toggleActive)
+  --           JS.onEvent trig JS.Click $ \_ -> toggleActive
             
-        withSubElems root ["capricon-input"] $ \[inpMain] -> do
-          withSubElems root' ["capricon-input","capricon-output"] $ \[inp,out] -> do
-            JS.withElemsQS root' ".capricon-context" $ \case
-              [con] -> do
-                context <- JS.getProp con "textContent"
-                let text = pref+" "+context
-                -- JS.alert ("Running "+fromString text)
-                (state',_) <- runWordsState (stringWords text) state
-                let onEnter x = \case
-                      JS.KeyData 13 False False False False -> x
-                      _ -> return ()
-                    runCode inp = do
-                      Just v <- JS.getValue inp
-                      (_,x) <- runWordsState (stringWords v) state'
-                      JS.setProp out "textContent" (toString x)
-                      return v
-                JS.onEvent inp JS.KeyPress $ onEnter $ void $ runCode inp
-                JS.onEvent inpMain JS.KeyPress $ onEnter $ do
-                  v <- runCode inpMain
-                  JS.setClass root' "active" True
-                  JS.focus inp
-                  JS.setProp inp "value" v
-                next state' ""
-
-cloneNode :: MonadIO m => JS.Elem -> m JS.Elem
-cloneNode x = liftIO $ JS.ffi "(function (n) { return n.cloneNode(true); })" x
+  --       withSubElems root ["capricon-input"] $ \[inpMain] -> do
+  --         withSubElems root' ["capricon-input","capricon-output"] $ \[inp,out] -> do
+  --           JS.withElemsQS root' ".capricon-context" $ \case
+  --             [con] -> do
+  --               context <- JS.getProp con "textContent"
+  --               let text = pref+" "+context
+  --               -- JS.alert ("Running "+fromString text)
+  --               (state',_) <- runWordsState (stringWords text) state
+  --               let onEnter x = \case
+  --                     JS.KeyData 13 False False False False -> x
+  --                     _ -> return ()
+  --                   runCode inp = do
+  --                     Just v <- JS.getValue inp
+  --                     (_,x) <- runWordsState (stringWords v) state'
+  --                     JS.setProp out "textContent" (toString x)
+  --                     return v
+  --               JS.onEvent inp JS.KeyPress $ onEnter $ void $ runCode inp
+  --               JS.onEvent inpMain JS.KeyPress $ onEnter $ do
+  --                 v <- runCode inpMain
+  --                 JS.setClass root' "active" True
+  --                 JS.focus inp
+  --                 JS.setProp inp "value" v
+  --               JS.setClass inpMain "ready" True
+  --               next state' ""
+
+-- cloneNode :: MonadIO m => JS.Elem -> m JS.Elem
+-- cloneNode x = liftIO $ JS.ffi "(function (n) { return n.cloneNode(true); })" x

capricon/src/CaPriCon/Run.hs

@@ -90,7 +90,7 @@ data COCBuiltin io str = COCB_Print | COCB_Quit
                        | COCB_Format
                        
                        deriving (Show,Generic)
-data ReadImpl io str bytes = ReadImpl (str -> io (Maybe bytes))
+data ReadImpl io str bytes = ReadImpl (str -> io (String :+: bytes))
 data WriteImpl io str bytes = WriteImpl (str -> bytes -> io ())
 instance Show (ReadImpl io str bytes) where show _ = "#<open>"
 instance Show (WriteImpl io str bytes) where show _ = "#<write>"
@@ -216,7 +216,7 @@ runCOCBuiltin (COCB_Open (ReadImpl getResource)) = do
   case s of
     StackSymbol f:t -> do
       runStackState $ put t
-      xs <- liftSubIO (getResource (f+".md")) >>= maybe undefined return . matches Just literate . maybe "" toString
+      xs <- liftSubIO (getResource (f+".md")) >>= maybe undefined return . matches Just literate . (const "" <|> toString)
       let ex = execSymbol runCOCBuiltin outputComment
       ex "{" >> traverse_ ex xs >> ex "}"
     _ -> return ()
@@ -346,7 +346,7 @@ runCOCBuiltin (COCB_Cache (ReadImpl getResource) (WriteImpl writeResource)) = do
     StackSymbol f:StackProg p:t -> do
       runStackState (put t)
       liftSubIO (getResource (f+".blob")) >>= \case
-        Just res | Just v <- matches Just datum res -> runStackState $ modify $ (v:)
+        Right res | Just v <- matches Just datum res -> runStackState $ modify $ (v:)
         _ -> do
           execProgram runCOCBuiltin outputComment p
           st' <- runStackState get
@@ -407,7 +407,7 @@ runCOCBuiltin COCB_InsertNodeDir = do
       StackCOC (COCDir (insert e (map fst (takeLast d ctx),x) dir)):t
     st -> st
 
-cocDict :: forall io str. IsCapriconString str => str -> (str -> io (Maybe str)) -> (str -> io (Maybe [Word8])) -> (str -> str -> io ()) -> (str -> [Word8] -> io ()) -> COCDict io str
+cocDict :: forall io str. IsCapriconString str => str -> (str -> io (String :+: str)) -> (str -> io (String :+: [Word8])) -> (str -> str -> io ()) -> (str -> [Word8] -> io ()) -> COCDict io str
 cocDict version getResource getBResource writeResource writeBResource =
   mkDict ((".",StackProg []):("steps.",StackProg []):("mustache.",StackProg []):("version",StackSymbol version):
            [(x,StackBuiltin b) | (x,b) <- [
@@ -504,13 +504,14 @@ outputComment c = (runExtraState $ do outputText =~ (\o t -> o (commentText+t)))
                              +fold [if isWord then let qw = htmlQuote w in "<span class=\"symbol\" data-symbol-name=\""+qw+"\">"+qw+"</span>"
                                     else w
                                    | (isWord,w) <- stringWordsAndSpaces (drop 2 c)]+"</pre>"+userInput+"</div>"+wrapEnd
-          'c':'s':_ -> wrapStart False 1+"<code class=\"capricon\">"+htmlQuote (drop 2 c)+"</code>"+wrapEnd
+          'c':'s':_ -> wrapStart False 1+"<code class=\"capricon capricon-steps\">"+htmlQuote (drop 2 c)+"</code>"+wrapEnd
           's':_ -> drop 1 c
           _ -> ""
 
         wrapStart isP nlines =
           let hide = if isP then "hideparagraph" else "hidestache"
-          in "<label class=\"hide-label\"><input type=\"checkbox\" class=\"capricon-hide\" checked=\"checked\"/><span class=\"capricon-"
+              chk = if isP then "" else " checked=\"checked\""
+          in "<label class=\"hide-label\"><input type=\"checkbox\" class=\"capricon-hide\""+chk+"/><span class=\"capricon-"
              + hide +"\"></span><span class=\"capricon-reveal\" data-linecount=\""
              + fromString (show nlines)+"\">"
         wrapEnd = "</span></label>"