TcBinds.lhs 61 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 )
Gergő Érdi's avatar
Gergő Érdi committed
17
import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl )
18

Simon Marlow's avatar
Simon Marlow committed
19
20
import DynFlags
import HsSyn
21
import HscTypes( isHsBoot )
22
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
23
24
25
import TcEnv
import TcUnify
import TcSimplify
26
import TcEvidence
Simon Marlow's avatar
Simon Marlow committed
27
28
29
import TcHsType
import TcPat
import TcMType
Gergő Érdi's avatar
Gergő Érdi committed
30
31
import PatSyn
import ConLike
Simon Peyton Jones's avatar
Simon Peyton Jones committed
32
import Type( tidyOpenType )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
33
import FunDeps( growThetaTyVars )
34
import TyCon
Simon Marlow's avatar
Simon Marlow committed
35
36
37
import TcType
import TysPrim
import Id
38
import Var
39
import VarSet
40
import Module
Simon Marlow's avatar
Simon Marlow committed
41
import Name
42
import NameSet
43
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
44
import SrcLoc
45
import Bag
46
import ListSetOps
Simon Marlow's avatar
Simon Marlow committed
47
48
49
50
51
import ErrUtils
import Digraph
import Maybes
import Util
import BasicTypes
52
import Outputable
53
import FastString
54
55
56
import Type(mkStrLitTy)
import Class(classTyCon)
import PrelNames(ipClassName)
57
58

import Control.Monad
59
60

#include "HsVersions.h"
61
\end{code}
62

63

64
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
65
%*                                                                      *
66
\subsection{Type-checking bindings}
Ian Lynagh's avatar
Ian Lynagh committed
67
%*                                                                      *
68
69
%************************************************************************

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

81
The real work is done by @tcBindWithSigsAndThen@.
82
83
84
85
86
87
88
89
90
91

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.

92
93
94
At the top-level the LIE is sure to contain nothing but constant
dictionaries, which we resolve at the module level.

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

