TcBinds.lhs 54.1 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, tcPolyCheck,
10
                 PragFun, tcSpecPrags, tcVectDecls, mkPragFun, 
11
12
                 TcSigInfo(..), TcSigFun, 
                 instTcTySig, instTcTySigFromId,
Ian Lynagh's avatar
Ian Lynagh committed
13
                 badBootDeclErr ) where
14

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

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

import Control.Monad
50
51

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

54

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

61
@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
62
63
64
65
66
67
68
69
70
71
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".

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

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.

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

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
Note [Polymorphic recursion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The game plan for polymorphic recursion in the code above is 

        * 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.

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:

        f :: Eq a => [a] -> [a]
        f xs = ...f...

If we don't take care, after typechecking we get

        f = /\a -> \d::Eq a -> let f' = f a d
                               in
                               \ys:[a] -> ...f'...

Notice the the stupid construction of (f a d), which is of course
identical to the function we're executing.  In this case, the
polymorphic recursion isn't being used (but that's a very common case).
This can lead to a massive space leak, from the following top-level defn
(post-typechecking)

        ff :: [Int] -> [Int]
        ff = f Int dEqInt

Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
f' is another thunk which evaluates to the same thing... and you end
up with a chain of identical values all hung onto by the CAF ff.

        ff = f Int dEqInt

           = let f' = f Int dEqInt in \ys. ...f'...

           = let f' = let f' = f Int dEqInt in \ys. ...f'...
                      in \ys. ...f'...

Etc.

NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
which would make the space leak go away in this case

Solution: when typechecking the RHSs we always have in hand the
*monomorphic* Ids for each binding.  So we just need to make sure that
if (Method f a d) shows up in the constraints emerging from (...f...)
we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
to the "givens" when simplifying constraints.  That's what the "lies_avail"
is doing.

Then we get

        f = /\a -> \d::Eq a -> letrec
                                 fm = \ys:[a] -> ...fm...
                               in
                               fm

145
\begin{code}
146
147
148
149
150
151
152
153
154
155
156
157
158
159
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
160
161
        -- The top level bindings are flattened into a giant 
        -- implicitly-mutually-recursive LHsBinds
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
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"
177

