Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry
curry-frontend
Commits
ab75f16d
Commit
ab75f16d
authored
May 30, 2014
by
Björn Peemöller
Browse files
Added language extension NegativeLiterals
parent
6367e2f3
Changes
7
Hide whitespace changes
Inline
Side-by-side
CHANGELOG.md
View file @
ab75f16d
...
...
@@ -4,6 +4,10 @@ Change log for curry-frontend
Under development
=================
*
Added syntax extension
`NegativeLiterals`
to translate negated literals
into negative literals instead of a call to
`Prelude.negate`
and
`Prelude.negateFloat`
, respectively.
*
The frontend now considers options pragmas of the following form:
~~~ {.curry}
...
...
src/Checks.hs
View file @
ab75f16d
...
...
@@ -54,9 +54,10 @@ kindCheck _ env (Module ps m es is ds)
-- * Environment: remains unchanged
syntaxCheck
::
Monad
m
=>
Check
m
Module
syntaxCheck
opts
env
mdl
|
null
msgs
=
right
(
env
,
mdl'
)
|
null
msgs
=
right
(
env
{
extensions
=
exts
}
,
mdl'
)
|
otherwise
=
left
msgs
where
(
mdl'
,
msgs
)
=
SC
.
syntaxCheck
opts
(
valueEnv
env
)
(
tyConsEnv
env
)
mdl
where
((
mdl'
,
exts
),
msgs
)
=
SC
.
syntaxCheck
opts
(
valueEnv
env
)
(
tyConsEnv
env
)
mdl
-- |Check the precedences of infix operators.
--
...
...
src/Checks/SyntaxCheck.lhs
View file @
ab75f16d
...
...
@@ -56,15 +56,17 @@ generated. Finally, all declarations are checked within the resulting
environment. In addition, this process will also rename the local variables.
\begin{verbatim}
>
syntaxCheck
::
Options
->
ValueEnv
->
TCEnv
->
Module
->
(
Module
,
[
Message
])
>
syntaxCheck
::
Options
->
ValueEnv
->
TCEnv
->
Module
>
->
((
Module
,
[
KnownExtension
]),
[
Message
])
>
syntaxCheck
opts
tyEnv
tcEnv
mdl
@
(
Module
_
m
_
_
ds
)
=
>
case
findMultiples
$
concatMap
constrs
typeDecls
of
>
[]
->
runSC
(
checkModule
mdl
)
state
>
css
->
(
mdl
,
map
errMultipleDataConstructor
css
)
>
css
->
(
(
mdl
,
exts
),
map
errMultipleDataConstructor
css
)
>
where
>
typeDecls
=
filter
isTypeDecl
ds
>
rEnv
=
globalEnv
$
fmap
(
renameInfo
tcEnv
)
tyEnv
>
state
=
initState
(
optExtensions
opts
)
m
rEnv
>
state
=
initState
exts
m
rEnv
>
exts
=
optExtensions
opts
\end{verbatim}
A global state transformer is used for generating fresh integer keys with
...
...
@@ -108,6 +110,10 @@ renaming literals and underscore to disambiguate them.
>
enableExtension
::
KnownExtension
->
SCM
()
>
enableExtension
e
=
S
.
modify
$
\
s
->
s
{
extensions
=
e
:
extensions
s
}
>
-- |Retrieve all enabled extensions
>
getExtensions
::
SCM
[
KnownExtension
]
>
getExtensions
=
S
.
gets
extensions
>
-- |Retrieve the 'ModuleIdent' of the current module
>
getModuleIdent
::
SCM
ModuleIdent
>
getModuleIdent
=
S
.
gets
moduleIdent
...
...
@@ -315,12 +321,13 @@ a goal. Note that all declarations in the goal must be considered as
local declarations.
\begin{verbatim}
>
checkModule
::
Module
->
SCM
Module
>
checkModule
::
Module
->
SCM
(
Module
,
[
KnownExtension
])
>
checkModule
(
Module
ps
m
es
is
decls
)
=
do
>
mapM_
checkPragma
ps
>
mapM_
bindTypeDecl
(
rds
++
dds
)
>
decls'
<-
liftM2
(
++
)
(
mapM
checkTypeDecl
tds
)
(
checkTopDecls
vds
)
>
return
$
Module
ps
m
es
is
decls'
>
exts
<-
getExtensions
>
return
(
Module
ps
m
es
is
decls'
,
exts
)
>
where
(
tds
,
vds
)
=
partition
isTypeDecl
decls
>
(
rds
,
dds
)
=
partition
isRecordDecl
tds
...
...
src/CompilerOpts.hs
View file @
ab75f16d
...
...
@@ -225,6 +225,8 @@ extensions =
,
"enable anonymous free variables"
)
,
(
FunctionalPatterns
,
"FunctionalPatterns"
,
"enable functional patterns"
)
,
(
NegativeLiterals
,
"NegativeLiterals"
,
"desugar negated literals as negative literal"
)
,
(
NoImplicitPrelude
,
"NoImplicitPrelude"
,
"do not implicitly import the Prelude"
)
,
(
Records
,
"Records"
...
...
src/Transformations.hs
View file @
ab75f16d
...
...
@@ -48,7 +48,8 @@ transType = IL.transType
-- |Remove syntactic sugar
desugar
::
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
desugar
mdl
env
=
(
mdl'
,
env
{
valueEnv
=
tyEnv'
})
where
(
mdl'
,
tyEnv'
)
=
DS
.
desugar
(
valueEnv
env
)
(
tyConsEnv
env
)
mdl
where
(
mdl'
,
tyEnv'
)
=
DS
.
desugar
(
extensions
env
)
(
valueEnv
env
)
(
tyConsEnv
env
)
mdl
-- |Lift local declarations
lift
::
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
...
...
src/Transformations/Desugar.lhs
View file @
ab75f16d
...
...
@@ -99,8 +99,9 @@ variables.
\begin{verbatim}
>
data
DesugarState
=
DesugarState
>
{
moduleIdent
::
ModuleIdent
-- read-only
>
,
tyConsEnv
::
TCEnv
-- read-only
>
{
moduleIdent
::
ModuleIdent
-- read-only
>
,
extensions
::
[
KnownExtension
]
-- read-only
>
,
tyConsEnv
::
TCEnv
-- read-only
>
,
valueEnv
::
ValueEnv
>
,
nextId
::
Integer
-- counter
>
}
...
...
@@ -110,6 +111,9 @@ variables.
>
getModuleIdent
::
DsM
ModuleIdent
>
getModuleIdent
=
S
.
gets
moduleIdent
>
negativeLiterals
::
DsM
Bool
>
negativeLiterals
=
S
.
gets
(
\
s
->
NegativeLiterals
`
elem
`
extensions
s
)
>
getTyConsEnv
::
DsM
TCEnv
>
getTyConsEnv
=
S
.
gets
tyConsEnv
...
...
@@ -159,10 +163,12 @@ Actually, the transformation is slightly more general than necessary
as it allows value declarations at the top-level of a module.
\begin{verbatim}
>
desugar
::
ValueEnv
->
TCEnv
->
Module
->
(
Module
,
ValueEnv
)
>
desugar
tyEnv
tcEnv
(
Module
ps
m
es
is
ds
)
=
(
Module
ps
m
es
is
ds'
,
valueEnv
s'
)
>
desugar
::
[
KnownExtension
]
->
ValueEnv
->
TCEnv
->
Module
>
->
(
Module
,
ValueEnv
)
>
desugar
xs
tyEnv
tcEnv
(
Module
ps
m
es
is
ds
)
>
=
(
Module
ps
m
es
is
ds'
,
valueEnv
s'
)
>
where
(
ds'
,
s'
)
=
S
.
runState
(
desugarModuleDecls
ds
)
>
(
DesugarState
m
tcEnv
tyEnv
1
)
>
(
DesugarState
m
xs
tcEnv
tyEnv
1
)
>
desugarModuleDecls
::
[
Decl
]
->
DsM
[
Decl
]
>
desugarModuleDecls
ds
=
do
...
...
@@ -454,7 +460,11 @@ type \texttt{Bool} of the guard because the guard's type defaults to
>
apply
prelEnumFromThenTo
`
liftM
`
mapM
(
dsExpr
p
)
[
e1
,
e2
,
e3
]
>
dsExpr
p
(
UnaryMinus
op
e
)
=
do
>
ty
<-
getTypeOf
e
>
Apply
(
unaryMinus
op
ty
)
`
liftM
`
dsExpr
p
e
>
e'
<-
dsExpr
p
e
>
negativeLits
<-
negativeLiterals
>
case
e'
of
>
Literal
l
|
negativeLits
->
return
(
Literal
$
negateLiteral
l
)
>
_
->
Apply
(
unaryMinus
op
ty
)
`
liftM
`
dsExpr
p
e
>
where
>
unaryMinus
op1
ty'
>
|
op1
==
minusId
=
if
ty'
==
floatType
then
prelNegateFloat
else
prelNegate
...
...
test/NegLit.curry
0 → 100644
View file @
ab75f16d
{-# LANGUAGE NegativeLiterals #-}
module NegLit where
f (-1) = -2354843759837495739457394
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