TcBinds.lhs 58.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, 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
Simon Peyton Jones's avatar
Simon Peyton Jones committed
29
import Type( tidyOpenType )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
30
import FunDeps( growThetaTyVars )
31
import TyCon
Simon Marlow's avatar
Simon Marlow committed
32
33
34
import TcType
import TysPrim
import Id
35
import Var
36
import VarSet
37
import Module
Simon Marlow's avatar
Simon Marlow committed
38
import Name
39
import NameSet
40
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
41
import SrcLoc
42
import Bag
43
import ListSetOps
Simon Marlow's avatar
Simon Marlow committed
44
45
46
47
48
import ErrUtils
import Digraph
import Maybes
import Util
import BasicTypes
49
import Outputable
50
import FastString
51
52
53
import Type(mkStrLitTy)
import Class(classTyCon)
import PrelNames(ipClassName)
54
55

import Control.Monad
56
57

#include "HsVersions.h"
58
\end{code}
59

60

61
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
62
%*                                                                      *
63
\subsection{Type-checking bindings}
Ian Lynagh's avatar
Ian Lynagh committed
64
%*                                                                      *
65
66
%************************************************************************

67
@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
68
69
70
71
72
73
74
75
76
77
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".

78
The real work is done by @tcBindWithSigsAndThen@.
79
80
81
82
83
84
85
86
87
88

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.

89
90
91
At the top-level the LIE is sure to contain nothing but constant
dictionaries, which we resolve at the module level.

92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
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

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

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

199
badBootDeclErr :: MsgDoc
Ian Lynagh's avatar
Ian Lynagh committed
200
badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
201

202
203
------------------------
tcLocalBinds :: HsLocalBinds Name -> TcM thing
Ian Lynagh's avatar
Ian Lynagh committed
204
             -> TcM (HsLocalBinds TcId, thing)
sof's avatar
sof committed
205

206
tcLocalBinds EmptyLocalBinds thing_inside 
Ian Lynagh's avatar
Ian Lynagh committed
207
208
  = do  { thing <- thing_inside
        ; return (EmptyLocalBinds, thing) }
sof's avatar
sof committed
209

210
211
212
213
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"
214

