CurryToIL.lhs 26.1 KB
Newer Older
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
% $Id: ILTrans.lhs,v 1.86 2004/02/13 19:23:58 wlux Exp $
%
% Copyright (c) 1999-2003, Wolfgang Lux
% See LICENSE for the full license.
%
% Modified by Martin Engelke (men@informatik.uni-kiel.de)
%
\nwfilename{ILTrans.lhs}
\section{Translating Curry into the Intermediate Language}
After desugaring and lifting have been performed, the source code is
translated into the intermediate language. Besides translating from
source terms and expressions into intermediate language terms and
expressions this phase in particular has to implement the pattern
matching algorithm for equations and case expressions.

Because of name conflicts between the source and intermediate language
data structures, we can use only a qualified import for the
\texttt{IL} module.
\begin{verbatim}

> module CurryToIL (ilTrans, ilTransIntf, translType) where

> import Data.Maybe (fromJust)
> import Data.List (nub, partition)
> import qualified Data.Set as Set (delete, fromList, toList)
> import qualified Data.Map as Map (Map, empty, insert, lookup)

> import Curry.Base.Position
> import Curry.Base.Ident
30
> import qualified IL as IL
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
31
32
> import Curry.Syntax

33
> import Base.Eval (EvalEnv)
34
> import Base.Expr
35
36
37
> import Base.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
> import Base.Types (toQualTypes)
> import Base.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
> import Messages (internalError)
> import Utils (foldr2, thd3)
> import Types

\end{verbatim}
\paragraph{Modules}
At the top-level, the compiler has to translate data type, newtype,
function, and external declarations. When translating a data type or
newtype declaration, we ignore the types in the declaration and lookup
the types of the constructors in the type environment instead because
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

> translGlobalDecl :: Bool -> ModuleIdent -> ValueEnv -> TCEnv -> EvalEnv
>                  -> Decl -> [IL.Decl]
> translGlobalDecl _ m tyEnv tcEnv _ (DataDecl _ tc tvs cs) =
>   [translData m tyEnv tcEnv tc tvs cs]
> 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 _) =
>   [translExternal m tyEnv tcEnv f cc (fromJust ie)]
> translGlobalDecl _ _ _ _ _ _ = []

> translData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident] -> [ConstrDecl]
>            -> IL.Decl
> translData m tyEnv tcEnv tc tvs cs =
>   IL.DataDecl (qualifyWith m tc) (length tvs)
>               (map (translConstrDecl m tyEnv tcEnv) cs)

> translNewtype :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident]
>	        -> NewConstrDecl -> IL.Decl
> translNewtype m tyEnv tcEnv tc tvs (NewConstrDecl _ _ c _) =
>   IL.NewtypeDecl (qualifyWith m tc) (length tvs)
>                  (IL.ConstrDecl c' (translType' m tyEnv tcEnv ty))
>                  -- (IL.ConstrDecl c' (translType ty))
>   where c' = qualifyWith m c
>         TypeArrow ty _ = constrType tyEnv c'

> translConstrDecl :: ModuleIdent -> ValueEnv -> TCEnv -> ConstrDecl
>                  -> IL.ConstrDecl [IL.Type]
> translConstrDecl m tyEnv tcEnv d =
>   IL.ConstrDecl c' (map (translType' m tyEnv tcEnv)
>	                  (arrowArgs (constrType tyEnv c')))
>   -- IL.ConstrDecl c' (map translType (arrowArgs (constrType tyEnv c')))
>   where c' = qualifyWith m (constr d)
>         constr (ConstrDecl _ _ c _) = c
>         constr (ConOpDecl _ _ _ op _) = op

> translExternal :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> CallConv
>                -> String -> IL.Decl
> translExternal m tyEnv tcEnv f cc ie =
>   IL.ExternalDecl f' (callConv cc) ie
>                   (translType' m tyEnv tcEnv (varType tyEnv f'))
>   -- IL.ExternalDecl f' (callConv cc) ie (translType (varType tyEnv f'))
>   where f' = qualifyWith m f
>         callConv CallConvPrimitive = IL.Primitive
>         callConv CallConvCCall = IL.CCall

