Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
clean-and-itasks
clean-sapl
Commits
9f0a3584
Commit
9f0a3584
authored
Mar 29, 2016
by
Laszlo Domoszlai
Browse files
compiler to the new SAPL
parent
484fb866
Changes
12
Hide whitespace changes
Inline
Side-by-side
src/Sapl/Optimization/StrictnessPropagation.icl
View file @
9f0a3584
...
...
@@ -47,8 +47,13 @@ propBody ps flavour sd body = walk sd body
where
walk
sd
t
=:(
SVar
var
)
=
(
insert
(
unpackVar
var
)
sd
,
t
)
walk
sd
t
=:(
SApplication
var
args
)
// We can skip the new args, cannot contain let definitions...
// We can skip the new expr, cannot contain let definitions...
walk
sd
t
=:(
SSelect
expr
idx
)
#
(
sd
,
_)
=
walk
sd
expr
=
(
sd
,
t
)
// We can skip the new args, cannot contain let definitions...
walk
sd
t
=:(
SApplication
(
SVar
var
)
args
)
#
nsds
=
map
fst
(
map
(
walk
newSet
)
strictArgs
)
=
(
unions
[
sd
:
nsds
],
t
)
where
...
...
@@ -57,16 +62,17 @@ where
checkArg
(
arg
,
i
)
=
isStrictArg
ps
flavour
varName
nr_args
i
strictArgs
=
map
fst
(
filter
checkArg
(
zip2
args
[
0
..]))
walk
sd
(
SIf
c
l
r
)
#
(
sdl
,
nl
)
=
walk
newSet
l
#
(
sdr
,
nr
)
=
walk
newSet
r
#
(
sdc
,
nc
)
=
walk
sd
c
=
(
union
sdc
(
intersection
sdl
sdr
),
SIf
nc
nl
nr
)
// We can skip the new expr, cannot contain let definitions...
// Args cannot be checked, we do not know the function defiition...
walk
sd
t
=:(
SApplication
expr
args
)
// expr is always strict
#
(
sd
,
_)
=
walk
sd
expr
=
(
sd
,
t
)
walk
sd
(
S
Select
p
cases
)
walk
sd
(
S
Case
p
cases
)
#
(
sdp
,
np
)
=
walk
sd
p
#
(
sdcs
,
ncases
)
=
unzip
(
map
walkcase
cases
)
=
(
union
sdp
(
intersections
sdcs
),
S
Select
np
ncases
)
=
(
union
sdp
(
intersections
sdcs
),
S
Case
np
ncases
)
where
walkcase
(
p
,
c
)
#
(
sd
,
nc
)
=
walk
newSet
c
...
...
@@ -89,7 +95,7 @@ where
where
vn
=
unpackVar
(
unpackBindVar
bnd
)
// Delete itself, it dosn't need any more
// Delete itself, it do
e
sn't need any more
walkbnd
sd
(
SaplLetDef
(
TypedVar
(
StrictVar
vn
_)
_)
body
)
=
delete
vn
(
fst
(
walk
sd
body
))
// skip new body, it cannot be a let definition
walkbnd
sd
(
SaplLetDef
(
TypedVar
(
NormalVar
vn
_)
_)
body
)
=
delete
vn
sd
...
...
src/Sapl/SaplParser.dcl
View file @
9f0a3584
...
...
@@ -49,4 +49,3 @@ parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm, ParserState)
* @return merged parser state
*/
mergeParserStates
::
ParserState
(
Maybe
ParserState
)
->
ParserState
src/Sapl/SaplParser.icl
View file @
9f0a3584
...
...
@@ -63,98 +63,110 @@ where
addTupleCons
_
=
returnS
Void
factor
[
TIdentifier
name
:
ts
]
=
getLevel
>>=
\
level
=
returnS
(
Just
(
SVar
(
NormalVar
name
level
)),
ts
)
factor
[
TLit
lit
:
ts
]
=
returnS
(
Just
(
SLit
lit
),
ts
)
factor
[
TOpenParenthesis
:
ts
]
=
application
ts
read_int
[
TLit
(
LInt
lit
):
ts
]
=
returnS
(
Just
lit
,
ts
)
read_int
ts
=
returnS
(
Nothing
,
ts
)
expr
[
TOpenParenthesis
:
ts
]
=
mexpr
ts
>>=
\(
t
,
ts
)
=
case
hd
ts
of
TCloseParenthesis
=
returnS
(
Just
t
,
tl
ts
)
=
returnE
(
ts
,
"Missing close parenthesis"
)
factor
ts
=
returnS
(
Nothing
,
ts
)
=
returnE
(
ts
,
"Missing close parenthesisx"
)
application
[
TOpenParenthesis
:
ts
]
=
application
ts
>>=
\(
t
,
ts
)
=
case
hd
ts
of
TCloseParenthesis
=
returnS
(
t
,
tl
ts
)
=
returnE
(
ts
,
"Missing close parenthesis"
)
expr
[
TLit
lit
:
ts
]
=
returnS
(
Just
(
SLit
lit
),
ts
)
application
[
TIdentifier
name
:
ts
]
=
expr
[
TIdentifier
name
:
ts
]
=
getLevel
>>=
\
level
=
returnS
(
NormalVar
name
level
)
>>=
\
t
=
addTupleCons
name
>>=
\_
=
args_
facto
r
ts
>>=
\_
=
args_
exp
r
ts
>>=
\(
as
,
ts
)
=
case
as
of
[]
=
returnS
(
SVar
t
,
ts
)
// !!!
=
returnS
(
SApplication
t
as
,
ts
)
application
[
TLit
lit
:
ts
]
=
returnS
(
SLit
lit
,
ts
)
application
ts
=
returnE
(
ts
,
"Invalid application"
)
selectexpr
[
TIfKeyword
:
ts
]
=
arg_adv
ts
>>=
mandatory
"Missing predicate"
>>=
\(
pred
,
ts
)
=
arg_adv
ts
>>=
mandatory
"Missing left hand side"
>>=
\(
lhs
,
ts
)
=
arg_adv
ts
>>=
mandatory
"Missing right hand side"
>>=
\(
rhs
,
ts
)
=
returnS
(
Just
(
SIf
pred
lhs
rhs
),
ts
)
selectexpr
[
TSelectKeyword
:
ts
]
=
arg_adv
ts
>>=
mandatory
"Missing select expression"
>>=
\(
expr
,
ts
)
=
args_pattern
ts
>>=
\(
ps
,
ts
)
=
if
(
isEmpty
ps
)
(
returnE
(
ts
,
"Missing select patterns"
))
(
returnS
(
Just
(
SSelect
expr
ps
),
ts
))
selectexpr
ts
=
returnS
(
Nothing
,
ts
)
[]
=
returnS
(
Just
(
SVar
t
),
ts
)
=
returnS
(
Just
(
SApplication
(
SVar
t
)
as
),
ts
)
expr
[
TSelectKeyword
:
ts
]
=
sexpr
ts
>>=
mandatory
"Missing select expression"
>>=
\(
expr
,
ts
)
=
read_int
ts
>>=
mandatory
"Missing select index"
>>=
\(
idx
,
ts
)
=
args_expr
ts
>>=
\(
as
,
ts
)
=
case
as
of
[]
=
returnS
(
Just
(
SSelect
expr
idx
),
ts
)
=
returnS
(
Just
(
SApplication
(
SSelect
expr
idx
)
as
),
ts
)
expr
ts
=
returnS
(
Nothing
,
ts
)
sexpr
[
TOpenParenthesis
:
ts
]
=
mexpr
ts
>>=
\(
t
,
ts
)
=
case
hd
ts
of
TCloseParenthesis
=
returnS
(
Just
t
,
tl
ts
)
=
returnE
(
ts
,
"Missing close parenthesisx"
)
mainexpr
ts
=
selectexpr
ts
>>=
\(
t
,
ts
)
=
case
t
of
Just
t
=
returnS
(
t
,
ts
)
=
application
ts
sexpr
[
TLit
lit
:
ts
]
=
returnS
(
Just
(
SLit
lit
),
ts
)
sexpr
[
TIdentifier
name
:
ts
]
=
getLevel
>>=
\
level
=
returnS
(
NormalVar
name
level
)
>>=
\
t
=
addTupleCons
name
>>=
\_
=
returnS
(
Just
(
SVar
t
),
ts
)
sexpr
ts
=
returnS
(
Nothing
,
ts
)
mexpr
ts
=
expr
ts
>>=
mandatory
"Missing expression"
letdefinitions
ts
=
letdef_1
ts
[]
where
letdef_1
[
TIdentifier
name
,
TTypeDef
,
TIdentifier
type
,
TAssignmentOp
:
ts
]
as
=
getLevel
>>=
\
level
=
application
ts
>>=
\
level
=
body
False
ts
>>=
\(
t
,
ts
)
=
letdef_2
ts
[
SaplLetDef
(
TypedVar
(
NormalVar
name
level
)
(
Type
type
))
t
:
as
]
letdef_1
[
TIdentifier
name
,
TAssignmentOp
:
ts
]
as
=
getLevel
>>=
\
level
=
application
ts
>>=
\
level
=
body
False
ts
>>=
\(
t
,
ts
)
=
letdef_2
ts
[
SaplLetDef
(
TypedVar
(
NormalVar
name
level
)
NoType
)
t
:
as
]
letdef_1
[
TStrictIdentifier
name
,
TTypeDef
,
TIdentifier
type
,
TAssignmentOp
:
ts
]
as
=
getLevel
>>=
\
level
=
application
ts
>>=
\
level
=
body
False
ts
>>=
\(
t
,
ts
)
=
letdef_2
ts
[
SaplLetDef
(
TypedVar
(
StrictVar
name
level
)
(
Type
type
))
t
:
as
]
letdef_1
[
TStrictIdentifier
name
,
TAssignmentOp
:
ts
]
as
=
getLevel
>>=
\
level
=
application
ts
>>=
\
level
=
body
False
ts
>>=
\(
t
,
ts
)
=
letdef_2
ts
[
SaplLetDef
(
TypedVar
(
StrictVar
name
level
)
NoType
)
t
:
as
]
letdef_1
ts
as
=
returnE
(
ts
,
"Invalid
\"
let
\"
definition"
)
letdef_2
[
TColon
:
ts
]
as
=
letdef_1
ts
as
letdef_2
ts
as
=
returnS
(
reverse
as
,
ts
)
body
[
TLetKeyword
:
ts
]
=
body
simple
[
TOpenParenthesis
:
ts
]
=
body
False
ts
>>=
\(
t
,
ts
)
=
case
hd
ts
of
TCloseParenthesis
=
returnS
(
t
,
tl
ts
)
=
returnE
(
ts
,
"Missing close parenthesis"
)
body
simple
[
TLetKeyword
:
ts
]
=
incLevel
ts
>>=
\
ts
=
letdefinitions
ts
>>=
\(
ds
,
ts
)
=
case
hd
ts
of
TInKeyword
=
returnS
(
tl
ts
)
=
returnE
(
ts
,
"Missing
\"
in
\"
keyword"
)
>>=
\
ts
=
mainexpr
ts
>>=
\
ts
=
body
False
ts
>>=
\(
t
,
ts
)
=
returnS
(
SLet
t
ds
,
ts
)
>>=
decLevel
body
simple
[
TCaseKeyword
:
ts
]
=
body
True
ts
>>=
\(
expr
,
ts
)
=
args_pattern
ts
>>=
\(
ps
,
ts
)
=
if
(
isEmpty
ps
)
(
returnE
(
ts
,
"Missing case patterns"
))
(
returnS
(
SCase
expr
ps
,
ts
))
body
[
TOpenBracket
:
ts
]
=
skip
ts
// ABC code: skip it
body
simple
[
TOpenBracket
:
ts
]
=
skip
ts
// ABC code: skip it
where
skip
[
TCloseBracket
:
ts
]
=
returnS
(
SAbortBody
,
ts
)
skip
[]
=
returnE
([],
"Missing close bracket in ABC code definition"
)
skip
[
t
:
ts
]
=
skip
ts
body
ts
=
mainexpr
ts
body
simple
ts
=
((
if
simple
sexpr
expr
)
ts
)
>>=
mandatory
"Missing expression"
args_
facto
r
ts
=
args_
facto
r
ts
args_
exp
r
ts
=
args_
sexp
r
ts
args_pattern
ts
=
args_
arg_pattern
ts
args_
f
ts
=
args`
ts
[]
...
...
@@ -166,36 +178,28 @@ where
arg_pattern
[
TOpenParenthesis
:
TLit
lit
:
ts
]
=
case
hd
ts
of
T
Select
AssignmentOp
=
body
(
tl
ts
)
T
Case
AssignmentOp
=
body
False
(
tl
ts
)
=
returnE
(
ts
,
"Missing select assignment operator"
)
>>=
\(
t
,
ts
)
=
case
hd
ts
of
TCloseParenthesis
=
returnS
(
Just
(
PLit
lit
,
t
),
tl
ts
)
=
returnE
(
ts
,
"Missing close parenthesis"
)
=
returnE
(
ts
,
"Missing close parenthesis
3
"
)
arg_pattern
[
TOpenParenthesis
:
TIdentifier
cons
:
ts
]
=
incLevel
ts
>>=
\
ts
=
addTupleCons
cons
>>=
\_
=
args
ts
>>=
\(
as
,
ts
)
=
case
hd
ts
of
T
Select
AssignmentOp
=
body
(
tl
ts
)
T
Case
AssignmentOp
=
body
False
(
tl
ts
)
=
returnE
(
ts
,
"Missing select assignment operator"
)
>>=
\(
t
,
ts
)
=
case
hd
ts
of
TCloseParenthesis
=
returnS
(
Just
(
mbCons
as
,
t
),
tl
ts
)
=
returnE
(
ts
,
"Missing close parenthesis"
)
=
returnE
(
ts
,
"Missing close parenthesis
4
"
)
>>=
decLevel
where
mbCons
as
=
if
(
cons
==
"_"
)
PDefault
(
PCons
cons
as
)
arg_pattern
ts
=
returnS
(
Nothing
,
ts
)
arg_adv
[
TOpenParenthesis
:
ts
]
=
body
ts
>>=
\(
t
,
ts
)
=
returnS
(
Just
t
,
ts
)
>>=
\(
t
,
ts
)
=
case
hd
ts
of
TCloseParenthesis
=
returnS
(
t
,
tl
ts
)
=
returnE
(
ts
,
"Missing close parenthesis"
)
arg_adv
ts
=
factor
ts
args
ts
=
args_
ts
[]
where
args_
[
TIdentifier
name
:
ts
]
as
=
getLevel
>>=
\
level
=
args_
ts
[
NormalVar
name
level
:
as
]
...
...
@@ -258,7 +262,7 @@ func ts = returnE (ts, "Not a function or type definition")
typed_caf
name
type
ts
=
getLevel
>>=
\
level
=
body
ts
>>=
\
level
=
body
False
ts
>>=
\(
t
,
ts
)
=
addCAF
(
NormalVar
name
level
)
>>=
\
tname
=
returnS
(
FTCAF
(
TypedVar
tname
type
)
t
,
ts
)
typed_fun
name
type
ts
=
...
...
@@ -268,7 +272,7 @@ typed_fun name type ts =
TAssignmentOp
=
returnS
(
True
,
tl
ts
)
TMacroAssignmentOp
=
returnS
(
False
,
tl
ts
)
=
returnE
(
ts
,
"Missing assignment operator"
)
>>=
\(
func
,
ts
)
=
body
ts
>>=
\(
func
,
ts
)
=
body
False
ts
>>=
\(
t
,
ts
)
=
if
func
(
addFunction
(
NormalVar
name
level
)
as
>>=
\
tname
=
returnS
(
FTFunc
(
TypedVar
tname
type
)
t
as
,
ts
))
(
addFunction
(
NormalVar
name
level
)
as
>>=
\
tname
=
returnS
(
FTMacro
(
TypedVar
tname
type
)
t
as
,
ts
))
...
...
@@ -297,7 +301,7 @@ where
parseExpr
::
[
PosToken
]
->
MaybeError
ErrorMsg
(
SaplTerm
,
ParserState
)
parseExpr
pts
#
ts
=
map
(\(
PosToken
_
_
t
)
=
t
)
pts
=
case
(
body
ts
)
defaultState
of
=
case
(
body
False
ts
)
defaultState
of
Ok
((
fts
,
_),
ps
)
=
Ok
(
fts
,
ps
)
Error
(
ts
,
msg
)
=
let
(
lp
,
cp
)
=
findpos
ts
in
Error
(
msg
+++
" at line "
+++
toString
lp
+++
" before charachter "
+++
toString
cp
)
where
...
...
src/Sapl/SaplStruct.dcl
View file @
9f0a3584
...
...
@@ -17,11 +17,10 @@ import Data.Maybe
::
SaplTerm
=
SLit
Literal
|
SVar
SaplVar
|
SApplication
SaplVar
[
SaplTerm
]
|
SIf
SaplTerm
SaplTerm
SaplTerm
|
SSelector
SaplTerm
|
SSelect
SaplTerm
[(
SaplPattern
,
SaplTerm
)]
|
SApplication
SaplTerm
[
SaplTerm
]
|
SCase
SaplTerm
[(
SaplPattern
,
SaplTerm
)]
|
SLet
SaplTerm
[
SaplLetDef
]
|
SSelect
SaplTerm
Int
|
SAbortBody
::
SaplLetDef
=
SaplLetDef
SaplTypedVar
SaplTerm
...
...
@@ -67,6 +66,7 @@ instance unpackVar SaplVar
instance
unpackVar
SaplTypedVar
unpackBindVar
::
!
SaplLetDef
->
SaplTypedVar
unpackBindExpr
::
!
SaplLetDef
->
SaplTerm
unpackConsName
::
!
SaplPattern
->
Maybe
String
toStrictBind
::
!
SaplLetDef
->
SaplLetDef
...
...
src/Sapl/SaplStruct.icl
View file @
9f0a3584
...
...
@@ -86,6 +86,9 @@ where
unpackBindVar
::
!
SaplLetDef
->
SaplTypedVar
unpackBindVar
(
SaplLetDef
typedVar
_)
=
typedVar
unpackBindExpr
::
!
SaplLetDef
->
SaplTerm
unpackBindExpr
(
SaplLetDef
_
expr
)
=
expr
unpackConsName
::
!
SaplPattern
->
Maybe
String
unpackConsName
(
PCons
cons
_)
=
Just
cons
unpackConsName
_
=
Nothing
...
...
src/Sapl/SaplTokenizer.dcl
View file @
9f0a3584
...
...
@@ -10,7 +10,7 @@ import StdString, Text.Unicode
|
TComment
String
|
TInlineAnnotation
|
TAssignmentOp
|
T
Select
AssignmentOp
|
T
Case
AssignmentOp
|
TMacroAssignmentOp
|
TCAFAssignmentOp
|
TLambda
...
...
@@ -22,8 +22,8 @@ import StdString, Text.Unicode
|
TCloseBracket
|
TTypeDef
|
TLit
Literal
|
T
Select
Keyword
|
T
If
Keyword
|
T
Case
Keyword
|
T
Select
Keyword
|
TLetKeyword
|
TInKeyword
|
TEndOfLine
...
...
src/Sapl/SaplTokenizer.icl
View file @
9f0a3584
...
...
@@ -101,7 +101,7 @@ read_token base line
|
matchAt
":=="
line
start
=
rnoarg
TMacroAssignmentOp
3
|
matchAt
"->"
line
start
=
rnoarg
T
Select
AssignmentOp
2
=
rnoarg
T
Case
AssignmentOp
2
|
matchCharAt
'\\'
line
start
=
rnoarg
TLambda
1
|
matchCharAt
','
line
start
...
...
@@ -136,8 +136,8 @@ read_token base line
"false"
=
return
(
TLit
(
LBool
False
),
stop
)
"True"
=
return
(
TLit
(
LBool
True
),
stop
)
"true"
=
return
(
TLit
(
LBool
True
),
stop
)
"case"
=
return
(
TCaseKeyword
,
stop
)
"select"
=
return
(
TSelectKeyword
,
stop
)
"if"
=
return
(
TIfKeyword
,
stop
)
"let"
=
return
(
TLetKeyword
,
stop
)
"in"
=
return
(
TInKeyword
,
stop
)
str
=
if
(
str
.[
0
]
==
'!'
)
...
...
@@ -225,8 +225,8 @@ where
toString
TCloseBracket
=
"}"
toString
TTypeDef
=
"::"
toString
(
TLit
lit
)
=
toString
lit
toString
TCaseKeyword
=
"case"
toString
TSelectKeyword
=
"select"
toString
TIfKeyword
=
"if"
toString
TLetKeyword
=
"let"
toString
TInKeyword
=
"in"
toString
TEndOfLine
=
"
\n
"
...
...
src/Sapl/Target/JS/CodeGeneratorJS.icl
View file @
9f0a3584
...
...
@@ -14,12 +14,14 @@ import qualified Data.Map as DM
import
Text
.
Unicode
.
Encodings
.
JS
import
Sapl
.
SaplTokenizer
,
Sapl
.
SaplParser
,
Sapl
.
Target
.
Flavour
,
Sapl
.
Optimization
.
StrictnessPropagation
import
Sapl
.
Transform
.
Let
import
Sapl
.
Target
.
JS
.
Lifting
import
Sapl
.
Transform
.
AddSelectors
from
Data
.
List
import
elem_by
,
partition
::
CoderState
=
{
cs_inbody
::
!
Maybe
SaplTypedVar
// The body of the function which is being generated (not signature)
,
cs_intrfunc
::
!
Maybe
SaplTypedVar
// The name of the currently generated function if it is tail recursive
,
cs_inletbind
::
!
Maybe
SaplTypedVar
// The name of the let binding we are in
,
cs_futuredefs
::
![
SaplTypedVar
]
// for finding out about let-rec and let bindings defined later
,
cs_incaseexpr
::
!
Bool
,
cs_current_vars
::
![
SaplTypedVar
]
...
...
@@ -36,6 +38,7 @@ newState :: !Flavour !Bool !ParserState -> CoderState
newState
f
tramp
p
=
{
cs_inbody
=
Nothing
,
cs_intrfunc
=
Nothing
,
cs_inletbind
=
Nothing
,
cs_futuredefs
=
[]
,
cs_incaseexpr
=
False
,
cs_current_vars
=
[]
...
...
@@ -48,13 +51,6 @@ newState f tramp p =
,
cs_prefix
=
f
.
fun_prefix
}
// Returns True if a term can be inlined, i.e. no separate statement is needed
inline
::
!
SaplTerm
->
Bool
inline
(
SLet
_
_)
=
False
inline
(
SSelect
_
_)
=
False
inline
(
SIf
_
_
_)
=
False
inline
_
=
True
pushArgs
::
!
CoderState
![
SaplTypedVar
]
->
CoderState
pushArgs
s
[
t
:
ts
]
=
pushArgs
{
s
&
cs_current_vars
=
[
t
:
s
.
cs_current_vars
]}
ts
pushArgs
s
[]
=
s
...
...
@@ -99,6 +95,8 @@ callWrapper :: !SaplTerm !CoderState !StringAppender -> StringAppender
callWrapper
t
s
a
|
not
(
inline
t
)
=
termCoder
t
s
a
|
isJust
s
.
cs_inletbind
=
a
<++
"var "
<++
termCoder
(
fromJust
s
.
cs_inletbind
)
{
s
&
cs_futuredefs
=
[]}
<++
"="
<++
forceTermCoder
t
s
<++
";"
|
isJust
s
.
cs_intrfunc
&&
isTailRecursive
(
fromJust
s
.
cs_intrfunc
)
t
=
forceTermCoder
t
s
a
|
s
.
cs_trampoline
...
...
@@ -106,9 +104,8 @@ callWrapper t s a
=
a
<++
"return "
<++
forceTermCoder
t
s
<++
";"
isTailRecursive
::
!
SaplTypedVar
!
SaplTerm
->
Bool
isTailRecursive
var
(
SSelect
_
patterns
)
=
any
(
isTailRecursive
var
o
snd
)
patterns
isTailRecursive
var
(
SIf
pred
lhs
rhs
)
=
isTailRecursive
var
lhs
||
isTailRecursive
var
rhs
isTailRecursive
var
(
SApplication
avar
_)
=
unpackVar
var
==
unpackVar
avar
isTailRecursive
var
(
SCase
_
patterns
)
=
any
(
isTailRecursive
var
o
snd
)
patterns
isTailRecursive
var
(
SApplication
(
SVar
avar
)
_)
=
unpackVar
var
==
unpackVar
avar
isTailRecursive
var
(
SLet
body
_)
=
isTailRecursive
var
body
isTailRecursive
_
_
=
False
...
...
@@ -305,8 +302,7 @@ splitDefaultPattern patterns
containsUnsafeSelect
::
!
CoderState
!
SaplTerm
->
Bool
containsUnsafeSelect
s
(
SApplication
_
ts
)
=
any
(
containsUnsafeSelect
s
)
ts
containsUnsafeSelect
s
(
SIf
_
tb
fb
)
=
containsUnsafeSelect
s
tb
||
containsUnsafeSelect
s
fb
containsUnsafeSelect
s
(
SSelect
_
ps
)
=
isUnsafeSelect
s
ps
||
any
(
containsUnsafeSelect
s
)
(
map
snd
ps
)
containsUnsafeSelect
s
(
SCase
_
ps
)
=
isUnsafeSelect
s
ps
||
any
(
containsUnsafeSelect
s
)
(
map
snd
ps
)
containsUnsafeSelect
s
(
SLet
b
_)
=
containsUnsafeSelect
s
b
containsUnsafeSelect
s
_
=
False
...
...
@@ -455,26 +451,38 @@ where
* A let definition is not the spine of the function, avoid tail recursion optimization:
* {s & cs_intrfunc = Nothing}
*/
letDefCoder
::
![
SaplLetDef
]
!
CoderState
!
StringAppender
->
StringAppender
letDefCoder
[
t
]
s
a
=
termCoder
t
{
s
&
cs_intrfunc
=
Nothing
,
cs_futuredefs
=[
toNormalVar
(
unpackBindVar
t
)]}
a
letDefCoder
all
=:[
t
:
ts
]
s
a
=
a
<++
termCoder
t
{
s
&
cs_intrfunc
=
Nothing
,
cs_futuredefs
=
fvs
}
<++
","
<++
letDefCoder
ts
{
s
&
cs_current_vars
=[
unpackBindVar
t
:
s
.
cs_current_vars
]}
letDefCoder
::
![
SaplLetDef
]
!
Bool
!
CoderState
!
StringAppender
->
StringAppender
letDefCoder
[
t
]
needsvar
s
a
|
inline
(
unpackBindExpr
t
)
=
a
<++
if
needsvar
"var "
","
<++
termCoder
t
{
s
&
cs_intrfunc
=
Nothing
,
cs_futuredefs
=[
toNormalVar
(
unpackBindVar
t
)]}
<++
";
\n
"
=
a
<++
if
needsvar
""
";
\n
"
<++
termCoder
t
{
s
&
cs_intrfunc
=
Nothing
,
cs_futuredefs
=[
toNormalVar
(
unpackBindVar
t
)]}
<++
";
\n
"
letDefCoder
all
=:[
t
:
ts
]
needsvar
s
a
|
inline
(
unpackBindExpr
t
)
=
a
<++
if
needsvar
"var "
","
<++
termCoder
t
{
s
&
cs_intrfunc
=
Nothing
,
cs_futuredefs
=
fvs
}
<++
letDefCoder
ts
False
{
s
&
cs_current_vars
=[
unpackBindVar
t
:
s
.
cs_current_vars
]}
where
fvs
=
map
(
toNormalVar
o
unpackBindVar
)
all
letDefCoder
all
=:[
t
:
ts
]
needsvar
s
a
=
a
<++
if
needsvar
""
";
\n
"
<++
termCoder
t
{
s
&
cs_intrfunc
=
Nothing
,
cs_futuredefs
=
fvs
}
<++
";
\n
"
<++
letDefCoder
ts
True
{
s
&
cs_current_vars
=[
unpackBindVar
t
:
s
.
cs_current_vars
]}
where
fvs
=
map
(
toNormalVar
o
unpackBindVar
)
all
letDefCoder
[]
_
a
=
a
letDefCoder
[]
_
_
a
=
a
isDependent
::
![
SaplVar
]
!
SaplTerm
->
Bool
isDependent
vs
(
SApplication
f
as
)
=
any
(
isDependent
vs
)
[
SVar
f
:
as
]
isDependent
vs
(
SApplication
(
SVar
f
)
as
)
=
any
(
isDependent
vs
)
[
SVar
f
:
as
]
isDependent
vs
(
SVar
v
)
=
elem_by
eqVarByNameLevel
v
vs
isDependent
_
_
=
False
instance
TermCoder
SaplLetDef
where
termCoder
(
SaplLetDef
name
body
)
s
a
termCoder
(
SaplLetDef
name
body
)
s
a
|
inline
body
=
a
<++
termCoder
name
{
s
&
cs_futuredefs
=
[]}
<++
"="
<++
(
if
(
isStrictVar
name
)
forceTermCoder
termCoder
)
body
s
termCoder
(
SaplLetDef
name
body
)
s
a
=
a
<++
(
if
(
isStrictVar
name
)
forceTermCoder
termCoder
)
body
{
s
&
cs_inletbind
=
Just
name
}
forceTermCoder
t
s
a
=
termCoder
t
s
a
trampolineCoder
t
s
a
=
termCoder
t
s
a
...
...
@@ -488,7 +496,7 @@ where
forceTermCoder
::
!
SaplTerm
!
CoderState
!
StringAppender
->
StringAppender
forceTermCoder
t
=:(
SVar
var
)
s
a
=
forceTermCoder
var
s
a
forceTermCoder
t
=:(
SApplication
name
args
)
s
a
forceTermCoder
t
=:(
SApplication
(
SVar
name
)
args
)
s
a
|
isJust
mbConstructor
&&
constructor
.
nr_args
==
length
args
=
constructorInliner
name
constructor
args
s
a
...
...
@@ -504,7 +512,7 @@ where
// more arguments than needed: split it
|
isJust
mbFunction
&&
functionArity
<
length
args
=
forceApp
(\
a
->
a
<++
forceTermCoder
(
SApplication
name
(
take
functionArity
args
))
s
<++
",["
=
forceApp
(\
a
->
a
<++
forceTermCoder
(
SApplication
(
SVar
name
)
(
take
functionArity
args
))
s
<++
",["
<++
termArrayCoder
(
drop
functionArity
args
)
","
{
s
&
cs_intrfunc
=
Nothing
}
<++
"]"
)
a
|
isJust
mbInlineFun
&&
inlineFun
.
arity
==
length
args
...
...
@@ -561,13 +569,21 @@ where
=
a
<++
escapeName
s
.
cs_prefix
(
unpackVar
fa
)
<++
"=t"
<++
i
<++
";"
<++
mta_2
fargs
(
i
+1
)
s
// skip level information for TR!
mta_2
[]
i
s
a
=
a
forceTermCoder
(
SApplication
sel
=:(
SSelect
_
_)
args
)
s
a
=
a
<++
"Sapl.fapp("
<++
forceTermCoder
sel
s
<++
",["
<++
termArrayCoder
args
","
s
<++
"])"
forceTermCoder
t
=:(
SSelect
expr
idx
)
s
a
=
a
<++
"Sapl.feval("
<++
forceTermCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
"["
<++
idx
+
2
<++
"])"
forceTermCoder
t
s
a
=
termCoder
t
s
a
// During trampolining, in only very special cases the expressions are forced in tail call
trampolineCoder
::
!
SaplTerm
!
CoderState
!
StringAppender
->
StringAppender
trampolineCoder
t
=:(
SVar
var
)
s
a
=
trampolineCoder
var
s
a
trampolineCoder
t
=:(
SApplication
name
args
)
s
a
trampolineCoder
t
=:(
SApplication
(
SVar
name
)
args
)
s
a
|
isJust
mbConstructor
&&
constructor
.
nr_args
==
length
args
=
constructorInliner
name
constructor
args
s
a
...
...
@@ -588,12 +604,10 @@ where
termCoder
::
!
SaplTerm
!
CoderState
!
StringAppender
->
StringAppender
termCoder
t
=:(
SVar
var
)
s
a
=
termCoder
var
s
a
termCoder
t
=:(
SSelector
(
SSelect
expr
[(
PCons
_
vs
,
SVar
x
)]))
s
a
#
(
idx
,
_)
=
foldl
(\(
idx
,
cnt
)
v
->
if
(
eqVarByName
x
v
)
(
cnt
,
cnt
)
(
idx
,
cnt
+
1
))
(
0
,
0
)
vs
=
a
<++
"Sapl.feval("
<++
forceTermCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
"["
<++
idx
+
2
<++
"])"
termCoder
t
=:(
SSelector
x
)
s
a
=
termCoder
x
s
a
termCoder
t
=:(
SSelect
expr
idx
)
s
a
=
a
<++
"[Sapl.select,["
<++
termCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
", "
<++
idx
+
2
<++
"]]"
termCoder
t
=:(
S
Select
expr
patterns
)
s
a
|
any
(
isConsPattern
o
fst
)
patterns
termCoder
t
=:(
S
Case
expr
patterns
)
s
a
|
any
(
isConsPattern
o
fst
)
patterns
#
a
=
a
<++
"var ys="
<++
forceTermCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
";"
=
if
(
containsUnsafeSelect
s
t
)
(
unsafe
a
)
(
safe
a
)
where
...
...
@@ -627,8 +641,14 @@ where
=
case
d
of
(
Just
d
)
=
a
<++
termCoder
(
defp
d
False
)
s
<++
";"
=
a
termCoder
t
=:(
SCase
expr
[(
PLit
(
LBool
True
),
true_expr
),(
PLit
(
LBool
False
),
false_expr
)])
s
a
=
termCodeIf
expr
true_expr
false_expr
s
a
termCoder
t
=:(
SCase
expr
[(
PLit
(
LBool
False
),
false_expr
),(
PLit
(
LBool
True
),
true_expr
)])
s
a
=
termCodeIf
expr
true_expr
false_expr
s
a