TcBinds.lhs 58.6 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6
7
%
\section[TcBinds]{TcBinds}

\begin{code}
8
module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
9
                 tcHsBootSigs, tcPolyBinds,
10
                 PragFun, tcSpecPrags, tcVectDecls, mkPragFun, 
11
                 TcSigInfo(..), SigFun, mkSigFun,
Ian Lynagh's avatar
Ian Lynagh committed
12
                 badBootDeclErr ) where
13

ross's avatar
ross committed
14
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
15
import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
16

Simon Marlow's avatar
Simon Marlow committed
17
18
import DynFlags
import HsSyn
19
import HscTypes( isHsBoot )
20
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
21
22
23
import TcEnv
import TcUnify
import TcSimplify
24
import TcEvidence
Simon Marlow's avatar
Simon Marlow committed
25
26
27
import TcHsType
import TcPat
import TcMType
28
import TyCon
Simon Marlow's avatar
Simon Marlow committed
29
30
31
import TcType
import TysPrim
import Id
32
import Var
33
import VarSet
Simon Marlow's avatar
Simon Marlow committed
34
import Name
35
import NameSet
36
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
37
import SrcLoc
38
import Bag
39
import ListSetOps
Simon Marlow's avatar
Simon Marlow committed
40
41
42
43
44
import ErrUtils
import Digraph
import Maybes
import Util
import BasicTypes
45
import Outputable
46
import FastString
47
48

import Control.Monad
49
50

#include "HsVersions.h"
51
\end{code}
52

53

54
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
55
%*                                                                      *
56
\subsection{Type-checking bindings}
Ian Lynagh's avatar
Ian Lynagh committed
57
%*                                                                      *
58
59
%************************************************************************

60
@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
61
62
63
64
65
66
67
68
69
70
it needs to know something about the {\em usage} of the things bound,
so that it can create specialisations of them.  So @tcBindsAndThen@
takes a function which, given an extended environment, E, typechecks
the scope of the bindings returning a typechecked thing and (most
important) an LIE.  It is this LIE which is then used as the basis for
specialising the things bound.

@tcBindsAndThen@ also takes a "combiner" which glues together the
bindings and the "thing" to make a new "thing".

71
The real work is done by @tcBindWithSigsAndThen@.
72
73
74
75
76
77
78
79
80
81

Recursive and non-recursive binds are handled in essentially the same
way: because of uniques there are no scoping issues left.  The only
difference is that non-recursive bindings can bind primitive values.

Even for non-recursive binding groups we add typings for each binder
to the LVE for the following reason.  When each individual binding is
checked the type of its LHS is unified with that of its RHS; and
type-checking the LHS of course requires that the binder is in scope.

82
83
84
At the top-level the LIE is sure to contain nothing but constant
dictionaries, which we resolve at the module level.

