Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
curry
curry-frontend
Commits
53527adc
Commit
53527adc
authored
Mar 08, 2016
by
Björn Peemöller
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Simplified + corrected desugaring w.r.t functional + non-linear patterns
parent
1ca2ffc7
Changes
4
Show whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
50 additions
and
60 deletions
+50
-60
src/Modules.hs
src/Modules.hs
+5
-8
src/Transformations.hs
src/Transformations.hs
+4
-4
src/Transformations/Desugar.hs
src/Transformations/Desugar.hs
+39
-48
test/NonLinearLHS.curry
test/NonLinearLHS.curry
+2
-0
No files found.
src/Modules.hs
View file @
53527adc
...
...
@@ -220,13 +220,10 @@ checkModule opts mdl = do
transModule
::
Options
->
CompEnv
CS
.
Module
->
IO
(
CompEnv
IL
.
Module
)
transModule
opts
mdl
=
do
desugared
<-
dumpCS
DumpDesugared
$
desugar
False
mdl
desugared
<-
dumpCS
DumpDesugared
$
desugar
mdl
simplified
<-
dumpCS
DumpSimplified
$
simplify
desugared
lifted
<-
dumpCS
DumpLifted
$
lift
simplified
desugared2
<-
dumpCS
DumpDesugared
$
desugar
True
lifted
simplified2
<-
dumpCS
DumpSimplified
$
simplify
desugared2
lifted2
<-
dumpCS
DumpLifted
$
lift
simplified2
il
<-
dumpIL
DumpTranslated
$
ilTrans
lifted2
il
<-
dumpIL
DumpTranslated
$
ilTrans
lifted
ilCaseComp
<-
dumpIL
DumpCaseCompleted
$
completeCase
il
return
ilCaseComp
where
...
...
src/Transformations.hs
View file @
53527adc
...
...
@@ -33,9 +33,9 @@ qual (env, mdl) = (qualifyEnv env, mdl')
where
mdl'
=
Q
.
qual
(
moduleIdent
env
)
(
tyConsEnv
env
)
(
valueEnv
env
)
mdl
-- |Remove any syntactic sugar, changes the value environment.
desugar
::
Bool
->
CompEnv
Module
->
CompEnv
Module
desugar
dsfp
(
env
,
mdl
)
=
(
env
{
valueEnv
=
tyEnv'
},
mdl'
)
where
(
mdl'
,
tyEnv'
)
=
DS
.
desugar
dsfp
(
extensions
env
)
(
valueEnv
env
)
desugar
::
CompEnv
Module
->
CompEnv
Module
desugar
(
env
,
mdl
)
=
(
env
{
valueEnv
=
tyEnv'
},
mdl'
)
where
(
mdl'
,
tyEnv'
)
=
DS
.
desugar
(
extensions
env
)
(
valueEnv
env
)
(
tyConsEnv
env
)
mdl
-- |Simplify the source code, changes the value environment.
...
...
src/Transformations/Desugar.hs
View file @
53527adc
...
...
@@ -97,12 +97,11 @@ import Env.Value (ValueEnv, ValueInfo (..), bindFun, lookupValue
-- out separately. Actually, the transformation is slightly more general than
-- necessary as it allows value declarations at the top-level of a module.
desugar
::
Bool
->
[
KnownExtension
]
->
ValueEnv
->
TCEnv
->
Module
->
(
Module
,
ValueEnv
)
desugar
dsFunPats
xs
tyEnv
tcEnv
(
Module
ps
m
es
is
ds
)
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
xs
tcEnv
tyEnv
1
dsFunPats
)
(
DesugarState
m
xs
tcEnv
tyEnv
1
)
-- ---------------------------------------------------------------------------
-- Desugaring monad and accessor functions
...
...
@@ -121,7 +120,6 @@ data DesugarState = DesugarState
,
tyConsEnv
::
TCEnv
-- read-only
,
valueEnv
::
ValueEnv
-- will be extended
,
nextId
::
Integer
-- counter
,
desugarFP
::
Bool
-- flat if to desugar functional patterns
}
type
DsM
a
=
S
.
State
DesugarState
a
...
...
@@ -141,9 +139,6 @@ getValueEnv = S.gets valueEnv
modifyValueEnv
::
(
ValueEnv
->
ValueEnv
)
->
DsM
()
modifyValueEnv
f
=
S
.
modify
$
\
s
->
s
{
valueEnv
=
f
$
valueEnv
s
}
desugarFunPats
::
DsM
Bool
desugarFunPats
=
S
.
gets
desugarFP
getNextId
::
DsM
Integer
getNextId
=
do
nid
<-
S
.
gets
nextId
...
...
@@ -299,20 +294,19 @@ dsDeclRhs _ = error "Desugar.dsDeclRhs: no pattern match"
-- Desugaring of an equation
dsEquation
::
Equation
->
DsM
Equation
dsEquation
(
Equation
p
lhs
rhs
)
=
do
funpats
<-
desugarFunPats
(
ds1
,
cs
,
ts1
)
<-
if
funpats
then
do
(
cs1
,
ts1
)
<-
dsNonLinearity
ts
(
ds2
,
cs2
,
ts2
)
<-
dsFunctionalPatterns
p
ts1
return
(
ds2
,
cs2
++
cs1
,
ts2
)
else
return
(
[]
,
[]
,
ts
)
(
ds2
,
ts2
)
<-
mapAccumM
(
dsPat
p
)
[]
ts1
rhs'
<-
dsRhs
p
(
addConstraints
cs
)
$
addDecls
(
ds1
++
ds2
)
$
rhs
return
$
Equation
p
(
FunLhs
f
ts2
)
rhs'
(
ds1
,
cs2
,
ts2
)
<-
dsFunctionalPatterns
p
ts1
(
ds2
,
ts3
)
<-
mapAccumM
(
dsPat
p
)
[]
ts2
rhs'
<-
dsRhs
p
(
constrain
cs2
.
constrain
cs1
)
(
addDecls
(
ds1
++
ds2
)
rhs
)
return
$
Equation
p
(
FunLhs
f
ts3
)
rhs'
where
(
f
,
ts
)
=
flatLhs
lhs
addConstraints
::
[
Expression
]
->
Expression
->
Expression
addConstraints
cs
e
|
null
cs
=
e
|
otherwise
=
apply
prelCond
[
foldr1
(
&>
)
cs
,
e
]
-- Constrain an expression by a list of constraints.
-- @constrain [] e == e@
-- @constrain c_n e == (c_1 & ... & c_n) &> e@
constrain
::
[
Expression
]
->
Expression
->
Expression
constrain
cs
e
=
if
null
cs
then
e
else
foldr1
(
&
)
cs
&>
e
-- -----------------------------------------------------------------------------
-- Desugaring of right-hand sides
...
...
@@ -339,7 +333,7 @@ expandGuards e0 es = do
return
$
if
boolGuards
tyEnv
es
then
foldr
mkIfThenElse
e0
es
else
mkCond
es
where
mkIfThenElse
(
CondExpr
p
g
e
)
=
IfThenElse
(
srcRefOf
p
)
g
e
mkCond
[
CondExpr
_
g
e
]
=
apply
prelCond
[
g
,
e
]
mkCond
[
CondExpr
_
g
e
]
=
g
&>
e
mkCond
_
=
error
"Desugar.expandGuards.mkCond: non-unary list"
boolGuards
::
ValueEnv
->
[
CondExpr
]
->
Bool
...
...
@@ -895,6 +889,15 @@ negateLiteral _ = internalError "Desugar.negateLiteral"
-- Prelude entities
-- ---------------------------------------------------------------------------
prel
::
String
->
SrcRef
->
Expression
prel
s
r
=
Variable
$
addRef
r
$
preludeIdent
s
prelude
::
String
->
Expression
prelude
=
Variable
.
preludeIdent
preludeIdent
::
String
->
QualIdent
preludeIdent
=
qualifyWith
preludeMIdent
.
mkIdent
prelBind
::
SrcRef
->
Expression
prelBind
=
prel
">>="
...
...
@@ -902,28 +905,28 @@ prelBind_ :: SrcRef -> Expression
prelBind_
=
prel
">>"
prelFlip
::
Expression
prelFlip
=
Variable
$
prelude
Ident
"flip"
prelFlip
=
prelude
"flip"
prelEnumFrom
::
Expression
prelEnumFrom
=
Variable
$
prelude
Ident
"enumFrom"
prelEnumFrom
=
prelude
"enumFrom"
prelEnumFromTo
::
Expression
prelEnumFromTo
=
Variable
$
prelude
Ident
"enumFromTo"
prelEnumFromTo
=
prelude
"enumFromTo"
prelEnumFromThen
::
Expression
prelEnumFromThen
=
Variable
$
prelude
Ident
"enumFromThen"
prelEnumFromThen
=
prelude
"enumFromThen"
prelEnumFromThenTo
::
Expression
prelEnumFromThenTo
=
Variable
$
prelude
Ident
"enumFromThenTo"
prelEnumFromThenTo
=
prelude
"enumFromThenTo"
prelFailed
::
Expression
prelFailed
=
Variable
$
prelude
Ident
"failed"
prelFailed
=
prelude
"failed"
prelUnknown
::
Expression
prelUnknown
=
Variable
$
prelude
Ident
"unknown"
prelUnknown
=
prelude
"unknown"
prelMap
::
SrcRef
->
Expression
prelMap
r
=
Variable
$
addRef
r
$
preludeIdent
"map"
prelMap
=
prel
"map"
prelFoldr
::
SrcRef
->
Expression
prelFoldr
=
prel
"foldr"
...
...
@@ -935,31 +938,22 @@ prelConcatMap :: SrcRef -> Expression
prelConcatMap
=
prel
"concatMap"
prelNegate
::
Expression
prelNegate
=
Variable
$
prelude
Ident
"negate"
prelNegate
=
prelude
"negate"
prelNegateFloat
::
Expression
prelNegateFloat
=
Variable
$
preludeIdent
"negateFloat"
prelCond
::
Expression
prelCond
=
Variable
$
preludeIdent
"cond"
prelNegateFloat
=
prelude
"negateFloat"
(
=:<=
)
::
Expression
->
Expression
->
Expression
e1
=:<=
e2
=
apply
prelFPEq
[
e1
,
e2
]
prelFPEq
::
Expression
prelFPEq
=
Variable
$
preludeIdent
"=:<="
e1
=:<=
e2
=
apply
(
prelude
"=:<="
)
[
e1
,
e2
]
(
=:=
)
::
Expression
->
Expression
->
Expression
e1
=:=
e2
=
apply
prelSEq
[
e1
,
e2
]
prelSEq
::
Expression
prelSEq
=
Variable
$
preludeIdent
"=:="
e1
=:=
e2
=
apply
(
prelude
"=:="
)
[
e1
,
e2
]
(
&>
)
::
Expression
->
Expression
->
Expression
e1
&>
e2
=
apply
prel
C
ond
[
e1
,
e2
]
e1
&>
e2
=
apply
(
prel
ude
"c
ond
"
)
[
e1
,
e2
]
prel
::
String
->
SrcRef
->
Expression
prel
s
r
=
Variable
$
addRef
r
$
preludeIdent
s
(
&
)
::
Expression
->
Expression
->
Expression
e1
&
e2
=
apply
(
prelude
"&"
)
[
e1
,
e2
]
truePat
::
Pattern
truePat
=
ConstructorPattern
qTrueId
[]
...
...
@@ -967,9 +961,6 @@ truePat = ConstructorPattern qTrueId []
falsePat
::
Pattern
falsePat
=
ConstructorPattern
qFalseId
[]
preludeIdent
::
String
->
QualIdent
preludeIdent
=
qualifyWith
preludeMIdent
.
mkIdent
-- ---------------------------------------------------------------------------
-- Auxiliary definitions
-- ---------------------------------------------------------------------------
...
...
test/NonLinearLHS.curry
View file @
53527adc
...
...
@@ -15,3 +15,5 @@ leftB a b (_ ++ [a,b] ++ _) = success
f x (_ ++ [x]) [x] | not x = x
test [x] (x ++ x) (x ++ x) x | null x = x
test2 [x] (id x) ~True | null x = x
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