154
\begin{code}
155
156
157
158
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)
Gergő Érdi's avatar
Gergő Érdi committed
159
160
161
162
163
  = do  { -- Pattern synonym bindings populate the global environment
          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
            do { gbl <- getGblEnv
               ; lcl <- getLclEnv
               ; return (gbl, lcl) }
164
165
166
167
168
169
170
171
        ; 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
172
173
        -- The top level bindings are flattened into a giant 
        -- implicitly-mutually-recursive LHsBinds
Gergő Érdi's avatar
Gergő Érdi committed
174

175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
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"
190

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

206
badBootDeclErr :: MsgDoc
Ian Lynagh's avatar
Ian Lynagh committed
207
badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
208

209
210
------------------------
tcLocalBinds :: HsLocalBinds Name -> TcM thing
Ian Lynagh's avatar
Ian Lynagh committed
211
             -> TcM (HsLocalBinds TcId, thing)
sof's avatar
sof committed
212

213
tcLocalBinds EmptyLocalBinds thing_inside 
Ian Lynagh's avatar
Ian Lynagh committed
214
215
  = do  { thing <- thing_inside
        ; return (EmptyLocalBinds, thing) }
sof's avatar
sof committed
216

217
218
219
220
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"
221

222
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
223
224
225
  = do  { ipClass <- tcLookupClass ipClassName
        ; (given_ips, ip_binds') <-
            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
226

Ian Lynagh's avatar
Ian Lynagh committed
227
228
        -- If the binding binds ?x = E, we  must now 
        -- discharge any ?x constraints in expr_lie
229
        -- See Note [Implicit parameter untouchables]
230
        ; (ev_binds, result) <- checkConstraints (IPSkol ips) 
231
                                  [] given_ips thing_inside
232
233

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

Ian Lynagh's avatar
Ian Lynagh committed
237
238
239
        -- I wonder if we should do these one at at time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
240
    tc_ip_bind ipClass (IPBind (Left ip) expr)
241
       = do { ty <- newFlexiTyVarTy openTypeKind
242
243
            ; let p = mkStrLitTy $ hsIPNameFS ip
            ; ip_id <- newDict ipClass [ p, ty ]
244
            ; expr' <- tcMonoExpr expr ty
245
246
247
248
249
250
251
252
            ; 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
Joachim Breitner's avatar
Joachim Breitner committed
253
        Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcSymCo $ mkTcUnbranchedAxInstCo Representational ax [x,ty]
254
255
256
        Nothing       -> panic "The dictionary for `IP` is not a newtype?"


257
\end{code}
258

259
260
261
262
263
264
265
266
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 
267
wanted).  Result disaster: the (Num alpha) is again solved, this
268
269
time by defaulting.  No no no.

270
271
272
However [Oct 10] this is all handled automatically by the 
untouchable-range idea.

273
\begin{code}
274
tcValBinds :: TopLevelFlag 
275
276
277
           -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
           -> TcM thing
           -> TcM ([(RecFlag, LHsBinds TcId)], thing) 
278

279
tcValBinds top_lvl binds sigs thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
280
  = do  {       -- Typecheck the signature
281
          (poly_ids, sig_fn) <- tcTySigs sigs
Ian Lynagh's avatar
Ian Lynagh committed
282

283
        ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
Ian Lynagh's avatar
Ian Lynagh committed
284
285
286

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

292
        ; return (binds', thing) }
293

294
------------------------
295
tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
296
297
             -> [(RecFlag, LHsBinds Name)] -> TcM thing
             -> TcM ([(RecFlag, LHsBinds TcId)], thing)
298
299
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
300
301
302
-- 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)
303

304
tcBindGroups _ _ _ [] thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
305
306
  = do  { thing <- thing_inside
        ; return ([], thing) }
307

308
tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
309
  = do  { (group', (groups', thing))
310
311
                <- 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
312
        ; return (group' ++ groups', thing) }
sof's avatar
sof committed
313

314
------------------------
315
tc_group :: forall thing. 
316
            TopLevelFlag -> TcSigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
317
318
         -> (RecFlag, LHsBinds Name) -> TcM thing
         -> TcM ([(RecFlag, LHsBinds TcId)], thing)
319
320
321
322
323

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

324
tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
325
326
        -- A single non-recursive binding
        -- We want to keep non-recursive things non-recursive
327
        -- so that we desugar unlifted bindings correctly
Gergő Érdi's avatar
Gergő Érdi committed
328
329
330
331
332
333
  = do { let bind = case bagToList binds of
                 [] -> panic "tc_group: empty list of binds"
                 [bind] -> bind
                 _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside
       ; return ( [(NonRecursive, bind')], thing) }
334
335

tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
336
  =     -- To maximise polymorphism, we do a new 
Ian Lynagh's avatar
Ian Lynagh committed
337
338
        -- strongly-connected-component analysis, this time omitting 
        -- any references to variables with type signatures.
339
        -- (This used to be optional, but isn't now.)
340
    do  { traceTc "tc_group rec" (pprLHsBinds binds)
Gergő Érdi's avatar
Gergő Érdi committed
341
        ; when hasPatSyn $ recursivePatSynErr binds
342
        ; (binds1, _ids, thing) <- go sccs
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
343
344
             -- Here is where we should do bindInstsOfLocalFuns
             -- if we start having Methods again
345
        ; return ([(Recursive, binds1)], thing) }
Ian Lynagh's avatar
Ian Lynagh committed
346
                -- Rec them all together
347
  where
Gergő Érdi's avatar
Gergő Érdi committed
348
349
350
351
352
    hasPatSyn = anyBag (isPatSyn . unLoc . snd) binds
    isPatSyn PatSynBind{} = True
    isPatSyn _ = False

    sccs :: [SCC (Origin, LHsBind Name)]
353
354
    sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)

Gergő Érdi's avatar
Gergő Érdi committed
355
    go :: [SCC (Origin, LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
356
    go (scc:sccs) = do  { (binds1, ids1, closed) <- tc_scc scc
357
                        ; (binds2, ids2, thing)  <- tcExtendLetEnv top_lvl closed ids1 $ 
358
                                                    go sccs
359
360
                        ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
    go []         = do  { thing <- thing_inside; return (emptyBag, [], thing) }
361

362
363
    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
sof's avatar
sof committed
364

365
    tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
sof's avatar
sof committed
366

Gergő Érdi's avatar
Gergő Érdi committed
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
recursivePatSynErr binds
  = failWithTc $
    hang (ptext (sLit "Recursive pattern synonym definition with following bindings:"))
       2 (vcat $ map (pprLBind . snd) . bagToList $ binds)
  where
    pprLoc loc  = parens (ptext (sLit "defined at") <+> ppr loc)
    pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
                            pprLoc loc

tc_single :: forall thing.
            TopLevelFlag -> TcSigFun -> PragFun
          -> (Origin, LHsBind Name) -> TcM thing
          -> TcM (LHsBinds TcId, thing)
tc_single _top_lvl _sig_fn _prag_fn (_, (L _ ps@PatSynBind{})) thing_inside
  = do { (pat_syn, aux_binds) <-
              tcPatSynDecl (patsyn_id ps) (patsyn_args ps) (patsyn_def ps) (patsyn_dir ps)

       ; let tything = AConLike (PatSynCon pat_syn)
             implicit_ids = (patSynMatcher pat_syn) :
                            (maybeToList (patSynWrapper pat_syn))

       ; thing <- tcExtendGlobalEnv [tything] $
                  tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
                  thing_inside
       ; return (aux_binds, thing)
       }
tc_single top_lvl sig_fn prag_fn lbind thing_inside
  = do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn
                                    NonRecursive NonRecursive
                                    [lbind]
       ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
       ; return (binds1, thing) }
          
401
------------------------
402
mkEdges :: TcSigFun -> LHsBinds Name
Gergő Érdi's avatar
Gergő Érdi committed
403
        -> [((Origin, LHsBind Name), BKey, [BKey])]
404
405
406
407

type BKey  = Int -- Just number off the bindings

mkEdges sig_fn binds
Gergő Érdi's avatar
Gergő Érdi committed
408
  = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc . snd $ bind)),
Ian Lynagh's avatar
Ian Lynagh committed
409
                         Just key <- [lookupNameEnv key_map n], no_sig n ])
410
411
412
413
414
415
416
417
    | (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
418
    key_map :: NameEnv BKey     -- Which binding it comes from
Gergő Érdi's avatar
Gergő Érdi committed
419
    key_map = mkNameEnv [(bndr, key) | ((_, L _ bind), key) <- keyd_binds
Ian Lynagh's avatar
Ian Lynagh committed
420
                                     , bndr <- bindersOfHsBind bind ]
421
422

bindersOfHsBind :: HsBind Name -> [Name]
Gergő Érdi's avatar
Gergő Érdi committed
423
424
425
426
427
bindersOfHsBind (PatBind { pat_lhs = pat })           = collectPatBinders pat
bindersOfHsBind (FunBind { fun_id = L _ f })          = [f]
bindersOfHsBind (PatSynBind { patsyn_id = L _ psyn }) = [psyn]
bindersOfHsBind (AbsBinds {})                         = panic "bindersOfHsBind AbsBinds"
bindersOfHsBind (VarBind {})                          = panic "bindersOfHsBind VarBind"
428

429
------------------------
430
tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
431
432
433
            -> RecFlag       -- Whether the group is really recursive
            -> RecFlag       -- Whether it's recursive after breaking
                             -- dependencies based on type signatures
Gergő Érdi's avatar
Gergő Érdi committed
434
            -> [(Origin, LHsBind Name)]
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
435
            -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
436
437
438
439
440

-- 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
--
441
442
443
-- 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.  
444
-- 
445
446
-- Knows nothing about the scope of the bindings

447
448
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
  = setSrcSpan loc                              $
Ian Lynagh's avatar
Ian Lynagh committed
449
    recoverM (recoveryCode binder_names sig_fn) $ do 
450
        -- Set up main recover; take advantage of any type sigs
451

452
    { traceTc "------------------------------------------------" empty
453
    ; traceTc "Bindings for {" (ppr binder_names)
454
    ; dflags   <- getDynFlags
455
456
    ; type_env <- getLclTypeEnv
    ; let plan = decideGeneralisationPlan dflags type_env 
457
                         binder_names bind_list sig_fn
458
    ; traceTc "Generalisation plan" (ppr plan)
459
    ; result@(tc_binds, poly_ids, _) <- case plan of
Gergő Érdi's avatar
Gergő Érdi committed
460
461
462
         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 lbind sig  -> tcPolyCheck rec_tc prag_fn sig lbind
463

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
464
        -- Check whether strict bindings are ok
Ian Lynagh's avatar
Ian Lynagh committed
465
466
        -- These must be non-recursive etc, and are not generalised
        -- They desugar to a case expression in the end
467
468
469
470
    ; 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]
                                          ])
471

472
    ; return result }
473
  where
Gergő Érdi's avatar
Gergő Érdi committed
474
475
476
    bind_list' = map snd bind_list
    binder_names = collectHsBindListBinders bind_list'
    loc = foldr1 combineSrcSpans (map getLoc bind_list')
477
478
         -- 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
479
         -- span that includes them all
480

481
------------------
482
tcPolyNoGen     -- No generalisation whatsoever
483
  :: RecFlag       -- Whether it's recursive after breaking
484
                   -- dependencies based on type signatures
485
  -> PragFun -> TcSigFun
Gergő Érdi's avatar
Gergő Érdi committed
486
  -> [(Origin, LHsBind Name)]
487
  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
488

489
490
tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
  = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
491
492
                                             (LetGblBndr prag_fn) 
                                             bind_list
493
       ; mono_ids' <- mapM tc_mono_info mono_infos
494
       ; return (binds', mono_ids', NotTopLevel) }
495
496
  where
    tc_mono_info (name, _, mono_id)
497
      = do { mono_ty' <- zonkTcType (idType mono_id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
498
             -- Zonk, mainly to expose unboxed types to checkStrictBinds
499
           ; let mono_id' = setIdType mono_id mono_ty'
500
           ; _specs <- tcSpecPrags mono_id' (prag_fn name)
501
           ; return mono_id' }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
502
503
504
505
           -- 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
506
507

------------------
508
tcPolyCheck :: RecFlag       -- Whether it's recursive after breaking
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
509
                             -- dependencies based on type signatures
510
            -> PragFun -> TcSigInfo 
Gergő Érdi's avatar
Gergő Érdi committed
511
            -> (Origin, LHsBind Name)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
512
            -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
513
514
515
-- There is just one binding, 
--   it binds a single variable,
--   it has a signature,
516
tcPolyCheck rec_tc prag_fn
517
            sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped 
518
                           , sig_theta = theta, sig_tau = tau, sig_loc = loc })
Gergő Érdi's avatar
Gergő Érdi committed
519
            bind@(origin, _)
520
  = do { ev_vars <- newEvVars theta
521
522
       ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
             prag_sigs = prag_fn (idName poly_id)
523
       ; tvs <- mapM (skolemiseSigTv . snd) tvs_w_scoped
524
       ; (ev_binds, (binds', [mono_info])) 
525
526
527
            <- setSrcSpan loc $  
               checkConstraints skol_info tvs ev_vars $
               tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $
Gergő Érdi's avatar
Gergő Érdi committed
528
               tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr [bind]
529

530
531
       ; spec_prags <- tcSpecPrags poly_id prag_sigs
       ; poly_id    <- addInlinePrags poly_id prag_sigs
532

533
534
535
536
537
       ; let (_, _, mono_id) = mono_info
             export = ABE { abe_wrap = idHsWrapper
                          , abe_poly = poly_id
                          , abe_mono = mono_id
                          , abe_prags = SpecPrags spec_prags }
538
539
540
541
             abs_bind = L loc $ AbsBinds 
                        { abs_tvs = tvs
                        , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
                        , abs_exports = [export], abs_binds = binds' }
542
543
             closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
                    | otherwise                                     = NotTopLevel
Gergő Érdi's avatar
Gergő Érdi committed
544
       ; return (unitBag (origin, abs_bind), [poly_id], closed) }
545

546
------------------
547
tcPolyInfer 
548
  :: RecFlag       -- Whether it's recursive after breaking
549
                   -- dependencies based on type signatures
550
551
552
  -> PragFun -> TcSigFun 
  -> Bool         -- True <=> apply the monomorphism restriction
  -> Bool         -- True <=> free vars have closed types
Gergő Érdi's avatar
Gergő Érdi committed
553
  -> [(Origin, LHsBind Name)]
554
  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
555
tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
556
  = do { ((binds', mono_infos), wanted)
557
             <- captureConstraints $
558
                tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
559

560
       ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
561
       ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
562
       ; (qtvs, givens, mr_bites, ev_binds) <- 
563
                          simplifyInfer closed mono name_taus wanted
564

565
566
       ; theta <- zonkTcThetaType (map evVarPred givens)
       ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos
567
568

       ; loc <- getSrcSpanM
569
       ; let poly_ids = map abe_poly exports
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
570
571
             final_closed | closed && not mr_bites = TopLevel
                          | otherwise              = NotTopLevel
572
573
574
575
             abs_bind = L loc $ 
                        AbsBinds { abs_tvs = qtvs
                                 , abs_ev_vars = givens, abs_ev_binds = ev_binds
                                 , abs_exports = exports, abs_binds = binds' }
576

Simon Peyton Jones's avatar
Simon Peyton Jones committed
577
578
       ; traceTc "Binding:" (ppr final_closed $$
                             ppr (poly_ids `zip` map idType poly_ids))
Gergő Érdi's avatar
Gergő Érdi committed
579
       ; return (unitBag (origin, abs_bind), poly_ids, final_closed) }
580
         -- poly_ids are guaranteed zonked by mkExport
Gergő Érdi's avatar
Gergő Érdi committed
581
582
  where
    origin = if all isGenerated (map fst bind_list) then Generated else FromSource
583
584

--------------
585
mkExport :: PragFun
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
586
         -> [TyVar] -> TcThetaType      -- Both already zonked
Ian Lynagh's avatar
Ian Lynagh committed
587
         -> MonoBindInfo
588
         -> TcM (ABExport Id)
589
590
591
592
-- 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
593
--      zonked poly_ids
594
595
596
597
-- 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
598
-- type environment; see the invariant on TcEnv.tcExtendIdEnv
599

600
-- Pre-condition: the qtvs and theta are already zonked
601

602
mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
603
  = do  { mono_ty <- zonkTcType (idType mono_id)
604
        ; let poly_id  = case mb_sig of
605
606
607
                           Nothing  -> mkLocalId poly_name inferred_poly_ty
                           Just sig -> sig_id sig
                -- poly_id has a zonked type
608

609
610
611
              -- In the inference case (no signature) this stuff figures out
              -- the right type variables and theta to quantify over
              -- See Note [Impedence matching]
612
613
              my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType mono_ty))
                            -- Include kind variables!  Trac #7916
614
615
              my_tvs   = filter (`elemVarSet` my_tvs2) qtvs   -- Maintain original order
              my_theta = filter (quantifyPred my_tvs2) theta
616
617
              inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty

618
        ; poly_id <- addInlinePrags poly_id prag_sigs
619
        ; spec_prags <- tcSpecPrags poly_id prag_sigs
Ian Lynagh's avatar
Ian Lynagh committed
620
                -- tcPrags requires a zonked poly_id
621

622
        ; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty
623
624
        ; traceTc "mkExport: check sig"
                  (ppr poly_name $$ ppr sel_poly_ty $$ ppr (idType poly_id))
625

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
626
627
628
        -- 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.
629
        -- 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
630
631
        -- closed (unless we are doing NoMonoLocalBinds in which case all bets
        -- are off)
632
        -- See Note [Impedence matching]
633
634
635
        ; (wrap, wanted) <- addErrCtxtM (mk_msg poly_id) $
                            captureConstraints $
                            tcSubType origin sig_ctxt sel_poly_ty (idType poly_id)
636
        ; ev_binds <- simplifyTop wanted
637
638
639
640
641

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

645
646
647
648
649
650
651
652
653
654
655
    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)
656

657
    prag_sigs = prag_fn poly_name
658
    origin    = AmbigOrigin sig_ctxt
659
    sig_ctxt  = InfSigCtxt poly_name
660
\end{code}
661

662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
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}
702
type PragFun = Name -> [LSig Name]
703

704
mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
705
706
mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
  where
Icelandjack's avatar
Icelandjack committed
707
    prs = mapMaybe get_sig sigs
708
709
710
711
712
713
714

    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
715
716
717
      | 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
718
719
720
721
722
723
724
725
      | 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
Gergő Érdi's avatar
Gergő Érdi committed
726
    ar_env = foldrBag (lhsBindArity . snd) emptyNameEnv binds
727
728
729
730

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
731
lhsBindArity _ env = env        -- PatBind/VarBind
732

733
------------------
734
735
tcSpecPrags :: Id -> [LSig Name]
            -> TcM [LTcSpecPrag]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
736
-- Add INLINE and SPECIALSE pragmas
737
738
--    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
739
740
-- Pre-condition: the poly_id is zonked
-- Reason: required by tcSubExp
741
742
743
tcSpecPrags poly_id prag_sigs
  = do { unless (null bad_sigs) warn_discarded_sigs
       ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
744
  where
745
746
747
748
    spec_sigs = filter isSpecLSig prag_sigs
    bad_sigs  = filter is_bad_sig prag_sigs
    is_bad_sig s = not (isSpecLSig s || isInlineLSig s)

749
750
751
752
753
754
    warn_discarded_sigs = warnPrags poly_id bad_sigs $
                          ptext (sLit "Discarding unexpected pragmas for")


--------------
tcSpec :: TcId -> Sig Name -> TcM TcSpecPrag
755
756
tcSpec poly_id prag@(SpecSig fun_name hs_ty inl) 
  -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
757
758
  -- Example: SPECIALISE for a class method: the Name in the SpecSig is
  --          for the selector Id, but the poly_id is something like $cop
759
760
  -- However we want to use fun_name in the error message, since that is
  -- what the user wrote (Trac #8537)
761
762
  = addErrCtxt (spec_ctxt prag) $
    do  { spec_ty <- tcHsSigType sig_ctxt hs_ty
763
        ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
764
                 (ptext (sLit "SPECIALISE pragma for non-overloaded function") 
765
                  <+> quotes (ppr fun_name))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
766
                  -- Note [SPECIALISE pragmas]
767
        ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty
768
769
        ; return (SpecPrag poly_id wrap inl) }
  where
770
771
772
    name      = idName poly_id
    poly_ty   = idType poly_id
    origin    = SpecPragOrigin name
773
774
    sig_ctxt  = FunSigCtxt name
    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
775

776
tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
777

778
779
--------------
tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
780
-- SPECIALISE pragamas for imported things
781
782
tcImpPrags prags
  = do { this_mod <- getModule
783
       ; dflags <- getDynFlags
784
785
       ; if (not_specialising dflags) then
            return []
786
787
788
789
         else
            mapAndRecoverM (wrapLocM tcImpSpec) 
            [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
                               , not (nameIsLocalOrFrom this_mod name) ] }
790
791
792
793
794
795
  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
796
      | not (gopt Opt_Specialise dflags) = True
797
798
799
800
      | otherwise = case hscTarget dflags of
                      HscNothing -> True
                      HscInterpreted -> True
                      _other         -> False
801
802
803

tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
tcImpSpec (name, prag)
804
 = do { id <- tcLookupId name
805
806
      ; unless (isAnyInlinePragma (idInlinePragma id))
               (addWarnTc (impSpecErr name))
807
808
809
810
811
      ; tcSpec id prag }

impSpecErr :: Name -> SDoc
impSpecErr name
  = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
812
       2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
813
814
815
816
817
               , parens $ sep 
                   [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
                   , ptext (sLit "was compiled without -O")]])
  where
    mod = nameModule name
818
819

--------------
820
tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
821
822
tcVectDecls decls 
  = do { decls' <- mapM (wrapLocM tcVect) decls
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
823
       ; let ids  = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
824
825
             dups = findDupsEq (==) ids
       ; mapM_ reportVectDups dups
826
       ; traceTcConstraints "End of tcVectDecls"
827
828
829
830
831
832
833
834
835
836
       ; 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)
837
838
839
-- 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
840
841
--   identifier (this is checked in 'rnHsVectDecl').  Fix this by enabling the use of 'vectType'
--   from the vectoriser here.
842
tcVect (HsVect name rhs)
843
844
  = addErrCtxt (vectCtxt name) $
    do { var <- wrapLocM tcLookupId name
845
846
       ; let L rhs_loc (HsVar rhs_var_name) = rhs
       ; rhs_id <- tcLookupId rhs_var_name
847
       ; return $ HsVect var (L rhs_loc (HsVar rhs_id))
848
       }
849

850
{- OLD CODE:
851
         -- turn the vectorisation declaration into a single non-recursive binding
852
       ; let bind    = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] 
853
854
855
856
             sigFun  = const Nothing
             pragFun = mkPragFun [] (unitBag bind)

         -- perform type inference (including generalisation)
857
       ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
858
       
859
       ; traceTc "tcVect inferred type" $ ppr (varType id')
860
       ; traceTc "tcVect bindings"      $ ppr binds
861
       
862
863
         -- add all bindings, including the type variable and dictionary bindings produced by type
         -- generalisation to the right-hand side of the vectorisation declaration
864
865
866
867
868
869
870
871
872
873
874
       ; 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)
       }
875
 -}
876
877
tcVect (HsNoVect name)
  = addErrCtxt (vectCtxt name) $
878
879
    do { var <- wrapLocM tcLookupId name
       ; return $ HsNoVect var
880
       }
881
tcVect (HsVectTypeIn isScalar lname rhs_name)
882
  = addErrCtxt (vectCtxt lname) $
883
    do { tycon <- tcLookupLocatedTyCon lname
884
885
886
887
888
       ; 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
889

890
891
       ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
       ; return $ HsVectTypeOut isScalar tycon rhs_tycon
892
       }
893
tcVect (HsVectTypeOut _ _ _)
894
  = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
895
896
897
898
899
900
901
tcVect (HsVectClassIn lname)
  = addErrCtxt (vectCtxt lname) $
    do { cls <- tcLookupLocatedClass lname
       ; return $ HsVectClassOut cls
       }
tcVect (HsVectClassOut _)
  = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
902
tcVect (HsVectInstIn linstTy)
903
904
905
  = addErrCtxt (vectCtxt linstTy) $
    do { (cls, tys) <- tcHsVectInst linstTy
       ; inst       <- tcLookupInstance cls tys
906
       ; return $ HsVectInstOut inst
907
       }
908
tcVect (HsVectInstOut _)
909
  = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
910

911
912
vectCtxt :: Outputable thing => thing -> SDoc
vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing
913

914
scalarTyConMustBeNullary :: MsgDoc
915
916
scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")

917
--------------
918
919
920
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise 
-- subsequent error messages
921
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
922
recoveryCode binder_names sig_fn
923
  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
Ian Lynagh's avatar
Ian Lynagh committed
924
        ; poly_ids <- mapM mk_dummy binder_names
925
926
        ; return (emptyBag, poly_ids, if all is_closed poly_ids
                                      then TopLevel else NotTopLevel) }
927
  where
928
    mk_dummy name 
Ian Lynagh's avatar
Ian Lynagh committed
929
930
        | isJust (sig_fn name) = tcLookupId name        -- Had signature; look it up
        | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
931

932
933
    is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id))