85
\begin{code}
86
87
88
89
90
91
92
93
94
95
96
97
98
99
tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv)
-- The TcGblEnv contains the new tcg_binds and tcg_spects
-- The TcLclEnv has an extended type envt for the new bindings
tcTopBinds (ValBindsOut binds sigs)
  = do  { tcg_env <- getGblEnv
        ; (binds', tcl_env) <- tcValBinds TopLevel binds sigs getLclEnv
        ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids

        ; let { tcg_env' = tcg_env { tcg_binds = foldr (unionBags . snd)
                                                       (tcg_binds tcg_env)
                                                       binds'
                                   , tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } }

        ; return (tcg_env', tcl_env) }
Ian Lynagh's avatar
Ian Lynagh committed
100
101
        -- The top level bindings are flattened into a giant 
        -- implicitly-mutually-recursive LHsBinds
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
tcTopBinds (ValBindsIn {}) = panic "tcTopBinds"

tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
tcRecSelBinds (ValBindsOut binds sigs)
  = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
    do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv)
       ; let tcg_env' 
              | isHsBoot (tcg_src tcg_env) = tcg_env
              | otherwise = tcg_env { tcg_binds = foldr (unionBags . snd)
                                                        (tcg_binds tcg_env)
                                                        rec_sel_binds }
              -- Do not add the code for record-selector bindings when 
              -- compiling hs-boot files
       ; return tcg_env' }
tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
117

118
tcHsBootSigs :: HsValBinds Name -> TcM [Id]
119
120
-- A hs-boot file has only one BindGroup, and it only has type
-- signatures in it.  The renamer checked all this
121
tcHsBootSigs (ValBindsOut binds sigs)
Ian Lynagh's avatar
Ian Lynagh committed
122
  = do  { checkTc (null binds) badBootDeclErr
123
        ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
124
  where
125
126
127
128
    tc_boot_sig (TypeSig lnames ty) = mapM f lnames
      where
        f (L _ name) = do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
                           ; return (mkVanillaGlobal name sigma_ty) }
Ian Lynagh's avatar
Ian Lynagh committed
129
        -- Notice that we make GlobalIds, not LocalIds
Ian Lynagh's avatar
Ian Lynagh committed
130
    tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
131
tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
132

133
badBootDeclErr :: Message
Ian Lynagh's avatar
Ian Lynagh committed
134
badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
135

136
137
------------------------
tcLocalBinds :: HsLocalBinds Name -> TcM thing
Ian Lynagh's avatar
Ian Lynagh committed
138
             -> TcM (HsLocalBinds TcId, thing)
sof's avatar
sof committed
139

140
tcLocalBinds EmptyLocalBinds thing_inside 
Ian Lynagh's avatar
Ian Lynagh committed
141
142
  = do  { thing <- thing_inside
        ; return (EmptyLocalBinds, thing) }
sof's avatar
sof committed
143

144
145
146
147
tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
  = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
        ; return (HsValBinds (ValBindsOut binds' sigs), thing) }
tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
148

149
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
150
  = do  { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
151

Ian Lynagh's avatar
Ian Lynagh committed
152
153
        -- If the binding binds ?x = E, we  must now 
        -- discharge any ?x constraints in expr_lie
154
        -- See Note [Implicit parameter untouchables]
155
        ; (ev_binds, result) <- checkConstraints (IPSkol ips) 
156
                                  [] given_ips thing_inside
157
158

        ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
159
  where
160
161
    ips = [ip | L _ (IPBind ip _) <- ip_binds]

Ian Lynagh's avatar
Ian Lynagh committed
162
163
164
        -- I wonder if we should do these one at at time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
165
166
167
168
169
    tc_ip_bind (IPBind ip expr) 
       = do { ty <- newFlexiTyVarTy argTypeKind
            ; ip_id <- newIP ip ty
            ; expr' <- tcMonoExpr expr ty
            ; return (ip_id, (IPBind (IPName ip_id) expr')) }
170
\end{code}
171

172
173
174
175
176
177
178
179
Note [Implicit parameter untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We add the type variables in the types of the implicit parameters
as untouchables, not so much because we really must not unify them,
but rather because we otherwise end up with constraints like this
    Num alpha, Implic { wanted = alpha ~ Int }
The constraint solver solves alpha~Int by unification, but then
doesn't float that solved constraint out (it's not an unsolved 
180
wanted).  Result disaster: the (Num alpha) is again solved, this
181
182
time by defaulting.  No no no.

183
184
185
However [Oct 10] this is all handled automatically by the 
untouchable-range idea.

186
\begin{code}
187
tcValBinds :: TopLevelFlag 
188
189
190
           -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
           -> TcM thing
           -> TcM ([(RecFlag, LHsBinds TcId)], thing) 
191

192
tcValBinds top_lvl binds sigs thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
193
  = do  {       -- Typecheck the signature
194
        ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
195
              ; ty_sigs = filter isTypeLSig sigs
196
              ; sig_fn  = mkSigFun ty_sigs }
Ian Lynagh's avatar
Ian Lynagh committed
197

198
        ; poly_ids <- concat <$> checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
Ian Lynagh's avatar
Ian Lynagh committed
199
200
201
202
203
204
205
206
207
                -- No recovery from bad signatures, because the type sigs
                -- may bind type variables, so proceeding without them
                -- can lead to a cascade of errors
                -- ToDo: this means we fall over immediately if any type sig
                -- is wrong, which is over-conservative, see Trac bug #745

                -- Extend the envt right away with all 
                -- the Ids declared with type signatures
        ; (binds', thing) <- tcExtendIdEnv poly_ids $
208
                             tcBindGroups top_lvl sig_fn prag_fn 
Ian Lynagh's avatar
Ian Lynagh committed
209
210
                                          binds thing_inside

211
        ; return (binds', thing) }
212

213
------------------------
214
tcBindGroups :: TopLevelFlag -> SigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
215
216
             -> [(RecFlag, LHsBinds Name)] -> TcM thing
             -> TcM ([(RecFlag, LHsBinds TcId)], thing)
217
218
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
219
220
221
-- Here a "strongly connected component" has the strightforward
-- meaning of a group of bindings that mention each other, 
-- ignoring type signatures (that part comes later)
222

223
tcBindGroups _ _ _ [] thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
224
225
  = do  { thing <- thing_inside
        ; return ([], thing) }
226

227
tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
228
  = do  { (group', (groups', thing))
229
230
                <- tc_group top_lvl sig_fn prag_fn group $ 
                   tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
231
        ; return (group' ++ groups', thing) }
sof's avatar
sof committed
232

233
------------------------
234
235
tc_group :: forall thing. 
            TopLevelFlag -> SigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
236
237
         -> (RecFlag, LHsBinds Name) -> TcM thing
         -> TcM ([(RecFlag, LHsBinds TcId)], thing)
238
239
240
241
242

-- Typecheck one strongly-connected component of the original program.
-- We get a list of groups back, because there may 
-- be specialisations etc as well

243
tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
244
245
        -- A single non-recursive binding
        -- We want to keep non-recursive things non-recursive
246
        -- so that we desugar unlifted bindings correctly
247
 =  do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
248
                                              NonRecursive NonRecursive
249
250
                                             (bagToList binds)
       ; thing <- tcExtendLetEnv closed ids thing_inside
251
252
253
254
       ; return ( [(NonRecursive, binds1)], thing) }

tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
  =     -- To maximise polymorphism (assumes -XRelaxedPolyRec), we do a new 
Ian Lynagh's avatar
Ian Lynagh committed
255
256
        -- strongly-connected-component analysis, this time omitting 
        -- any references to variables with type signatures.
257
258
    do  { traceTc "tc_group rec" (pprLHsBinds binds)
        ; (binds1, _ids, thing) <- go sccs
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
259
260
             -- Here is where we should do bindInstsOfLocalFuns
             -- if we start having Methods again
261
        ; return ([(Recursive, binds1)], thing) }
Ian Lynagh's avatar
Ian Lynagh committed
262
                -- Rec them all together
263
  where
264
265
266
267
    sccs :: [SCC (LHsBind Name)]
    sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)

    go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
268
269
    go (scc:sccs) = do  { (binds1, ids1, closed) <- tc_scc scc
                        ; (binds2, ids2, thing)  <- tcExtendLetEnv closed ids1 $ go sccs
270
271
                        ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
    go []         = do  { thing <- thing_inside; return (emptyBag, [], thing) }
272

273
274
    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
sof's avatar
sof committed
275

276
    tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
sof's avatar
sof committed
277

278
------------------------
279
mkEdges :: SigFun -> LHsBinds Name
Ian Lynagh's avatar
Ian Lynagh committed
280
        -> [(LHsBind Name, BKey, [BKey])]
281
282
283
284

type BKey  = Int -- Just number off the bindings

mkEdges sig_fn binds
285
  = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
Ian Lynagh's avatar
Ian Lynagh committed
286
                         Just key <- [lookupNameEnv key_map n], no_sig n ])
287
288
289
290
291
292
293
294
    | (bind, key) <- keyd_binds
    ]
  where
    no_sig :: Name -> Bool
    no_sig n = isNothing (sig_fn n)

    keyd_binds = bagToList binds `zip` [0::BKey ..]

Ian Lynagh's avatar
Ian Lynagh committed
295
    key_map :: NameEnv BKey     -- Which binding it comes from
296
    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
Ian Lynagh's avatar
Ian Lynagh committed
297
                                     , bndr <- bindersOfHsBind bind ]
298
299

bindersOfHsBind :: HsBind Name -> [Name]
300
301
bindersOfHsBind (PatBind { pat_lhs = pat })  = collectPatBinders pat
bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
Ian Lynagh's avatar
Ian Lynagh committed
302
303
bindersOfHsBind (AbsBinds {})                = panic "bindersOfHsBind AbsBinds"
bindersOfHsBind (VarBind {})                 = panic "bindersOfHsBind VarBind"
304

305
------------------------
306
tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
307
308
309
310
311
            -> RecFlag       -- Whether the group is really recursive
            -> RecFlag       -- Whether it's recursive after breaking
                             -- dependencies based on type signatures
            -> [LHsBind Name]
            -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
312
313
314
315
316

-- Typechecks a single bunch of bindings all together, 
-- and generalises them.  The bunch may be only part of a recursive
-- group, because we use type signatures to maximise polymorphism
--
317
318
319
-- Returns a list because the input may be a single non-recursive binding,
-- in which case the dependency order of the resulting bindings is
-- important.  
320
-- 
321
322
-- Knows nothing about the scope of the bindings

323
324
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
  = setSrcSpan loc                              $
Ian Lynagh's avatar
Ian Lynagh committed
325
    recoverM (recoveryCode binder_names sig_fn) $ do 
326
        -- Set up main recover; take advantage of any type sigs
327

328
329
    { traceTc "------------------------------------------------" empty
    ; traceTc "Bindings for" (ppr binder_names)
330

331
332
    -- Instantiate the polytypes of any binders that have signatures
    -- (as determined by sig_fn), returning a TcSigInfo for each
333
    ; tc_sig_fn <- tcInstSigs sig_fn binder_names
334

335
336
337
338
    ; dflags   <- getDOpts
    ; type_env <- getLclTypeEnv
    ; let plan = decideGeneralisationPlan dflags type_env 
                         binder_names bind_list tc_sig_fn
339
    ; traceTc "Generalisation plan" (ppr plan)
340
341
342
343
    ; result@(_, poly_ids, _) <- case plan of
         NoGen          -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
         InferGen mn cl -> tcPolyInfer mn cl tc_sig_fn prag_fn rec_tc bind_list
         CheckGen sig   -> tcPolyCheck sig prag_fn rec_tc bind_list
344

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
345
        -- Check whether strict bindings are ok
Ian Lynagh's avatar
Ian Lynagh committed
346
347
        -- These must be non-recursive etc, and are not generalised
        -- They desugar to a case expression in the end
348
349
    ; checkStrictBinds top_lvl rec_group bind_list poly_ids

350
    ; return result }
351
352
  where
    binder_names = collectHsBindListBinders bind_list
353
354
355
    loc = foldr1 combineSrcSpans (map getLoc bind_list)
         -- The mbinds have been dependency analysed and 
         -- may no longer be adjacent; so find the narrowest
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
356
         -- span that includes them all
357

358
------------------
359
360
361
362
363
tcPolyNoGen 
  :: TcSigFun -> PragFun
  -> RecFlag       -- Whether it's recursive after breaking
                   -- dependencies based on type signatures
  -> [LHsBind Name]
364
  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
365
366
-- No generalisation whatsoever

367
368
369
tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
  = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn) 
                                             rec_tc bind_list
370
       ; mono_ids' <- mapM tc_mono_info mono_infos
371
       ; return (binds', mono_ids', NotTopLevel) }
372
373
374
  where
    tc_mono_info (name, _, mono_id)
      = do { mono_ty' <- zonkTcTypeCarefully (idType mono_id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
375
             -- Zonk, mainly to expose unboxed types to checkStrictBinds
376
           ; let mono_id' = setIdType mono_id mono_ty'
377
           ; _specs <- tcSpecPrags mono_id' (prag_fn name)
378
           ; return mono_id' }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
379
380
381
382
           -- NB: tcPrags generates error messages for
           --     specialisation pragmas for non-overloaded sigs
           -- Indeed that is why we call it here!
           -- So we can safely ignore _specs
383
384
385

------------------
tcPolyCheck :: TcSigInfo -> PragFun
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
386
387
388
389
            -> RecFlag       -- Whether it's recursive after breaking
                             -- dependencies based on type signatures
            -> [LHsBind Name]
            -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
390
391
392
-- There is just one binding, 
--   it binds a single variable,
--   it has a signature,
393
tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_scoped = scoped
394
                           , sig_theta = theta, sig_tau = tau })