215
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
216
217
218
  = do  { ipClass <- tcLookupClass ipClassName
        ; (given_ips, ip_binds') <-
            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
219

Ian Lynagh's avatar
Ian Lynagh committed
220
221
        -- If the binding binds ?x = E, we  must now 
        -- discharge any ?x constraints in expr_lie
222
        -- See Note [Implicit parameter untouchables]
223
        ; (ev_binds, result) <- checkConstraints (IPSkol ips) 
224
                                  [] given_ips thing_inside
225
226

        ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
227
  where
228
    ips = [ip | L _ (IPBind (Left ip) _) <- ip_binds]
229

Ian Lynagh's avatar
Ian Lynagh committed
230
231
232
        -- I wonder if we should do these one at at time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
233
    tc_ip_bind ipClass (IPBind (Left ip) expr)
234
       = do { ty <- newFlexiTyVarTy openTypeKind
235
236
            ; let p = mkStrLitTy $ hsIPNameFS ip
            ; ip_id <- newDict ipClass [ p, ty ]
237
            ; expr' <- tcMonoExpr expr ty
238
239
240
241
242
243
244
245
            ; let d = toDict ipClass p ty `fmap` expr'
            ; return (ip_id, (IPBind (Right ip_id) d)) }
    tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"

    -- Coerces a `t` into a dictionry for `IP "x" t`.
    -- co : t -> IP "x" t
    toDict ipClass x ty =
      case unwrapNewTyCon_maybe (classTyCon ipClass) of
246
        Just (_,_,ax) -> HsWrap $ WpCast $ mkTcSymCo $ mkTcUnbranchedAxInstCo ax [x,ty]
247
248
249
        Nothing       -> panic "The dictionary for `IP` is not a newtype?"


250
\end{code}
251

252
253
254
255
256
257
258
259
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 
260
wanted).  Result disaster: the (Num alpha) is again solved, this
261
262
time by defaulting.  No no no.

263
264
265
However [Oct 10] this is all handled automatically by the 
untouchable-range idea.

266
\begin{code}
267
tcValBinds :: TopLevelFlag 
268
269
270
           -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
           -> TcM thing
           -> TcM ([(RecFlag, LHsBinds TcId)], thing) 
271

272
tcValBinds top_lvl binds sigs thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
273
  = do  {       -- Typecheck the signature
274
          (poly_ids, sig_fn) <- tcTySigs sigs
Ian Lynagh's avatar
Ian Lynagh committed
275

276
        ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
Ian Lynagh's avatar
Ian Lynagh committed
277
278
279

                -- Extend the envt right away with all 
                -- the Ids declared with type signatures
280
281
                -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack
        ; (binds', thing) <- tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $
282
                             tcBindGroups top_lvl sig_fn prag_fn 
Ian Lynagh's avatar
Ian Lynagh committed
283
284
                                          binds thing_inside

285
        ; return (binds', thing) }
286

287
------------------------
288
tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
289
290
             -> [(RecFlag, LHsBinds Name)] -> TcM thing
             -> TcM ([(RecFlag, LHsBinds TcId)], thing)
291
292
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
293
294
295
-- 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)
296

297
tcBindGroups _ _ _ [] thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
298
299
  = do  { thing <- thing_inside
        ; return ([], thing) }
300

301
tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
302
  = do  { (group', (groups', thing))
303
304
                <- 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
305
        ; return (group' ++ groups', thing) }
sof's avatar
sof committed
306

307
------------------------
308
tc_group :: forall thing. 
309
            TopLevelFlag -> TcSigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
310
311
         -> (RecFlag, LHsBinds Name) -> TcM thing
         -> TcM ([(RecFlag, LHsBinds TcId)], thing)
312
313
314
315
316

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

317
tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
318
319
        -- A single non-recursive binding
        -- We want to keep non-recursive things non-recursive
320
        -- so that we desugar unlifted bindings correctly
321
 =  do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
322
                                              NonRecursive NonRecursive
323
                                             (bagToList binds)
324
       ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
325
326
327
       ; return ( [(NonRecursive, binds1)], thing) }

tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
328
  =     -- To maximise polymorphism, we do a new 
Ian Lynagh's avatar
Ian Lynagh committed
329
330
        -- strongly-connected-component analysis, this time omitting 
        -- any references to variables with type signatures.
331
        -- (This used to be optional, but isn't now.)
332
333
    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
334
335
             -- Here is where we should do bindInstsOfLocalFuns
             -- if we start having Methods again
336
        ; return ([(Recursive, binds1)], thing) }
Ian Lynagh's avatar
Ian Lynagh committed
337
                -- Rec them all together
338
  where
339
340
341
342
    sccs :: [SCC (LHsBind Name)]
    sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)

    go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
343
    go (scc:sccs) = do  { (binds1, ids1, closed) <- tc_scc scc
344
                        ; (binds2, ids2, thing)  <- tcExtendLetEnv top_lvl closed ids1 $ 
345
                                                    go sccs
346
347
                        ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
    go []         = do  { thing <- thing_inside; return (emptyBag, [], thing) }
348

349
350
    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
sof's avatar
sof committed
351

352
    tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
sof's avatar
sof committed
353

354
------------------------
355
mkEdges :: TcSigFun -> LHsBinds Name
Ian Lynagh's avatar
Ian Lynagh committed
356
        -> [(LHsBind Name, BKey, [BKey])]
357
358
359
360

type BKey  = Int -- Just number off the bindings

mkEdges sig_fn binds
361
  = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
Ian Lynagh's avatar
Ian Lynagh committed
362
                         Just key <- [lookupNameEnv key_map n], no_sig n ])
363
364
365
366
367
368
369
370
    | (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
371
    key_map :: NameEnv BKey     -- Which binding it comes from
372
    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
Ian Lynagh's avatar
Ian Lynagh committed
373
                                     , bndr <- bindersOfHsBind bind ]
374
375