178
tcHsBootSigs :: HsValBinds Name -> TcM [Id]
179
180
-- A hs-boot file has only one BindGroup, and it only has type
-- signatures in it.  The renamer checked all this
181
tcHsBootSigs (ValBindsOut binds sigs)
Ian Lynagh's avatar
Ian Lynagh committed
182
  = do  { checkTc (null binds) badBootDeclErr
183
        ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
184
  where
185
186
187
188
    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
189
        -- Notice that we make GlobalIds, not LocalIds
Ian Lynagh's avatar
Ian Lynagh committed
190
    tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
191
tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
192

193
badBootDeclErr :: MsgDoc
Ian Lynagh's avatar
Ian Lynagh committed
194
badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
195

196
197
------------------------
tcLocalBinds :: HsLocalBinds Name -> TcM thing
Ian Lynagh's avatar
Ian Lynagh committed
198
             -> TcM (HsLocalBinds TcId, thing)
sof's avatar
sof committed
199

200
tcLocalBinds EmptyLocalBinds thing_inside 
Ian Lynagh's avatar
Ian Lynagh committed
201
202
  = do  { thing <- thing_inside
        ; return (EmptyLocalBinds, thing) }
sof's avatar
sof committed
203

204
205
206
207
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"
208

209
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
210
  = do  { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
211

Ian Lynagh's avatar
Ian Lynagh committed
212
213
        -- If the binding binds ?x = E, we  must now 
        -- discharge any ?x constraints in expr_lie
214
        -- See Note [Implicit parameter untouchables]
215
        ; (ev_binds, result) <- checkConstraints (IPSkol ips) 
216
                                  [] given_ips thing_inside
217
218

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

Ian Lynagh's avatar
Ian Lynagh committed
222
223
224
        -- I wonder if we should do these one at at time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
225
226
227
228
229
    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')) }
230
\end{code}
231

232
233
234
235
236
237
238
239
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 
240
wanted).  Result disaster: the (Num alpha) is again solved, this
241
242
time by defaulting.  No no no.

243
244
245
However [Oct 10] this is all handled automatically by the 
untouchable-range idea.

246
\begin{code}
247
tcValBinds :: TopLevelFlag 
248
249
250
           -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
           -> TcM thing
           -> TcM ([(RecFlag, LHsBinds TcId)], thing) 
251

252
tcValBinds top_lvl binds sigs thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
253
  = do  {       -- Typecheck the signature
254
          (poly_ids, sig_fn) <- tcTySigs sigs
Ian Lynagh's avatar
Ian Lynagh committed
255

256
        ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
Ian Lynagh's avatar
Ian Lynagh committed
257
258
259
260

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

264
        ; return (binds', thing) }
265

266
------------------------
267
tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
268
269
             -> [(RecFlag, LHsBinds Name)] -> TcM thing
             -> TcM ([(RecFlag, LHsBinds TcId)], thing)
270
271
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
272
273
274
-- 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)
275

276
tcBindGroups _ _ _ [] thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
277
278
  = do  { thing <- thing_inside
        ; return ([], thing) }
279

280
tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
281
  = do  { (group', (groups', thing))
282
283
                <- 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
284
        ; return (group' ++ groups', thing) }
sof's avatar
sof committed
285

286
------------------------
287
tc_group :: forall thing. 
288
            TopLevelFlag -> TcSigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
289
290
         -> (RecFlag, LHsBinds Name) -> TcM thing
         -> TcM ([(RecFlag, LHsBinds TcId)], thing)
291
292
293
294
295

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

296
tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
297
298
        -- A single non-recursive binding
        -- We want to keep non-recursive things non-recursive
299
        -- so that we desugar unlifted bindings correctly
300
 =  do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
301
                                              NonRecursive NonRecursive
302
303
                                             (bagToList binds)
       ; thing <- tcExtendLetEnv closed ids thing_inside
304
305
306
307
       ; 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
308
309
        -- strongly-connected-component analysis, this time omitting 
        -- any references to variables with type signatures.
310
311
    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
312
313
             -- Here is where we should do bindInstsOfLocalFuns
             -- if we start having Methods again
314
        ; return ([(Recursive, binds1)], thing) }
Ian Lynagh's avatar
Ian Lynagh committed
315
                -- Rec them all together
316
  where
317
318
319
320
    sccs :: [SCC (LHsBind Name)]
    sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)

    go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
321
322
    go (scc:sccs) = do  { (binds1, ids1, closed) <- tc_scc scc
                        ; (binds2, ids2, thing)  <- tcExtendLetEnv closed ids1 $ go sccs
323
324
                        ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
    go []         = do  { thing <- thing_inside; return (emptyBag, [], thing) }
325

326
327
    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
sof's avatar
sof committed
328

329
    tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
sof's avatar
sof committed
330

331
------------------------
332
mkEdges :: TcSigFun -> LHsBinds Name
Ian Lynagh's avatar
Ian Lynagh committed
333
        -> [(LHsBind Name, BKey, [BKey])]
334
335
336
337

type BKey  = Int -- Just number off the bindings

mkEdges sig_fn binds
338
  = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
Ian Lynagh's avatar
Ian Lynagh committed
339
                         Just key <- [lookupNameEnv key_map n], no_sig n ])
340
341
342
343
344
345
346
347
    | (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
348
    key_map :: NameEnv BKey     -- Which binding it comes from
349
    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
Ian Lynagh's avatar
Ian Lynagh committed
350
                                     , bndr <- bindersOfHsBind bind ]
351
352

bindersOfHsBind :: HsBind Name -> [Name]
353
354
bindersOfHsBind (PatBind { pat_lhs = pat })  = collectPatBinders pat
bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
Ian Lynagh's avatar
Ian Lynagh committed
355
356
bindersOfHsBind (AbsBinds {})                = panic "bindersOfHsBind AbsBinds"
bindersOfHsBind (VarBind {})                 = panic "bindersOfHsBind VarBind"
357

358
------------------------
359
tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
360
361
362
363
364
            -> 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)
365
366
367
368
369

-- 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
--
370
371
372
-- 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.  
373
-- 
374
375
-- Knows nothing about the scope of the bindings

376
377
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
  = setSrcSpan loc                              $
Ian Lynagh's avatar
Ian Lynagh committed
378
    recoverM (recoveryCode binder_names sig_fn) $ do 
379
        -- Set up main recover; take advantage of any type sigs
380

381
382
    { traceTc "------------------------------------------------" empty
    ; traceTc "Bindings for" (ppr binder_names)
383

384
385
386
--    -- Instantiate the polytypes of any binders that have signatures
--    -- (as determined by sig_fn), returning a TcSigInfo for each
--    ; tc_sig_fn <- tcInstSigs sig_fn binder_names
387

388
    ; dflags   <- getDynFlags
389
390
    ; type_env <- getLclTypeEnv
    ; let plan = decideGeneralisationPlan dflags type_env 
391
                         binder_names bind_list sig_fn
392
    ; traceTc "Generalisation plan" (ppr plan)
393
    ; result@(_, poly_ids, _) <- case plan of
394
395
         NoGen          -> tcPolyNoGen sig_fn prag_fn rec_tc bind_list
         InferGen mn cl -> tcPolyInfer mn cl sig_fn prag_fn rec_tc bind_list
396
         CheckGen sig   -> tcPolyCheck sig prag_fn rec_tc bind_list
397

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

403
    ; return result }
404
405
  where
    binder_names = collectHsBindListBinders bind_list
406
407
408
    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
409
         -- span that includes them all
410

411
------------------
412
413
414
415
416
tcPolyNoGen 
  :: TcSigFun -> PragFun
  -> RecFlag       -- Whether it's recursive after breaking
                   -- dependencies based on type signatures
  -> [LHsBind Name]
417
  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
418
419
-- No generalisation whatsoever

420
421
422
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
423
       ; mono_ids' <- mapM tc_mono_info mono_infos
424
       ; return (binds', mono_ids', NotTopLevel) }
425
426
  where
    tc_mono_info (name, _, mono_id)
427
      = do { mono_ty' <- zonkTcType (idType mono_id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
428
             -- Zonk, mainly to expose unboxed types to checkStrictBinds
429
           ; let mono_id' = setIdType mono_id mono_ty'
430
           ; _specs <- tcSpecPrags mono_id' (prag_fn name)
431
           ; return mono_id' }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
432
433
434
435
           -- 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
436
437
438

------------------
tcPolyCheck :: TcSigInfo -> PragFun
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
439
440
441
442
            -> RecFlag       -- Whether it's recursive after breaking
                             -- dependencies based on type signatures
            -> [LHsBind Name]
            -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
443
444
445
-- There is just one binding, 
--   it binds a single variable,
--   it has a signature,
446
447
tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped 
                           , sig_theta = theta, sig_tau = tau, sig_loc = loc })
448
    prag_fn rec_tc bind_list
