Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Marc Coiffier
BHR
Commits
1bf5a123
Commit
1bf5a123
authored
Mar 30, 2019
by
Marc Coiffier
Browse files
Change WiQEE.hs to be used as a Web Worker instead of running in the application thread
parent
a28cf1f5
Changes
3
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
)
(
Jus
t
<$>
readString
x
))
f_readBytes
=
(
\
x
->
try
(
return
Nothing
)
(
Jus
t
.
unpack
<$>
readBytes
x
))
f_readString
=
(
\
x
->
catch
(
return
.
Left
.
show
)
(
Righ
t
<$>
readString
x
))
f_readBytes
=
(
\
x
->
catch
(
return
.
Left
.
show
)
(
Righ
t
.
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
.
C
IO
String
String
)
where
datum
=
return
(
ReadImpl
getString
)
instance
Format
[
Word8
]
(
ReadImpl
JS
.
C
IO
String
[
Word8
])
where
datum
=
return
(
ReadImpl
getBytes
)
instance
Format
[
Word8
]
(
WriteImpl
JS
.
C
IO
String
String
)
where
datum
=
return
(
WriteImpl
setString
)
instance
Format
[
Word8
]
(
WriteImpl
JS
.
C
IO
String
[
Word8
])
where
datum
=
return
(
WriteImpl
setBytes
)
instance
Format
[
Word8
]
(
ReadImpl
FS
IO
String
String
)
where
datum
=
return
(
ReadImpl
getString
)
instance
Format
[
Word8
]
(
ReadImpl
FS
IO
String
[
Word8
])
where
datum
=
return
(
ReadImpl
getBytes
)
instance
Format
[
Word8
]
(
WriteImpl
FS
IO
String
String
)
where
datum
=
return
(
WriteImpl
setString
)
instance
Format
[
Word8
]
(
WriteImpl
FS
IO
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
(
Jus
t
$
toString
(
res
::
JS
.
JSString
))
Right
res
->
return
(
Righ
t
$
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
<-
get
FS
Item
file
case
mres
of
Right
res
->
return
(
Jus
t
$
toWordList
(
res
::
JS
.
JSString
))
Right
res
->
return
(
Righ
t
$
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
Jus
t
res
|
Just
v
<-
matches
Just
datum
res
->
runStackState
$
modify
$
(
v
:
)
Righ
t
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>"
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment