Skip to content

GitLab

Commit 1bf5a123 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

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

parent a28cf1f5
Hide whitespace changes
Inline Side-by-side
capricon/exe/CaPriCon.hs
View file @ 1bf5a123
......@@ -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
View file @ 1bf5a123
{-# 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
View file @ 1bf5a123
......@@ -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>"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment