Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
curry
curry-frontend
Commits
27ac926d
Commit
27ac926d
authored
Aug 07, 2014
by
Jan Rasmus Tikovsky
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Declaration of operator precedences is now optional
parent
c56da5ff
Changes
9
Hide whitespace changes
Inline
Side-by-side
Showing
9 changed files
with
45 additions
and
21 deletions
+45
-21
CHANGELOG.md
CHANGELOG.md
+3
-0
src/Checks/InterfaceCheck.hs
src/Checks/InterfaceCheck.hs
+1
-1
src/Checks/PrecCheck.hs
src/Checks/PrecCheck.hs
+4
-4
src/Checks/SyntaxCheck.hs
src/Checks/SyntaxCheck.hs
+4
-3
src/Env/OpPrec.hs
src/Env/OpPrec.hs
+21
-4
src/Exports.hs
src/Exports.hs
+1
-1
src/Generators/GenAbstractCurry.hs
src/Generators/GenAbstractCurry.hs
+3
-2
src/Generators/GenFlatCurry.hs
src/Generators/GenFlatCurry.hs
+5
-4
src/Imports.hs
src/Imports.hs
+3
-2
No files found.
CHANGELOG.md
View file @
27ac926d
...
@@ -4,6 +4,9 @@ Change log for curry-frontend
...
@@ -4,6 +4,9 @@ Change log for curry-frontend
Under development
Under development
=================
=================
*
Declaration of operator precedence is now optional in infix operator
declarations
*
Moved module
`InterfaceEquivalence`
to curry-base
*
Moved module
`InterfaceEquivalence`
to curry-base
(
`Curry.Syntax.InterfaceEquivalence`
)
(
`Curry.Syntax.InterfaceEquivalence`
)
...
...
src/Checks/InterfaceCheck.hs
View file @
27ac926d
...
@@ -99,7 +99,7 @@ interfaceCheck pEnv tcEnv tyEnv (Interface m _ ds) = reverse (errors s)
...
@@ -99,7 +99,7 @@ interfaceCheck pEnv tcEnv tyEnv (Interface m _ ds) = reverse (errors s)
checkImport
::
IDecl
->
IC
()
checkImport
::
IDecl
->
IC
()
checkImport
(
IInfixDecl
p
fix
pr
op
)
=
checkPrecInfo
check
p
op
checkImport
(
IInfixDecl
p
fix
pr
op
)
=
checkPrecInfo
check
p
op
where
check
(
PrecInfo
op'
(
OpPrec
fix'
pr'
))
=
where
check
(
PrecInfo
op'
(
OpPrec
fix'
pr'
))
=
op
==
op'
&&
fix
==
fix'
&&
pr
==
pr'
op
==
op'
&&
fix
==
fix'
&&
(
mkPrec
pr
)
==
pr'
checkImport
(
HidingDataDecl
p
tc
tvs
)
checkImport
(
HidingDataDecl
p
tc
tvs
)
=
checkTypeInfo
"hidden data type"
check
p
tc
=
checkTypeInfo
"hidden data type"
check
p
tc
where
check
(
DataType
tc'
n'
_
)
where
check
(
DataType
tc'
n'
_
)
...
...
src/Checks/PrecCheck.hs
View file @
27ac926d
...
@@ -34,7 +34,7 @@ import Base.Messages (Message, posMessage)
...
@@ -34,7 +34,7 @@ import Base.Messages (Message, posMessage)
import
Base.Utils
(
findDouble
)
import
Base.Utils
(
findDouble
)
import
Env.OpPrec
(
OpPrecEnv
,
OpPrec
(
..
),
PrecInfo
(
..
),
defaultP
,
bindP
import
Env.OpPrec
(
OpPrecEnv
,
OpPrec
(
..
),
PrecInfo
(
..
),
defaultP
,
bindP
,
qualLookupP
)
,
mkPrec
,
qualLookupP
)
precCheck
::
ModuleIdent
->
OpPrecEnv
->
[
Decl
]
->
([
Decl
],
OpPrecEnv
,
[
Message
])
precCheck
::
ModuleIdent
->
OpPrecEnv
->
[
Decl
]
->
([
Decl
],
OpPrecEnv
,
[
Message
])
precCheck
m
pEnv
decls
=
runPCM
(
checkDecls
decls
)
initState
precCheck
m
pEnv
decls
=
runPCM
(
checkDecls
decls
)
initState
...
@@ -91,11 +91,11 @@ bindPrecs ds = case findDouble opFixDecls of
...
@@ -91,11 +91,11 @@ bindPrecs ds = case findDouble opFixDecls of
bvs
=
concatMap
boundValues
nonFixDs
bvs
=
concatMap
boundValues
nonFixDs
bindPrec
::
ModuleIdent
->
Decl
->
OpPrecEnv
->
OpPrecEnv
bindPrec
::
ModuleIdent
->
Decl
->
OpPrecEnv
->
OpPrecEnv
bindPrec
m
(
InfixDecl
_
fix
prc
ops
)
pEnv
bindPrec
m
(
InfixDecl
_
fix
m
pr
e
c
ops
)
pEnv
|
p
==
defaultP
=
pEnv
|
p
==
defaultP
=
pEnv
|
otherwise
=
foldr
(
flip
(
bindP
m
)
p
)
pEnv
ops
|
otherwise
=
foldr
(
flip
(
bindP
m
)
p
)
pEnv
ops
where
p
=
OpPrec
fix
prc
where
p
=
OpPrec
fix
(
mkPrec
mprec
)
bindPrec
_
_
pEnv
=
pEnv
bindPrec
_
_
pEnv
=
pEnv
boundValues
::
Decl
->
[
Ident
]
boundValues
::
Decl
->
[
Ident
]
boundValues
(
DataDecl
_
_
_
cs
)
=
map
constr
cs
boundValues
(
DataDecl
_
_
_
cs
)
=
map
constr
cs
...
...
src/Checks/SyntaxCheck.hs
View file @
27ac926d
...
@@ -382,10 +382,11 @@ checkDeclLhs (FreeDecl p vs) =
...
@@ -382,10 +382,11 @@ checkDeclLhs (FreeDecl p vs) =
FreeDecl
p
`
liftM
`
mapM
(
checkVar
"free variables declaration"
)
vs
FreeDecl
p
`
liftM
`
mapM
(
checkVar
"free variables declaration"
)
vs
checkDeclLhs
d
=
return
d
checkDeclLhs
d
=
return
d
checkPrecedence
::
Position
->
Integer
->
SCM
Integer
checkPrecedence
::
Position
->
Maybe
Precedence
->
SCM
(
Maybe
Precedence
)
checkPrecedence
p
i
=
do
checkPrecedence
_
Nothing
=
return
Nothing
checkPrecedence
p
(
Just
i
)
=
do
unless
(
0
<=
i
&&
i
<=
9
)
$
report
$
errPrecedenceOutOfRange
p
i
unless
(
0
<=
i
&&
i
<=
9
)
$
report
$
errPrecedenceOutOfRange
p
i
return
i
return
$
Just
i
checkVar
::
String
->
Ident
->
SCM
Ident
checkVar
::
String
->
Ident
->
SCM
Ident
checkVar
_what
v
=
do
checkVar
_what
v
=
do
...
...
src/Env/OpPrec.hs
View file @
27ac926d
...
@@ -24,7 +24,7 @@
...
@@ -24,7 +24,7 @@
introduction of unlimited integer constants in the parser / lexer.
introduction of unlimited integer constants in the parser / lexer.
-}
-}
module
Env.OpPrec
module
Env.OpPrec
(
OpPrec
(
..
),
defaultP
(
OpPrec
(
..
),
defaultP
,
defaultAssoc
,
defaultPrecedence
,
mkPrec
,
OpPrecEnv
,
PrecInfo
(
..
),
bindP
,
lookupP
,
qualLookupP
,
initOpPrecEnv
,
OpPrecEnv
,
PrecInfo
(
..
),
bindP
,
lookupP
,
qualLookupP
,
initOpPrecEnv
)
where
)
where
...
@@ -33,18 +33,35 @@ import Curry.Syntax (Infix (..))
...
@@ -33,18 +33,35 @@ import Curry.Syntax (Infix (..))
import
Base.TopEnv
import
Base.TopEnv
import
Data.Maybe
(
fromMaybe
)
-- |Operator precedence.
-- |Operator precedence.
data
OpPrec
=
OpPrec
Infix
Integer
deriving
Eq
data
OpPrec
=
OpPrec
Infix
Precedence
deriving
Eq
type
Precedence
=
Integer
-- TODO: Change to real show instance and provide Pretty instance
-- if used anywhere.
instance
Show
OpPrec
where
instance
Show
OpPrec
where
showsPrec
_
(
OpPrec
fix
p
)
=
showString
(
assoc
fix
)
.
shows
p
showsPrec
_
(
OpPrec
fix
p
)
=
showString
(
assoc
fix
)
.
shows
p
where
assoc
InfixL
=
"left "
where
assoc
InfixL
=
"left "
assoc
InfixR
=
"right "
assoc
InfixR
=
"right "
assoc
Infix
=
"non-assoc "
assoc
Infix
=
"non-assoc "
-- |Default operator precedence.
-- |Default operator
declaration (associativity and
precedence
)
.
defaultP
::
OpPrec
defaultP
::
OpPrec
defaultP
=
OpPrec
InfixL
9
defaultP
=
OpPrec
defaultAssoc
defaultPrecedence
-- |Default operator associativity.
defaultAssoc
::
Infix
defaultAssoc
=
InfixL
-- |Default operator precedence.
defaultPrecedence
::
Precedence
defaultPrecedence
=
9
mkPrec
::
Maybe
Precedence
->
Precedence
mkPrec
mprec
=
fromMaybe
defaultPrecedence
mprec
-- |Precedence information for an identifier.
-- |Precedence information for an identifier.
data
PrecInfo
=
PrecInfo
QualIdent
OpPrec
deriving
(
Eq
,
Show
)
data
PrecInfo
=
PrecInfo
QualIdent
OpPrec
deriving
(
Eq
,
Show
)
...
...
src/Exports.hs
View file @
27ac926d
...
@@ -75,7 +75,7 @@ iInfixDecl :: ModuleIdent -> OpPrecEnv -> QualIdent -> [IDecl] -> [IDecl]
...
@@ -75,7 +75,7 @@ iInfixDecl :: ModuleIdent -> OpPrecEnv -> QualIdent -> [IDecl] -> [IDecl]
iInfixDecl
m
pEnv
op
ds
=
case
qualLookupP
op
pEnv
of
iInfixDecl
m
pEnv
op
ds
=
case
qualLookupP
op
pEnv
of
[]
->
ds
[]
->
ds
[
PrecInfo
_
(
OpPrec
fix
pr
)]
->
[
PrecInfo
_
(
OpPrec
fix
pr
)]
->
IInfixDecl
NoPos
fix
pr
(
qualUnqualify
m
op
)
:
ds
IInfixDecl
NoPos
fix
(
Just
pr
)
(
qualUnqualify
m
op
)
:
ds
_
->
internalError
"Exports.infixDecl"
_
->
internalError
"Exports.infixDecl"
typeDecl
::
ModuleIdent
->
TCEnv
->
Export
->
[
IDecl
]
->
[
IDecl
]
typeDecl
::
ModuleIdent
->
TCEnv
->
Export
->
[
IDecl
]
->
[
IDecl
]
...
...
src/Generators/GenAbstractCurry.hs
View file @
27ac926d
...
@@ -32,6 +32,7 @@ import Base.Types
...
@@ -32,6 +32,7 @@ import Base.Types
import
Env.TypeConstructor
(
TCEnv
,
lookupTC
)
import
Env.TypeConstructor
(
TCEnv
,
lookupTC
)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
import
Env.OpPrec
(
mkPrec
)
import
CompilerEnv
import
CompilerEnv
...
@@ -207,11 +208,11 @@ genTypeExpr env (RecordType fss mr) = case mr of
...
@@ -207,11 +208,11 @@ genTypeExpr env (RecordType fss mr) = case mr of
ls'
=
map
idName
ls
ls'
=
map
idName
ls
genOpDecl
::
AbstractEnv
->
Decl
->
[
COpDecl
]
genOpDecl
::
AbstractEnv
->
Decl
->
[
COpDecl
]
genOpDecl
env
(
InfixDecl
_
fix
prec
ops
)
=
map
genCOp
(
reverse
ops
)
genOpDecl
env
(
InfixDecl
_
fix
m
prec
ops
)
=
map
genCOp
(
reverse
ops
)
where
where
genCOp
op
=
COp
(
genQName
False
env
$
qualifyWith
(
moduleId
env
)
op
)
genCOp
op
=
COp
(
genQName
False
env
$
qualifyWith
(
moduleId
env
)
op
)
(
genFixity
fix
)
(
genFixity
fix
)
(
fromInteger
prec
)
(
fromInteger
(
mkPrec
m
prec
)
)
genFixity
InfixL
=
CInfixlOp
genFixity
InfixL
=
CInfixlOp
genFixity
InfixR
=
CInfixrOp
genFixity
InfixR
=
CInfixrOp
...
...
src/Generators/GenFlatCurry.hs
View file @
27ac926d
...
@@ -36,6 +36,7 @@ import Base.Types
...
@@ -36,6 +36,7 @@ import Base.Types
-- environments
-- environments
import
Env.Interface
import
Env.Interface
import
Env.TypeConstructor
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
import
Env.TypeConstructor
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
import
Env.OpPrec
(
mkPrec
)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
-- other
-- other
...
@@ -386,9 +387,9 @@ visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)
...
@@ -386,9 +387,9 @@ visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)
--
--
visitOpIDecl
::
CS
.
IDecl
->
FlatState
OpDecl
visitOpIDecl
::
CS
.
IDecl
->
FlatState
OpDecl
visitOpIDecl
(
CS
.
IInfixDecl
_
fixi
prec
op
)
=
do
visitOpIDecl
(
CS
.
IInfixDecl
_
fixi
m
prec
op
)
=
do
op'
<-
visitQualIdent
op
op'
<-
visitQualIdent
op
return
$
Op
op'
(
genFixity
fixi
)
prec
return
$
Op
op'
(
genFixity
fixi
)
(
mkPrec
m
prec
)
visitOpIDecl
_
=
internalError
"GenFlatCurry.visitOpIDecl: no pattern match"
visitOpIDecl
_
=
internalError
"GenFlatCurry.visitOpIDecl: no pattern match"
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
...
@@ -617,9 +618,9 @@ genOpDecls = fixities >>= mapM genOpDecl
...
@@ -617,9 +618,9 @@ genOpDecls = fixities >>= mapM genOpDecl
--
--
genOpDecl
::
CS
.
IDecl
->
FlatState
OpDecl
genOpDecl
::
CS
.
IDecl
->
FlatState
OpDecl
genOpDecl
(
CS
.
IInfixDecl
_
fixity
prec
qident
)
=
do
genOpDecl
(
CS
.
IInfixDecl
_
fixity
m
prec
qident
)
=
do
qname
<-
visitQualIdent
qident
qname
<-
visitQualIdent
qident
return
$
Op
qname
(
genFixity
fixity
)
prec
return
$
Op
qname
(
genFixity
fixity
)
(
mkPrec
m
prec
)
genOpDecl
_
=
internalError
"GenFlatCurry: no infix interface"
genOpDecl
_
=
internalError
"GenFlatCurry: no infix interface"
genFixity
::
CS
.
Infix
->
Fixity
genFixity
::
CS
.
Infix
->
Fixity
...
...
src/Imports.hs
View file @
27ac926d
...
@@ -168,8 +168,9 @@ intfEnv bind (Interface m _ ds) = foldr (bind m) Map.empty ds
...
@@ -168,8 +168,9 @@ intfEnv bind (Interface m _ ds) = foldr (bind m) Map.empty ds
-- operator precedences
-- operator precedences
bindPrec
::
ModuleIdent
->
IDecl
->
ExpPEnv
->
ExpPEnv
bindPrec
::
ModuleIdent
->
IDecl
->
ExpPEnv
->
ExpPEnv
bindPrec
m
(
IInfixDecl
_
fix
p
op
)
=
bindPrec
m
(
IInfixDecl
_
fix
mprec
op
)
=
Map
.
insert
(
unqualify
op
)
(
PrecInfo
(
qualQualify
m
op
)
(
OpPrec
fix
p
))
Map
.
insert
(
unqualify
op
)
(
PrecInfo
(
qualQualify
m
op
)
(
OpPrec
fix
(
mkPrec
mprec
)))
bindPrec
_
_
=
id
bindPrec
_
_
=
id
bindTCHidden
::
ModuleIdent
->
IDecl
->
ExpTCEnv
->
ExpTCEnv
bindTCHidden
::
ModuleIdent
->
IDecl
->
ExpTCEnv
->
ExpTCEnv
...
...
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