934
forall_a_a :: TcType
935
forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
936
937
\end{code}

938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
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.
958

959
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
960
%*                                                                      *
961
\subsection{tcMonoBind}
Ian Lynagh's avatar
Ian Lynagh committed
962
%*                                                                      *
963
964
%************************************************************************

965
@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
966
967
The signatures have been dealt with already.

968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
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.

990
\begin{code}
991
tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking purposes
Ian Lynagh's avatar
Ian Lynagh committed
992
                        -- i.e. the binders are mentioned in their RHSs, and
993
                        --      we are not rescued by a type signature
994
            -> TcSigFun -> LetBndrSpec 
Gergő Érdi's avatar
Gergő Érdi committed
995
            -> [(Origin, LHsBind Name)]
Ian Lynagh's avatar
Ian Lynagh committed
996
            -> TcM (LHsBinds TcId, [MonoBindInfo])
997

998
tcMonoBinds is_rec sig_fn no_gen
Gergő Érdi's avatar
Gergő Érdi committed
999
1000
           [ (origin, L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
                                         fun_matches = matches, bind_fvs = fvs }))]
1001
1002
1003
                             -- 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
1004
1005
1006
1007
1008
1009
  =     -- 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    $
1010
    do  { rhs_ty  <- newFlexiTyVarTy openTypeKind
1011
        ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
1012
1013
1014
1015
        ; (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
1016
1017
                               tcMatchesFun name inf matches rhs_ty

Gergő Érdi's avatar
Gergő Érdi committed
1018
1019
        ; return (unitBag (origin,
                           L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
Ian Lynagh's avatar
Ian Lynagh committed
1020
1021
1022
                                              fun_matches = matches', bind_fvs = fvs,
                                              fun_co_fn = co_fn, fun_tick = Nothing })),
                  [(name, Nothing, mono_id)]) }
1023

1024
tcMonoBinds _ sig_fn no_gen binds
Gergő Érdi's avatar
Gergő Érdi committed
1025
  = do  { tc_binds <- mapM (wrapOriginLocM (tcLhs sig_fn no_gen)) binds
1026

Ian Lynagh's avatar
Ian Lynagh committed
1027
        -- Bring the monomorphic Ids, into scope for the RHSs
Gergő Érdi's avatar
Gergő Érdi committed
1028
        ; let mono_info  = getMonoBindInfo (map snd tc_binds)
Ian Lynagh's avatar
Ian Lynagh committed
1029
              rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
1030
1031
                    -- A monomorphic binding for each term variable that lacks 
                    -- a type sig.  (Ones with a sig are already in scope.)
1032

1033
1034
1035
        ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) 
                                       | (n,id) <- rhs_id_env]
        ; binds' <- tcExtendIdEnv2 rhs_id_env $ 
Gergő Érdi's avatar
Gergő Érdi committed
1036
                    mapM (wrapOriginLocM tcRhs) tc_binds
Ian Lynagh's avatar
Ian Lynagh committed
1037
        ; return (listToBag binds', mono_info) }
1038
1039
1040
1041

------------------------
-- 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: