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
f5693969
Commit
f5693969
authored
Oct 19, 2011
by
Björn Peemöller
Browse files
Refactorings
parent
2204448d
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/Generators/GenFlatCurry.hs
View file @
f5693969
...
...
@@ -132,23 +132,23 @@ data IdentExport
-- Runs a 'FlatState' action and returns the result
run
::
Options
->
ModuleSummary
.
ModuleSummary
->
InterfaceEnv
->
ValueEnv
->
TCEnv
->
Bool
->
FlatState
a
->
(
a
,
[
Message
])
run
opts
cEnv
mEnv
tyEnv
tcEnv
genIntf
f
=
(
result
,
messagesE
env
)
run
opts
modSum
mEnv
tyEnv
tcEnv
genIntf
f
=
(
result
,
messagesE
env
)
where
(
result
,
env
)
=
runState
f
env0
env0
=
FlatEnv
{
moduleIdE
=
ModuleSummary
.
moduleId
cEnv
{
moduleIdE
=
ModuleSummary
.
moduleId
modSum
,
functionIdE
=
(
qualify
(
mkIdent
""
),
[]
)
,
compilerOptsE
=
opts
,
interfaceEnvE
=
mEnv
,
typeEnvE
=
tyEnv
,
tConsEnvE
=
tcEnv
,
publicEnvE
=
genPubEnv
(
ModuleSummary
.
moduleId
cEnv
)
(
ModuleSummary
.
interface
cEnv
)
,
fixitiesE
=
ModuleSummary
.
infixDecls
cEnv
,
typeSynonymsE
=
ModuleSummary
.
typeSynonyms
cEnv
,
importsE
=
ModuleSummary
.
imports
cEnv
,
exportsE
=
ModuleSummary
.
exports
cEnv
,
interfaceE
=
ModuleSummary
.
interface
cEnv
,
publicEnvE
=
genPubEnv
(
ModuleSummary
.
moduleId
modSum
)
(
ModuleSummary
.
interface
modSum
)
,
fixitiesE
=
ModuleSummary
.
infixDecls
modSum
,
typeSynonymsE
=
ModuleSummary
.
typeSynonyms
modSum
,
importsE
=
ModuleSummary
.
imports
modSum
,
exportsE
=
ModuleSummary
.
exports
modSum
,
interfaceE
=
ModuleSummary
.
interface
modSum
,
varIndexE
=
0
,
varIdsE
=
ScopeEnv
.
new
,
tvarIndexE
=
0
...
...
src/IL/XML.lhs
View file @
f5693969
...
...
@@ -24,22 +24,21 @@ similar to that of Flat-Curry XML representation.
>
import
Curry.Base.Ident
>
import
IL.Type
TODO: The following
two
import
s
should be avoided if possible as t
hey
make
TODO: The following import should be avoided if possible as
i
t make
s
the program structure less clear.
>
import
qualified
Curry.Syntax
as
CS
>
import
ModuleSummary
>
-- identation level
>
level
::
Int
>
level
=
3
>
xmlModule
::
ModuleSummary
->
Module
->
Doc
>
xmlModule
modSum
m
>
=
text
"<prog>"
$$
nest
level
(
xmlBody
modSum
m
)
$$
text
"</prog>"
>
xmlModule
::
[
CS
.
IDecl
]
->
[
CS
.
IDecl
]
->
Module
->
Doc
>
xmlModule
intf
infx
m
>
=
text
"<prog>"
$$
nest
level
(
xmlBody
intf
infx
m
)
$$
text
"</prog>"
>
xmlBody
::
ModuleSummary
->
Module
->
Doc
>
xmlBody
modSum
(
Module
mname
mimports
decls
)
=
>
xmlBody
::
[
CS
.
IDecl
]
->
[
CS
.
IDecl
]
->
Module
->
Doc
>
xmlBody
intf
infx
(
Module
mname
mimports
decls
)
=
>
xmlElement
"module"
xmlModuleDecl
moduleDecl
$$
>
xmlElement
"import"
xmlImportDecl
importDecl
$$
>
xmlElement
"types"
xmlTypeDecl
typeDecl
$$
...
...
@@ -50,8 +49,8 @@ TODO: The following two imports should be avoided if possible as they make
>
moduleDecl
=
[
mname
]
>
importDecl
=
mimports
>
(
funcDecl
,
typeDecl
)
=
splitDecls
decls
>
operatorDecl
=
inf
ixDecls
modSum
>
translationDecl
=
foldl
(
qualIDeclId
(
moduleId
modSum
)
)
[]
(
int
erface
modSum
)
>
operatorDecl
=
inf
x
>
translationDecl
=
foldl
(
qualIDeclId
mname
)
[]
int
f
>
xmlModuleDecl
::
ModuleIdent
->
Doc
>
xmlModuleDecl
=
xmlModuleIdent
...
...
src/Imports.hs
View file @
f5693969
...
...
@@ -336,7 +336,6 @@ expandTypeWith m tcEnv tc cs = case Map.lookup tc tcEnv of
|
l
`
elem
`
ls'
=
l
|
otherwise
=
errorMessage
$
errUndefinedLabel
tc
l
expandTypeAll
::
ModuleIdent
->
ExpTCEnv
->
Ident
->
Import
expandTypeAll
m
tcEnv
tc
=
case
Map
.
lookup
tc
tcEnv
of
Just
(
DataType
_
_
cs
)
->
ImportTypeWith
tc
...
...
@@ -348,6 +347,25 @@ expandTypeAll m tcEnv tc = case Map.lookup tc tcEnv of
Just
(
AliasType
_
_
_
)
->
errorMessage
$
errNonDataType
tc
Nothing
->
errorMessage
$
errUndefinedEntity
m
tc
errUndefinedEntity
::
ModuleIdent
->
Ident
->
Message
errUndefinedEntity
m
x
=
posErr
x
$
"Module "
++
moduleName
m
++
" does not export "
++
name
x
errUndefinedDataConstr
::
Ident
->
Ident
->
Message
errUndefinedDataConstr
tc
c
=
posErr
c
$
name
c
++
" is not a data constructor of type "
++
name
tc
errUndefinedLabel
::
Ident
->
Ident
->
Message
errUndefinedLabel
tc
c
=
posErr
c
$
name
c
++
" is not a label of record type "
++
name
tc
errNonDataType
::
Ident
->
Message
errNonDataType
tc
=
posErr
tc
$
name
tc
++
" is not a data type"
errImportDataConstr
::
ModuleIdent
->
Ident
->
Message
errImportDataConstr
_
c
=
posErr
c
$
"Explicit import for data constructor "
++
name
c
-- ---------------------------------------------------------------------------
-- After all modules have been imported, the compiler has to ensure that
...
...
@@ -404,9 +422,9 @@ importInterfaceIntf i@(Interface m _ _) env = env
,
valueEnv
=
importEntities
m
True
(
const
True
)
id
mTyEnv
$
valueEnv
env
}
where
mPEnv
=
intfEnv
bindPrec
i
-- all operator precedences
mTCEnv
=
intfEnv
bindTCHidden
i
-- all type constructors
mTyEnv
=
intfEnv
bindTy
i
-- all values
mPEnv
=
intfEnv
bindPrec
i
-- all operator precedences
mTCEnv
=
intfEnv
bindTCHidden
i
-- all type constructors
mTyEnv
=
intfEnv
bindTy
i
-- all values
-- ---------------------------------------------------------------------------
-- Record stuff
...
...
@@ -431,7 +449,7 @@ expandRecordTC tcEnv (DataType qid n args) =
expandRecordTC
tcEnv
(
RenamingType
qid
n
(
DataConstr
c
m
[
ty
]))
=
RenamingType
qid
n
(
DataConstr
c
m
[
expandRecords
tcEnv
ty
])
expandRecordTC
_
(
RenamingType
_
_
(
DataConstr
_
_
_
))
=
internalError
"
Rec
or
d
s.expandRecordTC"
internalError
"
Imp
or
t
s.expandRecordTC"
expandRecordTC
tcEnv
(
AliasType
qid
n
ty
)
=
AliasType
qid
n
(
expandRecords
tcEnv
ty
)
...
...
@@ -516,24 +534,3 @@ expandRecords _ ty = ty
-- addLabelType (LabelType l r ty) = importTopEnv m' l lblInfo
-- where lblInfo = Label (qualify l) (qualQualify m' r) (polyType ty)
-- m' = fromMaybe m (qualidMod r)
-- Error messages:
errUndefinedEntity
::
ModuleIdent
->
Ident
->
Message
errUndefinedEntity
m
x
=
posErr
x
$
"Module "
++
moduleName
m
++
" does not export "
++
name
x
errUndefinedDataConstr
::
Ident
->
Ident
->
Message
errUndefinedDataConstr
tc
c
=
posErr
c
$
name
c
++
" is not a data constructor of type "
++
name
tc
errUndefinedLabel
::
Ident
->
Ident
->
Message
errUndefinedLabel
tc
c
=
posErr
c
$
name
c
++
" is not a label of record type "
++
name
tc
errNonDataType
::
Ident
->
Message
errNonDataType
tc
=
posErr
tc
$
name
tc
++
" is not a data type"
errImportDataConstr
::
ModuleIdent
->
Ident
->
Message
errImportDataConstr
_
c
=
posErr
c
$
"Explicit import for data constructor "
++
name
c
src/ModuleSummary.hs
View file @
f5693969
...
...
@@ -36,9 +36,8 @@ data ModuleSummary = ModuleSummary
}
deriving
Show
{- |Return a 'ModuleSummary' for a module, its corresponding
table of type constructors and its interface
-}
-- |Return a 'ModuleSummary' for a module, its corresponding
-- table of type constructors and its interface
summarizeModule
::
TCEnv
->
Interface
->
Module
->
ModuleSummary
summarizeModule
tcEnv
(
Interface
iid
_
idecls
)
(
Module
mid
mExp
imps
decls
)
|
iid
==
mid
=
ModuleSummary
...
...
@@ -49,20 +48,15 @@ summarizeModule tcEnv (Interface iid _ idecls) (Module mid mExp imps decls)
,
infixDecls
=
genInfixDecls
mid
decls
,
typeSynonyms
=
genTypeSyns
tcEnv
mid
decls
}
|
otherwise
=
internalError
$
errInterfaceModuleMismatch
iid
mid
-- ---------------------------------------------------------------------------
|
otherwise
=
internalError
$
"Interface "
++
show
iid
++
" does not match module "
++
show
mid
-- |Generate interface import declarations
genImports
::
[
ImportDecl
]
->
[
IImportDecl
]
genImports
=
map
snd
.
foldr
addImport
[]
where
addImport
::
ImportDecl
->
[(
ModuleIdent
,
IImportDecl
)]
->
[(
ModuleIdent
,
IImportDecl
)]
addImport
(
ImportDecl
pos
mid
_
_
_
)
imps
=
case
lookup
mid
imps
of
Nothing
->
(
mid
,
IImportDecl
pos
mid
)
:
imps
Just
_
->
imps
-- ---------------------------------------------------------------------------
where
addImport
(
ImportDecl
pos
mid
_
_
_
)
imps
=
case
lookup
mid
imps
of
Nothing
->
(
mid
,
IImportDecl
pos
mid
)
:
imps
Just
_
->
imps
-- |Generate interface infix declarations in the module
genInfixDecls
::
ModuleIdent
->
[
Decl
]
->
[
IDecl
]
...
...
@@ -73,14 +67,6 @@ genInfixDecls mident decls = concatMap genInfixDecl decls
=
map
(
IInfixDecl
pos
spec
prec
.
qualifyWith
mident
)
idents
genInfixDecl
_
=
[]
-- collectIInfixDecls mident decls
-- collectIInfixDecls :: ModuleIdent -> [Decl] -> [IDecl]
-- collectIInfixDecls _ [] = []
-- collectIInfixDecls mident ((InfixDecl pos infixspec prec idents) : decls)
-- = map (IInfixDecl pos infixspec prec . qualifyWith mident) idents
-- ++ collectIInfixDecls mident decls
-- collectIInfixDecls mident (_ : decls) = collectIInfixDecls mident decls
-- ---------------------------------------------------------------------------
-- |Generate interface declarations for all type synonyms in the module.
...
...
@@ -158,7 +144,3 @@ lookupTCId qident tcEnv = case qualLookupTC qident tcEnv of
[
RenamingType
qid
_
_
]
->
Just
qid
[
AliasType
qid
_
_
]
->
Just
qid
_
->
Nothing
errInterfaceModuleMismatch
::
ModuleIdent
->
ModuleIdent
->
String
errInterfaceModuleMismatch
mi
mm
=
"Interface "
++
show
mi
++
" does not match module "
++
show
mm
src/Modules.hs
View file @
f5693969
...
...
@@ -258,7 +258,7 @@ writeXML opts fn modSum il = when xmlTarget $
xmlTarget
=
FlatXml
`
elem
`
optTargetTypes
opts
useSubDir
=
optUseSubdir
opts
targetFile
=
fromMaybe
(
xmlName
fn
)
(
optOutput
opts
)
curryXml
=
shows
(
IL
.
xmlModule
modSum
il
)
"
\n
"
curryXml
=
shows
(
IL
.
xmlModule
(
interface
modSum
)
(
infixDecls
modSum
)
il
)
"
\n
"
writeAbstractCurry
::
Options
->
FilePath
->
CompilerEnv
->
CS
.
Module
->
IO
()
writeAbstractCurry
opts
fname
env
modul
=
do
...
...
Write
Preview
Supports
Markdown
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