SyntaxCheck.lhs 47.3 KB
Newer Older
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1
2
3
4
5
6
% $Id: SyntaxCheck.lhs,v 1.53 2004/02/15 22:10:37 wlux Exp $
%
% Copyright (c) 1999-2004, Wolfgang Lux
% See LICENSE for the full license.
%
% Modified by Martin Engelke (men@informatik.uni-kiel.de)
Björn Peemöller 's avatar
Björn Peemöller committed
7
% Modified by Björn Peemöller (bjp@informatik.uni-kiel.de)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
8
9
10
%
\nwfilename{SyntaxCheck.lhs}
\section{Syntax Checks}
11
12
13
14
15
16
17
18
19
20
After the type declarations have been checked, the compiler performs a syntax
check on the remaining declarations. This check disambiguates nullary data
constructors and variables which -- in contrast to Haskell -- is not possible
on purely syntactic criteria. In addition, this pass checks for undefined as
well as ambiguous variables and constructors. In order to allow lifting of
local definitions in later phases, all local variables are renamed by adding a
key identifying their scope. Therefore, all variables defined in the same
scope share the same key so that multiple definitions can be recognized.
Finally, all (adjacent) equations of a function are merged into a single
definition.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
21
22
\begin{verbatim}

Björn Peemöller 's avatar
Björn Peemöller committed
23
> module Checks.SyntaxCheck (syntaxCheck) where
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
24

25
> import Control.Monad (liftM, liftM2, liftM3, unless, when)
Björn Peemöller 's avatar
Björn Peemöller committed
26
> import qualified Control.Monad.State as S (State, runState, gets, modify)
27
> import Data.List ((\\), insertBy, nub, partition)
Björn Peemöller 's avatar
Björn Peemöller committed
28
> import Data.Maybe (fromJust, isJust, isNothing, maybeToList)
Björn Peemöller 's avatar
Björn Peemöller committed
29
> import qualified Data.Set as Set (empty, insert, member)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
30
31

> import Curry.Base.Ident
Björn Peemöller 's avatar
Björn Peemöller committed
32
> import Curry.Base.Position
Björn Peemöller 's avatar
Björn Peemöller committed
33
> import Curry.Base.Pretty
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
34
> import Curry.Syntax
35
> import Curry.Syntax.Pretty (ppPattern)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
36

37
> import Base.Expr
38
> import Base.Messages (Message, posMessage, internalError)
Björn Peemöller 's avatar
Björn Peemöller committed
39
> import Base.NestEnv
Björn Peemöller 's avatar
Björn Peemöller committed
40
> import Base.Types
Björn Peemöller 's avatar
Björn Peemöller committed
41
> import Base.Utils ((++!), findDouble, findMultiples)
Björn Peemöller 's avatar
Björn Peemöller committed
42

43
> import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
Björn Peemöller 's avatar
Björn Peemöller committed
44
> import Env.Value (ValueEnv, ValueInfo (..))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
45

Björn Peemöller 's avatar
Björn Peemöller committed
46
47
> import CompilerOpts

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
48
49
50
51
\end{verbatim}
The syntax checking proceeds as follows. First, the compiler extracts
information about all imported values and data constructors from the
imported (type) environments. Next, the data constructors defined in
Björn Peemöller 's avatar
Björn Peemöller committed
52
the current module are entered into this environment. After this,
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
53
54
all record labels are entered into the environment too. If a record
identifier is already assigned to a constructor, then an error will be
55
56
generated. Finally, all declarations are checked within the resulting
environment. In addition, this process will also rename the local variables.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
57
58
\begin{verbatim}

59
60
> syntaxCheck :: Options -> ValueEnv -> TCEnv -> Module -> (Module, [Message])
> syntaxCheck opts tyEnv tcEnv mdl@(Module _ m _ _ ds) =
61
>   case findMultiples $ concatMap constrs typeDecls of
62
63
>     []  -> runSC (checkModule mdl) state
>     css -> (mdl, map errMultipleDataConstructor css)
Björn Peemöller 's avatar
Björn Peemöller committed
64
>   where
65
>     typeDecls  = filter isTypeDecl ds
66
>     rEnv       = globalEnv $ fmap (renameInfo tcEnv) tyEnv
67
>     state      = initState (optExtensions opts) m rEnv
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
68
69

\end{verbatim}
70
71
72
73
74
A global state transformer is used for generating fresh integer keys with
which the variables are renamed.
The state tracks the identifier of the current scope 'scopeId' as well as the
next fresh identifier, which is used for introducing new scopes as well as
renaming literals and underscore to disambiguate them.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
75
76
\begin{verbatim}

77
78
79
> -- |Syntax check monad
> type SCM = S.State SCState

80
> -- |Internal state of the syntax check
Björn Peemöller 's avatar
Björn Peemöller committed
81
> data SCState = SCState
82
83
84
85
86
87
>   { extensions  :: [KnownExtension] -- ^ Enabled language extensions
>   , moduleIdent :: ModuleIdent      -- ^ 'ModuleIdent' of the current module
>   , renameEnv   :: RenameEnv        -- ^ Information store
>   , scopeId     :: Integer          -- ^ Identifier for the current scope
>   , nextId      :: Integer          -- ^ Next fresh identifier
>   , errors      :: [Message]        -- ^ Syntactic errors in the module
Björn Peemöller 's avatar
Björn Peemöller committed
88
89
>   }

90
> -- |Initial syntax check state
91
> initState :: [KnownExtension] -> ModuleIdent -> RenameEnv -> SCState
92
> initState exts m rEnv = SCState exts m rEnv globalScopeId 1 []
Björn Peemöller 's avatar
Björn Peemöller committed
93

94
95
> -- |Identifier for global (top-level) declarations
> globalScopeId :: Integer
96
> globalScopeId = idUnique (mkIdent "")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
97

98
> -- |Run the syntax check monad
Björn Peemöller 's avatar
Björn Peemöller committed
99
100
> runSC :: SCM a -> SCState -> (a, [Message])
> runSC scm s = let (a, s') = S.runState scm s in (a, reverse $ errors s')
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
101

102
> -- |Check for an enabled extension
103
> hasExtension :: KnownExtension -> SCM Bool
Björn Peemöller 's avatar
Björn Peemöller committed
104
> hasExtension ext = S.gets (elem ext . extensions)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
105

106
> -- |Enable an additional 'Extension' to avoid redundant complaints about
107
> -- missing extensions
108
> enableExtension :: KnownExtension -> SCM ()
109
> enableExtension e = S.modify $ \ s -> s { extensions = e : extensions s }
110

111
> -- |Retrieve the 'ModuleIdent' of the current module
Björn Peemöller 's avatar
Björn Peemöller committed
112
113
114
> getModuleIdent :: SCM ModuleIdent
> getModuleIdent = S.gets moduleIdent

115
> -- |Retrieve the 'RenameEnv'
Björn Peemöller 's avatar
Björn Peemöller committed
116
117
118
> getRenameEnv :: SCM RenameEnv
> getRenameEnv = S.gets renameEnv

119
> -- |Modify the 'RenameEnv'
Björn Peemöller 's avatar
Björn Peemöller committed
120
121
122
> modifyRenameEnv :: (RenameEnv -> RenameEnv) -> SCM ()
> modifyRenameEnv f = S.modify $ \ s -> s { renameEnv = f $ renameEnv s }

123
124
125
> -- |Retrieve the current scope identifier
> getScopeId :: SCM Integer
> getScopeId = S.gets scopeId
126

127
> -- |Create a new identifier and return it
128
> newId :: SCM Integer
129
130
131
132
> newId = do
>   curId <- S.gets nextId
>   S.modify $ \ s -> s { nextId = succ curId }
>   return curId
133