bindersOfHsBind :: HsBind Name -> [Name]
376
377
bindersOfHsBind (PatBind { pat_lhs = pat })  = collectPatBinders pat
bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
Ian Lynagh's avatar
Ian Lynagh committed
378
379
bindersOfHsBind (AbsBinds {})                = panic "bindersOfHsBind AbsBinds"
bindersOfHsBind (VarBind {})                 = panic "bindersOfHsBind VarBind"
380

381
------------------------
382
tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
383
384
385
386
387
            -> 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)
388
389
390
391
392

-- 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
--
393
394
395
-- 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.  
396
-- 
397
398
-- Knows nothing about the scope of the bindings

399
400
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
  = setSrcSpan loc                              $
Ian Lynagh's avatar
Ian Lynagh committed
401
    recoverM (recoveryCode binder_names sig_fn) $ do 
402
        -- Set up main recover; take advantage of any type sigs
403

404
    { traceTc "------------------------------------------------" empty
405
    ; traceTc "Bindings for {" (ppr binder_names)
406
    ; dflags   <- getDynFlags
407
408
    ; type_env <- getLclTypeEnv
    ; let plan = decideGeneralisationPlan dflags type_env 
409
                         binder_names bind_list sig_fn
410
    ; traceTc "Generalisation plan" (ppr plan)
411
    ; result@(tc_binds, poly_ids, _) <- case plan of
412
413
414
         NoGen          -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list 
         InferGen mn cl -> tcPolyInfer rec_tc prag_fn sig_fn mn cl bind_list
         CheckGen sig   -> tcPolyCheck rec_tc prag_fn sig bind_list
415

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
416
        -- Check whether strict bindings are ok
Ian Lynagh's avatar
Ian Lynagh committed
417
418
        -- These must be non-recursive etc, and are not generalised
        -- They desugar to a case expression in the end
419
420
421
422
    ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
    ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
                                            , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
                                          ])
423

424
    ; return result }
425
426
  where
    binder_names = collectHsBindListBinders bind_list
427
428
429
    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
430
         -- span that includes them all
431

432
------------------
433
tcPolyNoGen     -- No generalisation whatsoever
434
  :: RecFlag       -- Whether it's recursive after breaking
435
                   -- dependencies based on type signatures
436
  -> PragFun -> TcSigFun
437
  -> [LHsBind Name]
438
  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
439

440
441
tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
  = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
442
443
                                             (LetGblBndr prag_fn) 
                                             bind_list
444
       ; mono_ids' <- mapM tc_mono_info mono_infos
445
       ; return (binds', mono_ids', NotTopLevel) }
446
447
  where
    tc_mono_info (name, _, mono_id)
448
      = do { mono_ty' <- zonkTcType (idType mono_id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
449
             -- Zonk, mainly to expose unboxed types to checkStrictBinds
450
           ; let mono_id' = setIdType mono_id mono_ty'
451
           ; _specs <- tcSpecPrags mono_id' (prag_fn name)
452
           ; return mono_id' }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
453
454
455
456
           -- 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
457
458

------------------
459
tcPolyCheck :: RecFlag       -- Whether it's recursive after breaking
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
460
                             -- dependencies based on type signatures
461
            -> PragFun -> TcSigInfo 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
462
463
            -> [LHsBind Name]
            -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
464
465
466
-- There is just one binding, 
--   it binds a single variable,
--   it has a signature,
467
tcPolyCheck rec_tc prag_fn
468
            sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped 
469
                           , sig_theta = theta, sig_tau = tau, sig_loc = loc })
470
            bind_list