449
  = do { ev_vars <- newEvVars theta
450
451
       ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
             prag_sigs = prag_fn (idName poly_id)
452
       ; tvs <- mapM (skolemiseSigTv . snd) tvs_w_scoped
453
       ; (ev_binds, (binds', [mono_info])) 
454
455
456
            <- setSrcSpan loc $  
               checkConstraints skol_info tvs ev_vars $
               tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $
457
               tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
458

459
460
       ; spec_prags <- tcSpecPrags poly_id prag_sigs
       ; poly_id    <- addInlinePrags poly_id prag_sigs
461

462
463
464
465
466
       ; let (_, _, mono_id) = mono_info
             export = ABE { abe_wrap = idHsWrapper
                          , abe_poly = poly_id
                          , abe_mono = mono_id
                          , abe_prags = SpecPrags spec_prags }
467
468
469
470
             abs_bind = L loc $ AbsBinds 
                        { abs_tvs = tvs
                        , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
                        , abs_exports = [export], abs_binds = binds' }
471
472
473
             closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
                    | otherwise                                     = NotTopLevel
       ; return (unitBag abs_bind, [poly_id], closed) }
474

475
------------------
476
tcPolyInfer 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
477
478
  :: Bool         -- True <=> apply the monomorphism restriction
  -> Bool         -- True <=> free vars have closed types
479
480
481
482
  -> TcSigFun -> PragFun
  -> RecFlag       -- Whether it's recursive after breaking
                   -- dependencies based on type signatures
  -> [LHsBind Name]
483
484
  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list
485
  = do { ((binds', mono_infos), wanted) 
486
             <- captureConstraints $
487
                tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
488

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

492
493
       ; theta <- zonkTcThetaType (map evVarPred givens)
       ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos
494
495

       ; loc <- getSrcSpanM
496
       ; let poly_ids = map abe_poly exports
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
497
498
             final_closed | closed && not mr_bites = TopLevel
                          | otherwise              = NotTopLevel
499
500
501
502
             abs_bind = L loc $ 
                        AbsBinds { abs_tvs = qtvs
                                 , abs_ev_vars = givens, abs_ev_binds = ev_binds
                                 , abs_exports = exports, abs_binds = binds' }
503

Simon Peyton Jones's avatar
Simon Peyton Jones committed
504
505
       ; traceTc "Binding:" (ppr final_closed $$
                             ppr (poly_ids `zip` map idType poly_ids))
506
507
       ; return (unitBag abs_bind, poly_ids, final_closed)   
         -- poly_ids are guaranteed zonked by mkExport
508
  }
509
510
511


--------------
512
mkExport :: PragFun 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
513
         -> [TyVar] -> TcThetaType      -- Both already zonked
Ian Lynagh's avatar
Ian Lynagh committed
514
         -> MonoBindInfo
515
         -> TcM (ABExport Id)
516
-- mkExport generates exports with 
Ian Lynagh's avatar
Ian Lynagh committed
517
518
--      zonked type variables, 
--      zonked poly_ids
519
520
521
522
523
524
-- 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 

525
-- Pre-condition: the qtvs and theta are already zonked
526

527
mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
528
  = do  { mono_ty <- zonkTcType (idType mono_id)
529
530
        ; let inferred_poly_ty = mkSigmaTy my_tvs theta mono_ty
              my_tvs   = filter (`elemVarSet` used_tvs) qtvs
batterseapower's avatar
batterseapower committed
531
              used_tvs = tyVarsOfTypes theta `unionVarSet` tyVarsOfType mono_ty
532

533
534
535
536
              poly_id  = case mb_sig of
                           Nothing  -> mkLocalId poly_name inferred_poly_ty
                           Just sig -> sig_id sig
                -- poly_id has a zonked type
537

538
        ; poly_id <- addInlinePrags poly_id prag_sigs
539
        ; spec_prags <- tcSpecPrags poly_id prag_sigs
Ian Lynagh's avatar
Ian Lynagh committed
540
                -- tcPrags requires a zonked poly_id
541

542
543
544
545
        ; 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
546
547
548
549
550
551
        -- 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)
552
553
554
        ; (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
555
        ; ev_binds <- simplifyAmbiguityCheck poly_name wanted
556
557
558
559
560

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

564
565
566
567
568
569
570
571
572
573
574
575
    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)
        
576

577
578
579
    prag_sigs = prag_fn poly_name
    origin    = AmbigOrigin poly_name
    sig_ctxt  = InfSigCtxt poly_name
580
581

------------------------
582
type PragFun = Name -> [LSig Name]
583

584
mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
585
586
587
588
589
590
591
592
593
594
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
595
596
597
      | 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
598
599
600
601
602
603
604
605
606
607
608
609
610
      | 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
611
lhsBindArity _ env = env        -- PatBind/VarBind
612

613
------------------
614
615
tcSpecPrags :: Id -> [LSig Name]
            -> TcM [LTcSpecPrag]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
616
-- Add INLINE and SPECIALSE pragmas
617
618
--    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
619
620
-- Pre-condition: the poly_id is zonked
-- Reason: required by tcSubExp
621
622
623
tcSpecPrags poly_id prag_sigs
  = do { unless (null bad_sigs) warn_discarded_sigs
       ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
624
  where
625
626
627
628
    spec_sigs = filter isSpecLSig prag_sigs
    bad_sigs  = filter is_bad_sig prag_sigs
    is_bad_sig s = not (isSpecLSig s || isInlineLSig s)

629
630
631
632
633
634
635
636
637
638
639
640
    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
641
        ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
642
643
                 (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
644
                  -- Note [SPECIALISE pragmas]
645
        ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty
646
647
        ; return (SpecPrag poly_id wrap inl) }
  where
648
649
650
    name      = idName poly_id
    poly_ty   = idType poly_id
    origin    = SpecPragOrigin name
651
652
    sig_ctxt  = FunSigCtxt name
    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
653

654
tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
655

656
657
--------------
tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
658
-- SPECIALISE pragamas for imported things
659
660
tcImpPrags prags
  = do { this_mod <- getModule
661
       ; dflags <- getDynFlags
662
663
       ; if (not_specialising dflags) then
            return []
664
665
666
667
         else
            mapAndRecoverM (wrapLocM tcImpSpec) 
            [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
                               , not (nameIsLocalOrFrom this_mod name) ] }
668
669
670
671
672
673
674
675
676
677
678
  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
679
680
681

tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
tcImpSpec (name, prag)
682
 = do { id <- tcLookupId name
683
684
      ; unless (isAnyInlinePragma (idInlinePragma id))
               (addWarnTc (impSpecErr name))
685
686
687
688
689
      ; tcSpec id prag }

impSpecErr :: Name -> SDoc
impSpecErr name
  = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
690
       2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
691
692
693
694
695
               , parens $ sep 
                   [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
                   , ptext (sLit "was compiled without -O")]])
  where
    mod = nameModule name
696
697

--------------
698
tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
699
700
tcVectDecls decls 
  = do { decls' <- mapM (wrapLocM tcVect) decls
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
701
       ; let ids  = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
702
703
             dups = findDupsEq (==) ids
       ; mapM_ reportVectDups dups
704
       ; traceTcConstraints "End of tcVectDecls"
705
706
707
708
709
710
711
712
713
714
       ; 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)
715
716
717
-- 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
718
719
--   identifier (this is checked in 'rnHsVectDecl').  Fix this by enabling the use of 'vectType'
--   from the vectoriser here.
720
721
tcVect (HsVect name Nothing)
  = addErrCtxt (vectCtxt name) $
722
723
    do { var <- wrapLocM tcLookupId name
       ; return $ HsVect var Nothing
724
       }
725
726
727
tcVect (HsVect name (Just rhs))
  = addErrCtxt (vectCtxt name) $
    do { var <- wrapLocM tcLookupId name
728
729
       ; let L rhs_loc (HsVar rhs_var_name) = rhs
       ; rhs_id <- tcLookupId rhs_var_name
730
       ; return $ HsVect var (Just $ L rhs_loc (HsVar rhs_id))
731
       }
732

733
{- OLD CODE:
734
         -- turn the vectorisation declaration into a single non-recursive binding
735
       ; let bind    = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] 
736
737
738
739
             sigFun  = const Nothing
             pragFun = mkPragFun [] (unitBag bind)

         -- perform type inference (including generalisation)
740
       ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
741
       
742
       ; traceTc "tcVect inferred type" $ ppr (varType id')
743
       ; traceTc "tcVect bindings"      $ ppr binds
744
       
745
746
         -- add all bindings, including the type variable and dictionary bindings produced by type
         -- generalisation to the right-hand side of the vectorisation declaration
747
748
749
750
751
752
753
754
755
756
757
       ; 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)
       }
758
 -}
759
760
tcVect (HsNoVect name)
  = addErrCtxt (vectCtxt name) $
761
762
    do { var <- wrapLocM tcLookupId name
       ; return $ HsNoVect var
763
       }
764
tcVect (HsVectTypeIn isScalar lname rhs_name)
765
  = addErrCtxt (vectCtxt lname) $
766
    do { tycon <- tcLookupLocatedTyCon lname
767
768
769
770
771
       ; 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
772

773
774
       ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
       ; return $ HsVectTypeOut isScalar tycon rhs_tycon
775
       }
776
tcVect (HsVectTypeOut _ _ _)
777
  = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
778
779
780
781
782
783
784
tcVect (HsVectClassIn lname)
  = addErrCtxt (vectCtxt lname) $
    do { cls <- tcLookupLocatedClass lname
       ; return $ HsVectClassOut cls
       }
tcVect (HsVectClassOut _)
  = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
785
tcVect (HsVectInstIn linstTy)
786
787
788
  = addErrCtxt (vectCtxt linstTy) $
    do { (cls, tys) <- tcHsVectInst linstTy
       ; inst       <- tcLookupInstance cls tys
789
       ; return $ HsVectInstOut inst
790
       }
791
tcVect (HsVectInstOut _)
792
  = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
793

794
795
vectCtxt :: Outputable thing => thing -> SDoc
vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing
796

797
scalarTyConMustBeNullary :: MsgDoc
798
799
scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")

800
--------------
801
802
803
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise 
-- subsequent error messages
804
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
805
recoveryCode binder_names sig_fn
806
  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
Ian Lynagh's avatar
Ian Lynagh committed
807
        ; poly_ids <- mapM mk_dummy binder_names
808
809
        ; return (emptyBag, poly_ids, if all is_closed poly_ids
                                      then TopLevel else NotTopLevel) }
810
  where
811
    mk_dummy name 
Ian Lynagh's avatar
Ian Lynagh committed
812
813
        | isJust (sig_fn name) = tcLookupId name        -- Had signature; look it up
        | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
814

815
816
    is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id))

