TcBinds.hs 84.1 KB
 Austin Seipp committed Dec 03, 2014 1 2 3 4 {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  partain committed Jan 08, 1996 5 \section[TcBinds]{TcBinds}  Austin Seipp committed Dec 03, 2014 6 -}  partain committed Jan 08, 1996 7   Herbert Valerio Riedel committed May 15, 2014 8 9 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}  Simon Peyton Jones committed Nov 29, 2011 10 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,  Ben Gamari committed Oct 30, 2015 11  tcValBinds, tcHsBootSigs, tcPolyCheck,  Simon Peyton Jones committed Jul 21, 2015 12  tcSpecPrags, tcSpecWrapper,  Ben Gamari committed Oct 30, 2015 13  tcVectDecls, addTypecheckedBinds,  Simon Peyton Jones committed Jul 21, 2015 14 15  TcSigInfo(..), TcSigFun, TcPragEnv, mkPragEnv,  Simon Peyton Jones committed Dec 01, 2015 16 17  tcUserTypeSig, instTcTySig, chooseInferredQuantifiers, instTcTySigFromId, tcExtendTyVarEnvFromSig,  Facundo Domínguez committed Dec 09, 2014 18  badBootDeclErr, mkExport ) where  partain committed Jan 08, 1996 19   ross committed Sep 20, 2003 20 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )  simonpj@microsoft.com committed Jan 25, 2006 21 import {-# SOURCE #-} TcExpr ( tcMonoExpr )  Simon Peyton Jones committed Dec 22, 2015 22 23 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl , tcPatSynBuilderBind, tcPatSynSig )  Simon Marlow committed Oct 11, 2006 24 25 import DynFlags import HsSyn  Edward Z. Yang committed Nov 16, 2015 26 import HscTypes( isHsBootOrSig )  simonpj committed Sep 13, 2002 27 import TcRnMonad  Simon Marlow committed Oct 11, 2006 28 29 30 import TcEnv import TcUnify import TcSimplify  Simon Peyton Jones committed Dec 05, 2011 31 import TcEvidence  Simon Marlow committed Oct 11, 2006 32 33 34 import TcHsType import TcPat import TcMType  cactus committed Jan 20, 2014 35 import ConLike  Simon Peyton Jones committed Jan 14, 2015 36 import Inst( deeplyInstantiate )  Simon Peyton Jones committed Nov 04, 2014 37 38 import FamInstEnv( normaliseType ) import FamInst( tcGetFamInstEnvs )  chak@cse.unsw.edu.au. committed Aug 19, 2011 39 import TyCon  Simon Marlow committed Oct 11, 2006 40 41 import TcType import TysPrim  Eric Seidel committed Sep 02, 2015 42 import TysWiredIn  Simon Marlow committed Oct 11, 2006 43 import Id  44 import Var  Simon Peyton Jones committed Aug 16, 2011 45 import VarSet  Simon Peyton Jones committed Jun 11, 2014 46 import VarEnv( TidyEnv )  ian@well-typed.com committed Nov 02, 2012 47 import Module  Simon Marlow committed Oct 11, 2006 48 import Name  simonpj committed May 18, 1999 49 import NameSet  simonpj committed Jul 19, 2005 50 import NameEnv  Simon Marlow committed Oct 11, 2006 51 import SrcLoc  simonm committed Dec 02, 1998 52 import Bag  chak@cse.unsw.edu.au. committed Feb 20, 2011 53 import ListSetOps  Simon Marlow committed Oct 11, 2006 54 55 56 57 58 import ErrUtils import Digraph import Maybes import Util import BasicTypes  simonm committed Jan 08, 1998 59 import Outputable  Ian Lynagh committed Mar 29, 2008 60 import FastString  Eric Seidel committed Dec 07, 2015 61 import Type(mkStrLitTy, tidyOpenType)  Simon Peyton Jones committed Dec 01, 2015 62 import PrelNames( mkUnboundName, gHC_PRIM )  Simon Peyton Jones committed Jun 11, 2014 63 import TcValidity (checkValidType)  Ben Gamari committed Dec 15, 2015 64 import qualified GHC.LanguageExtensions as LangExt  twanvl committed Jan 17, 2008 65 66  import Control.Monad  simonpj@microsoft.com committed Oct 07, 2010 67 68  #include "HsVersions.h"  simonpj committed Mar 14, 1997 69   Ben Gamari committed Oct 30, 2015 70 71 72 73 74 75 76 77 {- ********************************************************************* * * A useful helper function * * ********************************************************************* -} addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv addTypecheckedBinds tcg_env binds  Edward Z. Yang committed Nov 16, 2015 78  | isHsBootOrSig (tcg_src tcg_env) = tcg_env  Ben Gamari committed Oct 30, 2015 79 80 81 82 83 84  -- Do not add the code for record-selector bindings -- when compiling hs-boot files | otherwise = tcg_env { tcg_binds = foldr unionBags (tcg_binds tcg_env) binds }  Austin Seipp committed Dec 03, 2014 85 86 87 {- ************************************************************************ * *  partain committed Jan 08, 1996 88 \subsection{Type-checking bindings}  Austin Seipp committed Dec 03, 2014 89 90 * * ************************************************************************  partain committed Jan 08, 1996 91   partain committed Mar 19, 1996 92 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because  partain committed Jan 08, 1996 93 94 95 96 97 98 99 100 101 102 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".  simonpj committed Mar 14, 1997 103 The real work is done by @tcBindWithSigsAndThen@.  partain committed Jan 08, 1996 104 105 106 107 108 109 110 111 112 113  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.  partain committed Mar 19, 1996 114 115 116 At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level.  Simon Peyton Jones committed Mar 02, 2012 117 118 Note [Polymorphic recursion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~  cactus committed Nov 20, 2014 119 The game plan for polymorphic recursion in the code above is  Simon Peyton Jones committed Mar 02, 2012 120 121  * Bind any variable for which we have a type signature  cactus committed Nov 20, 2014 122  to an Id with a polymorphic type. Then when type-checking  Simon Peyton Jones committed Mar 02, 2012 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174  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  Austin Seipp committed Dec 03, 2014 175 -}  Simon Peyton Jones committed Mar 02, 2012 176   Simon Peyton Jones committed Nov 29, 2011 177 178 179 180 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)  cactus committed Jan 20, 2014 181 182 183 184 185  = 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) }  Simon Peyton Jones committed Nov 29, 2011 186 187  ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids  Ben Gamari committed Oct 30, 2015 188 189  ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } addTypecheckedBinds map snd binds' }  Simon Peyton Jones committed Nov 29, 2011 190 191  ; return (tcg_env', tcl_env) }  cactus committed Nov 20, 2014 192  -- The top level bindings are flattened into a giant  Ian Lynagh committed May 18, 2008 193  -- implicitly-mutually-recursive LHsBinds  cactus committed Jan 20, 2014 194   Simon Peyton Jones committed Nov 29, 2011 195 196 197 198 tcTopBinds (ValBindsIn {}) = panic "tcTopBinds" tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv tcRecSelBinds (ValBindsOut binds sigs)  Ben Gamari committed Oct 29, 2015 199  = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs]$  Ben Gamari committed Oct 30, 2015 200 201 202  do { (rec_sel_binds, tcg_env) <- discardWarnings $tcValBinds TopLevel binds sigs getGblEnv ; let tcg_env' = tcg_env addTypecheckedBinds map snd rec_sel_binds  Simon Peyton Jones committed Nov 29, 2011 203 204  ; return tcg_env' } tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"  simonpj committed Oct 13, 2000 205   simonpj committed Jul 19, 2005 206 tcHsBootSigs :: HsValBinds Name -> TcM [Id]  simonpj committed Jan 27, 2005 207 208 -- A hs-boot file has only one BindGroup, and it only has type -- signatures in it. The renamer checked all this  simonpj committed Aug 11, 2005 209 tcHsBootSigs (ValBindsOut binds sigs)  Ian Lynagh committed May 18, 2008 210  = do { checkTc (null binds) badBootDeclErr  waern committed Jun 10, 2011 211  ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }  simonpj committed Jan 27, 2005 212  where  Simon Peyton Jones committed Dec 01, 2015 213  tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames  waern committed Jun 10, 2011 214  where  Simon Peyton Jones committed Aug 05, 2015 215  f (L _ name)  eir@cis.upenn.edu committed Dec 11, 2015 216 217  = do { sigma_ty <- solveEqualities $tcHsSigWcType (FunSigCtxt name False) hs_ty  Simon Peyton Jones committed Aug 05, 2015 218  ; return (mkVanillaGlobal name sigma_ty) }  Ian Lynagh committed May 18, 2008 219  -- Notice that we make GlobalIds, not LocalIds  Ian Lynagh committed May 18, 2008 220  tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)  simonpj committed Jul 12, 2005 221 tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)  simonpj committed Oct 13, 2000 222   Simon Peyton Jones committed Jan 12, 2012 223 badBootDeclErr :: MsgDoc  Ian Lynagh committed Apr 12, 2008 224 badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")  simonpj committed May 03, 2005 225   simonpj committed Jul 19, 2005 226 227 ------------------------ tcLocalBinds :: HsLocalBinds Name -> TcM thing  Ian Lynagh committed May 18, 2008 228  -> TcM (HsLocalBinds TcId, thing)  sof committed May 18, 1997 229   cactus committed Nov 20, 2014 230 tcLocalBinds EmptyLocalBinds thing_inside  Ian Lynagh committed May 18, 2008 231 232  = do { thing <- thing_inside ; return (EmptyLocalBinds, thing) }  sof committed May 18, 1997 233   Simon Peyton Jones committed Nov 29, 2011 234 235 236 237 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"  simonm committed Jan 08, 1998 238   simonpj committed Jul 19, 2005 239 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside  Eric Seidel committed Sep 02, 2015 240  = do { (given_ips, ip_binds') <-  Simon Peyton Jones committed Jun 13, 2012 241  mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds  simonpj committed Oct 23, 2002 242   cactus committed Nov 20, 2014 243  -- If the binding binds ?x = E, we must now  Ian Lynagh committed May 18, 2008 244  -- discharge any ?x constraints in expr_lie  simonpj@microsoft.com committed Oct 21, 2010 245  -- See Note [Implicit parameter untouchables]  cactus committed Nov 20, 2014 246  ; (ev_binds, result) <- checkConstraints (IPSkol ips)  simonpj@microsoft.com committed Oct 21, 2010 247  [] given_ips thing_inside  simonpj@microsoft.com committed Sep 13, 2010 248 249  ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }  simonpj committed Oct 23, 2002 250  where  Alan Zimmerman committed Jan 16, 2015 251  ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds]  simonpj@microsoft.com committed Sep 13, 2010 252   Ian Lynagh committed May 18, 2008 253 254 255  -- I wonder if we should do these one at at time -- Consider ?x = 4 -- ?y = ?x + 1  Alan Zimmerman committed Jan 16, 2015 256  tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr)  eir@cis.upenn.edu committed Dec 11, 2015 257  = do { ty <- newOpenFlexiTyVarTy  Simon Peyton Jones committed Jun 13, 2012 258 259  ; let p = mkStrLitTy$ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ]  simonpj@microsoft.com committed Sep 13, 2010 260  ; expr' <- tcMonoExpr expr ty  Simon Peyton Jones committed Jun 13, 2012 261 262 263 264 265 266  ; 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  eir@cis.upenn.edu committed Dec 11, 2015 267  toDict ipClass x ty = HsWrap $mkWpCastR$  Eric Seidel committed Jan 19, 2015 268  wrapIP $mkClassPred ipClass [x,ty]  Simon Peyton Jones committed Jun 13, 2012 269   Austin Seipp committed Dec 03, 2014 270 {-  simonpj@microsoft.com committed Sep 17, 2010 271 272 273 274 275 276 277 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  cactus committed Nov 20, 2014 278 doesn't float that solved constraint out (it's not an unsolved  Simon Peyton Jones committed Aug 16, 2011 279 wanted). Result disaster: the (Num alpha) is again solved, this  simonpj@microsoft.com committed Sep 17, 2010 280 281 time by defaulting. No no no.  cactus committed Nov 20, 2014 282 However [Oct 10] this is all handled automatically by the  simonpj@microsoft.com committed Oct 21, 2010 283 284 untouchable-range idea.  Simon Peyton Jones committed Jun 24, 2014 285 286 287 288 289 290 291 292 293 294 295 296 Note [Placeholder PatSyn kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (Trac #9161) {-# LANGUAGE PatternSynonyms, DataKinds #-} pattern A = () b :: A b = undefined Here, the type signature for b mentions A. But A is a pattern synonym, which is typechecked (for very good reasons; a view pattern in the RHS may mention a value binding) as part of a group of  Gabor Greif committed Dec 09, 2015 297 bindings. It is entirely reasonable to reject this, but to do so  Simon Peyton Jones committed Jun 24, 2014 298 299 300 301 302 303 304 305 306 we need A to be in the kind environment when kind-checking the signature for B. Hence the tcExtendKindEnv2 patsyn_placeholder_kinds, which adds a binding A -> AGlobal (AConLike (PatSynCon _|_)) to the environment. Then TcHsType.tcTyVar will find A in the kind environment, and will give a 'wrongThingErr' as a result. But the lookup of A won't fail. The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in tcTyVar, doesn't look inside the TcTyThing.  Simon Peyton Jones committed Jul 21, 2015 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353  Note [Inlining and hs-boot files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this example (Trac #10083): ---------- RSR.hs-boot ------------ module RSR where data RSR eqRSR :: RSR -> RSR -> Bool ---------- SR.hs ------------ module SR where import {-# SOURCE #-} RSR data SR = MkSR RSR eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 ---------- RSR.hs ------------ module RSR where import SR data RSR = MkRSR SR -- deriving( Eq ) eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) foo x y = not (eqRSR x y) When compiling RSR we get this code RSR.eqRSR :: RSR -> RSR -> Bool RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) -> case ds1 of _ { RSR.MkRSR s1 -> case ds2 of _ { RSR.MkRSR s2 -> SR.eqSR s1 s2 }} RSR.foo :: RSR -> RSR -> Bool RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y) Now, when optimising foo: Inline eqRSR (small, non-rec) Inline eqSR (small, non-rec) but the result of inlining eqSR from SR is another call to eqRSR, so everything repeats. Neither eqSR nor eqRSR are (apparently) loop breakers. Solution: when compiling RSR, add a NOINLINE pragma to every function exported by the boot-file for RSR (if it exists). ALAS: doing so makes the boostrappted GHC itself slower by 8% overall (on Trac #9872a-d, and T1969. So I un-did this change, and parked it for now. Sigh.  Austin Seipp committed Dec 03, 2014 354 -}  Simon Peyton Jones committed Jun 24, 2014 355   cactus committed Nov 20, 2014 356 tcValBinds :: TopLevelFlag  Simon Peyton Jones committed Nov 29, 2011 357 358  -> [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM thing  cactus committed Nov 20, 2014 359  -> TcM ([(RecFlag, LHsBinds TcId)], thing)  simonpj committed Oct 27, 2005 360   Simon Peyton Jones committed Nov 29, 2011 361 tcValBinds top_lvl binds sigs thing_inside  Simon Peyton Jones committed Jun 24, 2014 362  = do { -- Typecheck the signature  Simon Peyton Jones committed Mar 24, 2015 363  ; (poly_ids, sig_fn) <- tcExtendKindEnv2 patsyn_placeholder_kinds$  thomasw committed Nov 28, 2014 364  -- See Note [Placeholder PatSyn kinds]  Simon Peyton Jones committed Mar 24, 2015 365  tcTySigs sigs  Ian Lynagh committed May 18, 2008 366   Simon Peyton Jones committed Jul 21, 2015 367 368 369 370 371 372 373 374 375 376 377 378 379  ; _self_boot <- tcSelfBootInfo ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds) -- ------- See Note [Inlining and hs-boot files] (change parked) -------- -- prag_fn | isTopLevel top_lvl -- See Note [Inlining and hs-boot files] -- , SelfBoot { sb_ids = boot_id_names } <- self_boot -- = foldNameSet add_no_inl prag_fn1 boot_id_names -- | otherwise -- = prag_fn1 -- add_no_inl boot_id_name prag_fn -- = extendPragEnv prag_fn (boot_id_name, no_inl_sig boot_id_name) -- no_inl_sig name = L boot_loc (InlineSig (L boot_loc name) neverInlinePragma) -- boot_loc = mkGeneralSrcSpan (fsLit "The hs-boot file for this module")  Ian Lynagh committed May 18, 2008 380   Simon Peyton Jones committed Mar 24, 2015 381 382 383 384 385  -- Extend the envt right away with all the Ids -- declared with complete type signatures -- Do not extend the TcIdBinderStack; instead -- we extend it on a per-rhs basis in tcExtendForRhs ; tcExtendLetEnvIds top_lvl [(idName id, id) | id <- poly_ids] $do  cactus committed Jul 29, 2014 386 387  { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds$ do { thing <- thing_inside  cactus committed Jan 20, 2015 388 389 390  -- See Note [Pattern synonym builders don't yield dependencies] ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]  cactus committed Jul 29, 2014 391  ; return (extra_binds, thing) }  eir@cis.upenn.edu committed Dec 11, 2015 392  ; return (binds' ++ extra_binds', thing) }}  cactus committed Jun 21, 2014 393  where  Simon Peyton Jones committed Mar 24, 2015 394  patsyns = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds]  Simon Peyton Jones committed Jun 24, 2014 395  patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds]  cactus committed Jul 29, 2014 396  = [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ]  Simon Peyton Jones committed Jun 24, 2014 397  placeholder_patsyn_tything  cactus committed Jul 29, 2014 398  = AGlobal $AConLike$ PatSynCon $panic "fakePatSynCon"  simonpj committed Mar 14, 1997 399   simonpj committed Jul 19, 2005 400 ------------------------  Simon Peyton Jones committed Jul 21, 2015 401 tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv  Ian Lynagh committed May 18, 2008 402 403  -> [(RecFlag, LHsBinds Name)] -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing)  simonpj committed Jul 19, 2005 404 405 -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time  406 -- Here a "strongly connected component" has the strightforward  cactus committed Nov 20, 2014 407 -- meaning of a group of bindings that mention each other,  408 -- ignoring type signatures (that part comes later)  simonpj committed Jul 19, 2005 409   simonpj@microsoft.com committed Sep 13, 2010 410 tcBindGroups _ _ _ [] thing_inside  Ian Lynagh committed May 18, 2008 411 412  = do { thing <- thing_inside ; return ([], thing) }  simonpj committed Jul 19, 2005 413   simonpj@microsoft.com committed Sep 13, 2010 414 tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside  Ian Lynagh committed May 18, 2008 415  = do { (group', (groups', thing))  cactus committed Nov 20, 2014 416  <- tc_group top_lvl sig_fn prag_fn group$  simonpj@microsoft.com committed Sep 13, 2010 417  tcBindGroups top_lvl sig_fn prag_fn groups thing_inside  Ian Lynagh committed May 18, 2008 418  ; return (group' ++ groups', thing) }  sof committed May 18, 1997 419   simonpj committed Jul 19, 2005 420 ------------------------  cactus committed Nov 20, 2014 421 tc_group :: forall thing.  Simon Peyton Jones committed Jul 21, 2015 422  TopLevelFlag -> TcSigFun -> TcPragEnv  Ian Lynagh committed May 18, 2008 423 424  -> (RecFlag, LHsBinds Name) -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing)  simonpj committed Jul 19, 2005 425 426  -- Typecheck one strongly-connected component of the original program.  cactus committed Nov 20, 2014 427 -- We get a list of groups back, because there may  simonpj committed Jul 19, 2005 428 429 -- be specialisations etc as well  simonpj@microsoft.com committed Sep 13, 2010 430 tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside  Ian Lynagh committed May 18, 2008 431 432  -- A single non-recursive binding -- We want to keep non-recursive things non-recursive  simonpj committed Jul 19, 2005 433  -- so that we desugar unlifted bindings correctly  cactus committed Jan 20, 2014 434 435  = do { let bind = case bagToList binds of [bind] -> bind  cactus committed Jan 09, 2015 436 437  [] -> panic "tc_group: empty list of binds" _ -> panic "tc_group: NonRecursive binds is not a singleton bag"  cactus committed Jan 20, 2014 438 439  ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside ; return ( [(NonRecursive, bind')], thing) }  simonpj@microsoft.com committed Sep 13, 2010 440 441  tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside  cactus committed Nov 20, 2014 442 443  = -- To maximise polymorphism, we do a new -- strongly-connected-component analysis, this time omitting  Ian Lynagh committed May 18, 2008 444  -- any references to variables with type signatures.  445  -- (This used to be optional, but isn't now.)  Simon Peyton Jones committed Dec 08, 2015 446  -- See Note [Polymorphic recursion] in HsBinds.  simonpj@microsoft.com committed Sep 13, 2010 447  do { traceTc "tc_group rec" (pprLHsBinds binds)  cactus committed Jan 20, 2014 448  ; when hasPatSyn $recursivePatSynErr binds  cactus committed Jan 09, 2015 449  ; (binds1, thing) <- go sccs  simonpj@microsoft.com committed Sep 13, 2010 450  ; return ([(Recursive, binds1)], thing) }  Ian Lynagh committed May 18, 2008 451  -- Rec them all together  simonpj committed Jul 19, 2005 452  where  cactus committed Apr 13, 2014 453  hasPatSyn = anyBag (isPatSyn . unLoc) binds  cactus committed Jan 20, 2014 454 455 456  isPatSyn PatSynBind{} = True isPatSyn _ = False  cactus committed Apr 13, 2014 457  sccs :: [SCC (LHsBind Name)]  simonpj@microsoft.com committed Sep 13, 2010 458 459  sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)  cactus committed Jan 09, 2015 460  go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)  Simon Peyton Jones committed Mar 24, 2015 461 462  go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc ; (binds2, thing) <- tcExtendLetEnv top_lvl ids1$  cactus committed Jan 09, 2015 463 464 465  go sccs ; return (binds1 unionBags binds2, thing) } go [] = do { thing <- thing_inside; return (emptyBag, thing) }  simonpj committed Jul 22, 2005 466   simonpj@microsoft.com committed Sep 13, 2010 467 468  tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds  sof committed May 18, 1997 469   simonpj@microsoft.com committed Sep 05, 2006 470  tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive  sof committed May 18, 1997 471   cactus committed Jan 20, 2014 472 473 474 475 recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a recursivePatSynErr binds = failWithTc $hang (ptext (sLit "Recursive pattern synonym definition with following bindings:"))  cactus committed Apr 13, 2014 476  2 (vcat$ map pprLBind . bagToList $binds)  cactus committed Jan 20, 2014 477 478 479 480 481 482  where pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc) pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> pprLoc loc tc_single :: forall thing.  Simon Peyton Jones committed Jul 21, 2015 483  TopLevelFlag -> TcSigFun -> TcPragEnv  cactus committed Apr 13, 2014 484  -> LHsBind Name -> TcM thing  cactus committed Jan 20, 2014 485  -> TcM (LHsBinds TcId, thing)  cactus committed Nov 20, 2014 486 tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside  Matthew Pickering committed Dec 11, 2015 487 488  = do { (aux_binds, tcg_env) <- tc_pat_syn_decl ; thing <- setGblEnv tcg_env thing_inside  cactus committed Jan 20, 2014 489 490  ; return (aux_binds, thing) }  cactus committed Nov 20, 2014 491  where  Matthew Pickering committed Dec 11, 2015 492  tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv)  cactus committed Nov 20, 2014 493  tc_pat_syn_decl = case sig_fn name of  Simon Peyton Jones committed Aug 05, 2015 494 495 496  Nothing -> tcInferPatSynDecl psb Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi Just _ -> panic "tc_single"  cactus committed Nov 20, 2014 497   cactus committed Jan 20, 2014 498 tc_single top_lvl sig_fn prag_fn lbind thing_inside  Simon Peyton Jones committed Mar 24, 2015 499 500 501 502  = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn NonRecursive NonRecursive [lbind] ; thing <- tcExtendLetEnv top_lvl ids thing_inside  cactus committed Jan 20, 2014 503  ; return (binds1, thing) }  cactus committed Nov 20, 2014 504   simonpj committed Aug 10, 2005 505 ------------------------  cactus committed Jan 09, 2015 506 type BKey = Int -- Just number off the bindings  simonpj committed Aug 10, 2005 507   Simon Peyton Jones committed Dec 08, 2015 508 509 mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)] -- See Note [Polymorphic recursion] in HsBinds.  simonpj committed Aug 10, 2005 510 mkEdges sig_fn binds  511  = [ (bind, key, [key | n <- nameSetElems (bind_fvs (unLoc bind)),  Ian Lynagh committed May 18, 2008 512  Just key <- [lookupNameEnv key_map n], no_sig n ])  simonpj committed Aug 10, 2005 513 514 515 516  | (bind, key) <- keyd_binds ] where no_sig :: Name -> Bool  thomasw committed Nov 28, 2014 517  no_sig n = noCompleteSig (sig_fn n)  simonpj committed Aug 10, 2005 518 519 520  keyd_binds = bagToList binds zip [0::BKey ..]  Ian Lynagh committed May 18, 2008 521  key_map :: NameEnv BKey -- Which binding it comes from  cactus committed Apr 13, 2014 522  key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds  cactus committed Jan 09, 2015 523  , bndr <- collectHsBindBinders bind ]  simonpj committed Mar 14, 1997 524   simonpj committed Jul 19, 2005 525 ------------------------  Simon Peyton Jones committed Jul 21, 2015 526 tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv  cactus committed Jan 09, 2015 527 528 529 530  -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> [LHsBind Name] -- None are PatSynBind  Simon Peyton Jones committed Mar 24, 2015 531  -> TcM (LHsBinds TcId, [TcId])  simonpj committed Jul 19, 2005 532   cactus committed Jan 09, 2015 533 -- Typechecks a single bunch of values bindings all together,  simonpj committed Jul 19, 2005 534 535 536 -- and generalises them. The bunch may be only part of a recursive -- group, because we use type signatures to maximise polymorphism --  simonpj committed Jul 22, 2005 537 538 -- Returns a list because the input may be a single non-recursive binding, -- in which case the dependency order of the resulting bindings is  cactus committed Nov 20, 2014 539 540 -- important. --  simonpj committed Jul 19, 2005 541 -- Knows nothing about the scope of the bindings  cactus committed Jan 09, 2015 542 -- None of the bindings are pattern synonyms  simonpj committed Jul 19, 2005 543   simonpj@microsoft.com committed Sep 13, 2010 544 545 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list = setSrcSpan loc$  cactus committed Nov 20, 2014 546  recoverM (recoveryCode binder_names sig_fn) $do  simonpj@microsoft.com committed Mar 31, 2011 547  -- Set up main recover; take advantage of any type sigs  simonpj committed Sep 30, 2004 548   Austin Seipp committed Sep 09, 2014 549  { traceTc "------------------------------------------------" Outputable.empty  Simon Peyton Jones committed May 09, 2012 550  ; traceTc "Bindings for {" (ppr binder_names)  Ian Lynagh committed Jan 19, 2012 551  ; dflags <- getDynFlags  Simon Peyton Jones committed Aug 16, 2011 552  ; type_env <- getLclTypeEnv  cactus committed Nov 20, 2014 553  ; let plan = decideGeneralisationPlan dflags type_env  Simon Peyton Jones committed Mar 02, 2012 554  binder_names bind_list sig_fn  simonpj@microsoft.com committed Sep 13, 2010 555  ; traceTc "Generalisation plan" (ppr plan)  Simon Peyton Jones committed Mar 24, 2015 556 557 558 559  ; result@(tc_binds, poly_ids) <- case plan of NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list CheckGen lbind sig -> tcPolyCheck rec_tc prag_fn sig lbind  simonpj@microsoft.com committed Sep 13, 2010 560   chak@cse.unsw.edu.au. committed Oct 31, 2011 561  -- Check whether strict bindings are ok  Ian Lynagh committed May 18, 2008 562 563  -- These must be non-recursive etc, and are not generalised -- They desugar to a case expression in the end  Simon Peyton Jones committed May 09, 2012 564 565 566 567  ; 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] ])  simonpj@microsoft.com committed Sep 13, 2010 568   Simon Peyton Jones committed Aug 16, 2011 569  ; return result }  simonpj@microsoft.com committed Sep 13, 2010 570  where  cactus committed Apr 13, 2014 571 572  binder_names = collectHsBindListBinders bind_list loc = foldr1 combineSrcSpans (map getLoc bind_list)  cactus committed Nov 20, 2014 573  -- The mbinds have been dependency analysed and  simonpj@microsoft.com committed Mar 31, 2011 574  -- may no longer be adjacent; so find the narrowest  chak@cse.unsw.edu.au. committed Oct 31, 2011 575  -- span that includes them all  simonpj@microsoft.com committed Sep 13, 2010 576   577 ------------------  Simon Peyton Jones committed Sep 17, 2012 578 tcPolyNoGen -- No generalisation whatsoever  Simon Peyton Jones committed Sep 10, 2013 579  :: RecFlag -- Whether it's recursive after breaking  simonpj@microsoft.com committed Sep 13, 2010 580  -- dependencies based on type signatures  Simon Peyton Jones committed Jul 21, 2015 581  -> TcPragEnv -> TcSigFun  cactus committed Apr 13, 2014 582  -> [LHsBind Name]  Simon Peyton Jones committed Mar 24, 2015 583  -> TcM (LHsBinds TcId, [TcId])  simonpj@microsoft.com committed Sep 13, 2010 584   Simon Peyton Jones committed Sep 10, 2013 585 586 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn  cactus committed Nov 20, 2014 587  (LetGblBndr prag_fn)  Simon Peyton Jones committed Sep 17, 2012 588  bind_list  simonpj@microsoft.com committed Sep 13, 2010 589  ; mono_ids' <- mapM tc_mono_info mono_infos  Simon Peyton Jones committed Mar 24, 2015 590  ; return (binds', mono_ids') }  simonpj@microsoft.com committed Sep 13, 2010 591 592  where tc_mono_info (name, _, mono_id)  Simon Peyton Jones committed Feb 16, 2012 593  = do { mono_ty' <- zonkTcType (idType mono_id)  chak@cse.unsw.edu.au. committed Oct 31, 2011 594  -- Zonk, mainly to expose unboxed types to checkStrictBinds  simonpj@microsoft.com committed Sep 13, 2010 595  ; let mono_id' = setIdType mono_id mono_ty'  Simon Peyton Jones committed Jul 21, 2015 596  ; _specs <- tcSpecPrags mono_id' (lookupPragEnv prag_fn name)  597  ; return mono_id' }  chak@cse.unsw.edu.au. committed Oct 31, 2011 598 599 600 601  -- 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  simonpj@microsoft.com committed Sep 13, 2010 602 603  ------------------  Simon Peyton Jones committed Sep 10, 2013 604 tcPolyCheck :: RecFlag -- Whether it's recursive after breaking  chak@cse.unsw.edu.au. committed Oct 31, 2011 605  -- dependencies based on type signatures  Simon Peyton Jones committed Jul 21, 2015 606  -> TcPragEnv  Simon Peyton Jones committed Aug 05, 2015 607  -> TcIdSigInfo  cactus committed Apr 13, 2014 608  -> LHsBind Name  Simon Peyton Jones committed Mar 24, 2015 609  -> TcM (LHsBinds TcId, [TcId])  cactus committed Nov 20, 2014 610 -- There is just one binding,  simonpj@microsoft.com committed Sep 13, 2010 611 -- it binds a single variable,  Simon Peyton Jones committed Feb 19, 2015 612 -- it has a complete type signature,  Simon Peyton Jones committed Sep 10, 2013 613 tcPolyCheck rec_tc prag_fn  Simon Peyton Jones committed Aug 05, 2015 614  sig@(TISI { sig_bndr = CompleteSig poly_id  Simon Peyton Jones committed Dec 01, 2015 615  , sig_skols = skol_prs  Simon Peyton Jones committed Aug 05, 2015 616 617 618 619  , sig_theta = theta , sig_tau = tau , sig_ctxt = ctxt , sig_loc = loc })  cactus committed Apr 13, 2014 620  bind  Simon Peyton Jones committed Aug 05, 2015 621 622  = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol ctxt (mkPhiTy theta tau)  Simon Peyton Jones committed Jul 21, 2015 623  prag_sigs = lookupPragEnv prag_fn name  Simon Peyton Jones committed Dec 01, 2015 624  skol_tvs = map snd skol_prs  Simon Peyton Jones committed Aug 05, 2015 625 626 627 628  -- Find the location of the original source type sig, if -- there is was one. This will appear in messages like -- "type variable x is bound by .. at " name = idName poly_id  cactus committed Nov 20, 2014 629 630  ; (ev_binds, (binds', [mono_info])) <- setSrcSpan loc$  Simon Peyton Jones committed Dec 01, 2015 631  checkConstraints skol_info skol_tvs ev_vars $ Simon Peyton Jones committed Aug 05, 2015 632  tcMonoBinds rec_tc (\_ -> Just (TcIdSig sig)) LetLclBndr [bind]  simonpj@microsoft.com committed Sep 13, 2010 633   Simon Peyton Jones committed Aug 16, 2011 634 635  ; spec_prags <- tcSpecPrags poly_id prag_sigs ; poly_id <- addInlinePrags poly_id prag_sigs  simonpj@microsoft.com committed Sep 13, 2010 636   Simon Peyton Jones committed Aug 16, 2011 637 638 639 640 641  ; let (_, _, mono_id) = mono_info export = ABE { abe_wrap = idHsWrapper , abe_poly = poly_id , abe_mono = mono_id , abe_prags = SpecPrags spec_prags }  cactus committed Nov 20, 2014 642  abs_bind = L loc$ AbsBinds  Simon Peyton Jones committed Dec 01, 2015 643  { abs_tvs = skol_tvs  Simon Peyton Jones committed Jan 06, 2015 644  , abs_ev_vars = ev_vars, abs_ev_binds = [ev_binds]  simonpj@microsoft.com committed Sep 13, 2010 645  , abs_exports = [export], abs_binds = binds' }  Simon Peyton Jones committed Mar 24, 2015 646  ; return (unitBag abs_bind, [poly_id]) }  simonpj@microsoft.com committed Sep 13, 2010 647   cactus committed Nov 20, 2014 648 649 650 tcPolyCheck _rec_tc _prag_fn sig _bind = pprPanic "tcPolyCheck" (ppr sig)  651 ------------------  cactus committed Nov 20, 2014 652 tcPolyInfer  Simon Peyton Jones committed Sep 10, 2013 653  :: RecFlag -- Whether it's recursive after breaking  simonpj@microsoft.com committed Sep 13, 2010 654  -- dependencies based on type signatures  Simon Peyton Jones committed Jul 21, 2015 655  -> TcPragEnv -> TcSigFun  Simon Peyton Jones committed Sep 17, 2012 656  -> Bool -- True <=> apply the monomorphism restriction  cactus committed Apr 13, 2014 657  -> [LHsBind Name]  Simon Peyton Jones committed Mar 24, 2015 658 659  -> TcM (LHsBinds TcId, [TcId]) tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list  Simon Peyton Jones committed Dec 01, 2015 660  = do { (tclvl, wanted, (binds', mono_infos))  Simon Peyton Jones committed Jan 06, 2015 661  <- pushLevelAndCaptureConstraints $ Simon Peyton Jones committed Sep 10, 2013 662  tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list  simonpj@microsoft.com committed Sep 13, 2010 663   simonpj@microsoft.com committed Jan 12, 2011 664  ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]  Simon Peyton Jones committed Dec 01, 2015 665 666  sigs = [ sig | (_, Just sig, _) <- mono_infos ] ; traceTc "simplifyInfer call" (ppr tclvl $$ppr name_taus$$ ppr wanted)  Simon Peyton Jones committed Oct 12, 2015 667  ; (qtvs, givens, ev_binds)  Simon Peyton Jones committed Dec 01, 2015 668  <- simplifyInfer tclvl mono sigs name_taus wanted  simonpj@microsoft.com committed Sep 13, 2010 669   Simon Peyton Jones committed Feb 13, 2015 670  ; let inferred_theta = map evVarPred givens  Simon Peyton Jones committed Mar 24, 2015 671 672  ; exports <- checkNoErrs$ mapM (mkExport prag_fn qtvs inferred_theta) mono_infos  thomasw committed Nov 28, 2014 673   simonpj@microsoft.com committed Sep 13, 2010 674  ; loc <- getSrcSpanM  Simon Peyton Jones committed Aug 16, 2011 675  ; let poly_ids = map abe_poly exports  cactus committed Nov 20, 2014 676  abs_bind = L loc $ Simon Peyton Jones committed Aug 16, 2011 677  AbsBinds { abs_tvs = qtvs  Simon Peyton Jones committed Jan 06, 2015 678  , abs_ev_vars = givens, abs_ev_binds = [ev_binds]  Simon Peyton Jones committed Aug 16, 2011 679  , abs_exports = exports, abs_binds = binds' }  simonpj@microsoft.com committed Sep 13, 2010 680   Simon Peyton Jones committed Mar 24, 2015 681 682  ; traceTc "Binding:" (ppr (poly_ids zip map idType poly_ids)) ; return (unitBag abs_bind, poly_ids) }  Simon Peyton Jones committed Aug 16, 2011 683  -- poly_ids are guaranteed zonked by mkExport  simonpj committed Jul 19, 2005 684 685  --------------  Simon Peyton Jones committed Jul 21, 2015 686 mkExport :: TcPragEnv  chak@cse.unsw.edu.au. committed Oct 31, 2011 687  -> [TyVar] -> TcThetaType -- Both already zonked  Ian Lynagh committed May 18, 2008 688  -> MonoBindInfo  Simon Peyton Jones committed Aug 16, 2011 689  -> TcM (ABExport Id)  Simon Peyton Jones committed Oct 03, 2013 690 691 692 693 -- Only called for generalisation plan IferGen, not by CheckGen or NoGen -- -- mkExport generates exports with -- zonked type variables,  Ian Lynagh committed May 18, 2008 694 -- zonked poly_ids  simonpj@microsoft.com committed Sep 18, 2006 695 696 697 698 -- 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  Simon Peyton Jones committed Oct 03, 2013 699 -- type environment; see the invariant on TcEnv.tcExtendIdEnv  simonpj@microsoft.com committed Sep 18, 2006 700   Simon Peyton Jones committed Aug 16, 2011 701 -- Pre-condition: the qtvs and theta are already zonked  simonpj@microsoft.com committed Sep 18, 2006 702   Simon Peyton Jones committed Dec 01, 2015 703 704 705 mkExport prag_fn qtvs theta mono_info@(poly_name, mb_sig, mono_id) = do { mono_ty <- zonkTcType (idType mono_id) ; poly_id <- case mb_sig of  Simon Peyton Jones committed Aug 05, 2015 706  Just sig | Just poly_id <- completeIdSigPolyId_maybe sig  Simon Peyton Jones committed Dec 01, 2015 707 708 709 710  -> return poly_id _other -> checkNoErrs$ mkInferredPolyId qtvs theta poly_name mb_sig mono_ty  Simon Peyton Jones committed Dec 04, 2015 711  -- The checkNoErrs ensures that if the type is ambiguous  Simon Peyton Jones committed Dec 01, 2015 712 713 714  -- we don't carry on to the impedence matching, and generate -- a duplicate ambiguity error. There is a similar -- checkNoErrs for complete type signatures too.  Simon Peyton Jones committed Jun 11, 2014 715 716  -- NB: poly_id has a zonked type  Simon Peyton Jones committed Aug 16, 2011 717  ; poly_id <- addInlinePrags poly_id prag_sigs  simonpj@microsoft.com committed Oct 07, 2010 718  ; spec_prags <- tcSpecPrags poly_id prag_sigs  Ian Lynagh committed May 18, 2008 719  -- tcPrags requires a zonked poly_id  simonpj@microsoft.com committed Sep 18, 2006 720   721  -- See Note [Impedence matching]  Simon Peyton Jones committed Dec 04, 2015 722 723  -- NB: we have already done checkValidType, including an ambiguity check, -- on the type; either when we checked the sig or in mkInferredPolyId  eir@cis.upenn.edu committed Dec 11, 2015 724  ; let sel_poly_ty = mkInvSigmaTy qtvs theta mono_ty  Simon Peyton Jones committed Dec 01, 2015 725 726 727 728 729 730 731  poly_ty = idType poly_id ; wrap <- if sel_poly_ty eqType poly_ty then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguouse type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $tcSubType_NC sig_ctxt sel_poly_ty poly_ty  Eric Seidel committed Dec 07, 2015 732 733 734 735  ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs ; when warn_missing_sigs$ localSigWarn poly_id mb_sig  Simon Peyton Jones committed Dec 01, 2015 736 737  ; return (ABE { abe_wrap = wrap -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)  Simon Peyton Jones committed Aug 16, 2011 738 739  , abe_poly = poly_id , abe_mono = mono_id  Simon Peyton Jones committed Mar 24, 2015 740  , abe_prags = SpecPrags spec_prags}) }  simonpj@microsoft.com committed Sep 18, 2006 741  where  Simon Peyton Jones committed Jul 21, 2015 742  prag_sigs = lookupPragEnv prag_fn poly_name  Simon Peyton Jones committed Aug 16, 2011 743  sig_ctxt = InfSigCtxt poly_name  Simon Peyton Jones committed Jun 11, 2014 744   Simon Peyton Jones committed Dec 01, 2015 745 746 747 748 mkInferredPolyId :: [TyVar] -> TcThetaType -> Name -> Maybe TcIdSigInfo -> TcType -> TcM TcId mkInferredPolyId qtvs inferred_theta poly_name mb_sig mono_ty  Simon Peyton Jones committed Nov 04, 2014 749  = do { fam_envs <- tcGetFamInstEnvs  Simon Peyton Jones committed Dec 01, 2015 750  ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty  Simon Peyton Jones committed Nov 06, 2014 751 752  -- Unification may not have normalised the type, -- (see Note [Lazy flattening] in TcFlatten) so do it  Simon Peyton Jones committed Nov 04, 2014 753 754 755  -- here to make it as uncomplicated as possible. -- Example: f :: [F Int] -> Bool -- should be rewritten to f :: [Char] -> Bool, if possible  Simon Peyton Jones committed Dec 01, 2015 756  --  Gabor Greif committed Dec 09, 2015 757  -- We can discard the coercion _co, because we'll reconstruct  Simon Peyton Jones committed Dec 01, 2015 758  -- it in the call to tcSubType below  Simon Peyton Jones committed Nov 06, 2014 759   Simon Peyton Jones committed Dec 01, 2015 760  ; (my_tvs, theta') <- chooseInferredQuantifiers  eir@cis.upenn.edu committed Dec 11, 2015 761  inferred_theta (tyCoVarsOfType mono_ty') mb_sig  Simon Peyton Jones committed Apr 30, 2015 762   Simon Peyton Jones committed Dec 01, 2015 763  ; let qtvs' = filter (elemVarSet my_tvs) qtvs -- Maintain original order  eir@cis.upenn.edu committed Dec 11, 2015 764  inferred_poly_ty = mkInvSigmaTy qtvs' theta' mono_ty'  Simon Peyton Jones committed Nov 04, 2014 765   Simon Peyton Jones committed Dec 04, 2015 766 767 768  ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr my_tvs, ppr theta' , ppr inferred_poly_ty]) ; addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ Simon Peyton Jones committed Nov 04, 2014 769  checkValidType (InfSigCtxt poly_name) inferred_poly_ty  Simon Peyton Jones committed Dec 04, 2015 770  -- See Note [Validity of inferred types]  Simon Peyton Jones committed Nov 21, 2014 771   eir@cis.upenn.edu committed Dec 11, 2015 772  ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }  Simon Peyton Jones committed Jun 11, 2014 773   Simon Peyton Jones committed Dec 01, 2015 774 775 776 777 778 779  chooseInferredQuantifiers :: TcThetaType -> TcTyVarSet -> Maybe TcIdSigInfo -> TcM (TcTyVarSet, TcThetaType) chooseInferredQuantifiers inferred_theta tau_tvs Nothing = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) -- Include kind variables! Trac #7916  eir@cis.upenn.edu committed Dec 11, 2015 780  my_theta = pickQuantifiablePreds free_tvs inferred_theta  Simon Peyton Jones committed Dec 01, 2015 781 782 783 784 785 786 787 788  ; return (free_tvs, my_theta) } chooseInferredQuantifiers inferred_theta tau_tvs (Just (TISI { sig_bndr = bndr_info , sig_ctxt = ctxt , sig_theta = annotated_theta })) | PartialSig { sig_cts = extra } <- bndr_info , Nothing <- extra  eir@cis.upenn.edu committed Dec 11, 2015 789 790  = do { annotated_theta <- zonkTcTypes annotated_theta ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta  Simon Peyton Jones committed Dec 01, 2015 791 792 793 794 795 796  unionVarSet tau_tvs) ; traceTc "ciq" (vcat [ ppr bndr_info, ppr annotated_theta, ppr free_tvs]) ; return (free_tvs, annotated_theta) } | PartialSig { sig_cts = extra } <- bndr_info , Just loc <- extra  eir@cis.upenn.edu committed Dec 11, 2015 797 798  = do { annotated_theta <- zonkTcTypes annotated_theta ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta  Simon Peyton Jones committed Dec 01, 2015 799  unionVarSet tau_tvs)  eir@cis.upenn.edu committed Dec 11, 2015 800  my_theta = pickQuantifiablePreds free_tvs inferred_theta  Simon Peyton Jones committed Dec 01, 2015 801 802 803 804 805  -- Report the inferred constraints for an extra-constraints wildcard/hole as -- an error message, unless the PartialTypeSignatures flag is enabled. In this -- case, the extra inferred constraints are accepted without complaining. -- Returns the annotated constraints combined with the inferred constraints.  eir@cis.upenn.edu committed Dec 11, 2015 806 807 808  inferred_diff = [ pred | pred <- my_theta , all (not . (eqType pred)) annotated_theta ]  thomasw committed Nov 28, 2014 809  final_theta = annotated_theta ++ inferred_diff  Ben Gamari committed Dec 15, 2015 810  ; partial_sigs <- xoptM LangExt.PartialTypeSignatures  thomasw committed Nov 28, 2014 811 812  ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty  Simon Peyton Jones committed Dec 01, 2015 813 814 815 816  ; traceTc "completeTheta"$ vcat [ ppr bndr_info , ppr annotated_theta, ppr inferred_theta , ppr inferred_diff ]  thomasw committed Nov 28, 2014 817  ; case partial_sigs of  Simon Peyton Jones committed Jan 09, 2015 818  True | warn_partial_sigs -> reportWarning msg  thomasw committed Nov 28, 2014 819 820 821  | otherwise -> return () False -> reportError msg  Simon Peyton Jones committed Dec 01, 2015 822 823 824 825  ; return (free_tvs, final_theta) } | otherwise = pprPanic "chooseInferredQuantifiers" (ppr bndr_info)  thomasw committed Nov 28, 2014 826 827 828  where pts_hint = text "To use the inferred type, enable PartialTypeSignatures" mk_msg inferred_diff suppress_hint  Simon Peyton Jones committed Dec 01, 2015 829 830  = vcat [ hang ((text "Found constraint wildcard") <+> quotes (char '_')) 2 (text "standing for") <+> quotes (pprTheta inferred_diff)  thomasw committed Nov 28, 2014 831  , if suppress_hint then empty else pts_hint  Simon Peyton Jones committed Dec 01, 2015 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859  , typeSigCtxt ctxt bndr_info ] mk_impedence_match_msg :: MonoBindInfo -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) -- This is a rare but rather awkward error messages mk_impedence_match_msg (name, mb_sig, _) inf_ty sig_ty tidy_env = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty ; let msg = vcat [ ptext (sLit "When checking that the inferred type") , nest 2 $ppr name <+> dcolon <+> ppr inf_ty , ptext (sLit "is as general as its") <+> what <+> ptext (sLit "signature") , nest 2$ ppr name <+> dcolon <+> ppr sig_ty ] ; return (tidy_env2, msg) } where what = case mb_sig of Nothing -> ptext (sLit "inferred") Just sig | isPartialSig sig -> ptext (sLit "(partial)") | otherwise -> empty mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_inf_msg poly_name poly_ty tidy_env = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty ; let msg = vcat [ ptext (sLit "When checking the inferred type") , nest 2 $ppr poly_name <+> dcolon <+> ppr poly_ty ] ; return (tidy_env1, msg) }  simonpj committed Jul 19, 2005 860   Eric Seidel committed Dec 07, 2015 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878  -- | Warn the user about polymorphic local binders that lack type signatures. localSigWarn :: Id -> Maybe TcIdSigInfo -> TcM () localSigWarn id mb_sig | Just _ <- mb_sig = return () | not (isSigmaTy (idType id)) = return () | otherwise = warnMissingSig msg id where msg = ptext (sLit "Polymorphic local binding with no type signature:") warnMissingSig :: SDoc -> Id -> TcM () warnMissingSig msg id = do { env0 <- tcInitTidyEnv ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) ; addWarnTcM (env1, mk_msg tidy_ty) } where mk_msg ty = sep [ msg, nest 2$ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]  Austin Seipp committed Dec 03, 2014 879 {-  Simon Peyton Jones committed Jan 06, 2015 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 Note [Partial type signatures and generalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we have a partial type signature, like f :: _ -> Int then we *always* use the InferGen plan, and hence tcPolyInfer. We do this even for a local binding with -XMonoLocalBinds. Reasons: * The TcSigInfo for 'f' has a unification variable for the '_', whose TcLevel is one level deeper than the current level. (See pushTcLevelM in tcTySig.) But NoGen doesn't increase the TcLevel like InferGen, so we lose the level invariant. * The signature might be f :: forall a. _ -> a so it really is polymorphic. It's not clear what it would mean to use NoGen on this, and indeed the ASSERT in tcLhs, in the (Just sig) case, checks that if there is a signature then we are using LetLclBndr, and hence a nested AbsBinds with increased TcLevel It might be possible to fix these difficulties somehow, but there doesn't seem much point. Indeed, adding a partial type signature is a way to get per-binding inferred generalisation.  Simon Peyton Jones committed Jun 11, 2014 903 904 Note [Validity of inferred types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  cactus committed Nov 20, 2014 905 We need to check inferred type for validity, in case it uses language  Simon Peyton Jones committed Jun 11, 2014 906 907 908 909 910 extensions that are not turned on. The principle is that if the user simply adds the inferred type to the program source, it'll compile fine. See #8883. Examples that might fail:  Simon Peyton Jones committed Dec 04, 2015 911 912  - the type might be ambiguous  Simon Peyton Jones committed Jun 11, 2014 913 914 915 916 917  - an inferred theta that requires type equalities e.g. (F a ~ G b) or multi-parameter type classes - an inferred type that includes unboxed tuples  918 919 920 921 922 923 924 925 926 927 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  cactus committed Nov 20, 2014 928 929  f_mono_ty :: a -> Bool -> Bool g_mono_ty :: [b] -> Bool -> Bool  930 931 932 933 934 935 936 937 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  Gabor Greif committed Jun 03, 2015 938 We can get these by "impedance matching":  939 940 941 942 943 944 945  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.  cactus committed Nov 20, 2014 946 Then we want to check that  Simon Peyton Jones committed Dec 01, 2015 947 948  f's final inferred polytype is more polymorphic than forall qtvs. theta => f_mono_ty  Gabor Greif committed Jun 03, 2015 949 and the proof is the impedance matcher.  950   Gabor Greif committed Jun 03, 2015 951 Notice that the impedance matcher may do defaulting. See Trac #7173.  952 953 954 955  It also cleverly does an ambiguity check; for example, rejecting f :: F a -> a where F is a non-injective type function.  Austin Seipp committed Dec 03, 2014 956 -}  957   Simon Peyton Jones committed Jan 14, 2015 958 959 960 961 -------------- -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages  Simon Peyton Jones committed Mar 24, 2015 962 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])  Simon Peyton Jones committed Jan 14, 2015 963 964 recoveryCode binder_names sig_fn = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)  thomasw committed Feb 18, 2015 965  ; let poly_ids = map mk_dummy binder_names  Simon Peyton Jones committed Mar 24, 2015 966  ; return (emptyBag, poly_ids) }  Simon Peyton Jones committed Jan 14, 2015 967 968  where mk_dummy name  Simon Peyton Jones committed Aug 05, 2015 969 970  | Just sig <- sig_fn name , Just poly_id <- completeSigPolyId_maybe sig  thomasw committed Feb 18, 2015 971 972 973  = poly_id | otherwise = mkLocalId name forall_a_a  Simon Peyton Jones committed Jan 14, 2015 974 975  forall_a_a :: TcType  eir@cis.upenn.edu committed Dec 11, 2015 976 forall_a_a = mkInvForAllTys [levity1TyVar, openAlphaTyVar] openAlphaTy  Simon Peyton Jones committed Jan 14, 2015 977 978 979 980 981 982 983 984 985 986 987 988 989 990  {- ********************************************************************* * * Pragmas, including SPECIALISE * * ************************************************************************ Note [Handling SPECIALISE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The basic idea is this: f:: Num a => a -> b -> a {-# SPECIALISE foo :: Int -> b -> Int #-}