471
  = do { ev_vars <- newEvVars theta
472
473
       ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
             prag_sigs = prag_fn (idName poly_id)
474
       ; tvs <- mapM (skolemiseSigTv . snd) tvs_w_scoped
475
       ; (ev_binds, (binds', [mono_info])) 
476
477
478
            <- setSrcSpan loc $  
               checkConstraints skol_info tvs ev_vars $
               tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $
479
               tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr bind_list
480

481
482
       ; spec_prags <- tcSpecPrags poly_id prag_sigs
       ; poly_id    <- addInlinePrags poly_id prag_sigs
483

484
485
486
487
488
       ; let (_, _, mono_id) = mono_info
             export = ABE { abe_wrap = idHsWrapper
                          , abe_poly = poly_id
                          , abe_mono = mono_id
                          , abe_prags = SpecPrags spec_prags }
489
490
491
492
             abs_bind = L loc $ AbsBinds 
                        { abs_tvs = tvs
                        , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
                        , abs_exports = [export], abs_binds = binds' }
493
494
495
             closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
                    | otherwise                                     = NotTopLevel
       ; return (unitBag abs_bind, [poly_id], closed) }
496

497
------------------
498
tcPolyInfer 
499
  :: RecFlag       -- Whether it's recursive after breaking
500
                   -- dependencies based on type signatures
501
502
503
  -> PragFun -> TcSigFun 
  -> Bool         -- True <=> apply the monomorphism restriction
  -> Bool         -- True <=> free vars have closed types
504
  -> [LHsBind Name]
505
  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
506
tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
507
  = do { ((binds', mono_infos), wanted)
508
             <- captureConstraints $
509
                tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
510

511
       ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
512
       ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
513
       ; (qtvs, givens, mr_bites, ev_binds) <- 
514
                          simplifyInfer closed mono name_taus wanted
515

516
517
       ; theta <- zonkTcThetaType (map evVarPred givens)
       ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos
518
519

       ; loc <- getSrcSpanM
520
       ; let poly_ids = map abe_poly exports
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
521
522
             final_closed | closed && not mr_bites = TopLevel
                          | otherwise              = NotTopLevel
523
524
525
526
             abs_bind = L loc $ 
                        AbsBinds { abs_tvs = qtvs
                                 , abs_ev_vars = givens, abs_ev_binds = ev_binds
                                 , abs_exports = exports, abs_binds = binds' }
527

Simon Peyton Jones's avatar
Simon Peyton Jones committed
528
529
       ; traceTc "Binding:" (ppr final_closed $$
                             ppr (poly_ids `zip` map idType poly_ids))
530
       ; return (unitBag abs_bind, poly_ids, final_closed) }
531
         -- poly_ids are guaranteed zonked by mkExport
532
533

--------------
534
mkExport :: PragFun
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
535
         -> [TyVar] -> TcThetaType      -- Both already zonked
Ian Lynagh's avatar
Ian Lynagh committed
536
         -> MonoBindInfo
537
         -> TcM (ABExport Id)
538
539
540
541
-- Only called for generalisation plan IferGen, not by CheckGen or NoGen
--
-- mkExport generates exports with
--      zonked type variables,
Ian Lynagh's avatar
Ian Lynagh committed
542
--      zonked poly_ids
543
544
545
546
-- 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
547
-- type environment; see the invariant on TcEnv.tcExtendIdEnv
548

549
-- Pre-condition: the qtvs and theta are already zonked
550

551
mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
552
  = do  { mono_ty <- zonkTcType (idType mono_id)
553
        ; let poly_id  = case mb_sig of
554
555
556
                           Nothing  -> mkLocalId poly_name inferred_poly_ty
                           Just sig -> sig_id sig
                -- poly_id has a zonked type
557

558
559
560
              -- In the inference case (no signature) this stuff figures out
              -- the right type variables and theta to quantify over
              -- See Note [Impedence matching]
561
562
              my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType mono_ty))
                            -- Include kind variables!  Trac #7916
563
564
              my_tvs   = filter (`elemVarSet` my_tvs2) qtvs   -- Maintain original order
              my_theta = filter (quantifyPred my_tvs2) theta
565
566
              inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty

567
        ; poly_id <- addInlinePrags poly_id prag_sigs
568
        ; spec_prags <- tcSpecPrags poly_id prag_sigs
Ian Lynagh's avatar
Ian Lynagh committed
569
                -- tcPrags requires a zonked poly_id
570

571
        ; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty
572
573
        ; traceTc "mkExport: check sig"
                  (ppr poly_name $$ ppr sel_poly_ty $$ ppr (idType poly_id))
574

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
575
576
577
        -- 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.
578
        -- Remember we are in the tcPolyInfer case, so the type envt is
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
579
580
        -- closed (unless we are doing NoMonoLocalBinds in which case all bets
        -- are off)
581
        -- See Note [Impedence matching]
582
583
584
        ; (wrap, wanted) <- addErrCtxtM (mk_msg poly_id) $
                            captureConstraints $
                            tcSubType origin sig_ctxt sel_poly_ty (idType poly_id)
585
        ; ev_binds <- simplifyTop wanted
586
587
588
589
590

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

594
595
596
597
598
599
600
601
602
603
604
    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)
605

606
    prag_sigs = prag_fn poly_name
607
    origin    = AmbigOrigin sig_ctxt
608
    sig_ctxt  = InfSigCtxt poly_name
609
\end{code}
610

611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
Note [Impedence matching]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   f 0 x = x
   f n x = g [] (not x)

   g [] y = f 10 y
   g _  y = f 9  y

After typechecking we'll get
  f_mono_ty :: a -> Bool -> Bool   
  g_mono_ty :: [b] -> Bool -> Bool 
with constraints
  (Eq a, Num a)

Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
The types we really want for f and g are
   f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
   g :: forall b. [b] -> Bool -> Bool

We can get these by "impedence matching":
   tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
   tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)

   f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
   g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g

Suppose the shared quantified tyvars are qtvs and constraints theta.
Then we want to check that 
   f's polytype  is more polymorphic than   forall qtvs. theta => f_mono_ty
and the proof is the impedence matcher.  

Notice that the impedence matcher may do defaulting.  See Trac #7173.

It also cleverly does an ambiguity check; for example, rejecting
   f :: F a -> a
where F is a non-injective type function.


\begin{code}
651
type PragFun = Name -> [LSig Name]
652

653
mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
654
655
656
657
658
659
660
661
662
663
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
664
665
666
      | 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
667
668
669
670
671
672
673
674
675
676
677
678
679
      | 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
680
lhsBindArity _ env = env        -- PatBind/VarBind
681

682
------------------
683
684
tcSpecPrags :: Id -> [LSig Name]
            -> TcM [LTcSpecPrag]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
685
-- Add INLINE and SPECIALSE pragmas
686
687
--    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
688
689
-- Pre-condition: the poly_id is zonked
-- Reason: required by tcSubExp
690
691
692
tcSpecPrags poly_id prag_sigs
  = do { unless (null bad_sigs) warn_discarded_sigs
       ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
693
  where
694
695
696
697
    spec_sigs = filter isSpecLSig prag_sigs
    bad_sigs  = filter is_bad_sig prag_sigs
    is_bad_sig s = not (isSpecLSig s || isInlineLSig s)

698
699
700
701
702
703
704
705
706
707
708
709
    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
710
        ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
711
712
                 (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
713
                  -- Note [SPECIALISE pragmas]
714
        ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty
715
716
        ; return (SpecPrag poly_id wrap inl) }
  where
717
718
719
    name      = idName poly_id
    poly_ty   = idType poly_id
    origin    = SpecPragOrigin name
720
721
    sig_ctxt  = FunSigCtxt name
    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
722

723
tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
724

725
726
--------------
tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
727
-- SPECIALISE pragamas for imported things
728
729
tcImpPrags prags
  = do { this_mod <- getModule
730
       ; dflags <- getDynFlags
731
732
       ; if (not_specialising dflags) then
            return []
733
734
735
736
         else
            mapAndRecoverM (wrapLocM tcImpSpec) 
            [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
                               , not (nameIsLocalOrFrom this_mod name) ] }
737
738
739
740
741
742
  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
ian@well-typed.com's avatar
ian@well-typed.com committed
743
      | not (gopt Opt_Specialise dflags) = True
744
745
746
747
      | otherwise = case hscTarget dflags of
                      HscNothing -> True
                      HscInterpreted -> True
                      _other         -> False
748
749
750

tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
tcImpSpec (name, prag)
751
 = do { id <- tcLookupId name
752
753
      ; unless (isAnyInlinePragma (idInlinePragma id))
               (addWarnTc (impSpecErr name))
754
755
756
757
758
      ; tcSpec id prag }

impSpecErr :: Name -> SDoc
impSpecErr name
  = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
759
       2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
760
761
762
763
764
               , parens $ sep 
                   [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
                   , ptext (sLit "was compiled without -O")]])
  where
    mod = nameModule name
765
766

--------------
767
tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
768
769
tcVectDecls decls 
  = do { decls' <- mapM (wrapLocM tcVect) decls
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
770
       ; let ids  = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
771
772
             dups = findDupsEq (==) ids
       ; mapM_ reportVectDups dups
773
       ; traceTcConstraints "End of tcVectDecls"
774
775
776
777
778
779
780
781
782
783
       ; 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)
784
785
786
-- 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
787
788
--   identifier (this is checked in 'rnHsVectDecl').  Fix this by enabling the use of 'vectType'
--   from the vectoriser here.
789
tcVect (HsVect name rhs)
790
791
  = addErrCtxt (vectCtxt name) $
    do { var <- wrapLocM tcLookupId name
792
793
       ; let L rhs_loc (HsVar rhs_var_name) = rhs
       ; rhs_id <- tcLookupId rhs_var_name
794
       ; return $ HsVect var (L rhs_loc (HsVar rhs_id))
795
       }
796

797
{- OLD CODE:
798
         -- turn the vectorisation declaration into a single non-recursive binding
799
       ; let bind    = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] 
800
801
802
803
             sigFun  = const Nothing
             pragFun = mkPragFun [] (unitBag bind)

         -- perform type inference (including generalisation)
804
       ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
805
       
806
       ; traceTc "tcVect inferred type" $ ppr (varType id')
807
       ; traceTc "tcVect bindings"      $ ppr binds
808
       
809
810
         -- add all bindings, including the type variable and dictionary bindings produced by type
         -- generalisation to the right-hand side of the vectorisation declaration
811
812
813
814
815
816
817
818
819
820
821
       ; 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)
       }
822
 -}