817
forall_a_a :: TcType
818
forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
819
820
\end{code}

821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
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.
841

842
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
843
%*                                                                      *
844
\subsection{tcMonoBind}
Ian Lynagh's avatar
Ian Lynagh committed
845
%*                                                                      *
846
847
%************************************************************************

848
@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
849
850
The signatures have been dealt with already.

851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
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.

873
\begin{code}
874
tcMonoBinds :: TcSigFun -> LetBndrSpec 
Ian Lynagh's avatar
Ian Lynagh committed
875
876
            -> RecFlag  -- Whether the binding is recursive for typechecking purposes
                        -- i.e. the binders are mentioned in their RHSs, and
877
                        --      we are not rescued by a type signature
878
            -> [LHsBind Name]
Ian Lynagh's avatar
Ian Lynagh committed
879
            -> TcM (LHsBinds TcId, [MonoBindInfo])
880

881
882
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
883
                                fun_matches = matches, bind_fvs = fvs })]
884
885
886
                             -- 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
887
888
889
890
891
892
893
894
  =     -- 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)

895
        ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
Ian Lynagh's avatar
Ian Lynagh committed
896
897
898
899
        ; 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)]) }
900

901
902
tcMonoBinds sig_fn no_gen _ binds
  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
903

Ian Lynagh's avatar
Ian Lynagh committed
904
905
906
        -- 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]