134
135
136
137
138
139
140
141
> -- |Increase the nesting of the 'RenameEnv' to introduce a new local scope.
> -- This also increases the scope identifier.
> incNesting :: SCM ()
> incNesting = do
>   newScopeId <- newId
>   S.modify $ \ s -> s { scopeId = newScopeId }
>   modifyRenameEnv nestEnv

142
143
> withLocalEnv :: SCM a -> SCM a
> withLocalEnv act = do
Björn Peemöller 's avatar
Björn Peemöller committed
144
>   oldEnv <- getRenameEnv
145
>   res    <- act
Björn Peemöller 's avatar
Björn Peemöller committed
146
147
148
>   modifyRenameEnv $ const oldEnv
>   return res

149
150
151
152
153
> -- |Perform an action in a nested scope (by creating a nested 'RenameEnv')
> -- and discard the nested 'RenameEnv' afterwards
> inNestedScope :: SCM a -> SCM a
> inNestedScope act = withLocalEnv (incNesting >> act)

154
> -- |Report a syntax error
Björn Peemöller 's avatar
Björn Peemöller committed
155
156
> report :: Message -> SCM ()
> report msg = S.modify $ \ s -> s { errors = msg : errors s }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
157

158
159
160
> ok :: SCM ()
> ok = return ()

Björn Peemöller 's avatar
Björn Peemöller committed
161
\end{verbatim}
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
162
163
164
165
166
167
168
169
A nested environment is used for recording information about the data
constructors and variables in the module. For every data constructor
its arity is saved. This is used for checking that all constructor
applications in patterns are saturated. For local variables the
environment records the new name of the variable after renaming.
Global variables are recorded with qualified identifiers in order
to distinguish multiply declared entities.

170
Currently, records must explicitly be declared together with their labels.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
171
172
173
174
175
176
177
178
179
180
When constructing or updating a record, it is necessary to compute
all its labels using just one of them. Thus for each label
the record identifier and all its labels are entered into the environment

\em{Note:} the function \texttt{qualLookupVar} has been extended to
allow the usage of the qualified list constructor \texttt{(prelude.:)}.
\begin{verbatim}

> type RenameEnv = NestEnv RenameInfo

Björn Peemöller 's avatar
Björn Peemöller committed
181
> data RenameInfo
182
>   -- |Arity of data constructor
183
>   = Constr QualIdent Int
184
185
186
>   -- |Record type and all labels for a single record label
>   | RecordLabel QualIdent [Ident]
>   -- |Arity of global function
187
>   | GlobalVar QualIdent Int
188
>   -- |Arity of local function
189
>   | LocalVar Ident Int
Björn Peemöller 's avatar
Björn Peemöller committed
190
>     deriving (Eq, Show)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
191

192
193
194
195
196
197
> ppRenameInfo :: RenameInfo -> Doc
> ppRenameInfo (Constr      qn _) = text (escQualName qn)
> ppRenameInfo (RecordLabel qn _) = text (escQualName qn)
> ppRenameInfo (GlobalVar   qn _) = text (escQualName qn)
> ppRenameInfo (LocalVar     n _) = text (escName      n)

198
199
200
201
202
203
\end{verbatim}
Since record types are currently translated into data types, it is necessary
to ensure that all identifiers for records and constructors are different.
Furthermore, it is not allowed to declare a label more than once.
\begin{verbatim}

204
> renameInfo :: TCEnv -> ValueInfo -> RenameInfo
205
206
207
208
> renameInfo _     (DataConstructor    qid a _) = Constr    qid a
> renameInfo _     (NewtypeConstructor qid   _) = Constr    qid 1
> renameInfo _     (Value              qid a _) = GlobalVar qid a
> renameInfo tcEnv (Label              _   r _) = case qualLookupTC r tcEnv of
Björn Peemöller 's avatar
Björn Peemöller committed
209
>   [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r $ map fst fs
210
>   _ -> internalError $ "SyntaxCheck.renameInfo: ambiguous record " ++ show r
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
211

Björn Peemöller 's avatar
Björn Peemöller committed
212
213
214
215
216
217
218
219
> bindGlobal :: ModuleIdent -> Ident -> RenameInfo -> RenameEnv -> RenameEnv
> bindGlobal m c r = bindNestEnv c r . qualBindNestEnv (qualifyWith m c) r

> bindLocal :: Ident -> RenameInfo -> RenameEnv -> RenameEnv
> bindLocal = bindNestEnv

------------------------------------------------------------------------------

220
> -- |Bind type constructor information
Björn Peemöller 's avatar
Björn Peemöller committed
221
222
223
224
225
226
227
228
229
230
231
232
233
234
> bindTypeDecl :: Decl -> SCM ()
> bindTypeDecl (DataDecl    _ _ _ cs) = mapM_ bindConstr cs
> bindTypeDecl (NewtypeDecl _ _ _ nc) = bindNewConstr nc
> bindTypeDecl (TypeDecl _ t _ (RecordType fs _)) = do
>   m <- getModuleIdent
>   others <- qualLookupVar (qualifyWith m t) `liftM` getRenameEnv
>   when (any isConstr others) $ report $ errIllegalRecordId t
>   mapM_ (bindRecordLabel t allLabels) allLabels
>   where allLabels = concatMap fst fs
> bindTypeDecl _ = return ()

> bindConstr :: ConstrDecl -> SCM ()
> bindConstr (ConstrDecl _ _ c tys) = do
>   m <- getModuleIdent
235
>   modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) $ length tys)
Björn Peemöller 's avatar
Björn Peemöller committed
236
237
> bindConstr (ConOpDecl _ _ _ op _) = do
>   m <- getModuleIdent
238
>   modifyRenameEnv $ bindGlobal m op (Constr (qualifyWith m op) 2)
Björn Peemöller 's avatar
Björn Peemöller committed
239
240
241
242

> bindNewConstr :: NewConstrDecl -> SCM ()
> bindNewConstr (NewConstrDecl _ _ c _) = do
>   m <- getModuleIdent
243
>   modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) 1)
Björn Peemöller 's avatar
Björn Peemöller committed
244
245
246
247
248
249
250

> bindRecordLabel :: Ident -> [Ident] -> Ident -> SCM ()
> bindRecordLabel t allLabels l = do
>   m <- getModuleIdent
>   new <- (null . lookupVar l) `liftM` getRenameEnv
>   unless new $ report $ errDuplicateDefinition l
>   modifyRenameEnv $ bindGlobal m l (RecordLabel (qualifyWith m t) allLabels)
Björn Peemöller 's avatar
Björn Peemöller committed
251
252
253
254

------------------------------------------------------------------------------

> -- |Bind a global function declaration in the 'RenameEnv'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
255
> bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv
256
257
258
259
260
261
262
263
264
265
> bindFuncDecl _ (FunctionDecl _ _ []) _
>   = internalError "SyntaxCheck.bindFuncDecl: no equations"
> bindFuncDecl m (FunctionDecl _ f (eq:_)) env
>   = let arty = length $ snd $ getFlatLhs eq
>     in  bindGlobal m f (GlobalVar (qualifyWith m f) arty) env
> bindFuncDecl m (ForeignDecl _ _ _ f ty) env
>   = let arty = typeArity ty
>     in bindGlobal m f (GlobalVar (qualifyWith m f) arty) env
> bindFuncDecl m (TypeSig _ fs ty) env
>   = foldr bindTS env $ map (qualifyWith m) fs
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
266
>  where
267
268
269
>  bindTS qf env'
>   | null $ qualLookupVar qf env'
>   = bindGlobal m (unqualify qf) (GlobalVar qf (typeArity ty)) env'
270
271
>   | otherwise
>   = env'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
272
273
> bindFuncDecl _ _ env = env