395
    prag_fn rec_tc bind_list
396
397
398
399
  = do { loc <- getSrcSpanM
       ; ev_vars <- newEvVars theta
       ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
             prag_sigs = prag_fn (idName poly_id)
400
       ; (ev_binds, (binds', [mono_info])) 
401
            <- checkConstraints skol_info tvs ev_vars $
402
               tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs)    $
403
               tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
404

405
406
       ; spec_prags <- tcSpecPrags poly_id prag_sigs
       ; poly_id    <- addInlinePrags poly_id prag_sigs
407

408
409
410
411
412
       ; let (_, _, mono_id) = mono_info
             export = ABE { abe_wrap = idHsWrapper
                          , abe_poly = poly_id
                          , abe_mono = mono_id
                          , abe_prags = SpecPrags spec_prags }
413
414
415
416
             abs_bind = L loc $ AbsBinds 
                        { abs_tvs = tvs
                        , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
                        , abs_exports = [export], abs_binds = binds' }
417
418
419
             closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
                    | otherwise                                     = NotTopLevel
       ; return (unitBag abs_bind, [poly_id], closed) }
420

421
------------------
422
tcPolyInfer 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
423
424
  :: Bool         -- True <=> apply the monomorphism restriction
  -> Bool         -- True <=> free vars have closed types
425
426
427
428
  -> TcSigFun -> PragFun
  -> RecFlag       -- Whether it's recursive after breaking
                   -- dependencies based on type signatures
  -> [LHsBind Name]
429
430
  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list
431
  = do { ((binds', mono_infos), wanted) 
432
             <- captureConstraints $
433
                tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
434

435
       ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
436
       ; (qtvs, givens, mr_bites, ev_binds) <- simplifyInfer closed mono name_taus wanted
437

438
439
       ; theta <- zonkTcThetaType (map evVarPred givens)
       ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos
440
441

       ; loc <- getSrcSpanM
442
       ; let poly_ids = map abe_poly exports
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
443
444
             final_closed | closed && not mr_bites = TopLevel
                          | otherwise              = NotTopLevel
445
446
447
448
             abs_bind = L loc $ 
                        AbsBinds { abs_tvs = qtvs
                                 , abs_ev_vars = givens, abs_ev_binds = ev_binds
                                 , abs_exports = exports, abs_binds = binds' }
449

Simon Peyton Jones's avatar
Simon Peyton Jones committed
450
451
       ; traceTc "Binding:" (ppr final_closed $$
                             ppr (poly_ids `zip` map idType poly_ids))
452
453
       ; return (unitBag abs_bind, poly_ids, final_closed)   
         -- poly_ids are guaranteed zonked by mkExport
454
  }
455
456
457


--------------
458
mkExport :: PragFun 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
459
         -> [TyVar] -> TcThetaType      -- Both already zonked
Ian Lynagh's avatar
Ian Lynagh committed
460
         -> MonoBindInfo
461
         -> TcM (ABExport Id)
462
-- mkExport generates exports with 
Ian Lynagh's avatar
Ian Lynagh committed
463
464
--      zonked type variables, 
--      zonked poly_ids
465
466
467
468
469
470
-- The former is just because no further unifications will change
-- the quantified type variables, so we can fix their final form
-- right now.
-- The latter is needed because the poly_ids are used to extend the
-- type environment; see the invariant on TcEnv.tcExtendIdEnv 

471
-- Pre-condition: the qtvs and theta are already zonked
472

473
474
475
476
mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
  = do  { mono_ty <- zonkTcTypeCarefully (idType mono_id)
        ; let inferred_poly_ty = mkSigmaTy my_tvs theta mono_ty
              my_tvs   = filter (`elemVarSet` used_tvs) qtvs
batterseapower's avatar
batterseapower committed
477
              used_tvs = tyVarsOfTypes theta `unionVarSet` tyVarsOfType mono_ty
478

479
480
481
482
              poly_id  = case mb_sig of
                           Nothing  -> mkLocalId poly_name inferred_poly_ty
                           Just sig -> sig_id sig
                -- poly_id has a zonked type
483

484
        ; poly_id <- addInlinePrags poly_id prag_sigs
485
        ; spec_prags <- tcSpecPrags poly_id prag_sigs
Ian Lynagh's avatar
Ian Lynagh committed
486
                -- tcPrags requires a zonked poly_id
487

488
489
490
491
        ; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty
        ; traceTc "mkExport: check sig" 
                  (ppr poly_name $$ ppr sel_poly_ty $$ ppr (idType poly_id)) 

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
492
493
494
495
496
497
        -- Perform the impedence-matching and ambiguity check
        -- right away.  If it fails, we want to fail now (and recover
        -- in tcPolyBinds).  If we delay checking, we get an error cascade.
        -- Remember we are in the tcPolyInfer case, so the type envt is 
        -- closed (unless we are doing NoMonoLocalBinds in which case all bets
        -- are off)
498
499
500
        ; (wrap, wanted) <- addErrCtxtM (mk_msg poly_id) $
                            captureConstraints $
                            tcSubType origin sig_ctxt sel_poly_ty (idType poly_id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
501
        ; ev_binds <- simplifyAmbiguityCheck poly_name wanted
502
503
504
505
506

        ; return (ABE { abe_wrap = mkWpLet (EvBinds ev_binds) <.> wrap
                      , abe_poly = poly_id
                      , abe_mono = mono_id
                      , abe_prags = SpecPrags spec_prags }) }
507
  where
508
    inferred = isNothing mb_sig
509

510
511
512
513
514
515
516
517
518
519
520
521
    mk_msg poly_id tidy_env
      = return (tidy_env', msg)
      where
        msg | inferred  = hang (ptext (sLit "When checking that") <+> pp_name)
                             2 (ptext (sLit "has the inferred type") <+> pp_ty)
                          $$ ptext (sLit "Probable cause: the inferred type is ambiguous")
            | otherwise = hang (ptext (sLit "When checking that") <+> pp_name)
                             2 (ptext (sLit "has the specified type") <+> pp_ty)
        pp_name = quotes (ppr poly_name)
        pp_ty   = quotes (ppr tidy_ty)
        (tidy_env', tidy_ty) = tidyOpenType tidy_env (idType poly_id)
        
522

523
524
525
    prag_sigs = prag_fn poly_name
    origin    = AmbigOrigin poly_name
    sig_ctxt  = InfSigCtxt poly_name
526
527

------------------------
528
type PragFun = Name -> [LSig Name]
529

530
mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
531
532
533
534
535
536
537
538
539
540
mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
  where
    prs = mapCatMaybes get_sig sigs

    get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
    get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig  nm ty (add_arity nm inl))
    get_sig (L l (InlineSig nm inl))  = Just (nm, L l $ InlineSig nm   (add_arity nm inl))
    get_sig _                         = Nothing

    add_arity (L _ n) inl_prag   -- Adjust inl_sat field to match visible arity of function
541
542
543
      | Just ar <- lookupNameEnv ar_env n,
        Inline <- inl_inline inl_prag     = inl_prag { inl_sat = Just ar }
        -- add arity only for real INLINE pragmas, not INLINABLE
544
545
546
547
548
549
550
551
552
553
554
555
556
      | otherwise                         = inl_prag

    prag_env :: NameEnv [LSig Name]
    prag_env = foldl add emptyNameEnv prs
    add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p

    -- ar_env maps a local to the arity of its definition
    ar_env :: NameEnv Arity
    ar_env = foldrBag lhsBindArity emptyNameEnv binds

lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
  = extendNameEnv env (unLoc id) (matchGroupArity ms)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
557
lhsBindArity _ env = env        -- PatBind/VarBind
558

559
------------------
560
561
tcSpecPrags :: Id -> [LSig Name]
            -> TcM [LTcSpecPrag]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
562
-- Add INLINE and SPECIALSE pragmas
563
564
--    INLINE prags are added to the (polymorphic) Id directly
--    SPECIALISE prags are passed to the desugarer via TcSpecPrags
Simon Marlow's avatar
Simon Marlow committed
565
566
-- Pre-condition: the poly_id is zonked
-- Reason: required by tcSubExp
567
568
569
tcSpecPrags poly_id prag_sigs
  = do { unless (null bad_sigs) warn_discarded_sigs
       ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
570
  where
571
572
573
574
    spec_sigs = filter isSpecLSig prag_sigs
    bad_sigs  = filter is_bad_sig prag_sigs
    is_bad_sig s = not (isSpecLSig s || isInlineLSig s)

575
576
577
578
579
580
581
582
583
584
585
586
    warn_discarded_sigs = warnPrags poly_id bad_sigs $
                          ptext (sLit "Discarding unexpected pragmas for")


--------------
tcSpec :: TcId -> Sig Name -> TcM TcSpecPrag
tcSpec poly_id prag@(SpecSig _ hs_ty inl) 
  -- The Name in the SpecSig may not be the same as that of the poly_id
  -- Example: SPECIALISE for a class method: the Name in the SpecSig is
  --          for the selector Id, but the poly_id is something like $cop
  = addErrCtxt (spec_ctxt prag) $
    do  { spec_ty <- tcHsSigType sig_ctxt hs_ty
587
588
        ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
                 (ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
589
                  -- Note [SPECIALISE pragmas]
590
        ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty
591
592
        ; return (SpecPrag poly_id wrap inl) }
  where
593
594
595
    name      = idName poly_id
    poly_ty   = idType poly_id
    origin    = SpecPragOrigin name
596
597
    sig_ctxt  = FunSigCtxt name
    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
598

599
tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
600

601
602
--------------
tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
603
-- SPECIALISE pragamas for imported things
604
605
tcImpPrags prags
  = do { this_mod <- getModule
606
       ; dflags <- getDOpts
607
608
       ; if (not_specialising dflags) then
            return []
609
610
611
612
         else
            mapAndRecoverM (wrapLocM tcImpSpec) 
            [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
                               , not (nameIsLocalOrFrom this_mod name) ] }
613
614
615
616
617
618
619
620
621
622
623
  where
    -- Ignore SPECIALISE pragmas for imported things
    -- when we aren't specialising, or when we aren't generating
    -- code.  The latter happens when Haddocking the base library;
    -- we don't wnat complaints about lack of INLINABLE pragmas 
    not_specialising dflags
      | not (dopt Opt_Specialise dflags) = True
      | otherwise = case hscTarget dflags of
                      HscNothing -> True
                      HscInterpreted -> True
                      _other         -> False
624
625
626

tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
tcImpSpec (name, prag)
627
 = do { id <- tcLookupId name
628
629
      ; unless (isAnyInlinePragma (idInlinePragma id))
               (addWarnTc (impSpecErr name))
630
631
632
633
634
      ; tcSpec id prag }

impSpecErr :: Name -> SDoc
impSpecErr name
  = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
635
       2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
636
637
638
639
640
               , parens $ sep 
                   [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
                   , ptext (sLit "was compiled without -O")]])
  where
    mod = nameModule name
641
642

--------------
643
tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
644
645
tcVectDecls decls 
  = do { decls' <- mapM (wrapLocM tcVect) decls
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
646
       ; let ids  = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
647
648
             dups = findDupsEq (==) ids
       ; mapM_ reportVectDups dups
649
       ; traceTcConstraints "End of tcVectDecls"
650
651
652
653
654
655
656
657
658
659
       ; return decls'
       }
  where
    reportVectDups (first:_second:_more) 
      = addErrAt (getSrcSpan first) $
          ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
    reportVectDups _ = return ()

--------------
tcVect :: VectDecl Name -> TcM (VectDecl TcId)
660
661
662
-- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
--   type of the original definition as this requires internals of the vectoriser not available
--   during type checking.  Instead, constrain the rhs of a vectorisation declaration to be a single
663
664
--   identifier (this is checked in 'rnHsVectDecl').  Fix this by enabling the use of 'vectType'
--   from the vectoriser here.
665
666
tcVect (HsVect name Nothing)
  = addErrCtxt (vectCtxt name) $
667
668
    do { var <- wrapLocM tcLookupId name
       ; return $ HsVect var Nothing
669
       }
670
671
672
tcVect (HsVect name (Just rhs))
  = addErrCtxt (vectCtxt name) $
    do { var <- wrapLocM tcLookupId name
673
674
       ; let L rhs_loc (HsVar rhs_var_name) = rhs
       ; rhs_id <- tcLookupId rhs_var_name
675
       ; return $ HsVect var (Just $ L rhs_loc (HsVar rhs_id))
676
       }
677

678
{- OLD CODE:
679
         -- turn the vectorisation declaration into a single non-recursive binding
680
       ; let bind    = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] 
681
682
683
684
             sigFun  = const Nothing
             pragFun = mkPragFun [] (unitBag bind)

         -- perform type inference (including generalisation)
685
       ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
686
       
687
       ; traceTc "tcVect inferred type" $ ppr (varType id')
688
       ; traceTc "tcVect bindings"      $ ppr binds
689
       
690
691
         -- add all bindings, including the type variable and dictionary bindings produced by type
         -- generalisation to the right-hand side of the vectorisation declaration
692
693
694
695
696
697
698
699
700
701
702
       ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
       ; let [bind']                                  = bagToList actualBinds
             MatchGroup 
               [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
               _                                      = (fun_matches . unLoc) bind'
             rhsWrapped                               = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
        
        -- We return the type-checked 'Id', to propagate the inferred signature
        -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
       ; return $ HsVect (L loc id') (Just rhsWrapped)
       }
703
 -}
704
705
tcVect (HsNoVect name)
  = addErrCtxt (vectCtxt name) $
706
707
    do { var <- wrapLocM tcLookupId name
       ; return $ HsNoVect var
708
       }
709
tcVect (HsVectTypeIn isScalar lname rhs_name)
710
  = addErrCtxt (vectCtxt lname) $
711
    do { tycon <- tcLookupLocatedTyCon lname
712
713
714
715
716
       ; checkTc (   not isScalar             -- either    we have a non-SCALAR declaration
                 || isJust rhs_name           -- or        we explicitly provide a vectorised type
                 || tyConArity tycon == 0     -- otherwise the type constructor must be nullary
                 )
                 scalarTyConMustBeNullary
717

718
719
       ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
       ; return $ HsVectTypeOut isScalar tycon rhs_tycon
720
       }
721
tcVect (HsVectTypeOut _ _ _)
722
  = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
723
724
725
726
727
728
729
tcVect (HsVectClassIn lname)
  = addErrCtxt (vectCtxt lname) $
    do { cls <- tcLookupLocatedClass lname
       ; return $ HsVectClassOut cls
       }
tcVect (HsVectClassOut _)
  = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
730
tcVect (HsVectInstIn linstTy)
731
732
733
  = addErrCtxt (vectCtxt linstTy) $
    do { (cls, tys) <- tcHsVectInst linstTy
       ; inst       <- tcLookupInstance cls tys
734
       ; return $ HsVectInstOut inst
735
       }
736
tcVect (HsVectInstOut _)
737
  = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
738

739
740
vectCtxt :: Outputable thing => thing -> SDoc
vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing
741

742
743
744
scalarTyConMustBeNullary :: Message
scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")

745
--------------
746
747
748
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise 
-- subsequent error messages
749
recoveryCode :: [Name] -> SigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
750
recoveryCode binder_names sig_fn
751
  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
Ian Lynagh's avatar
Ian Lynagh committed
752
        ; poly_ids <- mapM mk_dummy binder_names
753
754
        ; return (emptyBag, poly_ids, if all is_closed poly_ids
                                      then TopLevel else NotTopLevel) }
755
  where
756
    mk_dummy name 
Ian Lynagh's avatar
Ian Lynagh committed
757
758
        | isJust (sig_fn name) = tcLookupId name        -- Had signature; look it up
        | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
759

760
761
    is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id))

762
forall_a_a :: TcType
763
forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
764
765
\end{code}

766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
Note [SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~
There is no point in a SPECIALISE pragma for a non-overloaded function:
   reverse :: [a] -> [a]
   {-# SPECIALISE reverse :: [Int] -> [Int] #-}

But SPECIALISE INLINE *can* make sense for GADTS:
   data Arr e where
     ArrInt :: !Int -> ByteArray# -> Arr Int
     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)

   (!:) :: Arr e -> Int -> e
   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}  
   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)
   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)

When (!:) is specialised it becomes non-recursive, and can usefully
be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
for a non-overloaded function.
786

787
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
788
%*                                                                      *
789
\subsection{tcMonoBind}
Ian Lynagh's avatar
Ian Lynagh committed
790
%*                                                                      *
791
792
%************************************************************************

793
@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
794
795
The signatures have been dealt with already.

796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
Note [Pattern bindings]
~~~~~~~~~~~~~~~~~~~~~~~
The rule for typing pattern bindings is this:

    ..sigs..
    p = e

where 'p' binds v1..vn, and 'e' may mention v1..vn, 
typechecks exactly like

    ..sigs..
    x = e       -- Inferred type
    v1 = case x of p -> v1
    ..
    vn = case x of p -> vn

Note that  
    (f :: forall a. a -> a) = id
should not typecheck because
       case id of { (f :: forall a. a->a) -> f }
will not typecheck.

818
\begin{code}
819
tcMonoBinds :: TcSigFun -> LetBndrSpec 
Ian Lynagh's avatar
Ian Lynagh committed
820
821
            -> RecFlag  -- Whether the binding is recursive for typechecking purposes
                        -- i.e. the binders are mentioned in their RHSs, and
822
                        --      we are not rescued by a type signature
823
            -> [LHsBind Name]
Ian Lynagh's avatar
Ian Lynagh committed
824
            -> TcM (LHsBinds TcId, [MonoBindInfo])
825

826
827
tcMonoBinds sig_fn no_gen is_rec
           [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
Ian Lynagh's avatar
Ian Lynagh committed
828
                                fun_matches = matches, bind_fvs = fvs })]
829
830
831
                             -- Single function binding, 
  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
  , Nothing <- sig_fn name   -- ...with no type signature
Ian Lynagh's avatar
Ian Lynagh committed
832
833
834
835
836
837
838
839
  =     -- In this very special case we infer the type of the
        -- right hand side first (it may have a higher-rank type)
        -- and *then* make the monomorphic Id for the LHS
        -- e.g.         f = \(x::forall a. a->a) -> <body>
        --      We want to infer a higher-rank type for f
    setSrcSpan b_loc    $
    do  { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)

840
        ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
Ian Lynagh's avatar
Ian Lynagh committed
841
842
843
844
        ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
                                              fun_matches = matches', bind_fvs = fvs,
                                              fun_co_fn = co_fn, fun_tick = Nothing })),
                  [(name, Nothing, mono_id)]) }