907
908
                    -- A monomorphic binding for each term variable that lacks 
                    -- a type sig.  (Ones with a sig are already in scope.)
909

Ian Lynagh's avatar
Ian Lynagh committed
910
        ; binds' <- tcExtendIdEnv2 rhs_id_env $ do
911
912
                    traceTc "tcMonoBinds" $  vcat [ ppr n <+> ppr id <+> ppr (idType id) 
                                                  | (n,id) <- rhs_id_env]
Ian Lynagh's avatar
Ian Lynagh committed
913
914
                    mapM (wrapLocM tcRhs) tc_binds
        ; return (listToBag binds', mono_info) }
915
916
917
918

------------------------
-- 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
919
920
--      if there's a signature for it, use the instantiated signature type
--      otherwise invent a type variable
921
922
923
-- You see that quite directly in the FunBind case.
-- 
-- But there's a complication for pattern bindings:
Ian Lynagh's avatar
Ian Lynagh committed
924
925
--      data T = MkT (forall a. a->a)
--      MkT f = e
926
927
928
929
930
931
-- 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
932
data TcMonoBind         -- Half completed; LHS done, RHS not done
933
  = TcFunBind  MonoBindInfo  SrcSpan Bool (MatchGroup Name) 
934
935
  | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType

936
type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
Ian Lynagh's avatar
Ian Lynagh committed
937
938
        -- Type signature (if any), and
        -- the monomorphic bound things
939

940
tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
941
tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
942
943
944
945
946
947
948
  | 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) }
