Merge branch 'master' of http://darcs.haskell.org//ghc
authorSimon Peyton Jones <simonpj@microsoft.com>
Sat, 24 Mar 2012 22:25:56 +0000 (22:25 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Sat, 24 Mar 2012 22:25:56 +0000 (22:25 +0000)
Conflicts:
compiler/main/HscStats.lhs

1  2 
compiler/deSugar/DsMeta.hs
compiler/hsSyn/HsUtils.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs

@@@ -184,12 -184,12 +184,11 @@@ repTyClD (L loc (TyFamily { tcdFlavour 
    = do { tc1 <- lookupLOcc tc                 -- See note [Binders and occurrences] 
         ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
             do { flav   <- repFamilyFlavour flavour
--            ; bndrs1 <- coreList tyVarBndrTyConName bndrs
--              ; case opt_kind of 
--                  Nothing -> repFamilyNoKind flav tc1 bndrs1
++            ; case opt_kind of 
++                  Nothing -> repFamilyNoKind flav tc1 bndrs
                    Just (HsBSig ki _) 
                      -> do { ki1 <- repKind ki 
--                          ; repFamilyKind flav tc1 bndrs1 ki1 }
++                          ; repFamilyKind flav tc1 bndrs ki1 }
                }
         ; return $ Just (loc, dec)
         }
@@@ -293,27 -314,14 +292,14 @@@ repFamilyFlavour :: FamilyFlavour -> Ds
  repFamilyFlavour TypeFamily = rep2 typeFamName []
  repFamilyFlavour DataFamily = rep2 dataFamName []
  
- -- represent associated family declarations
- --
- repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
- repLAssocFamilys = mapM repLAssocFamily
-   where
-     repLAssocFamily tydecl@(L _ (TyFamily {})) 
-       = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
-     repLAssocFamily tydecl
-       = failWithDs msg
-       where
-         msg = ptext (sLit "Illegal associated declaration in class:") <+> 
-               ppr tydecl
 --- represent instance declarations
 +-- Represent instance declarations
  --
 -repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 -repInstD (L loc (FamInstDecl fi_decl))
 -  = repTyClD (L loc fi_decl)
 -
 +repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
 +repInstD (L loc (FamInstD fi_decl))
 +  = do { dec <- repFamInstD fi_decl
 +       ; return (loc, dec) }
  
 -repInstD (L loc (ClsInstDecl ty binds prags ats))
 +repInstD (L loc (ClsInstD ty binds prags ats))
    = do { dec <- addTyVarBinds tvs $ \_ ->
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't 
   where
     Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
  
-        ; addTyVarBinds hs_tvs $ \ bndrs ->
 +repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
 +repFamInstD (FamInstDecl { fid_tycon = tc_name, fid_pats = HsBSig tys tv_names, fid_defn = defn })
 +  = do { tc <- lookupLOcc tc_name             -- See note [Binders and occurrences]  
 +       ; let loc = getLoc tc_name
 +             hs_tvs = [ L loc (UserTyVar n) | n <- tv_names]   -- Yuk
++       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
 +         do { tys1 <- repLTys tys
 +            ; tys2 <- coreList typeQTyConName tys1
 +            ; repTyDefn tc bndrs (Just tys2) tv_names defn } }
 +
  repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
  repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
   = do MkC name' <- lookupLOcc name
@@@ -586,20 -585,20 +572,13 @@@ rep_InlinePrag (InlinePragma { inl_act 
  --                    Types
  -------------------------------------------------------
  
---- We process type variable bindings in two ways, either by generating fresh
---- names or looking up existing names.  The difference is crucial for type
---- families, depending on whether they are associated or not.
----
--type ProcessTyVarBinds a = 
--         [LHsTyVarBndr Name]                         -- the binders to be added
-       -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
 -      -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
--      -> DsM (Core (TH.Q a))
--
++addTyVarBinds :: [LHsTyVarBndr Name]                         -- the binders to be added
++              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
++              -> DsM (Core (TH.Q a))
  -- gensym a list of type variables and enter them into the meta environment;
  -- the computations passed as the second argument is executed in that extended
  -- meta environment and gets the *new* names on Core-level as an argument
----
--addTyVarBinds :: ProcessTyVarBinds a
++
  addTyVarBinds tvs m
    = do { freshNames <- mkGenSyms (hsLTyVarNames tvs)
         ; term <- addBinds freshNames $ 
    where
      mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
  
- addTyClTyVarBinds :: ProcessTyVarBinds a
++addTyClTyVarBinds :: [LHsTyVarBndr Name]
++                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
++                  -> DsM (Core (TH.Q a))
 -addTyClTyVarBinds :: ProcessTyVarBinds a
  -- Used for data/newtype declarations, and family instances,
  -- so that the nested type variables work right
  --    instance C (T a) where
@@@ -624,12 -623,12 +606,14 @@@ addTyClTyVarBinds tvs 
              -- This makes things work for family declarations
  
         ; term <- addBinds freshNames $ 
--               do { kindedBndrs <- mapM mk_tv_bndr tvs
--                  ; m kindedBndrs }
++               do { kbs1 <- mapM mk_tv_bndr tvs
++                    ; kbs2 <- coreList tyVarBndrTyConName kbs1
++                  ; m kbs2 }
  
         ; wrapGenSyms freshNames term }
    where
--    mk_tv_bndr tv = do { v <- lookupOcc (hsLTyVarName tv); repTyVarBndrWithKind tv v }
++    mk_tv_bndr tv = do { v <- lookupOcc (hsLTyVarName tv)
++                       ; repTyVarBndrWithKind tv v }
  
  -- Produce kinded binder constructors from the Haskell tyvar binders
  --
@@@ -265,12 -266,9 +265,13 @@@ unqualQuasiQuote = mkRdrUnqual (mkVarOc
  mkHsString :: String -> HsLit
  mkHsString s = HsString (mkFastString s)
  
 +mkHsBSig :: a -> HsBndrSig a
 +mkHsBSig x = HsBSig x placeHolderBndrs
 +
  -------------
--userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
--userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
++userHsTyVarBndrs :: SrcSpan -> [Located name] -> [Located (HsTyVarBndr name)]
++-- Caller sets location
++userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | L _ v <- bndrs ]
  \end{code}
  
  
@@@ -1048,7 -1018,7 +1048,7 @@@ rnConDecls = mapFvRn (wrapLocFstM rnCon
  
  rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
  rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
-                       , con_cxt = lcxt@(L _ cxt), con_details = details
 -                      , con_cxt = cxt, con_details = details
++                      , con_cxt = lcxt@(L loc cxt), con_details = details
                        , con_res = res_ty, con_doc = mb_doc
                        , con_old_rec = old_rec, con_explicit = expl })
    = do        { addLocM checkConName name
           -- With an Explicit forall, check for unused binders
         -- With Implicit, find the mentioned ones, and use them as binders
        ; new_tvs <- case expl of
--                     Implicit -> return (userHsTyVarBndrs mentioned_tvs)
++                     Implicit -> return (userHsTyVarBndrs loc mentioned_tvs)
                       Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs
                                        ; return tvs }
  
@@@ -121,7 -121,7 +121,7 @@@ rnHsKind = rnHsTyKi Fals
  
  rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
  
- rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) 
 -rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) 
++rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L loc ctxt) ty) 
    = ASSERT ( isType ) do
        -- Implicit quantifiction in source code (no kinds on tyvars)
        -- Given the signature  C => T  we universally quantify 
        -- class signatures:
        --      class C a where { op :: a -> a }
        forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
--      tyvar_bndrs   = userHsTyVarBndrs forall_tyvars
++      tyvar_bndrs   = userHsTyVarBndrs loc forall_tyvars
  
 -    rnForAll doc Implicit tyvar_bndrs ctxt ty
 +    rnForAll doc Implicit tyvar_bndrs lctxt ty
  
 -rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau)
 +rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau)
    = ASSERT ( isType ) do {    -- Explicit quantification.
           -- Check that the forall'd tyvars are actually 
         -- mentioned in the type, and produce a warning if not