845

846
847
tcMonoBinds sig_fn no_gen _ binds
  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
848

Ian Lynagh's avatar
Ian Lynagh committed
849
850
851
        -- Bring the monomorphic Ids, into scope for the RHSs
        ; let mono_info  = getMonoBindInfo tc_binds
              rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
852
853
                    -- A monomorphic binding for each term variable that lacks 
                    -- a type sig.  (Ones with a sig are already in scope.)
854

Ian Lynagh's avatar
Ian Lynagh committed
855
        ; binds' <- tcExtendIdEnv2 rhs_id_env $ do
856
857
                    traceTc "tcMonoBinds" $  vcat [ ppr n <+> ppr id <+> ppr (idType id) 
                                                  | (n,id) <- rhs_id_env]
Ian Lynagh's avatar
Ian Lynagh committed
858
859
                    mapM (wrapLocM tcRhs) tc_binds
        ; return (listToBag binds', mono_info) }
860
861
862
863

------------------------
-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
-- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
Ian Lynagh's avatar
Ian Lynagh committed
864
865
--      if there's a signature for it, use the instantiated signature type
--      otherwise invent a type variable
866
867
868
-- You see that quite directly in the FunBind case.
-- 
-- But there's a complication for pattern bindings:
Ian Lynagh's avatar
Ian Lynagh committed
869
870
--      data T = MkT (forall a. a->a)
--      MkT f = e
871
872
873
874
875
876
-- Here we can guess a type variable for the entire LHS (which will be refined to T)
-- but we want to get (f::forall a. a->a) as the RHS environment.
-- The simplest way to do this is to typecheck the pattern, and then look up the
-- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't

Ian Lynagh's avatar
Ian Lynagh committed
877
data TcMonoBind         -- Half completed; LHS done, RHS not done
878
  = TcFunBind  MonoBindInfo  SrcSpan Bool (MatchGroup Name) 
879
880
  | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType

881
type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
Ian Lynagh's avatar
Ian Lynagh committed
882
883
        -- Type signature (if any), and
        -- the monomorphic bound things
884

885
tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
886
tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
887
888
889
890
891
892
893
  | Just sig <- sig_fn name
  = do  { mono_id <- newSigLetBndr no_gen name sig
        ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
  | otherwise
  = do  { mono_ty <- newFlexiTyVarTy argTypeKind
        ; mono_id <- newNoSigLetBndr no_gen name mono_ty
        ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
894
895
896
897

tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
  = do  { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
                              mapM lookup_info (collectPatBinders pat)
Ian Lynagh's avatar
Ian Lynagh committed
898
899
900

                -- After typechecking the pattern, look up the binder
                -- names, which the pattern has brought into scope.
901
902
903
              lookup_info :: Name -> TcM MonoBindInfo
              lookup_info name = do { mono_id <- tcLookupId name
                                    ; return (name, sig_fn name, mono_id) }
Ian Lynagh's avatar
Ian Lynagh committed
904
905
906
907
908

        ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
                                     tcInfer tc_pat

        ; return (TcPatBind infos pat' grhss pat_ty) }
909

910
tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
Ian Lynagh's avatar
Ian Lynagh committed
911
        -- AbsBind, VarBind impossible
912

913
914
-------------------
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
915
916
917
918
-- When we are doing pattern bindings, or multiple function bindings at a time
-- we *don't* bring any scoped type variables into scope
-- Wny not?  They are not completely rigid.
-- That's why we have the special case for a single FunBind in tcMonoBinds
919
tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
920
921
  = do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
        ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf 
Ian Lynagh's avatar
Ian Lynagh committed
922
                                            matches (idType mono_id)
923
924
        ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
                          , fun_matches = matches'
925
926
                          , fun_co_fn = co_fn 
                          , bind_fvs = placeHolderNames, fun_tick = Nothing }) }
927

Ian Lynagh's avatar
Ian Lynagh committed
928
tcRhs (TcPatBind _ pat' grhss pat_ty)
929
930
  = do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
        ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
Ian Lynagh's avatar
Ian Lynagh committed
931
                    tcGRHSsPat grhss pat_ty
932
        ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty 
933
934
                          , bind_fvs = placeHolderNames
                          , pat_ticks = (Nothing,[]) }) }