\end{verbatim}
\paragraph{Interfaces}
In order to generate code, the compiler also needs to know the tags
and arities of all imported data constructors. For that reason we
compile the data type declarations of all interfaces into the
intermediate language, too. In this case we do not lookup the
types in the environment because the types in the interfaces are
already fully expanded. Note that we do not translate data types
which are imported into the interface from some other module.
\begin{verbatim}

> ilTransIntf :: ValueEnv -> TCEnv -> Interface -> [IL.Decl]
> ilTransIntf tyEnv tcEnv (Interface m ds) =
>   foldr (translIntfDecl m tyEnv tcEnv) [] ds

> translIntfDecl :: ModuleIdent -> ValueEnv -> TCEnv -> IDecl -> [IL.Decl]
>	         -> [IL.Decl]
> translIntfDecl m tyEnv tcEnv (IDataDecl _ tc tvs cs) ds
>   | not (isQualified tc) =
>     translIntfData m tyEnv tcEnv (unqualify tc) tvs cs : ds
> translIntfDecl _ _ _ _ ds = ds

> translIntfData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident]
>	         -> [Maybe ConstrDecl] -> IL.Decl
> translIntfData m tyEnv tcEnv tc tvs cs =
>   IL.DataDecl (qualifyWith m tc) (length tvs)
>               (map (maybe hiddenConstr
>	                    (translIntfConstrDecl m tyEnv tcEnv tvs)) cs)
>   where hiddenConstr = IL.ConstrDecl qAnonId []
>         qAnonId = qualify anonId

