Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Marc Coiffier
BHR
Commits
665f8e4b
Commit
665f8e4b
authored
Apr 27, 2019
by
Marc Coiffier
Browse files
Correct the 'substitute' and 'intro before' builtins
parent
558d53b8
Changes
5
Hide whitespace changes
Inline
Side-by-side
.gitignore
View file @
665f8e4b
...
...
@@ -10,3 +10,4 @@ Curly_Test.hs
*.jsmod
config.mk
*/dist
*.tar.gz
capricon/capricon.cabal
View file @
665f8e4b
...
...
@@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/
name: capricon
version: 0.13.1
version: 0.13.1
.1
-- synopsis:
-- description:
license: GPL-3
...
...
capricon/exe/CaPriCon_Engine.hs
View file @
665f8e4b
{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, DeriveGeneric
, StandaloneDeriving
#-}
module
Main
where
import
Definitive
...
...
@@ -22,6 +22,9 @@ import qualified Haste.Binary as JS hiding (get)
import
qualified
Prelude
as
P
import
qualified
Data.Array.Unboxed
as
Arr
deriving
instance
Show
BraceKind
deriving
instance
Show
s
=>
Show
(
AtomClass
s
)
instance
Semigroup
JS
.
JSString
where
(
+
)
=
JSS
.
append
instance
Monoid
JS
.
JSString
where
zero
=
JSS
.
empty
instance
Sequence
JS
.
JSString
where
splitAt
=
JSS
.
splitAt
...
...
@@ -142,19 +145,22 @@ setString f v = setFSItem (fromString f) (fromString v :: JS.JSString)
setBytes
::
String
->
[
Word8
]
->
FSIO
()
setBytes
f
v
=
setString
f
(
map
(
toEnum
.
fromIntegral
)
v
)
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
(
atomClass
w
);
tl
)
unit
ws
let
cl
=
atomClass
w
liftIO
(
JS
.
ffi
(
"console.log"
::
JS
.
JSString
)
(
fromString
(
"Executing symbol: "
+
show
w
+
" (class "
+
show
cl
+
")"
)
::
JS
.
JSString
)
::
IO
()
)
unless
x
$
do
execSymbol
runCOCBuiltin
runComment
cl
;
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.13.1-js"
::
String
)
getString
getBytes
setString
setBytes
hasteDict
=
cocDict
(
"0.13.1
.1
-js"
::
String
)
getString
getBytes
setString
setBytes
main
::
IO
()
main
=
do
...
...
@@ -169,7 +175,7 @@ main = do
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
(
st'
,
_
)
<-
runWordsState
(
stringWords
(
toString
(
code
::
JS
.
JSString
))
)
st
id
<-
appendState
capriconObject
st'
postMessage
(
reqID
::
Int
,
id
)
...
...
capricon/src/Algebra/Monad/Concatenative.hs
View file @
665f8e4b
...
...
@@ -135,6 +135,7 @@ instance StackSymbol String where
atomClass
"${"
=
Open
(
Splice
CloseExec
)
atomClass
"}"
=
Close
atomClass
(
'
\'
'
:
t
)
=
Quoted
t
atomClass
(
'
\x8217
'
:
t
)
=
Quoted
t
atomClass
(
'"'
:
t
)
=
Quoted
(
init
t
)
atomClass
(
':'
:
t
)
=
Comment
(
TextComment
t
)
atomClass
x
=
maybe
(
Other
x
)
Number
(
matches
Just
readable
x
)
...
...
capricon/src/Data/CaPriCon.hs
View file @
665f8e4b
...
...
@@ -170,16 +170,18 @@ instance (Show a,IsCapriconString str,MonadReader (Env str (Term str a)) m,Monad
return
(
ContextTerm
d'
$
inc_depth
(
d'
-
d
)
e
)
substHyp
h
vh
=
do
ContextTerm
dm
vh'
<-
pullTerm
(
Just
h
)
vh
ContextTerm
dh
vh'
<-
pullTerm
(
Just
h
)
vh
dm
<-
length
<$>
ask
first
(
\
f
cv
@
(
ContextTerm
d
v
)
->
if
d
<=
d
m
then
cv
else
ContextTerm
(
d
-
1
)
(
inc_depth
(
d
-
dm
)
$
f
$
inc_depth
(
dm
-
d
)
v
))
<$>
if
d
<=
d
h
then
cv
else
ContextTerm
(
d
-
1
)
(
inc_depth
(
d
-
dm
)
$
f
$
inc_depth
(
dm
-
d
)
v
))
<$>
substHyp
h
vh'
insertHypBefore
h
h'
cth'
=
do
ContextTerm
dh
th'
<-
pullTerm
h
cth'
dm
<-
length
<$>
ask
first
(
\
f
cx
@
(
ContextTerm
d
x
)
->
if
d
<=
dh
then
cx
else
ContextTerm
(
d
+
1
)
(
inc_depth
(
d
-
d
h
)
$
f
$
inc_depth
(
d
h
-
d
)
x
))
else
ContextTerm
(
d
+
1
)
(
inc_depth
(
d
-
d
m
)
$
f
$
inc_depth
(
d
m
-
d
)
x
))
<$>
insertHypBefore
h
h'
th'
data
NodeDir
str
ax
a
=
NodeDir
...
...
Write
Preview
Markdown
is supported
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