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
bd1ca0d3
Commit
bd1ca0d3
authored
Sep 13, 2012
by
Björn Peemöller
Browse files
Removal of eval annotations
parent
59d66221
Changes
13
Hide whitespace changes
Inline
Side-by-side
curry-frontend.cabal
View file @
bd1ca0d3
...
...
@@ -62,7 +62,6 @@ Executable cymake
, CompilerOpts
, CurryBuilder
, CurryDeps
, Env.Eval
, Env.Interface
, Env.ModuleAlias
, Env.OpPrec
...
...
src/Base/Expr.hs
View file @
bd1ca0d3
...
...
@@ -63,7 +63,6 @@ instance QualExpr Decl where
instance
QuantExpr
Decl
where
bv
(
TypeSig
_
vs
_
)
=
vs
bv
(
EvalAnnot
_
fs
_
)
=
fs
bv
(
FunctionDecl
_
f
_
)
=
[
f
]
bv
(
ExternalDecl
_
_
_
f
_
)
=
[
f
]
bv
(
FlatExternalDecl
_
fs
)
=
fs
...
...
src/Checks/SyntaxCheck.lhs
View file @
bd1ca0d3
...
...
@@ -355,8 +355,6 @@ top-level.
>
InfixDecl
p
fix'
pr
`
liftM
`
mapM
renameVar
ops
>
checkDeclLhs
(
TypeSig
p
vs
ty
)
=
>
(
\
vs'
->
TypeSig
p
vs'
ty
)
`
liftM
`
mapM
(
checkVar
"type signature"
)
vs
>
checkDeclLhs
(
EvalAnnot
p
fs
ev
)
=
>
(
\
fs'
->
EvalAnnot
p
fs'
ev
)
`
liftM
`
mapM
(
checkVar
"evaluation annotation"
)
fs
>
checkDeclLhs
(
FunctionDecl
p
_
eqs
)
=
>
checkEquationsLhs
p
eqs
>
checkDeclLhs
(
ExternalDecl
p
cc
ie
f
ty
)
=
...
...
@@ -452,10 +450,9 @@ top-level.
>
checkDecls
::
(
Decl
->
RenameEnv
->
RenameEnv
)
->
[
Decl
]
->
SCM
[
Decl
]
>
checkDecls
bindDecl
ds
=
do
>
let
dbls
@
[
dblVar
,
dblTys
,
dblEAs
]
=
map
findDouble
[
bvs
,
tys
,
evs
]
>
let
dbls
@
[
dblVar
,
dblTys
]
=
map
findDouble
[
bvs
,
tys
]
>
onJust
(
report
.
errDuplicateDefinition
)
dblVar
>
onJust
(
report
.
errDuplicateTypeSig
)
dblTys
>
onJust
(
report
.
errDuplicateEvalAnnot
)
dblEAs
>
let
missingTy
=
[
f
|
FlatExternalDecl
_
fs'
<-
ds
,
f
<-
fs'
,
f
`
notElem
`
tys
]
>
mapM_
(
report
.
errNoTypeSig
)
missingTy
>
if
all
isNothing
dbls
&&
null
missingTy
...
...
@@ -467,7 +464,6 @@ top-level.
>
tds
=
filter
isTypeSig
ds
>
bvs
=
concatMap
vars
vds
>
tys
=
concatMap
vars
tds
>
evs
=
concatMap
vars
$
filter
isEvalAnnot
ds
>
onJust
=
maybe
(
return
()
)
-- ---------------------------------------------------------------------------
...
...
@@ -475,8 +471,6 @@ top-level.
>
checkDeclRhs
::
[
Ident
]
->
Decl
->
SCM
Decl
>
checkDeclRhs
bvs
(
TypeSig
p
vs
ty
)
=
>
(
\
vs'
->
TypeSig
p
vs'
ty
)
`
liftM
`
mapM
(
checkLocalVar
bvs
)
vs
>
checkDeclRhs
bvs
(
EvalAnnot
p
vs
ev
)
=
>
(
\
vs'
->
EvalAnnot
p
vs'
ev
)
`
liftM
`
mapM
(
checkLocalVar
bvs
)
vs
>
checkDeclRhs
_
(
FunctionDecl
p
f
eqs
)
=
>
FunctionDecl
p
f
`
liftM
`
mapM
checkEquation
eqs
>
checkDeclRhs
_
(
PatternDecl
p
t
rhs
)
=
...
...
@@ -857,7 +851,6 @@ Auxiliary definitions.
>
vars
::
Decl
->
[
Ident
]
>
vars
(
TypeSig
_
fs
_
)
=
fs
>
vars
(
EvalAnnot
_
fs
_
)
=
fs
>
vars
(
FunctionDecl
_
f
_
)
=
[
f
]
>
vars
(
ExternalDecl
_
_
_
f
_
)
=
[
f
]
>
vars
(
FlatExternalDecl
_
fs
)
=
fs
...
...
@@ -1027,10 +1020,6 @@ Error messages.
>
errDuplicateTypeSig
v
=
posMessage
v
$
hsep
$
map
text
>
[
"More than one type signature for"
,
escName
v
]
>
errDuplicateEvalAnnot
::
Ident
->
Message
>
errDuplicateEvalAnnot
v
=
posMessage
v
$
hsep
$
map
text
>
[
"More than one eval annotation for"
,
escName
v
]
>
errDuplicateLabel
::
Ident
->
Message
>
errDuplicateLabel
l
=
posMessage
l
$
hsep
$
map
text
>
[
"Multiple occurrence of record label"
,
escName
l
]
...
...
src/CompilerEnv.hs
View file @
bd1ca0d3
...
...
@@ -20,7 +20,6 @@ import Curry.Base.Ident (ModuleIdent)
import
Base.TopEnv
(
allLocalBindings
)
import
Env.Eval
import
Env.Interface
import
Env.ModuleAlias
import
Env.OpPrec
...
...
@@ -37,7 +36,6 @@ data CompilerEnv = CompilerEnv
,
tyConsEnv
::
TCEnv
-- ^ type constructors
,
valueEnv
::
ValueEnv
-- ^ functions and data constructors
,
opPrecEnv
::
PEnv
-- ^ operator precedences
,
evalAnnotEnv
::
EvalEnv
-- ^ evaluation annotations
}
initCompilerEnv
::
ModuleIdent
->
CompilerEnv
...
...
@@ -48,7 +46,6 @@ initCompilerEnv mid = CompilerEnv
,
tyConsEnv
=
initTCEnv
,
valueEnv
=
initDCEnv
,
opPrecEnv
=
initPEnv
,
evalAnnotEnv
=
initEEnv
}
showCompilerEnv
::
CompilerEnv
->
String
...
...
@@ -59,7 +56,6 @@ showCompilerEnv env = show $ vcat
,
header
"TypeConstructors"
$
ppAL
$
allLocalBindings
$
tyConsEnv
env
,
header
"Values "
$
ppAL
$
allLocalBindings
$
valueEnv
env
,
header
"Precedences "
$
ppAL
$
allLocalBindings
$
opPrecEnv
env
,
header
"Eval Annotations"
$
ppMap
$
evalAnnotEnv
env
]
where
header
hdr
content
=
hang
(
text
hdr
<+>
colon
)
4
content
...
...
src/Env/Eval.hs
deleted
100644 → 0
View file @
59d66221
{- |
Module : $Header$
Description : Environment of Evaluation Annotations
Copyright : (c) 2001-2004, Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module computes the evaluation annotation environment. There is no
need to check the annotations because this happens already while checking
the definitions of the module.
-}
module
Env.Eval
(
EvalEnv
,
initEEnv
,
evalEnv
)
where
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
)
import
Curry.Base.Ident
(
Ident
)
import
Curry.Syntax
type
EvalEnv
=
Map
.
Map
Ident
EvalAnnotation
initEEnv
::
EvalEnv
initEEnv
=
Map
.
empty
-- |The function 'evalEnv' collects all evaluation annotations of
-- the module by traversing the syntax tree.
evalEnv
::
Module
->
EvalEnv
evalEnv
(
Module
_
_
_
ds
)
=
foldr
annDecl
initEEnv
ds
annDecl
::
Decl
->
EvalEnv
->
EvalEnv
annDecl
(
EvalAnnot
_
fs
ev
)
env
=
foldr
(`
Map
.
insert
`
ev
)
env
fs
annDecl
(
FunctionDecl
_
_
eqs
)
env
=
foldr
annEquation
env
eqs
annDecl
(
PatternDecl
_
_
rhs
)
env
=
annRhs
rhs
env
annDecl
_
env
=
env
annEquation
::
Equation
->
EvalEnv
->
EvalEnv
annEquation
(
Equation
_
_
rhs
)
=
annRhs
rhs
annRhs
::
Rhs
->
EvalEnv
->
EvalEnv
annRhs
(
SimpleRhs
_
e
ds
)
env
=
annExpr
e
(
foldr
annDecl
env
ds
)
annRhs
(
GuardedRhs
es
ds
)
env
=
foldr
annCondExpr
(
foldr
annDecl
env
ds
)
es
annCondExpr
::
CondExpr
->
EvalEnv
->
EvalEnv
annCondExpr
(
CondExpr
_
g
e
)
env
=
annExpr
g
(
annExpr
e
env
)
annExpr
::
Expression
->
EvalEnv
->
EvalEnv
annExpr
(
Literal
_
)
env
=
env
annExpr
(
Variable
_
)
env
=
env
annExpr
(
Constructor
_
)
env
=
env
annExpr
(
Paren
e
)
env
=
annExpr
e
env
annExpr
(
Typed
e
_
)
env
=
annExpr
e
env
annExpr
(
Tuple
_
es
)
env
=
foldr
annExpr
env
es
annExpr
(
List
_
es
)
env
=
foldr
annExpr
env
es
annExpr
(
ListCompr
_
e
qs
)
env
=
annExpr
e
(
foldr
annStatement
env
qs
)
annExpr
(
EnumFrom
e
)
env
=
annExpr
e
env
annExpr
(
EnumFromThen
e1
e2
)
env
=
annExpr
e1
(
annExpr
e2
env
)
annExpr
(
EnumFromTo
e1
e2
)
env
=
annExpr
e1
(
annExpr
e2
env
)
annExpr
(
EnumFromThenTo
e1
e2
e3
)
env
=
annExpr
e1
(
annExpr
e2
(
annExpr
e3
env
))
annExpr
(
UnaryMinus
_
e
)
env
=
annExpr
e
env
annExpr
(
Apply
e1
e2
)
env
=
annExpr
e1
(
annExpr
e2
env
)
annExpr
(
InfixApply
e1
_
e2
)
env
=
annExpr
e1
(
annExpr
e2
env
)
annExpr
(
LeftSection
e
_
)
env
=
annExpr
e
env
annExpr
(
RightSection
_
e
)
env
=
annExpr
e
env
annExpr
(
Lambda
_
_
e
)
env
=
annExpr
e
env
annExpr
(
Let
ds
e
)
env
=
foldr
annDecl
(
annExpr
e
env
)
ds
annExpr
(
Do
sts
e
)
env
=
foldr
annStatement
(
annExpr
e
env
)
sts
annExpr
(
IfThenElse
_
e1
e2
e3
)
env
=
annExpr
e1
(
annExpr
e2
(
annExpr
e3
env
))
annExpr
(
Case
_
e
alts
)
env
=
annExpr
e
(
foldr
annAlt
env
alts
)
annExpr
(
RecordConstr
fs
)
env
=
foldr
(
annExpr
.
fieldTerm
)
env
fs
annExpr
(
RecordSelection
e
_
)
env
=
annExpr
e
env
annExpr
(
RecordUpdate
fs
e
)
env
=
foldr
(
annExpr
.
fieldTerm
)
(
annExpr
e
env
)
fs
annStatement
::
Statement
->
EvalEnv
->
EvalEnv
annStatement
(
StmtExpr
_
e
)
env
=
annExpr
e
env
annStatement
(
StmtDecl
ds
)
env
=
foldr
annDecl
env
ds
annStatement
(
StmtBind
_
_
e
)
env
=
annExpr
e
env
annAlt
::
Alt
->
EvalEnv
->
EvalEnv
annAlt
(
Alt
_
_
rhs
)
=
annRhs
rhs
src/Generators/GenAbstractCurry.hs
View file @
bd1ca0d3
...
...
@@ -105,8 +105,6 @@ partitionDecl p d@(TypeDecl _ _ _ _) = p { typeDecls = d : typeDecls p }
-- function declarations
partitionDecl
p
(
TypeSig
pos
ids
ty
)
=
partitionFuncDecls
(
\
q
->
TypeSig
pos
[
q
]
ty
)
p
ids
partitionDecl
p
(
EvalAnnot
pos
ids
ann
)
=
partitionFuncDecls
(
\
q
->
EvalAnnot
pos
[
q
]
ann
)
p
ids
partitionDecl
p
d
@
(
FunctionDecl
_
ident
_
)
=
partitionFuncDecls
(
const
d
)
p
[
ident
]
partitionDecl
p
d
@
(
ExternalDecl
_
_
_
ident
_
)
...
...
@@ -235,10 +233,11 @@ genFuncDecl isLocal env (ident, decls)
where
qname
=
genQName
False
env
$
qualify
ident
visibility
=
genVisibility
env
ident
evalannot
=
case
find
isEvalAnnot
decls
of
Nothing
->
CFlex
Just
(
EvalAnnot
_
_
ea
)
->
genEvalAnnot
ea
_
->
internalError
"Gen.GenAbstractCurry.genFuncDecl: no Eval Annotation"
evalannot
=
CFlex
-- evalannot = case find isEvalAnnot decls of
-- Nothing -> CFlex
-- Just (EvalAnnot _ _ ea) -> genEvalAnnot ea
-- _ -> internalError "Gen.GenAbstractCurry.genFuncDecl: no Eval Annotation"
(
env1
,
mtype
)
=
case
genFuncType
env
decls
of
Nothing
->
(
env
,
Nothing
)
Just
(
env'
,
t
)
->
(
env'
,
Just
t
)
...
...
@@ -659,11 +658,6 @@ genVisibility env ident
|
isExported
env
ident
=
Public
|
otherwise
=
Private
--
genEvalAnnot
::
EvalAnnotation
->
CEvalAnnot
genEvalAnnot
EvalRigid
=
CRigid
genEvalAnnot
EvalChoice
=
CChoice
-------------------------------------------------------------------------------
-- This part defines an environment containing all necessary information
-- for generating the AbstractCurry representation of a CurrySyntax term.
...
...
src/Html/SyntaxColoring.hs
View file @
bd1ca0d3
...
...
@@ -419,11 +419,11 @@ code2qualString x = code2string x
token2code
::
Token
->
Code
token2code
tok
@
(
Token
cat
_
)
|
elem
cat
[
IntTok
,
FloatTok
,
IntegerTok
]
|
elem
cat
[
IntTok
,
FloatTok
]
=
NumberCode
(
token2string
tok
)
|
elem
cat
[
KW_case
,
KW_
choice
,
KW_
data
,
KW_do
,
KW_else
,
KW_
eval
,
KW_
external
,
|
elem
cat
[
KW_case
,
KW_data
,
KW_do
,
KW_else
,
KW_external
,
KW_free
,
KW_if
,
KW_import
,
KW_in
,
KW_infix
,
KW_infixl
,
KW_infixr
,
KW_let
,
KW_module
,
KW_newtype
,
KW_of
,
KW_
rigid
,
KW_
then
,
KW_type
,
KW_let
,
KW_module
,
KW_newtype
,
KW_of
,
KW_then
,
KW_type
,
KW_where
,
Id_as
,
Id_ccall
,
Id_forall
,
Id_hiding
,
Id_interface
,
Id_primitive
,
Id_qualified
]
=
Keyword
(
token2string
tok
)
...
...
@@ -455,7 +455,6 @@ declPos (DataDecl p _ _ _ ) = p
declPos
(
NewtypeDecl
p
_
_
_
)
=
p
declPos
(
TypeDecl
p
_
_
_
)
=
p
declPos
(
TypeSig
p
_
_
)
=
p
declPos
(
EvalAnnot
p
_
_
)
=
p
declPos
(
FunctionDecl
p
_
_
)
=
p
declPos
(
ExternalDecl
p
_
_
_
_
)
=
p
declPos
(
FlatExternalDecl
p
_
)
=
p
...
...
@@ -537,8 +536,6 @@ decl2codes (TypeDecl _ ident idents typeExpr) =
typeExpr2codes
typeExpr
decl2codes
(
TypeSig
_
idents
typeExpr
)
=
map
(
Function
TypSig
.
qualify
)
idents
++
typeExpr2codes
typeExpr
decl2codes
(
EvalAnnot
_
idents
_
)
=
map
(
Function
FunDecl
.
qualify
)
idents
decl2codes
(
FunctionDecl
_
_
equations
)
=
concatMap
equation2codes
equations
decl2codes
(
ExternalDecl
_
_
_
_
_
)
=
...
...
@@ -701,7 +698,6 @@ token2string (Token QSym a) = attributes2string a
token2string
(
Token
IntTok
a
)
=
attributes2string
a
token2string
(
Token
FloatTok
a
)
=
attributes2string
a
token2string
(
Token
CharTok
a
)
=
attributes2string
a
token2string
(
Token
IntegerTok
a
)
=
attributes2string
a
token2string
(
Token
StringTok
a
)
=
attributes2string
a
token2string
(
Token
LeftParen
_
)
=
"("
token2string
(
Token
RightParen
_
)
=
")"
...
...
@@ -729,11 +725,9 @@ token2string (Token SymDot _) = "."
token2string
(
Token
SymMinus
_
)
=
"-"
token2string
(
Token
SymMinusDot
_
)
=
"-."
token2string
(
Token
KW_case
_
)
=
"case"
token2string
(
Token
KW_choice
_
)
=
"choice"
token2string
(
Token
KW_data
_
)
=
"data"
token2string
(
Token
KW_do
_
)
=
"do"
token2string
(
Token
KW_else
_
)
=
"else"
token2string
(
Token
KW_eval
_
)
=
"eval"
token2string
(
Token
KW_external
_
)
=
"external"
token2string
(
Token
KW_free
_
)
=
"free"
token2string
(
Token
KW_if
_
)
=
"if"
...
...
@@ -746,7 +740,6 @@ token2string (Token KW_let _) = "let"
token2string
(
Token
KW_module
_
)
=
"module"
token2string
(
Token
KW_newtype
_
)
=
"newtype"
token2string
(
Token
KW_of
_
)
=
"of"
token2string
(
Token
KW_rigid
_
)
=
"rigid"
token2string
(
Token
KW_then
_
)
=
"then"
token2string
(
Token
KW_type
_
)
=
"type"
token2string
(
Token
KW_where
_
)
=
"where"
...
...
@@ -764,14 +757,12 @@ token2string (Token NestedComment (StringAttributes sv _)) = sv
token2string
(
Token
NestedComment
a
)
=
attributes2string
a
token2string
(
Token
LeftBraceSemicolon
_
)
=
"{;"
token2string
(
Token
Binds
_
)
=
":="
token2string
(
Token
Pragma
a
)
=
"{-#"
++
attributes2string
a
++
"#-}"
attributes2string
::
Attributes
->
[
Char
]
attributes2string
NoAttributes
=
""
attributes2string
(
CharAttributes
cv
_
)
=
showCh
cv
attributes2string
(
IntAttributes
iv
_
)
=
show
iv
attributes2string
(
FloatAttributes
fv
_
)
=
show
fv
attributes2string
(
IntegerAttributes
iv
_
)
=
show
iv
attributes2string
(
StringAttributes
sv
_
)
=
showSt
sv
attributes2string
(
IdentAttributes
mIdent
ident
)
=
concat
(
intersperse
"."
(
mIdent
++
[
ident
]))
...
...
src/Modules.hs
View file @
bd1ca0d3
...
...
@@ -31,8 +31,6 @@ import Curry.Files.PathUtils
import
Base.Messages
(
abortWith
,
abortWithMessages
,
putErrsLn
)
import
Env.Eval
(
evalEnv
)
-- source representations
import
qualified
Curry.AbstractCurry
as
AC
import
qualified
Curry.ExtendedFlat.Type
as
EF
...
...
@@ -202,8 +200,7 @@ transModule :: Options -> CompilerEnv -> CS.Module
transModule
opts
env
mdl
=
(
env5
,
ilCaseComp
,
dumps
)
where
flat'
=
FlatCurry
`
elem
`
optTargetTypes
opts
env0
=
env
{
evalAnnotEnv
=
evalEnv
mdl
}
(
desugared
,
env1
)
=
desugar
mdl
env0
(
desugared
,
env1
)
=
desugar
mdl
env
(
simplified
,
env2
)
=
simplify
flat'
desugared
env1
(
lifted
,
env3
)
=
lift
simplified
env2
(
il
,
env4
)
=
ilTrans
flat'
lifted
env3
...
...
src/Transformations.hs
View file @
bd1ca0d3
...
...
@@ -39,7 +39,7 @@ completeCase mdl env = (CC.completeCase (interfaceEnv env) mdl, env)
-- |Translate into the intermediate language
ilTrans
::
Bool
->
Module
->
CompilerEnv
->
(
IL
.
Module
,
CompilerEnv
)
ilTrans
flat
mdl
env
=
(
il
,
env
)
where
il
=
IL
.
ilTrans
flat
(
valueEnv
env
)
(
tyConsEnv
env
)
(
evalAnnotEnv
env
)
mdl
where
il
=
IL
.
ilTrans
flat
(
valueEnv
env
)
(
tyConsEnv
env
)
mdl
-- |Translate a type into its representation in the intermediate language
translType
::
ModuleIdent
->
ValueEnv
->
TCEnv
->
Type
->
IL
.
Type
...
...
@@ -52,8 +52,8 @@ desugar mdl env = (mdl', env { valueEnv = tyEnv' })
-- |Lift local declarations
lift
::
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
lift
mdl
env
=
(
mdl'
,
env
{
valueEnv
=
tyEnv'
,
evalAnnotEnv
=
eEnv'
})
where
(
mdl'
,
tyEnv'
,
eEnv'
)
=
L
.
lift
(
valueEnv
env
)
(
evalAnnotEnv
env
)
mdl
lift
mdl
env
=
(
mdl'
,
env
{
valueEnv
=
tyEnv'
})
where
(
mdl'
,
tyEnv'
)
=
L
.
lift
(
valueEnv
env
)
mdl
-- |Fully qualify used constructors and functions
qual
::
Options
->
CompilerEnv
->
Module
->
(
CompilerEnv
,
Module
)
...
...
@@ -63,4 +63,4 @@ qual opts env (Module m es is ds) = (qualifyEnv opts env, Module m es is ds')
-- |Simplify the source code
simplify
::
Bool
->
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
simplify
flat
mdl
env
=
(
mdl'
,
env
{
valueEnv
=
tyEnv'
})
where
(
mdl'
,
tyEnv'
)
=
S
.
simplify
flat
(
valueEnv
env
)
(
evalAnnotEnv
env
)
mdl
where
(
mdl'
,
tyEnv'
)
=
S
.
simplify
flat
(
valueEnv
env
)
mdl
src/Transformations/CurryToIL.lhs
View file @
bd1ca0d3
...
...
@@ -34,7 +34,6 @@ data structures, we can use only a qualified import for the
>
import
Base.Types
>
import
Base.Utils
(
foldr2
,
thd3
)
>
import
Env.Eval
(
EvalEnv
)
>
import
Env.TypeConstructor
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
>
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
...
...
@@ -50,22 +49,21 @@ these types are already fully expanded, i.e., they do not include any
alias types.
\begin{verbatim}
>
ilTrans
::
Bool
->
ValueEnv
->
TCEnv
->
EvalEnv
->
Module
->
IL
.
Module
>
ilTrans
flat
tyEnv
tcEnv
evEnv
(
Module
m
_
_
ds
)
=
>
IL
.
Module
m
(
imports
m
ds'
)
ds'
>
where
ds'
=
concatMap
(
translGlobalDecl
flat
m
tyEnv
tcEnv
evEnv
)
ds
>
ilTrans
::
Bool
->
ValueEnv
->
TCEnv
->
Module
->
IL
.
Module
>
ilTrans
flat
tyEnv
tcEnv
(
Module
m
_
_
ds
)
=
IL
.
Module
m
(
imports
m
ds'
)
ds'
>
where
ds'
=
concatMap
(
translGlobalDecl
flat
m
tyEnv
tcEnv
)
ds
>
translGlobalDecl
::
Bool
->
ModuleIdent
->
ValueEnv
->
TCEnv
->
EvalEnv
>
translGlobalDecl
::
Bool
->
ModuleIdent
->
ValueEnv
->
TCEnv
>
->
Decl
->
[
IL
.
Decl
]
>
translGlobalDecl
_
m
tyEnv
tcEnv
_
(
DataDecl
_
tc
tvs
cs
)
=
>
translGlobalDecl
_
m
tyEnv
tcEnv
(
DataDecl
_
tc
tvs
cs
)
=
>
[
translData
m
tyEnv
tcEnv
tc
tvs
cs
]
>
translGlobalDecl
_
m
tyEnv
tcEnv
_
(
NewtypeDecl
_
tc
tvs
nc
)
=
>
translGlobalDecl
_
m
tyEnv
tcEnv
(
NewtypeDecl
_
tc
tvs
nc
)
=
>
[
translNewtype
m
tyEnv
tcEnv
tc
tvs
nc
]
>
translGlobalDecl
flat
m
tyEnv
tcEnv
evEnv
(
FunctionDecl
pos
f
eqs
)
=
>
[
translFunction
pos
flat
m
tyEnv
tcEnv
evEnv
f
eqs
]
>
translGlobalDecl
_
m
tyEnv
tcEnv
_
(
ExternalDecl
_
cc
ie
f
_
)
=
>
translGlobalDecl
flat
m
tyEnv
tcEnv
(
FunctionDecl
pos
f
eqs
)
=
>
[
translFunction
pos
flat
m
tyEnv
tcEnv
f
eqs
]
>
translGlobalDecl
_
m
tyEnv
tcEnv
(
ExternalDecl
_
cc
ie
f
_
)
=
>
[
translExternal
m
tyEnv
tcEnv
f
cc
(
fromJust
ie
)]
>
translGlobalDecl
_
_
_
_
_
_
=
[]
>
translGlobalDecl
_
_
_
_
_
=
[]
>
translData
::
ModuleIdent
->
ValueEnv
->
TCEnv
->
Ident
->
[
Ident
]
->
[
ConstrDecl
]
>
->
IL
.
Decl
...
...
@@ -255,8 +253,8 @@ uses flexible matching.
>
type
RenameEnv
=
Map
.
Map
Ident
Ident
>
translFunction
::
Position
->
Bool
->
ModuleIdent
->
ValueEnv
->
TCEnv
>
->
EvalEnv
->
Ident
->
[
Equation
]
->
IL
.
Decl
>
translFunction
pos
flat
m
tyEnv
tcEnv
evEnv
f
eqs
=
>
->
Ident
->
[
Equation
]
->
IL
.
Decl
>
translFunction
pos
flat
m
tyEnv
tcEnv
f
eqs
=
>
-- - | f == mkIdent "fun" = error (show (translType' m tyEnv tcEnv ty))
>
-- - | otherwise =
>
IL
.
FunctionDecl
f'
vs
(
translType'
m
tyEnv
tcEnv
ty
)
expr
...
...
@@ -265,29 +263,30 @@ uses flexible matching.
>
where
f'
=
qualifyWith
m
f
>
ty
=
varType
tyEnv
f'
>
-- ty' = elimRecordType m tyEnv tcEnv (maximum (0:(typeVars ty))) ty
>
ev'
=
Map
.
lookup
f
evEnv
>
ev
=
maybe
(
defaultMode
ty
)
evalMode
ev'
>
--
ev' = Map.lookup f evEnv
>
ev
=
IL
.
Flex
--
= maybe (defaultMode ty) evalMode ev'
>
vs
=
if
not
flat
&&
isFpSelectorId
f
then
translArgs
eqs
vs'
else
vs'
>
(
vs'
,
vs''
)
=
splitAt
(
equationArity
(
head
eqs
))
>
(
argNames
(
mkIdent
""
))
>
expr
|
ev'
==
Just
EvalChoice
>
=
IL
.
Apply
>
(
IL
.
Function
>
(
qualifyWith
preludeMIdent
(
mkIdent
"commit"
))
>
1
)
>
(
match
(
srcRefOf
pos
)
IL
.
Rigid
vs
>
(
map
(
translEquation
tyEnv
vs
vs''
)
eqs
))
>
|
otherwise
>
expr
>
-- | ev' == Just EvalChoice
>
-- = IL.Apply
>
-- (IL.Function
>
-- (qualifyWith preludeMIdent (mkIdent "commit"))
>
-- 1)
>
-- (match (srcRefOf pos) IL.Rigid vs
>
-- (map (translEquation tyEnv vs vs'') eqs))
>
-- | otherwise
>
=
match
(
srcRefOf
pos
)
ev
vs
(
map
(
translEquation
tyEnv
vs
vs''
)
eqs
)
>
---
>
-- (vs',vs'') = splitAt (arrowArity ty) (argNames (mkIdent ""))
>
evalMode
::
EvalAnnotation
->
IL
.
Eval
>
evalMode
EvalRigid
=
IL
.
Rigid
>
evalMode
EvalChoice
=
error
"eval choice is not yet supported"
>
--
evalMode :: EvalAnnotation -> IL.Eval
>
--
evalMode EvalRigid = IL.Rigid
>
--
evalMode EvalChoice = error "eval choice is not yet supported"
>
defaultMode
::
Type
->
IL
.
Eval
>
defaultMode
_
=
IL
.
Flex
>
--
defaultMode :: Type -> IL.Eval
>
--
defaultMode _ = IL.Flex
>
>
--defaultMode ty = if isIO (arrowBase ty) then IL.Rigid else IL.Flex
>
-- where TypeConstructor qIOId _ = ioType undefined
...
...
src/Transformations/Lift.lhs
View file @
bd1ca0d3
...
...
@@ -32,15 +32,14 @@ lifted to the top-level.
>
import
Base.SCC
>
import
Base.Types
>
import
Env.Eval
(
EvalEnv
)
>
import
Env.Value
>
lift
::
ValueEnv
->
EvalEnv
->
Module
->
(
Module
,
ValueEnv
,
EvalEnv
)
>
lift
tyEnv
evEnv
(
Module
m
es
is
ds
)
=
(
lifted
,
tyEnv'
,
evEnv'
)
>
lift
::
ValueEnv
->
Module
->
(
Module
,
ValueEnv
)
>
lift
tyEnv
(
Module
m
es
is
ds
)
=
(
lifted
,
tyEnv'
)
>
where
>
lifted
=
Module
m
es
is
$
concatMap
liftFunDecl
ds'
>
(
ds'
,
tyEnv'
,
evEnv'
)
=
evalAbstract
(
abstractModule
ds
)
initState
>
initState
=
LiftState
m
evEnv
tyEnv
>
(
ds'
,
tyEnv'
)
=
evalAbstract
(
abstractModule
ds
)
initState
>
initState
=
LiftState
m
tyEnv
\end{verbatim}
\paragraph{Abstraction}
...
...
@@ -55,7 +54,6 @@ i.e. the function applied to its free variables.
>
data
LiftState
=
LiftState
>
{
moduleIdent
::
ModuleIdent
>
,
evalEnv
::
EvalEnv
>
,
valueEnv
::
ValueEnv
>
}
...
...
@@ -68,24 +66,17 @@ i.e. the function applied to its free variables.
>
getModuleIdent
::
LiftM
ModuleIdent
>
getModuleIdent
=
S
.
gets
moduleIdent
>
getEvalEnv
::
LiftM
EvalEnv
>
getEvalEnv
=
S
.
gets
evalEnv
>
getValueEnv
::
LiftM
ValueEnv
>
getValueEnv
=
S
.
gets
valueEnv
>
modifyValueEnv
::
(
ValueEnv
->
ValueEnv
)
->
LiftM
()
>
modifyValueEnv
f
=
S
.
modify
$
\
s
->
s
{
valueEnv
=
f
$
valueEnv
s
}
>
modifyEvalEnv
::
(
EvalEnv
->
EvalEnv
)
->
LiftM
()
>
modifyEvalEnv
f
=
S
.
modify
$
\
s
->
s
{
evalEnv
=
f
$
evalEnv
s
}
>
abstractModule
::
[
Decl
]
->
LiftM
([
Decl
],
ValueEnv
,
EvalEnv
)
>
abstractModule
::
[
Decl
]
->
LiftM
([
Decl
],
ValueEnv
)
>
abstractModule
ds
=
do
>
ds'
<-
mapM
(
abstractDecl
""
[]
Map
.
empty
)
ds
>
tyEnv'
<-
getValueEnv
>
evEnv'
<-
getEvalEnv
>
return
(
ds'
,
tyEnv'
,
evEnv'
)
>
return
(
ds'
,
tyEnv'
)
>
abstractDecl
::
String
->
[
Ident
]
->
AbstractEnv
->
Decl
->
LiftM
Decl
>
abstractDecl
_
lvs
env
(
FunctionDecl
p
f
eqs
)
=
...
...
@@ -182,7 +173,6 @@ in the type environment.
>
isLifted
tyEnv
f
=
null
$
lookupValue
f
tyEnv
>
fs'
<-
liftM
(
\
tyEnv
->
filter
(
not
.
isLifted
tyEnv
)
fs
)
getValueEnv
>
modifyValueEnv
$
abstractFunTypes
m
pre
fvs
fs'
>
modifyEvalEnv
$
abstractFunAnnots
m
pre
fs'
>
fds'
<-
mapM
(
abstractFunDecl
pre
fvs
lvs
env'
)
>
[
d
|
d
<-
fds
,
any
(`
elem
`
fs'
)
(
bv
d
)]
>
e'
<-
abstractFunDecls
pre
lvs
env'
fdss
vds
e
...
...
@@ -199,13 +189,6 @@ in the type environment.
>
(
unbindFun
f
tyEnv'
)
>
where
ty
=
foldr
TypeArrow
(
varType
tyEnv'
f
)
tys
>
abstractFunAnnots
::
ModuleIdent
->
String
->
[
Ident
]
->
EvalEnv
->
EvalEnv
>
abstractFunAnnots
_
pre
fs
evEnv
=
foldr
abstractFunAnnot
evEnv
fs
>
where
>
abstractFunAnnot
f
evEnv'
=
case
Map
.
lookup
f
evEnv'
of
>
Just
ev
->
Map
.
insert
(
liftIdent
pre
f
)
ev
(
Map
.
delete
f
evEnv'
)
>
Nothing
->
evEnv'
>
abstractFunDecl
::
String
->
[
Ident
]
->
[
Ident
]
>
->
AbstractEnv
->
Decl
->
LiftM
Decl
>
abstractFunDecl
pre
fvs
lvs
env
(
FunctionDecl
p
f
eqs
)
=
...
...
src/Transformations/Qual.lhs
View file @
bd1ca0d3
...
...
@@ -50,7 +50,6 @@ declarations groups as well as function arguments remain unchanged.
>
NewtypeDecl
p
n
vs
`
liftM
`
qualNewConstr
nc
>
qualDecl
(
TypeDecl
p
n
vs
ty
)
=
TypeDecl
p
n
vs
`
liftM
`
qualTypeExpr
ty
>
qualDecl
(
TypeSig
p
fs
ty
)
=
TypeSig
p
fs
`
liftM
`
qualTypeExpr
ty
>
qualDecl
e
@
(
EvalAnnot
_
_
_
)
=
return
e
>
qualDecl
(
FunctionDecl
p
f
eqs
)
=
>
FunctionDecl
p
f
`
liftM
`
mapM
qualEqn
eqs
>
qualDecl
(
ExternalDecl
p
c
x
n
ty
)
=
...
...
src/Transformations/Simplify.lhs
View file @
bd1ca0d3
...
...
@@ -37,13 +37,11 @@ Currently, the following optimizations are implemented:
>
import
Base.Types
>
import
Base.Typing
>
import
Env.Eval
(
EvalEnv
)
>
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
bindFun
,
qualLookupValue
)
>
data
SimplifyState
=
SimplifyState
>
{
moduleIdent
::
ModuleIdent
>
,
valueEnv
::
ValueEnv
>
,
evalEnv
::
EvalEnv
-- read-only!
>
,
nextId
::
Int
>
,
flat
::
Bool
-- read-only!
>
}
...
...
@@ -66,15 +64,12 @@ Currently, the following optimizations are implemented:
>
getValueEnv
::
SIM
ValueEnv
>
getValueEnv
=
S
.
gets
valueEnv
>
getEvalEnv
::
SIM
EvalEnv
>
getEvalEnv
=
S
.
gets
evalEnv
>
isFlat
::
SIM
Bool
>
isFlat
=
S
.
gets
flat
>
simplify
::
Bool
->
ValueEnv
->
EvalEnv
->
Module
->
(
Module
,
ValueEnv
)
>
simplify
flags
tyEnv
evEnv
mdl
@
(
Module
m
_
_
_
)
>
=
S
.
evalState
(
simplifyModule
mdl
)
(
SimplifyState
m
tyEnv
evEnv
1
flags
)
>
simplify
::
Bool
->
ValueEnv
->
Module
->
(
Module
,
ValueEnv
)
>
simplify
flags
tyEnv
mdl
@
(
Module
m
_
_
_
)
>
=
S
.
evalState
(
simplifyModule
mdl
)
(
SimplifyState
m
tyEnv
1
flags
)
>
simplifyModule
::
Module
->
SIM
(
Module
,
ValueEnv
)
>
simplifyModule
(
Module
m
es
is
ds
)
=
do
...
...
@@ -166,17 +161,15 @@ explicitly in a Curry expression.
>
m
<-
getModuleIdent
>
rhs'
<-
simplifyRhs
env
rhs
>
tyEnv
<-
getValueEnv
>
evEnv
<-
getEvalEnv
>
return
$
inlineFun
m
tyEnv
evEnv
p
lhs
rhs'
>
return
$
inlineFun
m
tyEnv
p
lhs
rhs'
>
inlineFun
::
ModuleIdent
->
ValueEnv
->
EvalEnv
->
Position
->
Lhs
->
Rhs
->
[
Equation
]
>
inlineFun
m
tyEnv
evEnv
p
(
FunLhs
f
ts
)
>
inlineFun
::
ModuleIdent
->
ValueEnv
->
Position
->
Lhs
->
Rhs
->
[
Equation
]
>
inlineFun
m
tyEnv
p
(
FunLhs
f
ts
)
>
(
SimpleRhs
_
(
Let
[
FunctionDecl
_
f'
eqs'
]
e
)
_
)
>
|
True
-- False -- inlining of functions is deactivated (hsi)
>
&&
f'
`
notElem
`
qfv
m
eqs'
&&
e'
==
Variable
(
qualify
f'
)
&&
>
n
==
arrowArity
(
funType
m
tyEnv
(
qualify
f'
))
&&
>
(
evMode
evEnv
f
==
evMode
evEnv
f'
||
>
and
[
all
isVarPattern
ts1
|
Equation
_
(
FunLhs
_
ts1
)
_
<-
eqs'
])
=
>
and
[
all
isVarPattern
ts1
|
Equation
_
(
FunLhs
_
ts1
)
_
<-
eqs'
]
=
>
map
(
mergeEqns
p
f
ts'
vs'
)
eqs'
>
where
n
::
Int
-- type signature necessary for nhc
>
(
n
,
vs'
,
ts'
,
e'
)
=
etaReduce
0
[]
(
reverse
ts
)
e
...
...
@@ -186,7 +179,7 @@ explicitly in a Curry expression.
>
etaReduce
n1
vs
(
VariablePattern
v
:
ts1
)
(
Apply
e1
(
Variable
v'
))
>
|
qualify
v
==
v'
=
etaReduce
(
n1
+
1
)
(
v
:
vs
)
ts1
e1
>
etaReduce
n1
vs
ts1
e1
=
(
n1
,
vs
,
reverse
ts1
,
e1
)
>
inlineFun
_
_
_
p
lhs
rhs
=
[
Equation
p
lhs
rhs
]
>
inlineFun
_
_
p
lhs
rhs
=
[
Equation
p
lhs
rhs
]
>
simplifyRhs
::
InlineEnv
->
Rhs
->
SIM
Rhs
>
simplifyRhs
env
(
SimpleRhs
p
e
_
)
=
...
...
@@ -444,9 +437,6 @@ Auxiliary functions