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
42d02357
Commit
42d02357
authored
Oct 29, 2015
by
Laszlo Domoszlai
Browse files
add capability to parse typed SAPL
parent
c6917dc5
Changes
8
Hide whitespace changes
Inline
Side-by-side
src/Sapl/Linker/SaplLinkerShared.icl
View file @
42d02357
...
...
@@ -78,7 +78,7 @@ read_line (lmap, startfn, id) line
=
(
lmap
,
startfn
,
id
+1
)
(
TIdentifier
name
)
#
lmap
=
case
skip_
arguments
next
of
#
lmap
=
case
skip_
to_definition
next
of
[
TAssignmentOp
,
(
TIdentifier
"StdMisc.undef"
):_]
// skip functions which are undefined
=
lmap
[
TAssignmentOp
:
ts
]
...
...
@@ -92,9 +92,10 @@ read_line (lmap, startfn, id) line
_
=
(
lmap
,
startfn
,
id
+1
)
// skip line. e.g. comment
where
skip_arguments
[
TIdentifier
_:
ts
]
=
skip_arguments
ts
skip_arguments
[
TStrictIdentifier
_:
ts
]
=
skip_arguments
ts
skip_arguments
ts
=
ts
skip_to_definition
[
TIdentifier
_:
ts
]
=
skip_to_definition
ts
skip_to_definition
[
TStrictIdentifier
_:
ts
]
=
skip_to_definition
ts
skip_to_definition
[
TTypeDef
:
ts
]
=
skip_to_definition
ts
skip_to_definition
ts
=
ts
macroBody
ts
=
toString
(
macroBody_
(
filter
macroTokens
ts
)
newAppender
)
where
...
...
src/Sapl/Optimization/StrictnessPropagation.icl
View file @
42d02357
...
...
@@ -37,8 +37,8 @@ where
(
ds
,
nbody
)
=
(
propBody
ps
flavour
newSet
body
)
nargs
=
map
addStrictness
args
addStrictness
var
=:(
StrictVar
_
_)
=
var
addStrictness
var
=:(
NormalVar
vn
_)
=
if
(
member
vn
ds
)
(
toStrictVar
var
)
var
addStrictness
var
=:
(
TypedVar
(
StrictVar
_
_)
_)
=
var
addStrictness
var
=:
(
TypedVar
(
NormalVar
vn
_)
_)
=
if
(
member
vn
ds
)
(
toStrictVar
var
)
var
propFunc
ps
_
f
=
(
f
,
ps
)
...
...
@@ -90,8 +90,8 @@ where
vn
=
unpackVar
(
unpackBindVar
bnd
)
// Delete itself, it dosn't need any more
walkbnd
sd
(
SaplLetDef
(
StrictVar
vn
_)
body
)
=
delete
vn
(
fst
(
walk
sd
body
))
// skip new body, it cannot be a let definition
walkbnd
sd
(
SaplLetDef
(
NormalVar
vn
_)
body
)
=
delete
vn
sd
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
walk
sd
t
=
(
sd
,
t
)
src/Sapl/SaplParser.dcl
View file @
42d02357
...
...
@@ -7,7 +7,7 @@ from Data.Map import :: Map
// Cannot be abstract because code generator uses it
::
ParserState
=
{
ps_level
::
Int
,
ps_constructors
::
Map
String
ConstructorDef
,
ps_functions
::
Map
String
[
SaplVar
]
,
ps_functions
::
Map
String
[
Sapl
Typed
Var
]
,
ps_CAFs
::
Map
String
Void
,
ps_genFuns
::
[
FuncType
]
// generated functions during parsing
}
...
...
@@ -15,7 +15,7 @@ from Data.Map import :: Map
::
ConstructorDef
=
{
index
::
!
Int
,
nr_cons
::
!
Int
,
nr_args
::
!
Int
// for efficiency
,
args
::
[
SaplVar
]
,
args
::
[
Sapl
Typed
Var
]
}
::
ErrorMsg
:==
String
...
...
src/Sapl/SaplParser.icl
View file @
42d02357
...
...
@@ -58,8 +58,8 @@ where
genadt
nrargs
s
=
FTADT
(
NormalVar
name
0
)
[
SaplConstructor
(
NormalVar
name
0
)
0
[
genarg
i
s
\\
i
<-
[
1
..
nrargs
]]]
genarg
i
s
|
s
bitand
(
1
<<
(
i
-1
))
>
0
=
StrictVar
"_"
0
=
NormalVar
"_"
0
=
TypedVar
(
StrictVar
"_"
0
)
NoType
=
TypedVar
(
NormalVar
"_"
0
)
NoType
addTupleCons
_
=
returnS
Void
...
...
@@ -116,14 +116,22 @@ mainexpr ts = selectexpr ts
letdefinitions
ts
=
letdef_1
ts
[]
where
letdef_1
[
TIdentifier
name
,
TTypeDef
,
TIdentifier
type
,
TAssignmentOp
:
ts
]
as
=
getLevel
>>=
\
level
=
application
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
>>=
\(
t
,
ts
)
=
letdef_2
ts
[
SaplLetDef
(
NormalVar
name
level
)
t
:
as
]
>>=
\(
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
>>=
\(
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
>>=
\(
t
,
ts
)
=
letdef_2
ts
[
SaplLetDef
(
StrictVar
name
level
)
t
:
as
]
>>=
\(
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
)
...
...
@@ -195,14 +203,18 @@ where
args_annotated
ts
=
args_
ts
[]
where
args_
[
TIdentifier
name
:
ts
]
as
=
getLevel
>>=
\
level
=
args_
ts
[
NormalVar
name
level
:
as
]
args_
[
TStrictIdentifier
name
:
ts
]
as
=
args_
ts
[
StrictVar
name
0
:
as
]
args_
[
TIdentifier
name
,
TTypeDef
,
TIdentifier
type
:
ts
]
as
=
getLevel
>>=
\
level
=
args_
ts
[
TypedVar
(
NormalVar
name
level
)
(
Type
type
):
as
]
args_
[
TIdentifier
name
:
ts
]
as
=
getLevel
>>=
\
level
=
args_
ts
[
TypedVar
(
NormalVar
name
level
)
NoType
:
as
]
args_
[
TStrictIdentifier
name
,
TTypeDef
,
TIdentifier
type
:
ts
]
as
=
args_
ts
[
TypedVar
(
StrictVar
name
0
)
(
Type
type
):
as
]
args_
[
TStrictIdentifier
name
:
ts
]
as
=
args_
ts
[
TypedVar
(
StrictVar
name
0
)
NoType
:
as
]
args_
ts
as
=
returnS
(
reverse
as
,
ts
)
args_record
ts
=
args_1
ts
[]
where
args_1
[
TIdentifier
name
:
ts
]
as
=
getLevel
>>=
\
level
=
args_2
ts
[
NormalVar
name
level
:
as
]
args_1
[
TStrictIdentifier
name
:
ts
]
as
=
getLevel
>>=
\
level
=
args_2
ts
[
StrictVar
name
level
:
as
]
args_1
[
TIdentifier
name
,
TTypeDef
,
TIdentifier
type
:
ts
]
as
=
getLevel
>>=
\
level
=
args_2
ts
[
TypedVar
(
NormalVar
name
level
)
(
Type
type
):
as
]
args_1
[
TIdentifier
name
:
ts
]
as
=
getLevel
>>=
\
level
=
args_2
ts
[
TypedVar
(
NormalVar
name
level
)
NoType
:
as
]
args_1
[
TStrictIdentifier
name
,
TTypeDef
,
TIdentifier
type
:
ts
]
as
=
getLevel
>>=
\
level
=
args_2
ts
[
TypedVar
(
StrictVar
name
level
)
(
Type
type
):
as
]
args_1
[
TStrictIdentifier
name
:
ts
]
as
=
getLevel
>>=
\
level
=
args_2
ts
[
TypedVar
(
StrictVar
name
level
)
NoType
:
as
]
args_1
ts
as
=
returnE
(
ts
,
"Missing argument"
)
args_2
[
TColon
:
ts
]
as
=
args_1
ts
as
args_2
ts
as
=
returnS
(
reverse
as
,
ts
)
...
...
@@ -236,12 +248,20 @@ constr [TTypeDef, TIdentifier name, TAssignmentOp: ts] =
constr
[
TTypeDef
:
ts
]
=
returnE
(
ts
,
"Invalid type definition"
)
constr
ts
=
returnE
(
ts
,
"Not a type definition"
)
func
[
TIdentifier
name
,
TCAFAssignmentOp
:
ts
]
=
func
[
TIdentifier
name
,
TTypeDef
,
TIdentifier
type
,
TCAFAssignmentOp
:
ts
]
=
typed_caf
name
(
Type
type
)
ts
func
[
TIdentifier
name
,
TCAFAssignmentOp
:
ts
]
=
typed_caf
name
NoType
ts
func
[
TIdentifier
name
,
TTypeDef
,
TIdentifier
type
:
ts
]
=
typed_fun
name
(
Type
type
)
ts
func
[
TIdentifier
name
:
ts
]
=
typed_fun
name
NoType
ts
func
ts
=:[
TTypeDef
:_]
=
constr
ts
>>=
\(
f
,
ts
)
=
returnS
(
f
,
ts
)
func
ts
=
returnE
(
ts
,
"Not a function or type definition"
)
typed_caf
name
type
ts
=
getLevel
>>=
\
level
=
body
ts
>>=
\(
t
,
ts
)
=
addCAF
(
NormalVar
name
level
)
>>=
\
tname
=
returnS
(
FTCAF
tname
t
,
ts
)
func
[
TIdentifier
name
:
ts
]
=
>>=
\(
t
,
ts
)
=
addCAF
(
NormalVar
name
level
)
>>=
\
tname
=
returnS
(
FTCAF
(
TypedVar
tname
type
)
t
,
ts
)
typed_fun
name
type
ts
=
getLevel
>>=
\
level
=
args_annotated
ts
>>=
\(
as
,
ts
)
=
case
hd
ts
of
...
...
@@ -250,11 +270,8 @@ func [TIdentifier name:ts] =
=
returnE
(
ts
,
"Missing assignment operator"
)
>>=
\(
func
,
ts
)
=
body
ts
>>=
\(
t
,
ts
)
=
if
func
(
addFunction
(
NormalVar
name
level
)
as
>>=
\
tname
=
returnS
(
FTFunc
tname
t
as
,
ts
))
(
addFunction
(
NormalVar
name
level
)
as
>>=
\
tname
=
returnS
(
FTMacro
tname
t
as
,
ts
))
func
ts
=:[
TTypeDef
:_]
=
constr
ts
>>=
\(
f
,
ts
)
=
returnS
(
f
,
ts
)
func
ts
=
returnE
(
ts
,
"Not a function or type definition"
)
(
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
))
skip_newlines
[
TEndOfLine
:
ts
]
=
skip_newlines
ts
skip_newlines
ts
=
returnS
ts
...
...
src/Sapl/SaplStruct.dcl
View file @
42d02357
...
...
@@ -7,13 +7,13 @@ import Data.Maybe
/**
* Possible function types and language constructs.
*/
::
FuncType
=
FTRecord
SaplVar
[
SaplVar
]
::
FuncType
=
FTRecord
SaplVar
[
Sapl
Typed
Var
]
|
FTADT
SaplVar
[
SaplConstructor
]
|
FTCAF
SaplVar
SaplTerm
|
FTMacro
SaplVar
SaplTerm
[
SaplVar
]
|
FTFunc
SaplVar
SaplTerm
[
SaplVar
]
|
FTCAF
Sapl
Typed
Var
SaplTerm
|
FTMacro
Sapl
Typed
Var
SaplTerm
[
Sapl
Typed
Var
]
|
FTFunc
Sapl
Typed
Var
SaplTerm
[
Sapl
Typed
Var
]
::
SaplConstructor
=
SaplConstructor
SaplVar
Int
[
SaplVar
]
::
SaplConstructor
=
SaplConstructor
SaplVar
Int
[
Sapl
Typed
Var
]
::
SaplTerm
=
SLit
Literal
|
SVar
SaplVar
...
...
@@ -24,15 +24,21 @@ import Data.Maybe
|
SLet
SaplTerm
[
SaplLetDef
]
|
SAbortBody
::
SaplLetDef
=
SaplLetDef
SaplVar
SaplTerm
::
SaplLetDef
=
SaplLetDef
Sapl
Typed
Var
SaplTerm
::
SaplVar
=
NormalVar
String
Int
|
StrictVar
String
Int
::
SaplName
:==
String
::
SaplVar
=
NormalVar
SaplName
Int
|
StrictVar
SaplName
Int
::
SaplTypedVar
=
TypedVar
SaplVar
SaplType
::
SaplPattern
=
PCons
String
[
SaplVar
]
|
PLit
Literal
|
PDefault
::
SaplType
=
Type
String
|
NoType
instance
toString
SaplVar
// I don't provide instances of (==) and (<) here because multiple good way can be imagined...
...
...
@@ -41,13 +47,26 @@ ltVarByName :: !SaplVar !SaplVar -> Bool
eqVarByNameLevel
::
!
SaplVar
!
SaplVar
->
Bool
ltVarByNameLevel
::
!
SaplVar
!
SaplVar
->
Bool
eqStrictVar
::
!
String
!
SaplVar
->
Bool
isStrictVar
::
!
SaplVar
->
Bool
toNormalVar
::
!
SaplVar
->
SaplVar
toStrictVar
::
!
SaplVar
->
SaplVar
removeTypeInfo
::
!
SaplTypedVar
->
SaplVar
class
eqStrictVar
v
::
!
String
!
v
->
Bool
class
isStrictVar
v
::
!
v
->
Bool
class
toNormalVar
v
::
!
v
->
v
class
toStrictVar
v
::
!
v
->
v
class
unpackVar
v
::
!
v
->
String
instance
eqStrictVar
SaplVar
instance
eqStrictVar
SaplTypedVar
instance
isStrictVar
SaplVar
instance
isStrictVar
SaplTypedVar
instance
toNormalVar
SaplVar
instance
toNormalVar
SaplTypedVar
instance
toStrictVar
SaplVar
instance
toStrictVar
SaplTypedVar
instance
unpackVar
SaplVar
instance
unpackVar
SaplTypedVar
unpackVar
::
!
SaplVar
->
String
unpackBindVar
::
!
SaplLetDef
->
SaplVar
unpackBindVar
::
!
SaplLetDef
->
SaplTypedVar
unpackConsName
::
!
SaplPattern
->
Maybe
String
toStrictBind
::
!
SaplLetDef
->
SaplLetDef
...
...
src/Sapl/SaplStruct.icl
View file @
42d02357
...
...
@@ -25,35 +25,73 @@ where
toString
(
StrictVar
name
0
)
=
"!"
+++
name
toString
(
StrictVar
name
level
)
=
"!"
+++
name
+++
"_"
+++
toString
level
isStrictVar
::
!
SaplVar
->
Bool
isStrictVar
(
StrictVar
_
_)
=
True
isStrictVar
_
=
False
removeTypeInfo
::
!
SaplTypedVar
->
SaplVar
removeTypeInfo
(
TypedVar
var
_)
=
var
eqStrictVar
::
!
String
!
SaplVar
->
Bool
eqStrictVar
name1
(
StrictVar
name2
_)
=
name1
==
name2
eqStrictVar
_
_
=
False
instance
eqStrictVar
SaplVar
where
eqStrictVar
::
!
String
!
SaplVar
->
Bool
eqStrictVar
name1
(
StrictVar
name2
_)
=
name1
==
name2
eqStrictVar
_
_
=
False
instance
eqStrictVar
SaplTypedVar
where
eqStrictVar
::
!
String
!
SaplTypedVar
->
Bool
eqStrictVar
name
(
TypedVar
var
_)
=
eqStrictVar
name
var
instance
isStrictVar
SaplVar
where
isStrictVar
::
!
SaplVar
->
Bool
isStrictVar
(
StrictVar
_
_)
=
True
isStrictVar
_
=
False
instance
isStrictVar
SaplTypedVar
where
isStrictVar
::
!
SaplTypedVar
->
Bool
isStrictVar
(
TypedVar
var
_)
=
isStrictVar
var
instance
toNormalVar
SaplVar
where
toNormalVar
::
!
SaplVar
->
SaplVar
toNormalVar
(
StrictVar
name
level
)
=
(
NormalVar
name
level
)
toNormalVar
v
=
v
instance
toNormalVar
SaplTypedVar
where
toNormalVar
::
!
SaplTypedVar
->
SaplTypedVar
toNormalVar
(
TypedVar
var
type
)
=
TypedVar
(
toNormalVar
var
)
type
instance
toStrictVar
SaplVar
where
toStrictVar
::
!
SaplVar
->
SaplVar
toStrictVar
(
NormalVar
name
level
)
=
(
StrictVar
name
level
)
toStrictVar
v
=
v
toNormalVar
::
!
SaplVar
->
SaplVar
toNormalVar
(
StrictVar
name
level
)
=
(
NormalVar
name
level
)
toNormalVar
v
=
v
instance
toStrictVar
SaplTypedVar
where
toStrictVar
::
!
SaplTypedVar
->
SaplTypedVar
toStrictVar
(
TypedVar
var
type
)
=
TypedVar
(
toStrictVar
var
)
type
toStrictVar
::
!
SaplVar
->
SaplVar
toStrictVar
(
NormalVar
name
level
)
=
(
StrictVar
name
level
)
toStrictVar
v
=
v
instance
unpackVar
SaplVar
where
unpackVar
::
!
SaplVar
->
String
unpackVar
(
NormalVar
name
_)
=
name
unpackVar
(
StrictVar
name
_)
=
name
unpackVar
::
!
SaplVar
->
String
unpackVar
(
NormalVar
name
_)
=
name
unpackVar
(
StrictVar
name
_)
=
name
instance
unpackVar
SaplTypedVar
where
unpackVar
::
!
SaplTypedVar
->
String
unpackVar
(
TypedVar
var
_)
=
unpackVar
var
unpackBindVar
::
!
SaplLetDef
->
SaplVar
unpackBindVar
(
SaplLetDef
v
ar
_)
=
v
ar
unpackBindVar
::
!
SaplLetDef
->
Sapl
Typed
Var
unpackBindVar
(
SaplLetDef
typedV
ar
_)
=
typedV
ar
unpackConsName
::
!
SaplPattern
->
Maybe
String
unpackConsName
(
PCons
cons
_)
=
Just
cons
unpackConsName
_
=
Nothing
toStrictBind
::
!
SaplLetDef
->
SaplLetDef
toStrictBind
(
SaplLetDef
var
body
)
=
SaplLetDef
(
toStrictVar
var
)
body
toStrictBind
(
SaplLetDef
(
TypedVar
var
type
)
body
)
=
SaplLetDef
(
TypedVar
(
toStrictVar
var
)
type
)
body
isConsPattern
::
!
SaplPattern
->
Bool
isConsPattern
(
PCons
_
_)
=
True
...
...
src/Sapl/Target/JS/CodeGeneratorJS.icl
View file @
42d02357
...
...
@@ -18,13 +18,13 @@ import Sapl.Transform.AddSelectors
from
Data
.
List
import
elem_by
,
partition
::
CoderState
=
{
cs_inbody
::
!
Maybe
SaplVar
// The body of the function which is being generated (not signature)
,
cs_intrfunc
::
!
Maybe
SaplVar
// The name of the currently generated function if it is tail recursive
,
cs_futuredefs
::
![
SaplVar
]
// for finding out about let-rec and let bindings defined later
::
CoderState
=
{
cs_inbody
::
!
Maybe
Sapl
Typed
Var
// The body of the function which is being generated (not signature)
,
cs_intrfunc
::
!
Maybe
Sapl
Typed
Var
// The name of the currently generated function if it is tail recursive
,
cs_futuredefs
::
![
Sapl
Typed
Var
]
// for finding out about let-rec and let bindings defined later
,
cs_incaseexpr
::
!
Bool
,
cs_current_vars
::
![
SaplVar
]
// Strict, Normal
,
cs_current_vars
::
![
Sapl
Typed
Var
]
,
cs_constructors
::
!
Map
String
ConstructorDef
,
cs_functions
::
!
Map
String
[
SaplVar
]
,
cs_functions
::
!
Map
String
[
Sapl
Typed
Var
]
,
cs_CAFs
::
!
Map
String
Void
,
cs_builtins
::
!
Map
String
(
String
,
Int
)
,
cs_inlinefuncs
::
!
Map
String
InlineFunDef
...
...
@@ -55,7 +55,7 @@ inline (SSelect _ _) = False
inline
(
SIf
_
_
_)
=
False
inline
_
=
True
pushArgs
::
!
CoderState
![
SaplVar
]
->
CoderState
pushArgs
::
!
CoderState
![
Sapl
Typed
Var
]
->
CoderState
pushArgs
s
[
t
:
ts
]
=
pushArgs
{
s
&
cs_current_vars
=
[
t
:
s
.
cs_current_vars
]}
ts
pushArgs
s
[]
=
s
...
...
@@ -105,7 +105,7 @@ callWrapper t s a
=
a
<++
"return "
<++
trampolineCoder
t
s
<++
";"
=
a
<++
"return "
<++
forceTermCoder
t
s
<++
";"
isTailRecursive
::
!
SaplVar
!
SaplTerm
->
Bool
isTailRecursive
::
!
Sapl
Typed
Var
!
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
...
...
@@ -122,7 +122,7 @@ funcCoder (FTRecord name args) s a
=
a
<++
termCoder
name
s
<++
".$f=["
<++
recordFieldCoder
args
<++
"];"
// Only real constants can be safely encoded as a simple variable...
encodeCAF
::
!
SaplVar
!
SaplTerm
!
CoderState
!
StringAppender
->
StringAppender
encodeCAF
::
!
Sapl
Typed
Var
!
SaplTerm
!
CoderState
!
StringAppender
->
StringAppender
encodeCAF
name
body
=:(
SLit
_)
s
a
#
a
=
a
<++
"var "
<++
termCoder
name
s
<++
" = "
...
...
@@ -148,7 +148,7 @@ encodeCAF name body s a
=
a
<++
"},[]];"
;
normalFunc
::
!
SaplVar
!
SaplTerm
![
SaplVar
]
!
CoderState
!
StringAppender
->
StringAppender
normalFunc
::
!
Sapl
Typed
Var
!
SaplTerm
![
Sapl
Typed
Var
]
!
CoderState
!
StringAppender
->
StringAppender
normalFunc
name
body
args
s
a
// Generate $eval function if any of its arguments is annotated as strict
#
a
=
if
(
any
isStrictVar
args
)
...
...
@@ -157,7 +157,7 @@ normalFunc name body args s a
// Generate function signature
#
a
=
a
<++
"function "
<++
termCoder
name
s
<++
"("
<++
termArrayCoder
args
","
s
<++
"){"
// Update coder state with the new local arguments, ...
#
s
=
{
s
&
cs_inbody
=
Just
name
,
cs_current_vars
=
args
...
...
@@ -191,7 +191,7 @@ make_app_args func args s a
=
a
<++
maa_
[]
args
0
s
where
// fargs: formal, aargs: actual
maa_
[(
StrictVar
_
_):
fargs
]
[
aa
:
aargs
]
i
s
a
maa_
[
TypedVar
(
StrictVar
_
_)
_
:
fargs
]
[
aa
:
aargs
]
i
s
a
#
a
=
if
(
i
>
0
)
(
a
<++
","
)
a
=
a
<++
forceTermCoder
aa
s
<++
maa_
fargs
aargs
(
i
+1
)
s
maa_
[_:
fargs
]
[
aa
:
aargs
]
i
s
a
...
...
@@ -202,9 +202,9 @@ where
=
a
<++
termCoder
aa
s
<++
maa_
[]
aargs
(
i
+1
)
s
maa_
_
[]
_
_
a
=
a
recordFieldCoder
::
![
SaplVar
]
!
StringAppender
->
StringAppender
recordFieldCoder
[
t
]
a
=
a
<++
"
\"
"
<++
unpackVar
t
<++
"
\"
"
recordFieldCoder
[
t
:
ts
]
a
recordFieldCoder
::
![
Sapl
Typed
Var
]
!
StringAppender
->
StringAppender
recordFieldCoder
[
TypedVar
t
_
]
a
=
a
<++
"
\"
"
<++
unpackVar
t
<++
"
\"
"
recordFieldCoder
[
TypedVar
t
_
:
ts
]
a
=
a
<++
"
\"
"
<++
unpackVar
t
<++
"
\"
,"
<++
recordFieldCoder
ts
recordFieldCoder
[]
a
=
a
...
...
@@ -226,7 +226,7 @@ where
//----------------------------------------------------------------------------------------
// Data constructor...
constructorCoder
::
!
SaplVar
!
Int
![
SaplVar
]
CoderState
!
StringAppender
->
StringAppender
constructorCoder
::
!
SaplVar
!
Int
![
Sapl
Typed
Var
]
CoderState
!
StringAppender
->
StringAppender
// A zero argument data constructor is a CAF
constructorCoder
name
id
[]
s
a
...
...
@@ -261,11 +261,11 @@ constructorInliner name def args s a
=
a
<++
"]"
where
// Formal arguments, actual arguments
argsCoder
[
NormalVar
_
_]
[
t
]
sep
s
a
=
termCoder
t
s
a
argsCoder
[
StrictVar
_
_]
[
t
]
sep
s
a
=
forceTermCoder
t
s
a
argsCoder
[
NormalVar
_
_:
fs
]
[
t
:
ts
]
sep
s
a
argsCoder
[
TypedVar
(
NormalVar
_
_)
_]
[
t
]
sep
s
a
=
termCoder
t
s
a
argsCoder
[
TypedVar
(
StrictVar
_
_)
_]
[
t
]
sep
s
a
=
forceTermCoder
t
s
a
argsCoder
[
TypedVar
(
NormalVar
_
_)
_:
fs
]
[
t
:
ts
]
sep
s
a
=
a
<++
termCoder
t
s
<++
sep
<++
argsCoder
fs
ts
sep
s
argsCoder
[
StrictVar
_
_:
fs
]
[
t
:
ts
]
sep
s
a
argsCoder
[
TypedVar
(
StrictVar
_
_)
_:
fs
]
[
t
:
ts
]
sep
s
a
=
a
<++
forceTermCoder
t
s
<++
sep
<++
argsCoder
fs
ts
sep
s
argsCoder
[]
[]
_
s
a
=
a
...
...
@@ -352,8 +352,8 @@ where
get_cons
=
get_cons_or_die
s
cons
annotate
(
StrictVar
_
_,
arg
)
=
toStrictVar
arg
annotate
(
_,
arg
)
=
arg
annotate
(
TypedVar
(
StrictVar
_
_
)
type
,
arg
)
=
TypedVar
(
toStrictVar
arg
)
type
annotate
(
TypedVar
_
type
,
arg
)
=
TypedVar
arg
type
forceTermCoder
t
s
a
=
termCoder
t
s
a
trampolineCoder
t
s
a
=
termCoder
t
s
a
...
...
@@ -361,6 +361,12 @@ where
//----------------------------------------------------------------------------------------
// Variables...
instance
TermCoder
SaplTypedVar
where
forceTermCoder
var
s
a
=
forceTermCoder
(
removeTypeInfo
var
)
s
a
trampolineCoder
var
s
a
=
trampolineCoder
(
removeTypeInfo
var
)
s
a
termCoder
var
s
a
=
termCoder
(
removeTypeInfo
var
)
s
a
instance
TermCoder
SaplVar
where
forceTermCoder
t
=:(
NormalVar
name
level
)
s
a
...
...
@@ -410,7 +416,7 @@ where
=
a
<++
escapeName
s
.
cs_prefix
name
<++
"$eval"
// else (TODO: probably bogus in tail-recursion...)
|
any
(
eqVarByNameLevel
t
)
s
.
cs_futuredefs
|
any
(
eqVarByNameLevel
t
)
(
map
removeTypeInfo
s
.
cs_futuredefs
)
=
a
<++
"[function(){return "
<++
force
var_name
<++
";},[]]"
// else: use the defined name if its a built-in function, otherwise its a variable...
...
...
@@ -424,10 +430,10 @@ where
mbCAF
=
'
DM
'.
get
name
s
.
cs_CAFs
// TODO: doc
findLocalVar
[(
NormalVar
cn
level
):
cs
]
=
if
(
cn
==
name
)
level
(
findLocalVar
cs
)
findLocalVar
[(
StrictVar
cn
level
):
cs
]
=
if
(
cn
==
name
)
level
(
findLocalVar
cs
)
findLocalVar
[
TypedVar
(
NormalVar
cn
level
)
_
:
cs
]
=
if
(
cn
==
name
)
level
(
findLocalVar
cs
)
findLocalVar
[
TypedVar
(
StrictVar
cn
level
)
_
:
cs
]
=
if
(
cn
==
name
)
level
(
findLocalVar
cs
)
findLocalVar
[]
=
0
isLocalVar
=
elem_by
eqVarByName
t
s
.
cs_current_vars
//isMember t s.cs_current_vars
isLocalVar
=
elem_by
eqVarByName
t
(
map
removeTypeInfo
s
.
cs_current_vars
)
//isMember t s.cs_current_vars
isFunction
=
isJust
('
DM
'.
get
t
s
.
cs_functions
)
isStrictFunction
=
a
||
b
...
...
@@ -543,7 +549,7 @@ where
=
a
<++
"var "
<++
mta_1
tr_function_args
args
0
s
<++
";"
<++
mta_2
tr_function_args
0
s
<++
"continue;"
where
mta_1
[(
StrictVar
_
_):
fargs
]
[
aa
:
aargs
]
i
s
a
mta_1
[
TypedVar
(
StrictVar
_
_)
_
:
fargs
]
[
aa
:
aargs
]
i
s
a
#
a
=
if
(
i
>
0
)
(
a
<++
","
)
a
=
a
<++
"t"
<++
i
<++
"="
<++
forceTermCoder
aa
s
<++
mta_1
fargs
aargs
(
i
+1
)
s
mta_1
[_:
fargs
]
[
aa
:
aargs
]
i
s
a
...
...
@@ -701,7 +707,7 @@ exprGenerateJS f tramp saplsrc mbPst out
=
case
parseExpr
pts
of
Ok
(
body
,
s
)
#
newpst
=
mergeParserStates
s
mbPst
#
state
=
newState
f
tramp
newpst
#
a
=
termCoder
body
{
state
&
cs_inbody
=
Just
(
NormalVar
"__dummy"
0
)}
newAppender
#
a
=
termCoder
body
{
state
&
cs_inbody
=
Just
(
TypedVar
(
NormalVar
"__dummy"
0
)
NoType
)
}
newAppender
#
out
=
foldl
(\
a
curr
=
a
<++
funcCoder
curr
state
)
out
s
.
ps_genFuns
=
Ok
(
toString
a
,
out
,
newpst
)
Error
msg
=
Error
msg
...
...
src/Sapl/Transform/Let.icl
View file @
42d02357
...
...
@@ -17,7 +17,7 @@ where
// Generate the graph: edges and the start nodes (independent nodes)
genGraph
::
!(
Set
SaplVar
)
![
SaplLetDef
]
->
(!
Set
(
SaplVar
,
SaplVar
),
!
Set
SaplVar
)
genGraph
binds
defs
=
foldl
(\
s
(
SaplLetDef
bv
body
)
->
gen
binds
bv
s
body
)
('
Data
.
Set
'.
newSet
,
binds
)
defs
genGraph
binds
defs
=
foldl
(\
s
(
SaplLetDef
(
TypedVar
bv
_)
body
)
->
gen
binds
bv
s
body
)
('
Data
.
Set
'.
newSet
,
binds
)
defs
where
gen
vs
bv
s
(
SApplication
f
as
)
=
foldl
(
gen
vs
bv
)
s
[
SVar
f
:
as
]
gen
vs
bv
(
es
,
is
)
(
SVar
v
)
...
...
@@ -34,8 +34,8 @@ sortBindings defs
=
Nothing
// cycle is detected
where
(
edges
,
startnodes
)
=
genGraph
binds
defs
binds
=
'
Data
.
Set
'.
fromList
(
map
(
toNormalVar
o
unpackBindVar
)
defs
)
defmap
=
'
Data
.
Map
'.
fromList
(
map
(\
d
=:(
SaplLetDef
bv
body
)
->
(
bv
,
d
))
defs
)
binds
=
'
Data
.
Set
'.
fromList
(
map
(
removeTypeInfo
o
toNormalVar
o
unpackBindVar
)
defs
)
defmap
=
'
Data
.
Map
'.
fromList
(
map
(\
d
=:(
SaplLetDef
bv
body
)
->
(
removeTypeInfo
bv
,
d
))
defs
)
// Returns the renaming edges (if any) and the ordered list of bind vars (reversed order)
gen
edges
[]
=
(
edges
,
[])
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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