949
950
951
952

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
953
954
955

                -- After typechecking the pattern, look up the binder
                -- names, which the pattern has brought into scope.
956
957
958
              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
959
960
961
962
963

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

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

965
tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
Ian Lynagh's avatar
Ian Lynagh committed
966
        -- AbsBind, VarBind impossible
967

968
969
-------------------
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
970
971
972
973
-- 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
974
tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
975
976
  = 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
977
                                            matches (idType mono_id)
978
979
        ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
                          , fun_matches = matches'
980
981
                          , fun_co_fn = co_fn 
                          , bind_fvs = placeHolderNames, fun_tick = Nothing }) }
982

Ian Lynagh's avatar
Ian Lynagh committed
983
tcRhs (TcPatBind _ pat' grhss pat_ty)
984
985
  = do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
        ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
Ian Lynagh's avatar
Ian Lynagh committed
986
                    tcGRHSsPat grhss pat_ty
987
        ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty 
988
989
                          , bind_fvs = placeHolderNames
                          , pat_ticks = (Nothing,[]) }) }
990
991
992


---------------------
993
getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
994
getMonoBindInfo tc_binds
995
  = foldr (get_info . unLoc) [] tc_binds
996
997
998
999
1000
1001
  where
    get_info (TcFunBind info _ _ _)  rest = info : rest
    get_info (TcPatBind infos _ _ _) rest = infos ++ rest
\end{code}


1002

1003
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
1004
1005
1006
%*                                                                      *
                Signatures
%*                                                                      *
1007
1008
%************************************************************************

1009
Type signatures are tricky.  See Note [Signature skolems] in TcType
1010

1011
1012
1013
1014
1015
1016
1017
1018
1019
@tcSigs@ checks the signatures for validity, and returns a list of
{\em freshly-instantiated} signatures.  That is, the types are already
split up, and have fresh type variables installed.  All non-type-signature
"RenamedSigs" are ignored.

The @TcSigInfo@ contains @TcTypes@ because they are unified with
the variable's type, and after that checked to see whether they've
been instantiated.

1020
1021
1022
1023
Note [Scoped tyvars]
~~~~~~~~~~~~~~~~~~~~
The -XScopedTypeVariables flag brings lexically-scoped type variables
into scope for any explicitly forall-quantified type variables:
Ian Lynagh's avatar
Ian Lynagh committed
1024
1025
        f :: forall a. a -> a
        f x = e