Björn Peemöller 's avatar
Björn Peemöller committed
274
275
276
------------------------------------------------------------------------------

> -- |Bind a local declaration (function, variables) in the 'RenameEnv'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
277
> bindVarDecl :: Decl -> RenameEnv -> RenameEnv
Björn Peemöller 's avatar
Björn Peemöller committed
278
279
280
> bindVarDecl (FunctionDecl _ f eqs) env
>   | null eqs  = internalError "SyntaxCheck.bindVarDecl: no equations"
>   | otherwise = let arty = length $ snd $ getFlatLhs $ head eqs
281
>                 in  bindLocal (unRenameIdent f) (LocalVar f arty) env
Björn Peemöller 's avatar
Björn Peemöller committed
282
> bindVarDecl (PatternDecl         _ t _) env = foldr bindVar env (bv t)
283
> bindVarDecl (FreeDecl             _ vs) env = foldr bindVar env vs
Björn Peemöller 's avatar
Björn Peemöller committed
284
> bindVarDecl _                           env = env
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
285
286

> bindVar :: Ident -> RenameEnv -> RenameEnv
Björn Peemöller 's avatar
Björn Peemöller committed
287
> bindVar v | isAnonId v = id
288
>           | otherwise  = bindLocal (unRenameIdent v) (LocalVar v 0)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
289
290
291
292
293

> lookupVar :: Ident -> RenameEnv -> [RenameInfo]
> lookupVar v env = lookupNestEnv v env ++! lookupTupleConstr v

> qualLookupVar :: QualIdent -> RenameEnv -> [RenameInfo]
Björn Peemöller 's avatar
Björn Peemöller committed
294
295
296
> qualLookupVar v env =  qualLookupNestEnv v env
>                    ++! qualLookupListCons v env
>                    ++! lookupTupleConstr (unqualify v)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
297
298
299

> lookupTupleConstr :: Ident -> [RenameInfo]
> lookupTupleConstr v
300
301
>   | isTupleId v = let a = tupleArity v
>                   in  [Constr (qualifyWith preludeMIdent $ tupleId a) a]
Björn Peemöller 's avatar
Björn Peemöller committed
302
303
304
305
306
>   | otherwise   = []

> qualLookupListCons :: QualIdent -> RenameEnv -> [RenameInfo]
> qualLookupListCons v env
>   | v == qualifyWith preludeMIdent consId
307
>   = qualLookupNestEnv (qualify $ qidIdent v) env
Björn Peemöller 's avatar
Björn Peemöller committed
308
309
>   | otherwise
>   = []
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
310
311
312
313
314
315
316
317

\end{verbatim}
When a module is checked, the global declaration group is checked. The
resulting renaming environment can be discarded. The same is true for
a goal. Note that all declarations in the goal must be considered as
local declarations.
\begin{verbatim}

318
319
320
> checkModule :: Module -> SCM Module
> checkModule (Module ps m es is decls) = do
>   mapM_ checkPragma ps
Björn Peemöller 's avatar
Björn Peemöller committed
321
>   mapM_ bindTypeDecl (rds ++ dds)
322
323
>   decls' <- liftM2 (++) (mapM checkTypeDecl tds) (checkTopDecls vds)
>   return $ Module ps m es is decls'
Björn Peemöller 's avatar
Björn Peemöller committed
324
>   where (tds, vds) = partition isTypeDecl decls
Björn Peemöller 's avatar
Björn Peemöller committed
325
>         (rds, dds) = partition isRecordDecl tds
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
326

327
328
329
330
331
332
333
334
> checkPragma :: ModulePragma -> SCM ()
> checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts
> checkPragma (OptionsPragma  _  _ _) = ok

> checkExtension :: Extension -> SCM ()
> checkExtension (KnownExtension   _ e) = enableExtension e
> checkExtension (UnknownExtension p e) = report $ errUnknownExtension p e

Björn Peemöller 's avatar
Björn Peemöller committed
335
336
> checkTypeDecl :: Decl -> SCM Decl
> checkTypeDecl rec@(TypeDecl _ r _ (RecordType fs rty)) = do
337
>   checkRecordExtension $ idPosition r
Björn Peemöller 's avatar
Björn Peemöller committed
338
>   when (isJust  rty) $ internalError
339
>                        "SyntaxCheck.checkTypeDecl: illegal record type"
340
>   when (null     fs) $ report $ errEmptyRecord $ idPosition r
Björn Peemöller 's avatar
Björn Peemöller committed
341
342
>   return rec
> checkTypeDecl d = return d
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
343

Björn Peemöller 's avatar
Björn Peemöller committed
344
345
346
347
> checkTopDecls :: [Decl] -> SCM [Decl]
> checkTopDecls decls = do
>   m <- getModuleIdent
>   checkDeclGroup (bindFuncDecl m) decls
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365

\end{verbatim}
Each declaration group opens a new scope and uses a distinct key
for renaming the variables in this scope. In a declaration group,
first the left hand sides of all declarations are checked, next the
compiler checks that there is a definition for every type signature
and evaluation annotation in this group. Finally, the right hand sides
are checked and adjacent equations for the same function are merged
into a single definition.

The function \texttt{checkDeclLhs} also handles the case where a
pattern declaration is recognized as a function declaration by the
parser. This happens, e.g., for the declaration \verb|where Just x = y|
because the parser cannot distinguish nullary constructors and
functions. Note that pattern declarations are not allowed on the
top-level.
\begin{verbatim}

Björn Peemöller 's avatar
Björn Peemöller committed
366
367
368
369
370
371
> checkDeclGroup :: (Decl -> RenameEnv -> RenameEnv) -> [Decl] -> SCM [Decl]
> checkDeclGroup bindDecl ds = do
>   checkedLhs <- mapM checkDeclLhs $ sortFuncDecls ds
>   joinEquations checkedLhs >>= checkDecls bindDecl