935
936
937


---------------------
938
getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
939
getMonoBindInfo tc_binds
940
  = foldr (get_info . unLoc) [] tc_binds
941
942
943
944
945
946
947
  where
    get_info (TcFunBind info _ _ _)  rest = info : rest
    get_info (TcPatBind infos _ _ _) rest = infos ++ rest
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
948
949
950
%*                                                                      *
                Generalisation
%*                                                                      *
951
952
%************************************************************************

953
954
955
unifyCtxts checks that all the signature contexts are the same
The type signatures on a mutually-recursive group of definitions
must all have the same context (or none).
956

957
958
959
960
961
962
963
964
965
The trick here is that all the signatures should have the same
context, and we want to share type variables for that context, so that
all the right hand sides agree a common vocabulary for their type
constraints

We unify them because, with polymorphic recursion, their types
might not otherwise be related.  This is a rather subtle issue.

\begin{code}
966
{-
967
unifyCtxts :: [TcSigInfo] -> TcM ()
968
-- Post-condition: the returned Insts are full zonked
969
970
971
unifyCtxts [] = return ()
unifyCtxts (sig1 : sigs)
  = do  { traceTc "unifyCtxts" (ppr (sig1 : sigs))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
972
        ; mapM_ unify_ctxt sigs }
973
974
975
976
  where
    theta1 = sig_theta sig1
    unify_ctxt :: TcSigInfo -> TcM ()
    unify_ctxt sig@(TcSigInfo { sig_theta = theta })
977
        = setSrcSpan (sig_loc sig)                      $
Ian Lynagh's avatar
Ian Lynagh committed
978
          addErrCtxt (sigContextsCtxt sig1 sig)         $
batterseapower's avatar
batterseapower committed
979
          do { mk_cos <- unifyTheta theta1 theta
Ian Lynagh's avatar
Ian Lynagh committed
980
981
982
983
984
985
986
             ; -- Check whether all coercions are identity coercions
               -- That can happen if we have, say
               --         f :: C [a]   => ...
               --         g :: C (F a) => ...
               -- where F is a type function and (F a ~ [a])
               -- Then unification might succeed with a coercion.  But it's much
               -- much simpler to require that such signatures have identical contexts
batterseapower's avatar
batterseapower committed
987
               checkTc (isReflMkCos mk_cos)
Ian Lynagh's avatar
Ian Lynagh committed
988
989
                       (ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
             }
990
991
992
993
994
995
996
997
998
999
1000
1001

-----------------------------------------------
sigContextsCtxt :: TcSigInfo -> TcSigInfo -> SDoc
sigContextsCtxt sig1 sig2
  = vcat [ptext (sLit "When matching the contexts of the signatures for"), 
          nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
                        ppr id2 <+> dcolon <+> ppr (idType id2)]),
          ptext (sLit "The signature contexts in a mutually recursive group should all be identical")]
  where
    id1 = sig_id sig1
    id2 = sig_id sig2