> translIntfConstrDecl :: ModuleIdent -> ValueEnv -> TCEnv -> [Ident]
>                      -> ConstrDecl -> IL.ConstrDecl [IL.Type]
> translIntfConstrDecl m tyEnv tcEnv tvs (ConstrDecl _ _ c tys) =
>   IL.ConstrDecl (qualifyWith m c) (map (translType' m tyEnv tcEnv)
>			                 (toQualTypes m tvs tys))
>   -- IL.ConstrDecl (qualifyWith m c) (map translType (toQualTypes m tvs tys))
> translIntfConstrDecl m tyEnv tcEnv tvs (ConOpDecl _ _ ty1 op ty2) =
>   IL.ConstrDecl (qualifyWith m op)
>                 (map (translType' m tyEnv tcEnv)
>	               (toQualTypes m tvs [ty1,ty2]))
>   -- IL.ConstrDecl (qualifyWith m op)
>   --              (map translType (toQualTypes m tvs [ty1,ty2]))

\end{verbatim}
\paragraph{Types}
The type representation in the intermediate language is the same as
the internal representation except that it does not support
constrained type variables and skolem types. The former are fixed and
the later are replaced by fresh type constructors.

Due to possible occurrence of record types, it is necessary to transform
them back into their corresponding type constructors.
\begin{verbatim}

> translType' :: ModuleIdent -> ValueEnv -> TCEnv -> Type -> IL.Type
> translType' m tyEnv tcEnv ty =
>   translType (elimRecordTypes m tyEnv tcEnv (maximum (0:(typeVars ty))) ty)

> translType :: Type -> IL.Type
> translType (TypeConstructor tc tys) =
>   IL.TypeConstructor tc (map translType tys)
> translType (TypeVariable tv) = IL.TypeVariable tv
> translType (TypeConstrained tys _) = translType (head tys)
> translType (TypeArrow ty1 ty2) =
>   IL.TypeArrow (translType ty1) (translType ty2)
> translType (TypeSkolem k) =
>   IL.TypeConstructor (qualify (mkIdent ("_" ++ show k))) []
> translType (TypeRecord _ _) = error "Translation of record not defined" -- TODO

> elimRecordTypes :: ModuleIdent -> ValueEnv -> TCEnv -> Int -> Type -> Type
> elimRecordTypes m tyEnv tcEnv n (TypeConstructor t tys) =
>   TypeConstructor t (map (elimRecordTypes m tyEnv tcEnv n) tys)
> elimRecordTypes _ _ _ _ (TypeVariable v) =
>   TypeVariable v
> elimRecordTypes m tyEnv tcEnv n (TypeConstrained tys v) =
>   TypeConstrained (map (elimRecordTypes m tyEnv tcEnv n) tys) v
> elimRecordTypes m tyEnv tcEnv n (TypeArrow t1 t2) =
>   TypeArrow (elimRecordTypes m tyEnv tcEnv n t1)
>             (elimRecordTypes m tyEnv tcEnv n t2)
> elimRecordTypes _ _ _ _ (TypeSkolem v) =
>   TypeSkolem v
> elimRecordTypes m tyEnv tcEnv n (TypeRecord fs _)
>   | null fs = internalError "elimRecordTypes: empty record type"
>   | otherwise =
>     case (lookupValue (fst (head fs)) tyEnv) of
>       [Label _ r _] ->
>         case (qualLookupTC r tcEnv) of
>           [AliasType _ n' (TypeRecord fs' _)] ->
>	      let is = [0 .. n'-1]
>                 vs = foldl (matchTypeVars fs)
>			     Map.empty
>			     fs'
>		  tys = map (\i -> maybe (TypeVariable (i+n))
>			                 (elimRecordTypes m tyEnv tcEnv n)
>		                         (Map.lookup i vs))
>		            is
>	      in  TypeConstructor r tys
>	    _ -> internalError "elimRecordTypes: no record type"
>       _ -> internalError "elimRecordTypes: no label"

> matchTypeVars :: [(Ident,Type)] -> Map.Map Int Type -> (Ident,Type)
>	           -> Map.Map Int Type
> matchTypeVars fs vs (l,ty) =
>   maybe vs (match' vs ty) (lookup l fs)
>   where
>   match' vs' (TypeVariable i) ty' = Map.insert i ty' vs'
>   match' vs' (TypeConstructor _ tys) (TypeConstructor _ tys') =
>     matchList vs' tys tys'
>   match' vs' (TypeConstrained tys _) (TypeConstrained tys' _) =
>     matchList vs' tys tys'
>   match' vs' (TypeArrow ty1 ty2) (TypeArrow ty1' ty2') =
>     matchList vs' [ty1,ty2] [ty1',ty2']
>   match' vs' (TypeSkolem _) (TypeSkolem _) = vs'
>   match' vs' (TypeRecord fs1 _) (TypeRecord fs2 _) =
>     foldl (matchTypeVars fs2) vs' fs1
>   match' _ ty1 ty2 =
>     internalError ("matchTypeVars: " ++ show ty1 ++ "\n" ++ show ty2)
>
>   matchList vs1 tys tys' =
>     foldl (\vs' (ty1,ty2) -> match' vs' ty1 ty2) vs1 (zip tys tys')

\end{verbatim}
\paragraph{Functions}
Each function in the program is translated into a function of the
intermediate language. The arguments of the function are renamed such
that all variables occurring in the same position (in different
equations) have the same name. This is necessary in order to
facilitate the translation of pattern matching into a \texttt{case}
expression. We use the following simple convention here: The top-level
arguments of the function are named from left to right \texttt{\_1},
\texttt{\_2}, and so on. The names of nested arguments are constructed
by appending \texttt{\_1}, \texttt{\_2}, etc. from left to right to
the name that were assigned to a variable occurring at the position of
the constructor term.

Some special care is needed for the selector functions introduced by
the compiler in place of pattern bindings. In order to generate the
code for updating all pattern variables, the equality of names between
the pattern variables in the first argument of the selector function
and their repeated occurrences in the remaining arguments must be
preserved. This means that the second and following arguments of a
selector function have to be renamed according to the name mapping
computed for its first argument.

If an evaluation annotation is available for a function, it determines
the evaluation mode of the case expression. Otherwise, the function
uses flexible matching.
\begin{verbatim}

> 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 =
>   -- - | f == mkIdent "fun" = error (show (translType' m tyEnv tcEnv ty))
>   -- - | otherwise =
>     IL.FunctionDecl f' vs (translType' m tyEnv tcEnv ty) expr
>    -- = IL.FunctionDecl f' vs (translType ty)
>    --                  (match ev vs (map (translEquation tyEnv vs vs'') eqs))
>   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'
>         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
>                =  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"

> defaultMode :: Type -> IL.Eval
> defaultMode _ = IL.Flex
>
> --defaultMode ty = if isIO (arrowBase ty) then IL.Rigid else IL.Flex
> --  where TypeConstructor qIOId _ = ioType undefined
> --        isIO (TypeConstructor tc [_]) = tc == qIOId
> --        isIO _ = False

> translArgs :: [Equation] -> [Ident] -> [Ident]
> translArgs [Equation _ (FunLhs _ (t:ts)) _] (v:_) =
>   v : map (translArg (bindRenameEnv v t Map.empty)) ts
>   where
>     translArg env (VariablePattern v') = fromJust (Map.lookup v' env)
>     translArg _ _ = error "Translation of arguments not defined"
> translArgs _ _ = error "Translation of arguments not defined" -- TODO

> translEquation :: ValueEnv -> [Ident] -> [Ident] -> Equation
>                -> ([NestedTerm],IL.Expression)
> translEquation tyEnv vs vs' (Equation _ (FunLhs _ ts) rhs) =
>   (zipWith translTerm vs ts,
>    translRhs tyEnv vs' (foldr2 bindRenameEnv Map.empty vs ts) rhs)
> translEquation _ _ _ _ = error "Translation of non-FunLhs euqation not defined"

> translRhs :: ValueEnv -> [Ident] -> RenameEnv -> Rhs -> IL.Expression
> translRhs tyEnv vs env (SimpleRhs _ e _) = translExpr tyEnv vs env e
> translRhs _ _ _ _ = error "Translation of non-simple RHS not defined"


> equationArity :: Equation -> Int
> equationArity (Equation _ lhs _) = p_equArity lhs
>  where
>    p_equArity (FunLhs _ ts) = length ts
>    p_equArity (OpLhs _ _ _) = 2
>    p_equArity _             = error "ILTrans - illegal equation"


\end{verbatim}
\paragraph{Pattern Matching}
The pattern matching code searches for the left-most inductive
argument position in the left hand sides of all rules defining an
equation. An inductive position is a position where all rules have a
constructor rooted term. If such a position is found, a \texttt{case}
expression is generated for the argument at that position. The
matching code is then computed recursively for all of the alternatives
independently. If no inductive position is found, the algorithm looks
for the left-most demanded argument position, i.e., a position where
at least one of the rules has a constructor rooted term. If such a
position is found, an \texttt{or} expression is generated with those
cases that have a variable at the argument position in one branch and
all other rules in the other branch. If there is no demanded position,
the pattern matching is finished and the compiler translates the right
hand sides of the remaining rules, eventually combining them using
\texttt{or} expressions.

Actually, the algorithm below combines the search for inductive and
demanded positions. The function \texttt{match} scans the argument
lists for the left-most demanded position. If this turns out to be
also an inductive position, the function \texttt{matchInductive} is
called in order to generate a \texttt{case} expression. Otherwise, the
function \texttt{optMatch} is called that tries to find an inductive
position in the remaining arguments. If one is found,
\texttt{matchInductive} is called, otherwise the function
\texttt{optMatch} uses the demanded argument position found by
\texttt{match}.
\begin{verbatim}

> data NestedTerm = NestedTerm IL.ConstrTerm [NestedTerm] deriving Show

> pattern :: NestedTerm -> IL.ConstrTerm
> pattern (NestedTerm t _) = t

> arguments :: NestedTerm -> [NestedTerm]
> arguments (NestedTerm _ ts) = ts

> translLiteral :: Literal -> IL.Literal
> translLiteral (Char p c) = IL.Char p c
> translLiteral (Int ident i) = IL.Int (srcRefOf (positionOfIdent ident)) i
> translLiteral (Float p f) = IL.Float p f
> translLiteral _ = internalError "translLiteral"

> translTerm :: Ident -> ConstrTerm -> NestedTerm
> translTerm _ (LiteralPattern l) =
>   NestedTerm (IL.LiteralPattern (translLiteral l)) []
> translTerm v (VariablePattern _) = NestedTerm (IL.VariablePattern v) []
> translTerm v (ConstructorPattern c ts) =
>   NestedTerm (IL.ConstructorPattern c (take (length ts) vs))
>              (zipWith translTerm vs ts)
>   where vs = argNames v
> translTerm v (AsPattern _ t) = translTerm v t
> translTerm _ _ = internalError "translTerm"

> bindRenameEnv :: Ident -> ConstrTerm -> RenameEnv -> RenameEnv
> bindRenameEnv _ (LiteralPattern _) env = env
> bindRenameEnv v (VariablePattern v') env = Map.insert v' v env
> bindRenameEnv v (ConstructorPattern _ ts) env =
>   foldr2 bindRenameEnv env (argNames v) ts
> bindRenameEnv v (AsPattern v' t) env = Map.insert v' v (bindRenameEnv v t env)
> bindRenameEnv _ _ _ = internalError "bindRenameEnv"

> argNames :: Ident -> [Ident]
> argNames v = [mkIdent (prefix ++ show i) | i <- [1 ..] :: [Int]]
>   where prefix = name v ++ "_"

> type Match = ([NestedTerm],IL.Expression)
> type Match' = ([NestedTerm] -> [NestedTerm],[NestedTerm],IL.Expression)

> isDefaultPattern :: IL.ConstrTerm -> Bool
> isDefaultPattern (IL.VariablePattern _) = True
> isDefaultPattern _ = False

> isDefaultMatch :: (IL.ConstrTerm,a) -> Bool
> isDefaultMatch = isDefaultPattern . fst

> match :: SrcRef -> IL.Eval -> [Ident] -> [Match] -> IL.Expression
> match _   _ [] alts = foldl1 IL.Or (map snd alts)
> match pos ev (v:vs) alts
>   | null vars = e1
>   | null nonVars = e2
>   | otherwise = optMatch pos ev (IL.Or e1 e2) (v:) vs (map skipArg alts)
>   where (vars,nonVars) = partition isDefaultMatch (map tagAlt alts)
>         e1 = matchInductive pos ev id v vs nonVars
>         e2 = match pos ev vs (map snd vars)
>         tagAlt (t:ts,e) = (pattern t,(arguments t ++ ts,e))
>         tagAlt ([]  ,_) = error "IL.CurryToIL.match.tagAlt: empty list"
>         skipArg (t:ts,e) = ((t:),ts,e)
>         skipArg ([]  ,_) = error "IL.CurryToIL.match.skipArg: empty list"

> optMatch :: SrcRef -> IL.Eval -> IL.Expression -> ([Ident] -> [Ident])
>    -> [Ident] ->[Match'] -> IL.Expression
> optMatch _   _  e _      []     _    = e
> optMatch pos ev e prefix (v:vs) alts
>   | null vars = matchInductive pos ev prefix v vs nonVars
>   | otherwise = optMatch pos ev e (prefix . (v:)) vs (map skipArg alts)
>   where (vars,nonVars) = partition isDefaultMatch (map tagAlt alts)
>         tagAlt (pref,t:ts,e') = (pattern t,(pref (arguments t ++ ts),e'))
>         tagAlt (_   ,[]  ,_ ) = error "IL.CurryToIL.optMatch.tagAlt: empty list"
>         skipArg (pref,t:ts,e') = (pref . (t:),ts,e')
>         skipArg (_   ,[]  ,_ ) = error "IL.CurryToIL.optMatch.skipArg: empty list"

> matchInductive :: SrcRef -> IL.Eval -> ([Ident] -> [Ident]) -> Ident
>    -> [Ident] ->[(IL.ConstrTerm,Match)] -> IL.Expression
> matchInductive pos ev prefix v vs alts =
>   IL.Case pos ev (IL.Variable v) (matchAlts ev prefix vs alts)

> matchAlts :: IL.Eval -> ([Ident] -> [Ident]) -> [Ident] ->
>     [(IL.ConstrTerm,Match)] -> [IL.Alt]
> matchAlts _  _      _  [] = []
> matchAlts ev prefix vs ((t,alt):alts) =
>   IL.Alt t (match (srcRefOf t)
>                   ev (prefix (vars t ++ vs)) (alt : map snd same)) :
>   matchAlts ev prefix vs others
>   where (same,others) = partition ((t ==) . fst) alts
>         vars (IL.ConstructorPattern _ vs') = vs'
>         vars _ = []

\end{verbatim}
Matching in a \texttt{case}-expression works a little bit differently.
In this case, the alternatives are matched from the first to the last
alternative and the first matching alternative is chosen. All
remaining alternatives are discarded.

\ToDo{The case matching algorithm should use type information in order
to detect total matches and immediately discard all alternatives which
cannot be reached.}
\begin{verbatim}

> caseMatch :: SrcRef -> ([Ident] -> [Ident]) -> [Ident] -> [Match']
>    -> IL.Expression
> caseMatch _ _      []     alts = thd3 (head alts)
> caseMatch r prefix (v:vs) alts
>   | isDefaultMatch (head alts') =
>       caseMatch r (prefix . (v:)) vs (map skipArg alts)
>   | otherwise =
>       IL.Case r IL.Rigid (IL.Variable v) (caseMatchAlts prefix vs alts')
>   where alts' = map tagAlt alts
>         tagAlt (pref,t:ts,e) = (pattern t,(pref,arguments t ++ ts,e))
>         tagAlt (_   ,[]  ,_ ) = error "IL.CurryToIL.caseMatch.tagAlt: empty list"
>         skipArg (pref,t:ts,e) = (pref . (t:),ts,e)
>         skipArg (_   ,[]  ,_ ) = error "IL.CurryToIL.caseMatch.skipArg: empty list"

> caseMatchAlts ::
>     ([Ident] -> [Ident]) -> [Ident] -> [(IL.ConstrTerm,Match')] -> [IL.Alt]
> caseMatchAlts prefix vs alts = map caseAlt (ts ++ ts')
>   where (ts',ts) = partition isDefaultPattern (nub (map fst alts))
>         caseAlt t =
>           IL.Alt t (caseMatch (srcRefOf t) id (prefix (vars t ++ vs))
>                               (matchingCases t alts))
>         matchingCases t =
>           map (joinArgs (vars t)) . filter (matches t . fst)
>         matches t t' = t == t' || isDefaultPattern t'
>         joinArgs vs' (IL.VariablePattern _,(pref,ts1,e)) =
>            (id,pref (map varPattern vs' ++ ts1),e)
>         joinArgs _ (_,(pref,ts1,e)) = (id,pref ts1,e)
>         varPattern v = NestedTerm (IL.VariablePattern v) []
>         vars (IL.ConstructorPattern _ vs') = vs'
>         vars _ = []

\end{verbatim}
\paragraph{Expressions}
Note that the case matching algorithm assumes that the matched
expression is accessible through a variable. The translation of case
expressions therefore introduces a let binding for the scrutinized
expression and immediately throws it away after the matching -- except
if the matching algorithm has decided to use that variable in the
right hand sides of the case expression. This may happen, for
instance, if one of the alternatives contains an \texttt{@}-pattern.
\begin{verbatim}

> translExpr :: ValueEnv -> [Ident] -> RenameEnv -> Expression -> IL.Expression
> translExpr _ _ _ (Literal l) = IL.Literal (translLiteral l)
> translExpr tyEnv _ env (Variable v) =
>   case lookupVar v env of
>     Just v' -> IL.Variable v'
>     Nothing -> IL.Function v (arrowArity (varType tyEnv v))
>   where lookupVar v1 env1
>           | isQualified v1 = Nothing
>           | otherwise = Map.lookup (unqualify v1) env1
> translExpr tyEnv _ _ (Constructor c) =
>   IL.Constructor c (arrowArity (constrType tyEnv c))
> translExpr tyEnv vs env (Apply e1 e2) =
>   IL.Apply (translExpr tyEnv vs env e1) (translExpr tyEnv vs env e2)
> translExpr tyEnv vs env (Let ds e) =
>   case ds of
>     [ExtraVariables _ vs'] -> foldr IL.Exist e' vs'
>     [d] | all (`notElem` bv d) (qfv emptyMIdent d) ->
>       IL.Let (translBinding env' d) e'
>     _ -> IL.Letrec (map (translBinding env') ds) e'
>   where e' = translExpr tyEnv vs env' e
>         env' = foldr2 Map.insert env bvs bvs
>         bvs = bv ds
>         translBinding env1 (PatternDecl _ (VariablePattern v) rhs) =
>           IL.Binding v (translRhs tyEnv vs env1 rhs)
>         translBinding _ p = error $ "unexpected binding: " ++ show p
> translExpr tyEnv ~(v:vs) env (Case r e alts) =
>   case caseMatch r id [v] (map (translAlt v) alts) of
>     IL.Case r' mode (IL.Variable v') alts'
>       | v == v' && v `notElem` fv alts' -> IL.Case r' mode e' alts'
>     e''
>       | v `elem` fv e'' -> IL.Let (IL.Binding v e') e''
>       | otherwise -> e''
>   where e' = translExpr tyEnv vs env e
>         translAlt v' (Alt _ t rhs) =
>           (id,
>            [translTerm v' t],
>            translRhs tyEnv vs (bindRenameEnv v' t env) rhs)
> translExpr _ _ _ _ = internalError "translExpr"

\end{verbatim}
\paragraph{Auxiliary Definitions}
The functions \texttt{varType} and \texttt{constrType} return the type
of variables and constructors, respectively. The quantifiers are
stripped from the types.
\begin{verbatim}

> varType :: ValueEnv -> QualIdent -> Type
> varType tyEnv f =
>   case qualLookupValue f tyEnv of
>     [Value _ (ForAll _ ty)] -> ty
>     _ -> internalError ("varType: " ++ show f)

> constrType :: ValueEnv -> QualIdent -> Type
> constrType tyEnv c =
>   case qualLookupValue c tyEnv of
>     [DataConstructor _ (ForAllExist _ _ ty)] -> ty
>     [NewtypeConstructor _ (ForAllExist _ _ ty)] -> ty
>     _ -> internalError ("constrType: " ++ show c)

\end{verbatim}
The list of import declarations in the intermediate language code is
determined by collecting all module qualifiers used in the current
module.
\begin{verbatim}

> imports :: ModuleIdent -> [IL.Decl] -> [ModuleIdent]
> imports m = Set.toList . Set.delete m . Set.fromList . foldr modulesDecl []

> modulesDecl :: IL.Decl -> [ModuleIdent] -> [ModuleIdent]
> modulesDecl (IL.DataDecl _ _ cs) ms = foldr modulesConstrDecl ms cs
>   where modulesConstrDecl (IL.ConstrDecl _ tys) ms' = foldr modulesType ms' tys
> modulesDecl (IL.NewtypeDecl _ _ (IL.ConstrDecl _ ty)) ms = modulesType ty ms
> modulesDecl (IL.FunctionDecl _ _ ty e) ms = modulesType ty (modulesExpr e ms)
> modulesDecl (IL.ExternalDecl _ _ _ ty) ms = modulesType ty ms

> modulesType :: IL.Type -> [ModuleIdent] -> [ModuleIdent]
> modulesType (IL.TypeConstructor tc tys) ms =
>   modules tc (foldr modulesType ms tys)
> modulesType (IL.TypeVariable _) ms = ms
> modulesType (IL.TypeArrow ty1 ty2) ms = modulesType ty1 (modulesType ty2 ms)

> modulesExpr :: IL.Expression -> [ModuleIdent] -> [ModuleIdent]
> modulesExpr (IL.Function f _) ms = modules f ms
> modulesExpr (IL.Constructor c _) ms = modules c ms
> modulesExpr (IL.Apply e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
> modulesExpr (IL.Case _ _ e as) ms = modulesExpr e (foldr modulesAlt ms as)
>   where modulesAlt (IL.Alt t e') ms' = modulesConstrTerm t (modulesExpr e' ms')
>         modulesConstrTerm (IL.ConstructorPattern c _) ms' = modules c ms'
>         modulesConstrTerm _ ms' = ms'
> modulesExpr (IL.Or e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
> modulesExpr (IL.Exist _ e) ms = modulesExpr e ms
> modulesExpr (IL.Let b e) ms = modulesBinding b (modulesExpr e ms)
> modulesExpr (IL.Letrec bs e) ms = foldr modulesBinding (modulesExpr e ms) bs
> modulesExpr _ ms = ms

> modulesBinding :: IL.Binding -> [ModuleIdent] -> [ModuleIdent]
> modulesBinding (IL.Binding _ e) = modulesExpr e

> modules :: QualIdent -> [ModuleIdent] -> [ModuleIdent]
> modules x ms = maybe ms (: ms) (qualidMod x)

\end{verbatim}