1026
1027
1028
1029
Then 'a' is in scope inside 'e'.

However, we do *not* support this 
  - For pattern bindings e.g
Ian Lynagh's avatar
Ian Lynagh committed
1030
1031
        f :: forall a. a->a
        (f,g) = e
1032
1033

  - For multiple function bindings, unless Opt_RelaxedPolyRec is on
Ian Lynagh's avatar
Ian Lynagh committed
1034
1035
1036
1037
        f :: forall a. a -> a
        f = g
        g :: forall b. b -> b
        g = ...f...
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
    Reason: we use mutable variables for 'a' and 'b', since they may
    unify to each other, and that means the scoped type variable would
    not stand for a completely rigid variable.

    Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec

Note [More instantiated than scoped]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There may be more instantiated type variables than lexically-scoped 
ones.  For example:
Ian Lynagh's avatar
Ian Lynagh committed
1048
1049
        type T a = forall b. b -> (a,b)
        f :: forall c. T c
1050
1051
1052
1053
1054
1055
Here, the signature for f will have one scoped type variable, c,
but two instantiated type variables, c' and b'.  

We assume that the scoped ones are at the *front* of sig_tvs,
and remember the names from the original HsForAllTy in the TcSigFun.

1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
Note [Signature skolems]
~~~~~~~~~~~~~~~~~~~~~~~~
When instantiating a type signature, we do so with either skolems or
SigTv meta-type variables depending on the use_skols boolean.  This
variable is set True when we are typechecking a single function
binding; and False for pattern bindings and a group of several
function bindings.

Reason: in the latter cases, the "skolems" can be unified together, 
        so they aren't properly rigid in the type-refinement sense.
NB: unless we are doing H98, each function with a sig will be done
    separately, even if it's mutually recursive, so use_skols will be True


Note [Only scoped tyvars are in the TyVarEnv]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are careful to keep only the *lexically scoped* type variables in
the type environment.  Why?  After all, the renamer has ensured
that only legal occurrences occur, so we could put all type variables
into the type env.

But we want to check that two distinct lexically scoped type variables
do not map to the same internal type variable.  So we need to know which
the lexically-scoped ones are... and at the moment we do that by putting
only the lexically scoped ones into the environment.

Note [Instantiate sig with fresh variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's vital to instantiate a type signature with fresh variables.
For example:
      type T = forall a. [a] -> [a]
      f :: T; 
      f = g where { g :: T; g = <rhs> }

 We must not use the same 'a' from the defn of T at both places!!
(Instantiation is only necessary because of type synonyms.  Otherwise,
it's all cool; each signature has distinct type variables from the renamer.)
1093

1094
\begin{code}
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)
tcTySigs hs_sigs
  = do { ty_sigs <- concat <$> checkNoErrs (mapAndRecoverM tcTySig hs_sigs)
                -- 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
       ; let env = mkNameEnv [(idName (sig_id sig), sig) | sig <- ty_sigs]
       ; return (map sig_id ty_sigs, lookupNameEnv env) }

tcTySig :: LSig Name -> TcM [TcSigInfo]
tcTySig (L loc (IdSig id))
  = do { sig <- instTcTySigFromId loc id
       ; return [sig] }
tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty))
  = setSrcSpan loc $ 
    do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty
       ; mapM (instTcTySig hs_ty sigma_ty) (map unLoc names) }
tcTySig _ = return []

instTcTySigFromId :: SrcSpan -> Id -> TcM TcSigInfo
instTcTySigFromId loc id
  = do { (tvs, theta, tau) <- tcInstType inst_sig_tyvars (idType id)
       ; return (TcSigInfo { sig_id = id, sig_loc = loc
                           , sig_tvs = [(Nothing, tv) | tv <- tvs]
                           , sig_theta = theta, sig_tau = tau }) }