-}
SamB's avatar
SamB committed
1002
\end{code}
1003

1004

1005
@getTyVarsToGen@ decides what type variables to generalise over.
1006
1007
1008
1009
1010
1011
1012
1013

For a "restricted group" -- see the monomorphism restriction
for a definition -- we bind no dictionaries, and
remove from tyvars_to_gen any constrained type variables

*Don't* simplify dicts at this point, because we aren't going
to generalise over these dicts.  By the time we do simplify them
we may well know more.  For example (this actually came up)
Ian Lynagh's avatar
Ian Lynagh committed
1014
1015
        f :: Array Int Int
        f x = array ... xs where xs = [1,2,3,4,5]
1016
1017
1018
1019
1020
We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
stuff.  If we simplify only at the f-binding (not the xs-binding)
we'll know that the literals are all Ints, and we can just produce
Int literals!

1021
1022
1023
1024
Find all the type variables involved in overloading, the
"constrained_tyvars".  These are the ones we *aren't* going to
generalise.  We must be careful about doing this:

1025
 (a) If we fail to generalise a tyvar which is not actually
Ian Lynagh's avatar
Ian Lynagh committed
1026
1027
1028
1029
1030
1031
1032
        constrained, then it will never, ever get bound, and lands
        up printed out in interface files!  Notorious example:
                instance Eq a => Eq (Foo a b) where ..
        Here, b is not constrained, even though it looks as if it is.
        Another, more common, example is when there's a Method inst in
        the LIE, whose type might very well involve non-overloaded
        type variables.
1033
  [NOTE: Jan 2001: I don't understand the problem here so I'm doing 
Ian Lynagh's avatar
Ian Lynagh committed
1034
        the simple thing instead]
1035

1036
 (b) On the other hand, we mustn't generalise tyvars which are constrained,
Ian Lynagh's avatar
Ian Lynagh committed
1037
1038
        because we are going to pass on out the unmodified LIE, with those
        tyvars in it.  They won't be in scope if we've generalised them.
1039
1040
1041
1042
1043

So we are careful, and do a complete simplification just to find the
constrained tyvars. We don't use any of the results, except to
find which tyvars are constrained.

1044
1045
1046
Note [Polymorphic recursion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The game plan for polymorphic recursion in the code above is 
1047

Ian Lynagh's avatar
Ian Lynagh committed
1048
1049
1050
        * Bind any variable for which we have a type signature
          to an Id with a polymorphic type.  Then when type-checking 
          the RHSs we'll make a full polymorphic call.
1051

1052
1053
This fine, but if you aren't a bit careful you end up with a horrendous
amount of partial application and (worse) a huge space leak. For example:
1054

Ian Lynagh's avatar
Ian Lynagh committed
1055
1056
        f :: Eq a => [a] -> [a]
        f xs = ...f...