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
54dcdba2
Commit
54dcdba2
authored
May 31, 2011
by
Björn Peemöller
Browse files
Compilation errors removed
parent
7e5d0d97
Changes
11
Hide whitespace changes
Inline
Side-by-side
src/Base/Arity.hs
View file @
54dcdba2
...
...
@@ -149,11 +149,11 @@ visitExpr _ aEnv _ = aEnv
visitStatement
::
ModuleIdent
->
ArityEnv
->
Statement
->
ArityEnv
visitStatement
mid
aEnv
(
StmtExpr
_
expr
)
=
visitExpr
ession
mid
aEnv
expr
=
visitExpr
mid
aEnv
expr
visitStatement
mid
aEnv
(
StmtDecl
decls
)
=
foldl
(
visitDecl
mid
)
aEnv
decls
visitStatement
mid
aEnv
(
StmtBind
_
_
expr
)
=
visitExpr
ession
mid
aEnv
expr
=
visitExpr
mid
aEnv
expr
visitAlt
::
ModuleIdent
->
ArityEnv
->
Alt
->
ArityEnv
visitAlt
mid
aEnv
(
Alt
_
_
rhs
)
=
visitRhs
mid
aEnv
rhs
...
...
src/CompilerOpts.hs
View file @
54dcdba2
...
...
@@ -8,7 +8,6 @@
module
CompilerOpts
(
Options
(
..
),
Verbosity
(
..
),
TargetType
(
..
),
Extension
(
..
)
,
DumpLevel
(
..
),
defaultOptions
,
compilerOpts
,
usage
,
implicitPrelude
)
where
import
Data.List
(
nub
)
...
...
@@ -29,7 +28,7 @@ data Options = Options
,
optForce
::
Bool
-- ^ force compilation
,
optImportPaths
::
[
FilePath
]
-- ^ directories for imports
,
optOutput
::
Maybe
FilePath
-- ^ name of output file
,
optUseSubdir
::
Bool
-- use subdir for output?
,
optUseSubdir
::
Bool
--
^
use subdir for output?
,
optInterface
::
Bool
-- ^ do not create an interface file
,
optWarn
::
Bool
-- ^ warnings on/off
,
optOverlapWarn
::
Bool
-- ^ "overlap" warnings on/off
...
...
src/Curry/Syntax/Lexer.lhs
View file @
54dcdba2
...
...
@@ -23,9 +23,7 @@ In this section a lexer for Curry is implemented.
>
import
Data.Char
(
chr
,
ord
,
isAlpha
,
isAlphaNum
,
isSpace
,
isUpper
>
,
isDigit
,
isOctDigit
,
isHexDigit
)
>
import
Data.List
(
intercalate
)
>
import
qualified
Data.Map
as
Map
(
Map
,
union
,
lookup
,
fromList
>
,
findWithDefault
)
>
import
Data.Maybe
(
fromMaybe
)
>
import
qualified
Data.Map
as
Map
(
Map
,
union
,
lookup
,
fromList
)
>
import
Curry.Base.LexComb
>
import
Curry.Base.LLParseComb
(
Symbol
(
..
))
...
...
@@ -50,9 +48,9 @@ In this section a lexer for Curry is implemented.
>
data
Category
>
-- literals
>
=
CharTok
>
|
IntTok
>
|
FloatTok
>
|
IntegerTok
>
|
IntTok
>
|
FloatTok
>
|
IntegerTok
>
|
StringTok
>
-- identifiers
...
...
@@ -62,7 +60,7 @@ In this section a lexer for Curry is implemented.
>
|
QSym
-- qualified symbol
>
-- punctuation symbols
>
|
LeftParen
-- (
>
|
LeftParen
-- (
>
|
RightParen
-- )
>
|
Semicolon
-- ;
>
|
LeftBrace
-- {
...
...
@@ -84,24 +82,24 @@ In this section a lexer for Curry is implemented.
>
|
KW_choice
-- deprecated
>
|
KW_data
>
-- | KW_deriving -- not supported yet
>
|
KW_do
>
|
KW_else
>
|
KW_do
>
|
KW_else
>
|
KW_eval
-- deprecated
>
|
KW_external
>
|
KW_free
>
|
KW_if
>
|
KW_import
>
|
KW_in
>
|
KW_infix
>
|
KW_infixl
>
|
KW_free
>
|
KW_if
>
|
KW_import
>
|
KW_in
>
|
KW_infix
>
|
KW_infixl
>
|
KW_infixr
>
-- | KW_instance -- not supported yet
>
|
KW_let
>
|
KW_module
>
|
KW_newtype
>
|
KW_of
>
|
KW_let
>
|
KW_module
>
|
KW_newtype
>
|
KW_of
>
|
KW_rigid
-- deprecated
>
|
KW_then
>
|
KW_then
>
|
KW_type
>
|
KW_where
...
...
@@ -119,11 +117,11 @@ In this section a lexer for Curry is implemented.
>
-- | Context -- => -- not supported yet
>
-- special identifiers
>
|
Id_as
>
|
Id_ccall
>
|
Id_forall
>
|
Id_hiding
>
|
Id_interface
>
|
Id_as
>
|
Id_ccall
>
|
Id_forall
>
|
Id_hiding
>
|
Id_interface
>
|
Id_primitive
>
|
Id_qualified
...
...
@@ -137,7 +135,7 @@ In this section a lexer for Curry is implemented.
>
|
Pragma
>
-- comments (only for full lexer) inserted by men & bbr
>
|
LineComment
>
|
LineComment
>
|
NestedComment
>
-- end-of-file token
...
...
@@ -170,7 +168,7 @@ attribute values, we make use of records.
>
showsPrec
_
(
FloatAttributes
fv
_
)
=
shows
fv
>
showsPrec
_
(
IntegerAttributes
iv
_
)
=
shows
iv
>
showsPrec
_
(
StringAttributes
sv
_
)
=
shows
sv
>
showsPrec
_
(
IdentAttributes
mIdent
ident
)
=
showsEscaped
>
showsPrec
_
(
IdentAttributes
mIdent
ident
)
=
showsEscaped
>
$
intercalate
"."
>
$
mIdent
++
[
ident
]
...
...
@@ -236,9 +234,6 @@ all tokens in their source representation.
-- Helper for showing
>
showsQualified
::
[
String
]
->
String
->
ShowS
>
showsQualified
modul
ident
=
showsEscaped
$
intercalate
"."
$
modul
++
[
ident
]
>
showsEscaped
::
String
->
ShowS
>
showsEscaped
s
=
showChar
'`'
.
showString
s
.
showChar
'
\'
'
...
...
@@ -256,10 +251,10 @@ all tokens in their source representation.
>
instance
Show
Token
where
>
showsPrec
_
(
Token
Id
a
)
=
showsIdentifier
a
>
showsPrec
_
(
Token
QId
a
)
=
showString
"qualified "
>
showsPrec
_
(
Token
QId
a
)
=
showString
"qualified "
>
.
showsIdentifier
a
>
showsPrec
_
(
Token
Sym
a
)
=
showsOperator
a
>
showsPrec
_
(
Token
QSym
a
)
=
showString
"qualified "
>
showsPrec
_
(
Token
QSym
a
)
=
showString
"qualified "
>
.
showsOperator
a
>
showsPrec
_
(
Token
IntTok
a
)
=
showString
"integer "
.
shows
a
>
showsPrec
_
(
Token
FloatTok
a
)
=
showString
"float "
.
shows
a
...
...
@@ -276,11 +271,11 @@ all tokens in their source representation.
>
showsPrec
_
(
Token
Comma
_
)
=
showsEscaped
","
>
showsPrec
_
(
Token
Underscore
_
)
=
showsEscaped
"_"
>
showsPrec
_
(
Token
Backquote
_
)
=
showsEscaped
"`"
>
showsPrec
_
(
Token
LeftBraceSemicolon
_
)
=
showsEscaped
"{;"
>
showsPrec
_
(
Token
LeftBraceSemicolon
_
)
=
showsEscaped
"{;"
>
.
showString
" (turn off layout)"
>
showsPrec
_
(
Token
VSemicolon
_
)
=
showsEscaped
";"
>
showsPrec
_
(
Token
VSemicolon
_
)
=
showsEscaped
";"
>
.
showString
" (inserted due to layout)"
>
showsPrec
_
(
Token
VRightBrace
_
)
=
showsEscaped
"}"
>
showsPrec
_
(
Token
VRightBrace
_
)
=
showsEscaped
"}"
>
.
showString
" (inserted due to layout)"
>
showsPrec
_
(
Token
At
_
)
=
showsEscaped
"@"
>
showsPrec
_
(
Token
DotDot
_
)
=
showsEscaped
".."
...
...
@@ -342,7 +337,7 @@ Maps for reserved operators and identifiers
>
,
(
".."
,
DotDot
)
>
,
(
"="
,
Equals
)
>
,
(
"
\\
"
,
Backslash
)
>
,
(
"|"
,
Bar
)
>
,
(
"|"
,
Bar
)
>
,
(
"<-"
,
LeftArrow
)
>
,
(
"->"
,
RightArrow
)
>
,
(
"~"
,
Tilde
)
...
...
@@ -370,7 +365,7 @@ Maps for reserved operators and identifiers
>
,
(
"external"
,
KW_external
)
>
,
(
"free"
,
KW_free
)
>
,
(
"if"
,
KW_if
)
>
,
(
"import"
,
KW_import
)
>
,
(
"import"
,
KW_import
)
>
,
(
"in"
,
KW_in
)
>
,
(
"infix"
,
KW_infix
)
>
,
(
"infixl"
,
KW_infixl
)
...
...
@@ -540,7 +535,7 @@ Lexing functions
>
lexSymbol
::
(
Token
->
P
a
)
->
P
a
>
lexSymbol
cont
p
s
=
>
cont
(
idTok
(
maybe
Sym
id
(
Map
.
lookup
sym
keywords
Special
Id
s
))
[]
sym
)
>
cont
(
idTok
(
maybe
Sym
id
(
Map
.
lookup
sym
reserved
Special
Op
s
))
[]
sym
)
>
(
incr
p
(
length
sym
))
rest
>
where
(
sym
,
rest
)
=
span
isSymbol
s
...
...
src/Curry/Syntax/Parser.lhs
View file @
54dcdba2
...
...
@@ -726,7 +726,7 @@ qconop = qConSym <|> backquotes (qConId <?> "operator name expected")
>
sym
::
Parser
Token
Ident
a
>
sym
=
(
\
pos
->
mkIdentPosition
pos
.
sval
)
<$>
position
<*>
>
tokens
[
Sym
,
Sym
_
Dot
,
Sym
_
Minus
,
Sym
_
MinusDot
]
>
tokens
[
Sym
,
Sym
Colon
,
Sym
Dot
,
SymMinus
,
SymMinusDot
]
>
qSym
::
Parser
Token
QualIdent
a
>
qSym
=
qualify
<$>
sym
<|>
mkQIdent
<$>
position
<*>
token
QSym
...
...
@@ -735,15 +735,15 @@ qconop = qConSym <|> backquotes (qConId <?> "operator name expected")
>
colon
::
Parser
Token
QualIdent
a
>
colon
=
(
\
p
_
->
qualify
$
addPositionIdent
p
consId
)
<$>
>
position
<*>
token
Colon
>
position
<*>
token
Sym
Colon
>
minus
::
Parser
Token
Ident
a
>
minus
=
(
\
p
_
->
addPositionIdent
p
minusId
)
<$>
>
position
<*>
token
Sym
_
Minus
>
position
<*>
token
SymMinus
>
fminus
::
Parser
Token
Ident
a
>
fminus
=
(
\
p
_
->
addPositionIdent
p
fminusId
)
<$>
>
position
<*>
token
Sym
_
MinusDot
>
position
<*>
token
SymMinusDot
>
tupleCommas
::
Parser
Token
QualIdent
a
>
tupleCommas
=
(
\
p
->
qualify
.
addPositionIdent
p
.
tupleId
.
succ
.
length
)
...
...
src/CurryBuilder.hs
View file @
54dcdba2
...
...
@@ -16,7 +16,7 @@ import Curry.Files.Filenames
import
Curry.Files.PathUtils
(
dropExtension
,
doesModuleExist
,
lookupCurryFile
,
getModuleModTime
,
tryGetModuleModTime
)
import
CompilerOpts
(
Options
(
..
),
Extension
(
..
),
TargetType
(
..
))
import
CompilerOpts
(
Options
(
..
),
TargetType
(
..
))
import
CurryDeps
(
Source
(
..
),
flatDeps
)
import
Messages
(
status
,
abortWith
)
import
Modules
(
compileModule
)
...
...
@@ -27,7 +27,7 @@ import Modules (compileModule)
-}
buildCurry
::
Options
->
FilePath
->
IO
()
buildCurry
opts
file
=
do
mbFile
<-
lookupCurryFile
i
mportPaths
file
mbFile
<-
lookupCurryFile
(
optI
mportPaths
opts
)
file
case
mbFile
of
Nothing
->
abortWith
[
missingModule
file
]
Just
f
->
do
...
...
@@ -85,13 +85,13 @@ makeCurry opts deps1 targetFile = mapM_ (compile . snd) deps1 where
compileFile
f
=
do
status
opts
$
"compiling "
++
f
compileModule
(
compOpts
True
)
f
>>
return
()
compileModule
(
compOpts
True
)
f
skipFile
f
=
status
opts
$
"skipping "
++
f
generateFile
f
=
do
status
opts
$
"generating "
++
head
(
targetNames
f
)
compileModule
(
compOpts
False
)
f
>>
return
()
compileModule
(
compOpts
False
)
f
compOpts
isImport
|
isImport
=
opts
{
optTargetTypes
=
[
FlatCurry
],
optDumps
=
[]
}
...
...
src/CurryDeps.lhs
View file @
54dcdba2
...
...
@@ -42,7 +42,7 @@ dependencies and to update programs composed of multiple modules.
>
mEnv
<-
deps
implicitPrelude
[]
libPaths
Map
.
empty
fn
>
return
$
flattenDeps
mEnv
>
where
>
implicitPrelude
=
NoImplicitPrelude
`
notElem
`
optExtensions
o
t
ps
>
implicitPrelude
=
NoImplicitPrelude
`
notElem
`
optExtensions
op
t
s
>
libPaths
=
optImportPaths
opts
>
deps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
SourceEnv
->
FilePath
...
...
src/Frontend.hs
View file @
54dcdba2
...
...
@@ -87,12 +87,11 @@ makeInterfaces paths (CS.Module mid _ decls) = do
when
(
null
errs
)
(
mapM_
(
compile
deps1
.
snd
)
deps1
)
return
errs
where
compile
deps'
(
Source
file'
mods
)
=
do
_
<-
smake
[
flatName
file'
,
flatIntName
file'
]
(
file'
:
mapMaybe
(
flatInterface
deps'
)
mods
)
(
compileModule
(
opts
paths
)
file'
)
(
return
Nothing
)
return
()
compile
deps'
(
Source
file'
mods
)
=
smake
[
flatName
file'
,
flatIntName
file'
]
(
file'
:
mapMaybe
(
flatInterface
deps'
)
mods
)
(
compileModule
(
opts
paths
)
file'
)
(
return
()
)
compile
_
_
=
return
()
flatInterface
deps'
mod1
=
case
(
lookup
mod1
deps'
)
of
...
...
src/Gen/GenAbstractCurry.hs
View file @
54dcdba2
...
...
@@ -109,7 +109,7 @@ partitionDecl parts (FlatExternalDecl pos ids)
=
partitionFuncDecls
(
\
ident
->
FlatExternalDecl
pos
[
ident
])
parts
ids
-- op decls
partitionDecl
parts
(
InfixDecl
pos
fix
prec
idents
)
=
part
ition
s
{
opDecls
=
map
(
\
ident
->
(
InfixDecl
pos
fix
prec
[
ident
]))
idents
++
opDecls
parts
}
=
parts
{
opDecls
=
map
(
\
ident
->
(
InfixDecl
pos
fix
prec
[
ident
]))
idents
++
opDecls
parts
}
-- default
partitionDecl
parts
_
=
parts
...
...
src/Gen/GenFlatCurry.hs
View file @
54dcdba2
...
...
@@ -58,10 +58,10 @@ genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
-- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
WarnMsg
])
genFlatInterface
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
modul
=
(
patchPreludeFCY
intf
,
messages
)
where
(
intf
,
messages
)
=
run
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
True
(
visitModule
modul
)
genFlatInterface
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
modul
=
(
patchPreludeFCY
intf
,
messages
)
where
(
intf
,
messages
)
=
run
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
True
(
visitModule
modul
)
patchPreludeFCY
::
Prog
->
Prog
patchPreludeFCY
p
@
(
Prog
n
_
types
funcs
ops
)
...
...
src/Html/SyntaxColoring.hs
View file @
54dcdba2
...
...
@@ -427,7 +427,7 @@ token2code tok@(Token cat _)
=
Keyword
(
token2string
tok
)
|
elem
cat
[
LeftParen
,
RightParen
,
Semicolon
,
LeftBrace
,
RightBrace
,
LeftBracket
,
RightBracket
,
Comma
,
Underscore
,
Backquote
,
At
,
Colon
,
DotDot
,
DoubleColon
,
Equals
,
Backslash
,
Bar
,
LeftArrow
,
RightArrow
,
At
,
DotDot
,
DoubleColon
,
Equals
,
Backslash
,
Bar
,
LeftArrow
,
RightArrow
,
Tilde
]
=
Symbol
(
token2string
tok
)
|
elem
cat
[
LineComment
,
NestedComment
]
...
...
@@ -443,7 +443,7 @@ token2code tok@(Token cat _)
isTokenIdentifier
::
Token
->
Bool
isTokenIdentifier
(
Token
cat
_
)
=
elem
cat
[
Id
,
QId
,
Sym
,
QSym
,
Sym
_
Dot
,
Sym
_
Minus
,
Sym
_
MinusDot
]
elem
cat
[
Id
,
QId
,
Sym
,
QSym
,
Sym
Colon
,
Sym
Dot
,
SymMinus
,
SymMinusDot
]
-- DECL Position
...
...
@@ -714,7 +714,6 @@ token2string (Token Backquote _) = "`"
token2string
(
Token
VSemicolon
_
)
=
""
token2string
(
Token
VRightBrace
_
)
=
""
token2string
(
Token
At
_
)
=
"@"
token2string
(
Token
Colon
_
)
=
":"
token2string
(
Token
DotDot
_
)
=
".."
token2string
(
Token
DoubleColon
_
)
=
"::"
token2string
(
Token
Equals
_
)
=
"="
...
...
@@ -723,9 +722,10 @@ token2string (Token Bar _) = "|"
token2string
(
Token
LeftArrow
_
)
=
"<-"
token2string
(
Token
RightArrow
_
)
=
"->"
token2string
(
Token
Tilde
_
)
=
"~"
token2string
(
Token
Sym_Dot
_
)
=
"."
token2string
(
Token
Sym_Minus
_
)
=
"-"
token2string
(
Token
Sym_MinusDot
_
)
=
"-."
token2string
(
Token
SymColon
_
)
=
":"
token2string
(
Token
SymDot
_
)
=
"."
token2string
(
Token
SymMinus
_
)
=
"-"
token2string
(
Token
SymMinusDot
_
)
=
"-."
token2string
(
Token
KW_case
_
)
=
"case"
token2string
(
Token
KW_choice
_
)
=
"choice"
token2string
(
Token
KW_data
_
)
=
"data"
...
...
src/Modules.lhs
View file @
54dcdba2
...
...
@@ -20,7 +20,6 @@ This module controls the compilation of modules.
>
import
Data.List
(
find
,
isPrefixOf
,
partition
)
>
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
insertWith
,
lookup
,
toList
)
>
import
Data.Maybe
(
fromMaybe
)
>
import
System.IO
(
stderr
,
hPutStrLn
)
>
import
Text.PrettyPrint.HughesPJ
(
Doc
,
(
$$
),
text
,
vcat
)
>
import
qualified
Curry.AbstractCurry
as
AC
...
...
@@ -34,14 +33,14 @@ This module controls the compilation of modules.
>
import
qualified
Curry.IL
as
IL
>
import
Curry.Syntax
>
import
Base.Arity
(
ArityEnv
,
initAEnv
,
bindArities
)
>
import
Base.Eval
(
evalEnv
)
>
import
Base.Import
(
bindAlias
,
initIEnv
,
fromDeclList
)
>
import
Base.Module
(
ModuleEnv
)
>
import
Base.OpPrec
(
PEnv
,
initPEnv
)
>
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
initTCEnv
,
qualLookupTC
)
>
import
Base.Types
(
toType
,
fromQualType
)
>
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
),
initDCEnv
)
>
import
Base.Arity
(
ArityEnv
,
initAEnv
,
bindArities
)
>
import
Base.Import
(
bindAlias
,
initIEnv
)
>
import
Check.InterfaceCheck
(
interfaceCheck
)
>
import
Check.KindCheck
(
kindCheck
)
>
import
Check.SyntaxCheck
(
syntaxCheck
)
...
...
@@ -66,7 +65,7 @@ This module controls the compilation of modules.
>
import
CurryToIL
(
ilTrans
)
>
import
Exports
(
expandInterface
,
exportInterface
)
>
import
Imports
(
importInterface
,
importInterfaceIntf
,
importUnifyData
)
>
import
Messages
(
errorAt
,
internalError
)
>
import
Messages
(
errorAt
,
internalError
,
putErrsLn
)
>
import
Types
>
import
TypeSubst
...
...
@@ -94,7 +93,7 @@ as a frontend for PAKCS, all functions for evaluating goals and generating C
code are obsolete and commented out.
\begin{verbatim}
>
compileModule
::
Options
->
FilePath
->
IO
(
Maybe
FilePath
)
>
compileModule
::
Options
->
FilePath
->
IO
()
>
compileModule
opts
fn
=
do
>
-- read and parse module
>
parsed
<-
(
ok
.
parseModule
likeFlat
fn
)
`
liftM
`
readModule
fn
...
...
@@ -110,7 +109,7 @@ code are obsolete and commented out.
>
then
do
>
(
tyEnv
,
tcEnv
,
_
,
m'
,
_
,
_
)
<-
simpleCheckModule
opts
mEnv
m
>
-- generate untyped AbstractCurry
>
when
uacy
$
genAbstract
opts
fn
tyEnv
tcEnv
m'
>>
return
()
>
when
uacy
$
genAbstract
opts
fn
tyEnv
tcEnv
m'
>
-- output the parsed source
>
when
src
$
genParsed
opts
fn
m'
>
else
do
...
...
@@ -123,8 +122,8 @@ code are obsolete and commented out.
>
-- dump intermediate results
>
mapM_
(
doDump
opts
)
dumps
>
-- generate target code
>
when
(
acy
||
uacy
)
$
genAbstract
opts
fn
tyEnv
tcEnv
m'
>>
return
()
>
when
(
fcy
||
xml
)
$
genFlat
opts
fn
mEnv
tyEnv
tcEnv
aEnv'
intf
m'
il
>>
return
()
>
when
(
acy
||
uacy
)
$
genAbstract
opts
fn
tyEnv
tcEnv
m'
>
when
(
fcy
||
xml
)
$
genFlat
opts
fn
mEnv
tyEnv
tcEnv
aEnv'
intf
m'
il
>
when
src
$
genParsed
opts
fn
m'
>
where
>
acy
=
AbstractCurry
`
elem
`
optTargetTypes
opts
...
...
@@ -168,7 +167,7 @@ only a qualified import is added.
\begin{verbatim}
>
importPrelude
::
Options
->
FilePath
->
Module
->
Module
>
importPrelude
opts
fn
m
(
Module
mid
es
ds
)
>
importPrelude
opts
fn
m
@
(
Module
mid
es
ds
)
>
-- the Prelude itself
>
|
mid
==
preludeMIdent
=
m
>
-- disabled by option
...
...
@@ -183,15 +182,15 @@ only a qualified import is added.
>
False
-- qualified
>
Nothing
-- no alias
>
Nothing
-- no selection of types, functions, etc.
>
imported
=
[
imp
|
decl
@
(
ImportDecl
_
imp
_
_
_
)
<-
ds
]
>
imported
=
[
imp
|
(
ImportDecl
_
imp
_
_
_
)
<-
ds
]
>
-- |
>
simpleCheckModule
::
Options
->
ModuleEnv
->
Module
>
->
IO
(
ValueEnv
,
TCEnv
,
ArityEnv
,
Module
,
Interface
,
[
WarnMsg
])
>
simpleCheckModule
opts
mEnv
(
Module
m
es
ds
)
=
do
>
showWarnings
warnMsgs
>
return
(
tyEnv''
,
tcEnv
,
aEnv''
,
modul
,
intf
,
m
sgs
)
>
showWarnings
opts
warnMsgs
>
return
(
tyEnv''
,
tcEnv
,
aEnv''
,
modul
,
intf
,
warnM
sgs
)
>
where
>
-- split import declarations
>
(
impDs
,
topDs
)
=
partition
isImportDecl
ds
...
...
@@ -215,9 +214,9 @@ only a qualified import is added.
>
checkModule
::
Options
->
ModuleEnv
->
Module
>
->
IO
(
ValueEnv
,
TCEnv
,
ArityEnv
,
Module
,
Interface
,
[
WarnMsg
])
>
checkModule
opts
mEnv
(
Module
m
es
ds
)
=
do
>
showWarnings
warnMsgs
>
showWarnings
opts
warnMsgs
>
when
(
m
==
mkMIdent
[
"field114..."
])
(
error
(
show
es
))
>
return
(
tyEnv'''
,
tcEnv'
,
aEnv''
,
modul
,
intf
,
m
sgs
)
>
return
(
tyEnv'''
,
tcEnv'
,
aEnv''
,
modul
,
intf
,
warnM
sgs
)
>
where
>
(
impDs
,
topDs
)
=
partition
isImportDecl
ds
>
iEnv
=
foldr
bindAlias
initIEnv
impDs
...
...
@@ -338,21 +337,21 @@ content to a type environment.
>
where
r'
=
qualifyWith
m
(
fromRecordExtId
(
unqualify
r
))
>
importLabelType
_
_
_
lEnv
_
=
lEnv
>
>
insertLabelType
_
_
r
(
Just
(
ImportTypeAll
_
))
lEnv
([
l
],
ty
)
=
>
bindLabelType
l
r
(
toType
[]
ty
)
lEnv
>
insertLabelType
_
_
r
(
Just
(
ImportTypeWith
_
ls
))
lEnv
([
l
],
ty
)
>
|
l
`
elem
`
ls
=
bindLabelType
l
r
(
toType
[]
ty
)
lEnv
>
|
otherwise
=
lEnv
>
insertLabelType
_
_
_
_
lEnv
_
=
lEnv
>
insertLabelType
_
_
r
(
Just
(
ImportTypeAll
_
))
lEnv
([
l
],
ty
)
=
>
bindLabelType
l
r
(
toType
[]
ty
)
lEnv
>
insertLabelType
_
_
r
(
Just
(
ImportTypeWith
_
ls
))
lEnv
([
l
],
ty
)
>
|
l
`
elem
`
ls
=
bindLabelType
l
r
(
toType
[]
ty
)
lEnv
>
|
otherwise
=
lEnv
>
insertLabelType
_
_
_
_
lEnv
_
=
lEnv
>
>
getImportSpec
r
(
Just
(
Importing
_
is'
))
=
>
find
(
isImported
(
unqualify
r
))
is'
>
getImportSpec
r
Nothing
=
Just
(
ImportTypeAll
(
unqualify
r
))
>
getImportSpec
_
_
=
Nothing
>
getImportSpec
r
(
Just
(
Importing
_
is'
))
=
>
find
(
isImported
(
unqualify
r
))
is'
>
getImportSpec
r
Nothing
=
Just
(
ImportTypeAll
(
unqualify
r
))
>
getImportSpec
_
_
=
Nothing
>
>
isImported
r
(
Import
r'
)
=
r
==
r'
>
isImported
r
(
ImportTypeWith
r'
_
)
=
r
==
r'
>
isImported
r
(
ImportTypeAll
r'
)
=
r
==
r'
>
isImported
r
(
Import
r'
)
=
r
==
r'
>
isImported
r
(
ImportTypeWith
r'
_
)
=
r
==
r'
>
isImported
r
(
ImportTypeAll
r'
)
=
r
==
r'
>
addImportedLabels
::
ModuleIdent
->
LabelEnv
->
ValueEnv
->
ValueEnv
>
addImportedLabels
m
lEnv
tyEnv
=
...
...
@@ -484,7 +483,7 @@ Interface files are updated by the Curry builder when necessary.
>
writeFlatFile
::
Options
->
(
Prog
,
[
WarnMsg
])
->
String
->
IO
Prog
>
writeFlatFile
opts
(
res
,
msgs
)
fname
=
do
>
showWarnings
msgs
>
showWarnings
opts
msgs
>
when
extended
$
writeExtendedFlat
sub
fname
res
>
when
flat
$
writeFlatCurry
sub
fname
res
>
return
res
...
...
@@ -535,51 +534,43 @@ be dependent on it any longer.
\begin{verbatim}
>
genFlat
::
Options
->
FilePath
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
>
->
Interface
->
Module
->
IL
.
Module
->
IO
(
Maybe
FilePath
)
>
genFlat
opts
fname
mEnv
tyEnv
tcEnv
aEnv
intf
modul
il
>
|
FlatCurry
`
elem
`
optTargetTypes
opts
>
=
do
_
<-
writeFlat
opts
Nothing
fname
cEnv
mEnv
tyEnv
tcEnv
aEnv
il
>
let
(
flatInterface
,
intMsgs
)
=
genFlatInterface
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
il
>
if
optForce
opts
>
then
>
do
writeInterface
flatInterface
intMsgs
>
return
Nothing
>
else
>
do
mfint
<-
readFlatInterface
fintName
>
let
flatIntf
=
fromMaybe
emptyIntf
mfint
>
if
mfint
==
mfint
-- necessary to close the file 'fintName'
>
&&
not
(
interfaceCheck
flatIntf
flatInterface
)
>
then
>
do
writeInterface
flatInterface
intMsgs
>
return
Nothing
>
else
return
Nothing
>
|
FlatXml
`
elem
`
optTargetTypes
opts
>
=
writeXML
(
optUseSubdir
opts
)
(
optOutput
opts
)
fname
cEnv
il
>>
>
return
Nothing
>
|
otherwise
>
=
internalError
"@Modules.genFlat: illegal option"
>
where
>
fintName
=
flatIntName
fname
>
cEnv
=
curryEnv
mEnv
tcEnv
intf
modul
>
emptyIntf
=
Prog
""
[]
[]
[]
[]
>
writeInterface
intf'
msgs
=
do
>
when
(
optWarn
opts
)
(
printMessages
msgs
)
>
writeFlatCurry
(
optUseSubdir
opts
)
fintName
intf'
>
genAbstract
::
Options
->
FilePath
->
ValueEnv
->
TCEnv
->
Module
->
IO
(
Maybe
FilePath
)
>
genAbstract
opts
@
Options
{
optUseSubdir
=
sub
}
fname
tyEnv
tcEnv
modul
>
|
AbstractCurry
`
elem
`
optTargetTypes
opts
>
=
do
writeTypedAbs
sub
Nothing
fname
tyEnv
tcEnv
modul
>
return
Nothing
>
|
UntypedAbstractCurry
`
elem
`
optTargetTypes
opts
>
=
do
writeUntypedAbs
sub
Nothing
fname
tyEnv
tcEnv
modul
>
return
Nothing
>
|
otherwise
>
=
internalError
"@Modules.genAbstract: illegal option"
>
->
Interface
->
Module
->
IL
.
Module
->
IO
()
>
genFlat
opts
fname
mEnv
tyEnv
tcEnv
aEnv
intf
modul
il
=
do
>
when
fcy
$
do
>
_
<-
writeFlat
opts
Nothing
fname
cEnv
mEnv
tyEnv
tcEnv
aEnv
il
>
let
(
flatInterface
,
intMsgs
)
=
genFlatInterface
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
il
>
if
optForce
opts
>
then
writeInterface
flatInterface
intMsgs
>
else
do
>
mfint
<-
readFlatInterface
fintName
>
let
flatIntf
=
fromMaybe
emptyIntf
mfint
>
when
(
mfint
==
mfint
-- necessary to close the file 'fintName'
>
&&
not
(
interfaceCheck
flatIntf
flatInterface
))
$
>
writeInterface
flatInterface
intMsgs
>
when
xml
$
writeXML
(
optUseSubdir
opts
)
(
optOutput
opts
)
fname
cEnv
il
>
where
>
fcy
=
FlatCurry
`
elem
`
optTargetTypes
opts
>
xml
=
FlatXml
`
elem
`
optTargetTypes
opts
>
fintName
=
flatIntName
fname
>
cEnv
=
curryEnv
mEnv
tcEnv
intf
modul
>
emptyIntf
=
Prog
""
[]
[]
[]
[]
>
writeInterface
intf'
msgs
=
do
>
showWarnings
opts
msgs
>
writeFlatCurry
(
optUseSubdir
opts
)
fintName
intf'
>
genAbstract
::
Options
->
FilePath
->
ValueEnv
->
TCEnv
->
Module
->
IO
()
>
genAbstract
opts
fname
tyEnv
tcEnv
modul
=
do
>
when
acy
$
writeTypedAbs
subdir
Nothing
fname
tyEnv
tcEnv
modul
>
when
uacy
$
writeUntypedAbs
subdir
Nothing
fname
tyEnv
tcEnv
modul
>
where
>
subdir
=
optUseSubdir
opts
>
acy
=
AbstractCurry
`
elem
`
optTargetTypes
opts
>
uacy
=
UntypedAbstractCurry
`
elem
`
optTargetTypes
opts
>
genParsed
::
Options
->
FilePath
->
Module
->
IO
()
>
ge
t
Parsed
opts
fn
modul
=
writeModule
intoSubdir
outputFile
modString
>
ge
n
Parsed
opts
fn
modul
=
writeModule
intoSubdir
outputFile
modString
>
where
>
intoSubdir
=
optUseSubdir
opts
>
outputFile
=
fromMaybe
(
sourceRepName
fn
)
(
optOutput
opts
)
...
...
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