823
824
tcVect (HsNoVect name)
  = addErrCtxt (vectCtxt name) $
825
826
    do { var <- wrapLocM tcLookupId name
       ; return $ HsNoVect var
827
       }
828
tcVect (HsVectTypeIn isScalar lname rhs_name)
829
  = addErrCtxt (vectCtxt lname) $
830
    do { tycon <- tcLookupLocatedTyCon lname
831
832
833
834
835
       ; 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
836

837
838
       ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
       ; return $ HsVectTypeOut isScalar tycon rhs_tycon
839
       }
840
tcVect (HsVectTypeOut _ _ _)
841
  = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
842
843
844
845
846
847
848
tcVect (HsVectClassIn lname)
  = addErrCtxt (vectCtxt lname) $
    do { cls <- tcLookupLocatedClass lname
       ; return $ HsVectClassOut cls
       }
tcVect (HsVectClassOut _)
  = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
849
tcVect (HsVectInstIn linstTy)
850
851
852
  = addErrCtxt (vectCtxt linstTy) $
    do { (cls, tys) <- tcHsVectInst linstTy
       ; inst       <- tcLookupInstance cls tys
853
       ; return $ HsVectInstOut inst
854
       }
855
tcVect (HsVectInstOut _)
856
  = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
857

858
859
vectCtxt :: Outputable thing => thing -> SDoc
vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing
860

861
scalarTyConMustBeNullary :: MsgDoc
862
863
scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")

864
--------------
865
866
867
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise 
-- subsequent error messages
868
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
869
recoveryCode binder_names sig_fn
870
  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
Ian Lynagh's avatar
Ian Lynagh committed
871
        ; poly_ids <- mapM mk_dummy binder_names
872
873
        ; return (emptyBag, poly_ids, if all is_closed poly_ids
                                      then TopLevel else NotTopLevel) }
874
  where
875
    mk_dummy name 
Ian Lynagh's avatar
Ian Lynagh committed
876
877
        | isJust (sig_fn name) = tcLookupId name        -- Had signature; look it up
        | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
878

879
880
    is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id))

881
forall_a_a :: TcType
882
forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
883
884
\end{code}

885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
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.
905

906
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
907
%*                                                                      *
908
\subsection{tcMonoBind}
Ian Lynagh's avatar
Ian Lynagh committed
909
%*                                                                      *
910
911
%************************************************************************

912
@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
913
914
The signatures have been dealt with already.

915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
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.

937
\begin{code}
938
tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking purposes
Ian Lynagh's avatar
Ian Lynagh committed
939
                        -- i.e. the binders are mentioned in their RHSs, and
940
                        --      we are not rescued by a type signature
941
            -> TcSigFun -> LetBndrSpec 
942
            -> [LHsBind Name]
Ian Lynagh's avatar
Ian Lynagh committed
943
            -> TcM (LHsBinds TcId, [MonoBindInfo])
944

945
tcMonoBinds is_rec sig_fn no_gen
946
           [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
Ian Lynagh's avatar
Ian Lynagh committed
947
                                fun_matches = matches, bind_fvs = fvs })]
948
949
950
                             -- 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
951
952
953
954
955
956
  =     -- 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    $
957
    do  { rhs_ty  <- newFlexiTyVarTy openTypeKind
958
        ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
959
960
961
962
        ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
                                 -- We extend the error context even for a non-recursive 
                                 -- function so that in type error messages we show the 
                                 -- type of the thing whose rhs we are type checking
963
964
                               tcMatchesFun name inf matches rhs_ty

Ian Lynagh's avatar
Ian Lynagh committed
965
966
967
968
        ; 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)]) }
969

970
tcMonoBinds _ sig_fn no_gen binds
971
  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
972

Ian Lynagh's avatar
Ian Lynagh committed
973
974
975
        -- 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]
976
977
                    -- A monomorphic binding for each term variable that lacks 
                    -- a type sig.  (Ones with a sig are already in scope.)
978

979
980
981
        ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) 
                                       | (n,id) <- rhs_id_env]
        ; binds' <- tcExtendIdEnv2 rhs_id_env $ 
982
                    mapM (wrapLocM tcRhs) tc_binds
Ian Lynagh's avatar
Ian Lynagh committed
983
        ; return (listToBag binds', mono_info) }
984
985
986
987

------------------------
-- 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
988
989
--      if there's a signature for it, use the instantiated signature type
--      otherwise invent a type variable
990
991
992
-- You see that quite directly in the FunBind case.
-- 
-- But there's a complication for pattern bindings:
Ian Lynagh's avatar
Ian Lynagh committed
993
994
--      data T = MkT (forall a. a->a)
--      MkT f = e
995
996
997
998
999
1000
-- 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
1001
data TcMonoBind         -- Half completed; LHS done, RHS not done
1002
1003
  = TcFunBind  MonoBindInfo  SrcSpan Bool (MatchGroup Name (LHsExpr Name)) 
  | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
1004

1005
type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
Ian Lynagh's avatar
Ian Lynagh committed
1006
1007
        -- Type signature (if any), and
        -- the monomorphic bound things
1008

1009
tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
1010
tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
1011
  | Just sig <- sig_fn name
1012
1013
1014
1015
1016
1017
  = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
           , ppr name )  -- { f :: ty; f x = e } is always done via CheckGen
                         -- which gives rise to LetLclBndr.  It wouldn't make
                         -- sense to have a *polymorphic* function Id at this point
    do  { mono_name <- newLocalName name
        ; let mono_id = mkLocalId mono_name (sig_tau sig)
1018
1019
        ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
  | otherwise
1020
  = do  { mono_ty <- newFlexiTyVarTy openTypeKind
1021
1022
        ; mono_id <- newNoSigLetBndr no_gen name mono_ty
        ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
1023
1024
1025
1026

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
1027
1028
1029

                -- After typechecking the pattern, look up the binder
                -- names, which the pattern has brought into scope.
1030
1031
1032
              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
1033
1034
1035
1036
1037

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

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

simonpj@microsoft.com's avatar