> checkDeclLhs :: Decl -> SCM Decl
372
> checkDeclLhs (InfixDecl   p fix' pr ops) =
373
>   liftM2 (InfixDecl p fix') (checkPrecedence p pr) (mapM renameVar ops)
374
375
376
377
> checkDeclLhs (TypeSig           p vs ty) =
>   (\vs' -> TypeSig p vs' ty) `liftM` mapM (checkVar "type signature") vs
> checkDeclLhs (FunctionDecl      p _ eqs) =
>   checkEquationsLhs p eqs
378
> checkDeclLhs (ForeignDecl  p cc ie f ty) =
379
380
381
>   (\f' -> ForeignDecl p cc ie f' ty) `liftM` checkVar "foreign declaration" f
> checkDeclLhs (    ExternalDecl     p fs) =
>   ExternalDecl p `liftM` mapM (checkVar "external declaration") fs
382
> checkDeclLhs (PatternDecl       p t rhs) =
383
384
385
>     (\t' -> PatternDecl p t' rhs) `liftM` checkPattern p t
> checkDeclLhs (FreeDecl             p vs) =
>   FreeDecl p `liftM` mapM (checkVar "free variables declaration") vs
Björn Peemöller 's avatar
Björn Peemöller committed
386
387
> checkDeclLhs d                           = return d

388
389
390
391
392
> checkPrecedence :: Position -> Integer -> SCM Integer
> checkPrecedence p i = do
>   unless (0 <= i && i <= 9) $ report $ errPrecedenceOutOfRange p i
>   return i

Björn Peemöller 's avatar
Björn Peemöller committed
393
394
395
396
> checkVar :: String -> Ident -> SCM Ident
> checkVar _what v = do
>   -- isDC <- S.gets (isDataConstr v . renameEnv)
>   -- when isDC $ report $ nonVariable what v -- TODO Why is this disabled?
397
398
399
400
>   renameVar v

> renameVar :: Ident -> SCM Ident
> renameVar v = renameIdent v `liftM` getScopeId
Björn Peemöller 's avatar
Björn Peemöller committed
401

402
403
> checkEquationsLhs :: Position -> [Equation] -> SCM Decl
> checkEquationsLhs p [Equation p' lhs rhs] = do
Björn Peemöller 's avatar
Björn Peemöller committed
404
405
406
407
>   lhs' <- checkEqLhs p' lhs
>   case lhs' of
>     Left  l -> return $ funDecl l
>     Right r -> patDecl r >>= checkDeclLhs
408
>   where funDecl (f, lhs') = FunctionDecl p f [Equation p' lhs' rhs]
Björn Peemöller 's avatar
Björn Peemöller committed
409
>         patDecl t = do
410
411
>           k <- getScopeId
>           when (k == globalScopeId) $ report $ errToplevelPattern p
Björn Peemöller 's avatar
Björn Peemöller committed
412
>           return $ PatternDecl p' t rhs
413
> checkEquationsLhs _ _ = internalError "SyntaxCheck.checkEquationsLhs"
Björn Peemöller 's avatar
Björn Peemöller committed
414

415
> checkEqLhs :: Position -> Lhs -> SCM (Either (Ident, Lhs) Pattern)
Björn Peemöller 's avatar
Björn Peemöller committed
416
417
> checkEqLhs p toplhs = do
>   m   <- getModuleIdent
418
>   k   <- getScopeId
Björn Peemöller 's avatar
Björn Peemöller committed
419
420
421
422
>   env <- getRenameEnv
>   case toplhs of
>     FunLhs f ts
>       | not $ isDataConstr f env -> return left
423
>       | k /= globalScopeId       -> return right
Björn Peemöller 's avatar
Björn Peemöller committed
424
425
426
427
428
429
430
431
432
>       | null infos               -> return left
>       | otherwise                -> do report $ errToplevelPattern p
>                                        return right
>       where f'    = renameIdent f k
>             infos = qualLookupVar (qualifyWith m f) env
>             left  = Left  (f', FunLhs f' ts)
>             right = Right $ ConstructorPattern (qualify f) ts
>     OpLhs t1 op t2
>       | not $ isDataConstr op env -> return left
433
>       | k /= globalScopeId        -> return right
Björn Peemöller 's avatar
Björn Peemöller committed
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
>       | null infos                -> return left
>       | otherwise                 -> do report $ errToplevelPattern p
>                                         return right
>       where op'   = renameIdent op k
>             infos = qualLookupVar (qualifyWith m op) env
>             left  = Left (op', OpLhs t1 op' t2)
>             right = checkOpLhs k env (infixPattern t1 (qualify op)) t2
>             infixPattern (InfixPattern t1' op1 t2') op2 t3 =
>               InfixPattern t1' op1 (infixPattern t2' op2 t3)
>             infixPattern t1' op1 t2' = InfixPattern t1' op1 t2'
>     ApLhs lhs ts -> do
>       checked <- checkEqLhs p lhs
>       case checked of
>         Left (f', lhs') -> return $ Left (f', ApLhs lhs' ts)
>         r               -> do report $ errNonVariable "curried definition" f
>                               return $ r
>         where (f, _) = flatLhs lhs
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
451

452
453
> checkOpLhs :: Integer -> RenameEnv -> (Pattern -> Pattern)
>            -> Pattern -> Either (Ident, Lhs) Pattern
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
454
> checkOpLhs k env f (InfixPattern t1 op t2)
Björn Peemöller 's avatar
Björn Peemöller committed
455
456
457
458
>   | isJust m || isDataConstr op' env
>   = checkOpLhs k env (f . InfixPattern t1 op) t2
>   | otherwise
>   = Left (op'', OpLhs (f t1) op'' t2)
459
>   where (m,op') = (qidModule op, qidIdent op)
Björn Peemöller 's avatar
Björn Peemöller committed
460
>         op''    = renameIdent op' k
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
461
462
> checkOpLhs _ _ f t = Right (f t)

Björn Peemöller 's avatar
Björn Peemöller committed
463
464
465
466
-- ---------------------------------------------------------------------------

> joinEquations :: [Decl] -> SCM [Decl]
> joinEquations [] = return []
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
467
> joinEquations (FunctionDecl p f eqs : FunctionDecl _ f' [eq] : ds)
Björn Peemöller 's avatar
Björn Peemöller committed
468
>   | f == f' = do
469
>     when (getArity (head eqs) /= getArity eq) $ report $ errDifferentArity [f, f']
Björn Peemöller 's avatar
Björn Peemöller committed
470
471
472
473
>     joinEquations (FunctionDecl p f (eqs ++ [eq]) : ds)
>   where getArity = length . snd . getFlatLhs
> joinEquations (d : ds) = (d :) `liftM` joinEquations ds

474
> checkDecls :: (Decl -> RenameEnv -> RenameEnv) -> [Decl] -> SCM [Decl]
Björn Peemöller 's avatar
Björn Peemöller committed
475
> checkDecls bindDecl ds = do
476
>   let dblVar = findDouble bvs
Björn Peemöller 's avatar
Björn Peemöller committed
477
>   onJust (report . errDuplicateDefinition) dblVar
478
479
480
481
482
>   let mulTys = findMultiples tys
>   mapM_ (report . errDuplicateTypeSig) mulTys
>   let missingTys = [f | ExternalDecl _ fs' <- ds, f <- fs', f `notElem` tys]
>   mapM_ (report . errNoTypeSig) missingTys
>   if isNothing dblVar && null mulTys && null missingTys
Björn Peemöller 's avatar
Björn Peemöller committed
483
484
485
486
487
488
489
490
491
>     then do
>       modifyRenameEnv $ \env -> foldr bindDecl env (tds ++ vds)
>       mapM (checkDeclRhs bvs) ds
>     else return ds -- skip further checking
>   where vds    = filter isValueDecl ds
>         tds    = filter isTypeSig ds
>         bvs    = concatMap vars vds
>         tys    = concatMap vars tds
>         onJust = maybe (return ())
Björn Peemöller 's avatar
Björn Peemöller committed
492
493
494
495

-- ---------------------------------------------------------------------------

> checkDeclRhs :: [Ident] -> Decl -> SCM Decl
496
497
> checkDeclRhs bvs (TypeSig      p vs ty) =
>   (\vs' -> TypeSig p vs' ty) `liftM` mapM (checkLocalVar bvs) vs
Björn Peemöller 's avatar
Björn Peemöller committed
498
499
500
501
502
503
504
505
506
507
508
509
> checkDeclRhs _   (FunctionDecl p f eqs) =
>   FunctionDecl p f `liftM` mapM checkEquation eqs
> checkDeclRhs _   (PatternDecl  p t rhs) =
>   PatternDecl p t `liftM` checkRhs rhs
> checkDeclRhs _   d                      = return d

> checkLocalVar :: [Ident] -> Ident -> SCM Ident
> checkLocalVar bvs v = do
>   when (v `notElem` bvs) $ report $ errNoBody v
>   return v

> checkEquation :: Equation -> SCM Equation
510
> checkEquation (Equation p lhs rhs) = inNestedScope $ do
511
>   lhs' <- checkLhs p lhs >>= addBoundVariables False
Björn Peemöller 's avatar
Björn Peemöller committed
512
513
514
515
>   rhs' <- checkRhs rhs
>   return $ Equation p lhs' rhs'

> checkLhs :: Position -> Lhs -> SCM Lhs
516
> checkLhs p (FunLhs    f ts) = FunLhs f `liftM` mapM (checkPattern p) ts
Björn Peemöller 's avatar
Björn Peemöller committed
517
> checkLhs p (OpLhs t1 op t2) = do
518
>   let wrongCalls = concatMap (checkParenPattern (Just $ qualify op)) [t1,t2]
519
>   unless (null wrongCalls) $ report $ errInfixWithoutParens
520
>     (idPosition op) wrongCalls
521
>   liftM2 (flip OpLhs op) (checkPattern p t1) (checkPattern p t2)
Björn Peemöller 's avatar
Björn Peemöller committed
522
> checkLhs p (ApLhs   lhs ts) =
523
>   liftM2 ApLhs (checkLhs p lhs) (mapM (checkPattern p) ts)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
524

Björn Peemöller 's avatar
Björn Peemöller committed
525
526
checkParen
@param Aufrufende InfixFunktion
527
@param Pattern
Björn Peemöller 's avatar
Björn Peemöller committed
528
529
530
@return Liste mit fehlerhaften Funktionsaufrufen
\begin{verbatim}

531
532
533
534
535
536
537
> checkParenPattern :: (Maybe QualIdent) -> Pattern -> [(QualIdent,QualIdent)]
> checkParenPattern _ (LiteralPattern          _) = []
> checkParenPattern _ (NegativePattern       _ _) = []
> checkParenPattern _ (VariablePattern         _) = []
> checkParenPattern _ (ConstructorPattern   _ cs) =
>   concatMap (checkParenPattern Nothing) cs
> checkParenPattern o (InfixPattern     t1 op t2) =
Björn Peemöller 's avatar
Björn Peemöller committed
538
>   maybe [] (\c -> [(c, op)]) o
539
540
541
542
543
544
545
546
547
548
549
550
551
552
>   ++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2
> checkParenPattern _ (ParenPattern            t) =
>   checkParenPattern Nothing t
> checkParenPattern _ (TuplePattern         _ ts) =
>   concatMap (checkParenPattern Nothing) ts
> checkParenPattern _ (ListPattern          _ ts) =
>   concatMap (checkParenPattern Nothing) ts
> checkParenPattern o (AsPattern             _ t) =
>   checkParenPattern o t
> checkParenPattern o (LazyPattern           _ t) =
>   checkParenPattern o t
> checkParenPattern _ (FunctionPattern      _ ts) =
>   concatMap (checkParenPattern Nothing) ts
> checkParenPattern o (InfixFuncPattern t1 op t2) =
Björn Peemöller 's avatar
Björn Peemöller committed
553
>   maybe [] (\c -> [(c, op)]) o
554
555
556
557
>   ++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2
> checkParenPattern _ (RecordPattern        fs t) =
>     maybe [] (checkParenPattern Nothing) t
>     ++ concatMap (\(Field _ _ t') -> checkParenPattern Nothing t') fs
Björn Peemöller 's avatar
Björn Peemöller committed
558

559
560
> checkPattern :: Position -> Pattern -> SCM Pattern
> checkPattern _ (LiteralPattern        l) =
Björn Peemöller 's avatar
Björn Peemöller committed
561
>   LiteralPattern `liftM` renameLiteral l
562
> checkPattern _ (NegativePattern    op l) =
Björn Peemöller 's avatar
Björn Peemöller committed
563
>   NegativePattern op `liftM` renameLiteral l
564
> checkPattern p (VariablePattern       v)
565
566
>   | isAnonId v = (VariablePattern . renameIdent v) `liftM` newId
>   | otherwise  = checkConstructorPattern p (qualify v) []
567
> checkPattern p (ConstructorPattern c ts) =
Björn Peemöller 's avatar
Björn Peemöller committed
568
>   checkConstructorPattern p c ts
569
> checkPattern p (InfixPattern   t1 op t2) =
Björn Peemöller 's avatar
Björn Peemöller committed
570
>   checkInfixPattern p t1 op t2
571
572
573
574
575
576
577
578
579
580
581
> checkPattern p (ParenPattern          t) =
>   ParenPattern `liftM` checkPattern p t
> checkPattern p (TuplePattern     pos ts) =
>   TuplePattern pos `liftM` mapM (checkPattern p) ts
> checkPattern p (ListPattern      pos ts) =
>   ListPattern pos `liftM` mapM (checkPattern p) ts
> checkPattern p (AsPattern           v t) = do
>   liftM2 AsPattern (checkVar "@ pattern" v) (checkPattern p t)
> checkPattern p (LazyPattern       pos t) =
>   LazyPattern pos `liftM` checkPattern p t
> checkPattern p (RecordPattern      fs t) =
Björn Peemöller 's avatar
Björn Peemöller committed
582
>   checkRecordPattern p fs t
583
584
585
586
> checkPattern _ (FunctionPattern     _ _) = internalError $
>   "SyntaxCheck.checkPattern: function pattern not defined"
> checkPattern _ (InfixFuncPattern  _ _ _) = internalError $
>   "SyntaxCheck.checkPattern: infix function pattern not defined"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
587

588
589
> checkConstructorPattern :: Position -> QualIdent -> [Pattern]
>                         -> SCM Pattern
Björn Peemöller 's avatar
Björn Peemöller committed
590
591
592
> checkConstructorPattern p c ts = do
>   env <- getRenameEnv
>   m <- getModuleIdent
593
>   k <- getScopeId
Björn Peemöller 's avatar
Björn Peemöller committed
594
>   case qualLookupVar c env of
595
596
>     [Constr _ n] -> processCons c n
>     [r]          -> processVarFun r k
Björn Peemöller 's avatar
Björn Peemöller committed
597
>     rs -> case qualLookupVar (qualQualify m c) env of
598
599
>       [Constr _ n] -> processCons (qualQualify m c) n
>       [r]          -> processVarFun r k
Björn Peemöller 's avatar
Björn Peemöller committed
600
601
>       []
>         | null ts && not (isQualified c) ->
Björn Peemöller 's avatar
Björn Peemöller committed
602
>             return $ VariablePattern $ renameIdent (unqualify c) k
Björn Peemöller 's avatar
Björn Peemöller committed
603
>         | null rs -> do
604
>             ts' <- mapM (checkPattern p) ts
Björn Peemöller 's avatar
Björn Peemöller committed
605
>             report $ errUndefinedData c
606
607
>             return $ ConstructorPattern c ts'
>       _ -> do ts' <- mapM (checkPattern p) ts
608
>               report $ errAmbiguousData rs c
609
>               return $ ConstructorPattern c ts'
610
611
612
613
>   where
>   n' = length ts
>   processCons qc n = do
>     when (n /= n') $ report $ errWrongArity c n n'
614
>     ConstructorPattern qc `liftM` mapM (checkPattern p) ts
Björn Peemöller 's avatar
Björn Peemöller committed
615
616
617
618
619
620
621
>   processVarFun r k
>     | null ts && not (isQualified c)
>     = return $ VariablePattern $ renameIdent (unqualify c) k -- (varIdent r) k
>     | otherwise = do
>       let n = arity r
>       checkFuncPatsExtension p
>       ts' <- mapM (checkPattern p) ts
622
>       mapM_ (checkFPTerm p) ts'
Björn Peemöller 's avatar
Björn Peemöller committed
623
624
625
626
627
>       return $ if n' > n
>                  then let (ts1, ts2) = splitAt n ts'
>                       in  genFuncPattAppl
>                           (FunctionPattern (qualVarIdent r) ts1) ts2
>                  else FunctionPattern (qualVarIdent r) ts'
Björn Peemöller 's avatar
Björn Peemöller committed
628

629
630
> checkInfixPattern :: Position -> Pattern -> QualIdent -> Pattern
>                   -> SCM Pattern
Björn Peemöller 's avatar
Björn Peemöller committed
631
632
633
634
> checkInfixPattern p t1 op t2 = do
>   m <- getModuleIdent
>   env <- getRenameEnv
>   case qualLookupVar op env of
635
636
637
638
>     [Constr _ n] -> infixPattern op n
>     [_]          -> funcPattern  op
>     rs           -> case qualLookupVar (qualQualify m op) env of
>       [Constr _ n] -> infixPattern (qualQualify m op) n
639
640
641
>       [_]          -> funcPattern  (qualQualify m op)
>       rs'          -> do if (null rs && null rs')
>                             then report $ errUndefinedData op
642
>                             else report $ errAmbiguousData rs op
643
644
>                          liftM2 (flip InfixPattern op) (checkPattern p t1)
>                                                        (checkPattern p t2)
645
646
647
>   where
>   infixPattern qop n = do
>     when (n /= 2) $ report $ errWrongArity op n 2
648
649
>     liftM2 (flip InfixPattern qop) (checkPattern p t1)
>                                    (checkPattern p t2)
650
651
>   funcPattern qop = do
>     checkFuncPatsExtension p
652
653
654
>     ts'@[t1',t2'] <- mapM (checkPattern p) [t1,t2]
>     mapM_ (checkFPTerm p) ts'
>     return $ InfixFuncPattern t1' qop t2'
655

656
657
> checkRecordPattern :: Position -> [Field Pattern]
>                    -> (Maybe Pattern) -> SCM Pattern
Björn Peemöller 's avatar
Björn Peemöller committed
658
659
660
> checkRecordPattern p fs t = do
>   checkRecordExtension p
>   case fs of
661
662
>     [] -> do report (errEmptyRecord p)
>              return (RecordPattern fs t)
Björn Peemöller 's avatar
Björn Peemöller committed
663
664
665
666
667
>     (Field _ l _ : _) -> do
>     env <- getRenameEnv
>     case lookupVar l env of
>       [RecordLabel r ls] -> do
>         when (isJust duplicate) $ report $ errDuplicateLabel
668
>                                          $ fromJust duplicate
Björn Peemöller 's avatar
Björn Peemöller committed
669
670
671
>         if isNothing t
>           then do
>             when (not $ null missings) $ report $ errMissingLabel
672
>               (idPosition l) (head missings) r "record pattern"
Björn Peemöller 's avatar
Björn Peemöller committed
673
674
675
676
>             flip RecordPattern t `liftM` mapM (checkFieldPatt r) fs
>           else if t == Just (VariablePattern anonId)
>             then liftM2 RecordPattern
>                         (mapM (checkFieldPatt r) fs)
677
>                         (Just `liftM` checkPattern p (fromJust t))
Björn Peemöller 's avatar
Björn Peemöller committed
678
679
680
681
682
683
684
685
686
>             else do report (errIllegalRecordPattern p)
>                     return $ RecordPattern fs t
>         where ls'       = map fieldLabel fs
>               duplicate = findDouble ls'
>               missings  = ls \\ ls'
>       [] -> report (errUndefinedLabel l) >> return (RecordPattern fs t)
>       [_] -> report (errNotALabel l) >> return (RecordPattern fs t)
>       _   -> report (errDuplicateDefinition l) >> return (RecordPattern fs t)

687
> checkFieldPatt :: QualIdent -> Field Pattern -> SCM (Field Pattern)
Björn Peemöller 's avatar
Björn Peemöller committed
688
689
690
691
> checkFieldPatt r (Field p l t) = do
>   env <- getRenameEnv
>   case lookupVar l env of
>     [RecordLabel r' _] -> when (r /= r') $ report $ errIllegalLabel l r
692
693
694
>     []                 -> report $ errUndefinedLabel l
>     [_]                -> report $ errNotALabel l
>     _                  -> report $ errDuplicateDefinition l
695
>   Field p l `liftM` checkPattern (idPosition l) t
Björn Peemöller 's avatar
Björn Peemöller committed
696
697
698

> -- Note: process decls first
> checkRhs :: Rhs -> SCM Rhs
699
> checkRhs (SimpleRhs p e ds) = inNestedScope $ liftM2 (flip (SimpleRhs p))
Björn Peemöller 's avatar
Björn Peemöller committed
700
>   (checkDeclGroup bindVarDecl ds) (checkExpr p e)
701
> checkRhs (GuardedRhs es ds) = inNestedScope $ liftM2 (flip GuardedRhs)
Björn Peemöller 's avatar
Björn Peemöller committed
702
703
704
705
706
707
708
709
710
711
712
713
714
715
>   (checkDeclGroup bindVarDecl ds) (mapM checkCondExpr es)

> checkCondExpr :: CondExpr -> SCM CondExpr
> checkCondExpr (CondExpr p g e) =
>   liftM2 (CondExpr p) (checkExpr p g) (checkExpr p e)

> checkExpr :: Position -> Expression -> SCM Expression
> checkExpr _ (Literal     l) = Literal       `liftM` renameLiteral l
> checkExpr _ (Variable    v) = checkVariable v
> checkExpr _ (Constructor c) = checkVariable c
> checkExpr p (Paren       e) = Paren         `liftM` checkExpr p e
> checkExpr p (Typed    e ty) = flip Typed ty `liftM` checkExpr p e
> checkExpr p (Tuple  pos es) = Tuple pos     `liftM` mapM (checkExpr p) es
> checkExpr p (List   pos es) = List pos      `liftM` mapM (checkExpr p) es
716
> checkExpr p (ListCompr      pos e qs) = withLocalEnv $
Björn Peemöller 's avatar
Björn Peemöller committed
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
>   -- Note: must be flipped to insert qs into RenameEnv first
>   liftM2 (flip (ListCompr pos)) (mapM (checkStatement p) qs) (checkExpr p e)
> checkExpr p (EnumFrom              e) = EnumFrom `liftM` checkExpr p e
> checkExpr p (EnumFromThen      e1 e2) =
>   liftM2 EnumFromThen (checkExpr p e1) (checkExpr p e2)
> checkExpr p (EnumFromTo        e1 e2) =
>   liftM2 EnumFromTo (checkExpr p e1) (checkExpr p e2)
> checkExpr p (EnumFromThenTo e1 e2 e3) =
>   liftM3 EnumFromThenTo (checkExpr p e1) (checkExpr p e2) (checkExpr p e3)
> checkExpr p (UnaryMinus         op e) = UnaryMinus op `liftM` checkExpr p e
> checkExpr p (Apply             e1 e2) =
>   liftM2 Apply (checkExpr p e1) (checkExpr p e2)
> checkExpr p (InfixApply     e1 op e2) =
>   liftM3 InfixApply (checkExpr p e1) (checkOp op) (checkExpr p e2)
> checkExpr p (LeftSection        e op) =
>   liftM2 LeftSection (checkExpr p e) (checkOp op)
> checkExpr p (RightSection       op e) =
>   liftM2 RightSection (checkOp op) (checkExpr p e)
735
> checkExpr p (Lambda           r ts e) = inNestedScope $
736
>   liftM2 (Lambda r) (mapM (bindPattern p) ts) (checkExpr p e)
737
> checkExpr p (Let                ds e) = inNestedScope $
Björn Peemöller 's avatar
Björn Peemöller committed
738
>   liftM2 Let (checkDeclGroup bindVarDecl ds) (checkExpr p e)
739
> checkExpr p (Do                sts e) = withLocalEnv $
Björn Peemöller 's avatar
Björn Peemöller committed
740
741
742
>   liftM2 Do (mapM (checkStatement p) sts) (checkExpr p e)
> checkExpr p (IfThenElse r e1 e2 e3) =
>   liftM3 (IfThenElse r) (checkExpr p e1) (checkExpr p e2) (checkExpr p e3)
743
744
> checkExpr p (Case r ct e alts) =
>   liftM2 (Case r ct) (checkExpr p e) (mapM checkAlt alts)
Björn Peemöller 's avatar
Björn Peemöller committed
745
746
747
748
749
750
751
> checkExpr p rec@(RecordConstr   fs) = do
>   checkRecordExtension p
>   env <- getRenameEnv
>   case fs of
>     []              -> report (errEmptyRecord p) >> return rec
>     Field _ l _ : _ -> case lookupVar l env of
>       [RecordLabel r ls] -> do
752
753
>         unless (null dups)     $ report $ errDuplicateLabel $ head dups
>         unless (null missings) $ report $ errMissingLabel
754
>              (idPosition l) (head missings) r "record construction"
Björn Peemöller 's avatar
Björn Peemöller committed
755
756
>         RecordConstr `liftM` mapM (checkFieldExpr r) fs
>         where ls' = map fieldLabel fs
757
>               dups = maybeToList (findDouble ls')
Björn Peemöller 's avatar
Björn Peemöller committed
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
>               missings = ls \\ ls'
>       []  -> report (errUndefinedLabel l)      >> return rec
>       [_] -> report (errNotALabel l)           >> return rec
>       _   -> report (errDuplicateDefinition l) >> return rec

> checkExpr p (RecordSelection e l) = do
>   checkRecordExtension p
>   env <- getRenameEnv
>   case lookupVar l env of
>     [RecordLabel _ _] -> return ()
>     []                -> report $ errUndefinedLabel l
>     [_]               -> report $ errNotALabel l
>     _                 -> report $ errDuplicateDefinition l
>   flip RecordSelection l `liftM` checkExpr p e
> checkExpr p rec@(RecordUpdate fs e) = do
>   checkRecordExtension p
>   env <- getRenameEnv
>   case fs of
>     []              -> report (errEmptyRecord p) >> return rec
>     Field _ l _ : _ -> case lookupVar l env of
>       [RecordLabel r _] -> do
779
>         unless (null dups) $ report $ errDuplicateLabel $ head dups
Björn Peemöller 's avatar
Björn Peemöller committed
780
>         liftM2 RecordUpdate (mapM (checkFieldExpr r) fs)
781
>                             (checkExpr (idPosition l) e)
782
>         where dups = maybeToList $ findDouble $ map fieldLabel fs
Björn Peemöller 's avatar
Björn Peemöller committed
783
784
785
786
787
788
>       []  -> report (errUndefinedLabel l)      >> return rec
>       [_] -> report (errNotALabel l)           >> return rec
>       _   -> report (errDuplicateDefinition l) >> return rec

> checkVariable :: QualIdent -> SCM Expression
> checkVariable v
789
790
>     -- anonymous free variable
>   | isAnonId (unqualify v) = do
791
>     checkAnonFreeVarsExtension $ qidPosition v
792
793
794
>     (\n -> Variable $ updQualIdent id (flip renameIdent n) v) `liftM` newId
>     -- return $ Variable v
>     -- normal variable
Björn Peemöller 's avatar
Björn Peemöller committed
795
796
797
798
799
>   | otherwise             = do
>     env <- getRenameEnv
>     case qualLookupVar v env of
>       []              -> do report $ errUndefinedVariable v
>                             return $ Variable v
800
>       [Constr _ _]    -> return $ Constructor v
Björn Peemöller 's avatar
Björn Peemöller committed
801
>       [GlobalVar _ _] -> return $ Variable v
802
>       [LocalVar v' _] -> return $ Variable $ qualify v'
Björn Peemöller 's avatar
Björn Peemöller committed
803
804
805
806
807
>       rs -> do
>         m <- getModuleIdent
>         case qualLookupVar (qualQualify m v) env of
>           []              -> do report $ errAmbiguousIdent rs v
>                                 return $ Variable v
808
>           [Constr _ _]    -> return $ Constructor v
Björn Peemöller 's avatar
Björn Peemöller committed
809
>           [GlobalVar _ _] -> return $ Variable v
810
>           [LocalVar v' _] -> return $ Variable $ qualify v'
Björn Peemöller 's avatar
Björn Peemöller committed
811
812
813
>           rs'             -> do report $ errAmbiguousIdent rs' v
>                                 return $ Variable v

814
815
816
817
> -- * Because patterns or decls eventually introduce new variables, the
> --   scope has to be nested one level.
> -- * Because statements are processed list-wise, inNestedEnv can not be
> --   used as this nesting must be visible to following statements.
Björn Peemöller 's avatar
Björn Peemöller committed
818
819
820
> checkStatement :: Position -> Statement -> SCM Statement
> checkStatement p (StmtExpr   pos e) = StmtExpr pos `liftM` checkExpr p e
> checkStatement p (StmtBind pos t e) =
821
>   liftM2 (flip (StmtBind pos)) (checkExpr p e) (incNesting >> bindPattern p t)
Björn Peemöller 's avatar
Björn Peemöller committed
822
> checkStatement _ (StmtDecl      ds) =
823
>   StmtDecl `liftM` (incNesting >> checkDeclGroup bindVarDecl ds)
Björn Peemöller 's avatar
Björn Peemöller committed
824

825
> bindPattern :: Position -> Pattern -> SCM Pattern
826
> bindPattern p t = checkPattern p t >>= addBoundVariables True
Björn Peemöller 's avatar
Björn Peemöller committed
827
828
829
830
831
832

> checkOp :: InfixOp -> SCM InfixOp
> checkOp op = do
>   env <- getRenameEnv
>   case qualLookupVar v env of
>     []              -> report (errUndefinedVariable v) >> return op
833
>     [Constr _ _]    -> return $ InfixConstr v
Björn Peemöller 's avatar
Björn Peemöller committed
834
>     [GlobalVar _ _] -> return $ InfixOp v
835
>     [LocalVar v' _] -> return $ InfixOp $ qualify v'
Björn Peemöller 's avatar
Björn Peemöller committed
836
837
838
839
>     rs              -> do
>       m <- getModuleIdent
>       case qualLookupVar (qualQualify m v) env of
>         []              -> report (errAmbiguousIdent rs v) >> return op
840
>         [Constr _ _]    -> return $ InfixConstr v
Björn Peemöller 's avatar
Björn Peemöller committed
841
>         [GlobalVar _ _] -> return $ InfixOp v
842
>         [LocalVar v' _] -> return $ InfixOp $ qualify v'
Björn Peemöller 's avatar
Björn Peemöller committed
843
>         rs'             -> report (errAmbiguousIdent rs' v) >> return op
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
844
845
>   where v = opName op

Björn Peemöller 's avatar
Björn Peemöller committed
846
> checkAlt :: Alt -> SCM Alt
847
> checkAlt (Alt p t rhs) = inNestedScope $
848
>   liftM2 (Alt p) (bindPattern p t) (checkRhs rhs)
849

850
851
852
853
854
> addBoundVariables :: QuantExpr t => Bool -> t -> SCM t
> addBoundVariables checkDuplicates ts = do
>   when checkDuplicates $ maybe (return ()) (report . errDuplicateVariable)
>                        $ findDouble bvs
>   modifyRenameEnv $ \ env -> foldr bindVar env (nub bvs)
855
>   return ts
Björn Peemöller 's avatar
Björn Peemöller committed
856
857
858
859
860
861
862
863
864
865
>   where bvs = bv ts

> checkFieldExpr :: QualIdent -> Field Expression -> SCM (Field Expression)
> checkFieldExpr r (Field p l e) = do
>   env <- getRenameEnv
>   case lookupVar l env of
>     [RecordLabel r' _] -> when (r /= r') $ report $ errIllegalLabel l r
>     []                 -> report $ errUndefinedLabel l
>     [_]                -> report $ errNotALabel l
>     _                  -> report $ errDuplicateDefinition l
866
>   Field p l `liftM` checkExpr (idPosition l) e
Björn Peemöller 's avatar
Björn Peemöller committed
867

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
868
869
870
871
872
873
\end{verbatim}
Auxiliary definitions.
\begin{verbatim}

> constrs :: Decl -> [Ident]
> constrs (DataDecl _ _ _ cs) = map constr cs
Björn Peemöller 's avatar
Björn Peemöller committed
874
>   where constr (ConstrDecl   _ _ c _) = c
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
875
876
877
878
879
>         constr (ConOpDecl _ _ _ op _) = op
> constrs (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]
> constrs _ = []

> vars :: Decl -> [Ident]
Björn Peemöller 's avatar
Björn Peemöller committed
880
881
> vars (TypeSig         _ fs _) = fs
> vars (FunctionDecl     _ f _) = [f]
882
883
> vars (ForeignDecl  _ _ _ f _) = [f]
> vars (ExternalDecl      _ fs) = fs
884
> vars (PatternDecl      _ t _) = bv t
885
> vars (FreeDecl          _ vs) = vs
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
886
887
> vars _ = []

Björn Peemöller 's avatar
Björn Peemöller committed
888
> renameLiteral :: Literal -> SCM Literal
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
889
890
891
892
893
894
895
> renameLiteral (Int v i) = liftM (flip Int i . renameIdent v) newId
> renameLiteral l = return l

Since the compiler expects all rules of the same function to be together,
it is necessary to sort the list of declarations.

> sortFuncDecls :: [Decl] -> [Decl]
Björn Peemöller 's avatar
Björn Peemöller committed
896
> sortFuncDecls decls = sortFD Set.empty [] decls
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
897
>  where
Björn Peemöller 's avatar
Björn Peemöller committed
898
899
900
901
902
903
904
905
>  sortFD _   res []              = reverse res
>  sortFD env res (decl : decls') = case decl of
>    FunctionDecl _ ident _
>     | ident `Set.member` env
>     -> sortFD env (insertBy cmpFuncDecl decl res) decls'
>     | otherwise
>     -> sortFD (Set.insert ident env) (decl:res) decls'
>    _    -> sortFD env (decl:res) decls'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935

> cmpFuncDecl :: Decl -> Decl -> Ordering
> cmpFuncDecl (FunctionDecl _ id1 _) (FunctionDecl _ id2 _)
>    | id1 == id2 = EQ
>    | otherwise  = GT
> cmpFuncDecl _ _ = GT

\end{verbatim}
Due to the lack of a capitalization convention in Curry, it is
possible that an identifier may ambiguously refer to a data
constructor and a function provided that both are imported from some
other module. When checking whether an identifier denotes a
constructor there are two options with regard to ambiguous
identifiers:
\begin{enumerate}
\item Handle the identifier as a data constructor if at least one of
  the imported names is a data constructor.
\item Handle the identifier as a data constructor only if all imported
  entities are data constructors.
\end{enumerate}
We choose the first possibility here because in the second case a
redefinition of a constructor can magically become possible if a
function with the same name is imported. It seems better to warn
the user about the fact that the identifier is ambiguous.
\begin{verbatim}

> isDataConstr :: Ident -> RenameEnv -> Bool
> isDataConstr v = any isConstr . lookupVar v . globalEnv . toplevelEnv

> isConstr :: RenameInfo -> Bool
936
> isConstr (Constr      _ _) = True
Björn Peemöller 's avatar
Björn Peemöller committed
937
938
> isConstr (GlobalVar   _ _) = False
> isConstr (LocalVar    _ _) = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
939
940
> isConstr (RecordLabel _ _) = False

Björn Peemöller 's avatar
Björn Peemöller committed
941
942
943
944
varIdent :: RenameInfo -> Ident
varIdent (GlobalVar _ v) = unqualify v
varIdent (LocalVar  _ v) = v
varIdent _ = internalError "SyntaxCheck.varIdent: no variable"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
945
946

> qualVarIdent :: RenameInfo -> QualIdent
947
948
> qualVarIdent (GlobalVar v _) = v
> qualVarIdent (LocalVar  v _) = qualify v
Björn Peemöller 's avatar
Björn Peemöller committed
949
> qualVarIdent _ = internalError "SyntaxCheck.qualVarIdent: no variable"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
950
951

> arity :: RenameInfo -> Int
952
953
954
> arity (Constr      _  n) = n
> arity (GlobalVar   _  n) = n
> arity (LocalVar    _  n) = n
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
955
956
957
958
> arity (RecordLabel _ ls) = length ls

\end{verbatim}
Unlike expressions, constructor terms have no possibility to represent
Björn Peemöller 's avatar
Björn Peemöller committed
959
over-applications in functional patterns. Therefore it is necessary to
960
961
962
transform them to nested function patterns using the prelude function
\texttt{apply}. E.g., the function pattern \texttt{(id id 10)} is transformed
to \texttt{(apply (id id) 10)}.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
963
964
\begin{verbatim}

965
> genFuncPattAppl :: Pattern -> [Pattern] -> Pattern
Björn Peemöller 's avatar
Björn Peemöller committed
966
> genFuncPattAppl term []     = term
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
967
968
969
970
971
> genFuncPattAppl term (t:ts)
>    = FunctionPattern qApplyId [genFuncPattAppl term ts, t]
>  where
>  qApplyId = qualifyWith preludeMIdent (mkIdent "apply")

972
973
974
975
976
> checkFPTerm :: Position -> Pattern -> SCM ()
> checkFPTerm _ (LiteralPattern         _) = ok
> checkFPTerm _ (NegativePattern      _ _) = ok
> checkFPTerm _ (VariablePattern        _) = ok
> checkFPTerm p (ConstructorPattern  _ ts) = mapM_ (checkFPTerm p) ts
977
> checkFPTerm p (InfixPattern     t1 _ t2) = mapM_ (checkFPTerm p) [t1, t2]
978
979
980
> checkFPTerm p (ParenPattern           t) = checkFPTerm p t
> checkFPTerm p (TuplePattern        _ ts) = mapM_ (checkFPTerm p) ts
> checkFPTerm p (ListPattern         _ ts) = mapM_ (checkFPTerm p) ts
981
> checkFPTerm p (AsPattern            _ t) = checkFPTerm p t
982
983
> checkFPTerm p t@(LazyPattern        _ _) = report $ errUnsupportedFPTerm "Lazy"   p t
> checkFPTerm p t@(RecordPattern      _ _) = report $ errUnsupportedFPTerm "Record" p t
984
985
> checkFPTerm _ (FunctionPattern      _ _) = ok -- dot not check again
> checkFPTerm _ (InfixFuncPattern   _ _ _) = ok -- dot not check again
986

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
987
988
989
990
\end{verbatim}
Miscellaneous functions.
\begin{verbatim}

Björn Peemöller 's avatar
Björn Peemöller committed
991
> checkFuncPatsExtension :: Position -> SCM ()
992
> checkFuncPatsExtension p = checkUsedExtension p
993
>   "Functional Patterns" FunctionalPatterns
Björn Peemöller 's avatar
Björn Peemöller committed
994
995

> checkRecordExtension :: Position -> SCM ()
996
> checkRecordExtension p = checkUsedExtension p "Records" Records
997
998

> checkAnonFreeVarsExtension :: Position -> SCM ()
999
> checkAnonFreeVarsExtension p = checkUsedExtension p
1000
1001
>   "Anonymous free variables" AnonFreeVars

1002
1003
> checkUsedExtension :: Position -> String -> KnownExtension -> SCM ()
> checkUsedExtension pos msg ext = do