Better treatment of signatures in cls/inst
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 30 Jul 2015 14:06:55 +0000 (15:06 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 30 Jul 2015 14:35:22 +0000 (15:35 +0100)
The provoking cause for this patch is Trac #5001, comment:23.  There
was an INLINE pragma in an instance decl, that shouldn't be there.
But there was no complaint, just a  mysterious WARN later.

I ended up having to do some real refactoring but the result is,
I think, simpler and more robust.

14 files changed:
compiler/rename/RnBinds.hs
compiler/rename/RnEnv.hs
compiler/rename/RnSource.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcDeriv.hs
testsuite/tests/module/mod48.stderr
testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.hs
testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.stderr
testsuite/tests/patsyn/should_fail/T9705-1.stderr
testsuite/tests/patsyn/should_fail/T9705-2.stderr
testsuite/tests/rename/should_fail/T5001.hs [new file with mode: 0644]
testsuite/tests/rename/should_fail/T5001.stderr [new file with mode: 0644]
testsuite/tests/rename/should_fail/all.T
testsuite/tests/typecheck/should_fail/tcfail021.stderr

index aa39b59..ceef7c9 100644 (file)
@@ -45,6 +45,7 @@ import ListSetOps       ( findDupsEq )
 import BasicTypes       ( RecFlag(..) )
 import Digraph          ( SCC(..) )
 import Bag
+import Util
 import Outputable
 import FastString
 import Data.List        ( partition, sort )
@@ -702,13 +703,17 @@ in many ways the @op@ in an instance decl is just like an occurrence, not
 a binder.
 -}
 
-rnMethodBinds :: Name                   -- Class name
-              -> (Name -> [Name])       -- Signature tyvar function
-              -> LHsBinds RdrName
-              -> RnM (LHsBinds Name, FreeVars)
-
-rnMethodBinds cls sig_fn binds
-  = do { checkDupRdrNames meth_names
+rnMethodBinds :: Bool                   -- True <=> is a class declaration
+              -> Name                   -- Class name
+              -> [Name]                 -- Type variables from the class/instance header
+              -> LHsBinds RdrName       -- Binds
+              -> [LSig RdrName]         -- and signatures/pragmas
+              -> RnM (LHsBinds Name, [LSig Name], FreeVars)
+-- Used for
+--   * the default method bindings in a class decl
+--   * the method bindings in an instance decl
+rnMethodBinds is_cls_decl cls ktv_names binds sigs
+  = do { checkDupRdrNames (collectMethodBinders binds)
              -- Check that the same method is not given twice in the
              -- same instance decl      instance C T where
              --                       f x = ...
@@ -719,49 +724,70 @@ rnMethodBinds cls sig_fn binds
              -- points to the class declaration; and we use rnMethodBinds
              -- for instance decls too
 
-       ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
+       -- Rename the bindings LHSs
+       ; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds
+
+       -- Rename the pragmas and signatures
+       -- Annoyingly the type variables *are* in scope for signatures, but
+       -- *are not* in scope in the SPECIALISE instance pramas; e.g.
+       --    instance Eq a => Eq (T a) where
+       --       (==) :: a -> a -> a
+       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
+       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs
+             bound_nms = mkNameSet (collectHsBindsBinders binds')
+             sig_ctxt | is_cls_decl = ClsDeclCtxt cls
+                      | otherwise   = InstDeclCtxt bound_nms
+       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags
+       ; (other_sigs',      sig_fvs) <- extendTyVarEnvFVRn ktv_names $
+                                        renameSigs sig_ctxt other_sigs
+
+       -- Rename the bindings RHSs.  Again there's an issue about whether the
+       -- type variables from the class/instance head are in scope.
+       -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables
+       ; scoped_tvs  <- xoptM Opt_ScopedTypeVariables
+       ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $
+              do { binds_w_dus <- mapBagM (rnLBind (mkSigTvFn other_sigs')) binds'
+                 ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)
+                                           emptyFVs binds_w_dus
+                 ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
+
+       ; return ( binds'', spec_inst_prags' ++ other_sigs'
+                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }
   where
-    meth_names  = collectMethodBinders binds
-    do_one (binds,fvs) bind
-       = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
-            ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
-
-rnMethodBind :: Name
-              -> (Name -> [Name])
-              -> LHsBindLR RdrName RdrName
-              -> RnM (Bag (LHsBindLR Name Name), FreeVars)
-rnMethodBind cls sig_fn
-             (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix
-                                  , fun_matches = MG { mg_alts = matches
-                                                     , mg_origin = origin } }))
+    -- For the method bindings in class and instance decls, we extend
+    -- the type variable environment iff -XScopedTypeVariables
+    maybe_extend_tyvar_env scoped_tvs thing_inside
+       | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside
+       | otherwise  = thing_inside
+
+rnMethodBindLHS :: Bool -> Name
+                -> LHsBindLR RdrName RdrName
+                -> LHsBindsLR Name RdrName
+                -> RnM (LHsBindsLR Name RdrName)
+rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest
   = setSrcSpan loc $ do
-    sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name
-    let plain_name = unLoc sel_name
-        -- We use the selector name as the binder
-
-    (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-                          mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr)
-                                           matches
-    let new_group = mkMatchGroupName origin new_matches
-
-    when is_infix $ checkPrecMatch plain_name new_group
-    return (unitBag (L loc (bind { fun_id      = sel_name
-                                 , fun_matches = new_group
-                                 , bind_fvs    = fvs })),
-             fvs `addOneFV` plain_name)
-        -- The 'fvs' field isn't used for method binds
-
--- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind _ _ (L loc bind@(PatBind {})) = do
-    addErrAt loc (methodBindErr bind)
-    return (emptyBag, emptyFVs)
-
--- Associated pattern synonyms are not implemented yet
-rnMethodBind _ _ (L loc bind@(PatSynBind {})) = do
-    addErrAt loc $ methodPatSynErr bind
-    return (emptyBag, emptyFVs)
-
-rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b)
+    do { sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name
+                     -- We use the selector name as the binder
+       ; let bind' = bind { fun_id = sel_name
+                          , bind_fvs = placeHolderNamesTc }
+
+       ; return (L loc bind' `consBag` rest ) }
+
+-- Report error for all other forms of bindings
+-- This is why we use a fold rather than map
+rnMethodBindLHS is_cls_decl _ (L loc bind) rest
+  = do { addErrAt loc $
+         vcat [ what <+> ptext (sLit "not allowed in") <+> decl_sort
+              , nest 2 (ppr bind) ]
+       ; return rest }
+  where
+    decl_sort | is_cls_decl = ptext (sLit "class declaration:")
+              | otherwise   = ptext (sLit "instance declaration:")
+    what = case bind of
+              PatBind {}    -> ptext (sLit "Pattern bindings (except simple variables)")
+              PatSynBind {} -> ptext (sLit "Pattern synonyms")
+                               -- Associated pattern synonyms are not implemented yet
+              _ -> pprPanic "rnMethodBind" (ppr bind)
 
 {-
 ************************************************************************
@@ -1093,16 +1119,6 @@ defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
                               2 (ppr sig)
                          , ptext (sLit "Use DefaultSignatures to enable default signatures") ]
 
-methodBindErr :: HsBindLR RdrName RdrName -> SDoc
-methodBindErr mbind
- =  hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
-       2 (ppr mbind)
-
-methodPatSynErr :: HsBindLR RdrName RdrName -> SDoc
-methodPatSynErr mbind
- =  hang (ptext (sLit "Pattern synonyms not allowed in class/instance declarations"))
-       2 (ppr mbind)
-
 bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc
 bindsInHsBootFile mbinds
   = hang (ptext (sLit "Bindings in hs-boot files are not allowed"))
index 9f5c076..75486fa 100644 (file)
@@ -1082,7 +1082,8 @@ data HsSigCtxt
                              -- See Note [Signatures for top level things]
   | LocalBindCtxt NameSet    -- In a local binding, binding these names
   | ClsDeclCtxt   Name       -- Class decl for this class
-  | InstDeclCtxt  Name       -- Intsance decl for this class
+  | InstDeclCtxt  NameSet    -- Instance decl whose user-written method
+                             -- bindings are for these methods
   | HsBootCtxt               -- Top level of a hs-boot file
   | RoleAnnotCtxt NameSet    -- A role annotation, with the names of all types
                              -- in the group
@@ -1130,7 +1131,7 @@ lookupBindGroupOcc ctxt what rdr_name
       RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)
       LocalBindCtxt ns -> lookup_group ns
       ClsDeclCtxt  cls -> lookup_cls_op cls
-      InstDeclCtxt cls -> lookup_cls_op cls
+      InstDeclCtxt ns  -> lookup_top (`elemNameSet` ns)
   where
     lookup_cls_op cls
       = do { env <- getGlobalRdrEnv
index 9ad8b1e..8396e84 100644 (file)
@@ -36,7 +36,7 @@ import NameEnv
 import Avail
 import Outputable
 import Bag
-import BasicTypes       ( RuleName )
+import BasicTypes       ( RuleName, pprRuleName )
 import FastString
 import SrcLoc
 import DynFlags
@@ -45,7 +45,7 @@ import ListSetOps       ( findDupsEq, removeDups )
 import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
 
 import Control.Monad
-import Data.List( partition, sortBy )
+import Data.List( sortBy )
 import Maybes( orElse, mapMaybe )
 #if __GLASGOW_HASKELL__ < 709
 import Data.Traversable (traverse)
@@ -472,42 +472,26 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                              , inst_fvs) ;
            Just (inst_tyvars, _, L _ cls,_) ->
 
-    do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
-             ktv_names = hsLKiTyVarNames inst_tyvars
+    do { let ktv_names = hsLKiTyVarNames inst_tyvars
+
+        -- Rename the bindings
+        -- The typechecker (not the renamer) checks that all
+        -- the bindings are for the right class
+        -- (Slightly strangely) when scoped type variables are on, the
+        -- forall-d tyvars scope over the method bindings too
+       ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
 
        -- Rename the associated types, and type signatures
        -- Both need to have the instance type variables in scope
        ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
-       ; ((ats', adts', other_sigs'), more_fvs)
+       ; ((ats', adts'), more_fvs)
              <- extendTyVarEnvFVRn ktv_names $
                 do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
                    ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
-                   ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
-                   ; return ( (ats', adts', other_sigs')
-                            , at_fvs `plusFV` adt_fvs `plusFV` sig_fvs) }
+                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
 
-        -- Rename the bindings
-        -- The typechecker (not the renamer) checks that all
-        -- the bindings are for the right class
-        -- (Slightly strangely) when scoped type variables are on, the
-        -- forall-d tyvars scope over the method bindings too
-       ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $
-                                rnMethodBinds cls (mkSigTvFn other_sigs')
-                                                  mbinds
-
-        -- Rename the SPECIALISE instance pramas
-        -- Annoyingly the type variables are not in scope here,
-        -- so that      instance Eq a => Eq (T a) where
-        --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
-        -- works OK. That's why we did the partition game above
-        --
-       ; (spec_inst_prags', spec_inst_fvs)
-             <- renameSigs (InstDeclCtxt cls) spec_inst_prags
-
-       ; let uprags' = spec_inst_prags' ++ other_sigs'
-             all_fvs = meth_fvs `plusFV` more_fvs
-                          `plusFV` spec_inst_fvs
-                          `plusFV` inst_fvs
+       ; let all_fvs = meth_fvs `plusFV` more_fvs
+                                `plusFV` inst_fvs
        ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
                              , cid_sigs = uprags', cid_tyfam_insts = ats'
                              , cid_overlap_mode = oflag
@@ -677,18 +661,6 @@ can all be in scope (Trac #5862):
 Here 'k' is in scope in the kind signature, just like 'x'.
 -}
 
-extendTyVarEnvForMethodBinds :: [Name]
-                             -> RnM (LHsBinds Name, FreeVars)
-                             -> RnM (LHsBinds Name, FreeVars)
--- For the method bindings in class and instance decls, we extend
--- the type variable environment iff -XScopedTypeVariables
-
-extendTyVarEnvForMethodBinds ktv_names thing_inside
-  = do  { scoped_tvs <- xoptM Opt_ScopedTypeVariables
-        ; if scoped_tvs then
-                extendTyVarEnvFVRn ktv_names thing_inside
-          else
-                thing_inside }
 
 {-
 *********************************************************
@@ -789,7 +761,7 @@ checkValidRule rule_name ids lhs' fv_lhs'
 
 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 -- Nothing => OK
--- Just e  => Not ok, and e is the offending expression
+-- Just e  => Not ok, and e is the offending sub-expression
 validRuleLhs foralls lhs
   = checkl lhs
   where
@@ -826,11 +798,15 @@ badRuleVar name var
 
 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
 badRuleLhsErr name lhs bad_e
-  = sep [ptext (sLit "Rule") <+> ftext name <> colon,
-         nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
+  = sep [ptext (sLit "Rule") <+> pprRuleName name <> colon,
+         nest 4 (vcat [err,
                        ptext (sLit "in left-hand side:") <+> ppr lhs])]
     $$
     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
+  where
+    err = case bad_e of
+            HsUnboundVar occ -> ptext (sLit "Not in scope:") <+> ppr occ
+            _ -> ptext (sLit "Illegal expression:") <+> ppr bad_e
 
 {-
 *********************************************************
@@ -1048,18 +1024,16 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
                         -- kind signatures on the tyvars
 
         -- Tyvars scope over superclass context and method signatures
-        ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
+        ; ((tyvars', context', fds', ats'), stuff_fvs)
             <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
                   -- Checks for distinct tyvars
              { (context', cxt_fvs) <- rnContext cls_doc context
              ; fds'  <- rnFds fds
                          -- The fundeps have no free variables
-             ; (ats',   fv_ats) <- rnATDecls cls' ats
-             ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
+             ; (ats', fv_ats) <- rnATDecls cls' ats
              ; let fvs = cxt_fvs     `plusFV`
-                         sig_fvs     `plusFV`
                          fv_ats
-             ; return ((tyvars', context', fds', ats', sigs'), fvs) }
+             ; return ((tyvars', context', fds', ats'), fvs) }
 
         ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
 
@@ -1083,12 +1057,11 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
         --        op {| a*b |} (a*b)   = ...
         -- we want to name both "x" tyvars with the same unique, so that they are
         -- easy to group together in the typechecker.
-        ; (mbinds', meth_fvs)
-            <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $
+        ; (mbinds', sigs', meth_fvs)
+            <- rnMethodBinds True cls' (hsLKiTyVarNames tyvars') mbinds sigs
                 -- No need to check for duplicate method signatures
                 -- since that is done by RnNames.extendGlobalRdrEnvRn
                 -- and the methods are already in scope
-                 rnMethodBinds cls' (mkSigTvFn sigs') mbinds
 
   -- Haddock docs
         ; docs' <- mapM (wrapLocM rnDocDecl) docs
index eab6c5c..7df495f 100644 (file)
@@ -1033,8 +1033,11 @@ mkPragEnv sigs binds
     add_arity n inl_prag   -- Adjust inl_sat field to match visible arity of function
       | Inline <- inl_inline inl_prag
         -- add arity only for real INLINE pragmas, not INLINABLE
-      , Just ar <- lookupNameEnv ar_env n
-      = inl_prag { inl_sat = Just ar }
+      = case lookupNameEnv ar_env n of
+          Just ar -> inl_prag { inl_sat = Just ar }
+          Nothing -> WARN( True, ptext (sLit "mkPragEnv no arity") <+> ppr n )
+                     -- There really should be a binding for every INLINE pragma
+                     inl_prag
       | otherwise
       = inl_prag
 
index 8da2229..429ba78 100644 (file)
@@ -540,7 +540,7 @@ renameDeriv is_boot inst_infos bagBinds
                             , ib_derived = sa } })
         =  ASSERT( null sigs )
            bindLocalNamesFV tyvars $
-           do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
+           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
               ; let binds' = InstBindings { ib_binds = rn_binds
                                           , ib_tyvars = tyvars
                                           , ib_pragmas = []
index d184d2a..3800615 100644 (file)
@@ -1,4 +1,4 @@
-
-mod48.hs:5:3:
-    Pattern bindings (except simple variables) not allowed in instance declarations
-       (x, y) = error "foo"
+\r
+mod48.hs:5:3: error:\r
+    Pattern bindings (except simple variables) not allowed in class declaration:\r
+      (x, y) = error "foo"\r
index cd36449..360366d 100644 (file)
@@ -1,4 +1,6 @@
 {-# LANGUAGE InstanceSigs #-}
 module WildcardInInstanceSig where
 
-instance Num Bool where negate :: _
+instance Num Bool where
+  negate :: _
+  negate = undefined
index 339f9fa..8e697bb 100644 (file)
@@ -1,5 +1,5 @@
-
-WildcardInInstanceSig.hs:4:35:
-    Unexpected wild card: ‘_’
-    In the type signature for ‘negate’: negate :: _
-    In the instance declaration for ‘Num Bool’
+\r
+WildcardInInstanceSig.hs:5:13: error:\r
+    Unexpected wild card: ‘_’\r
+    In the type signature for ‘negate’: negate :: _\r
+    In the instance declaration for ‘Num Bool’\r
index abe4fe6..400ecaa 100644 (file)
@@ -1,4 +1,4 @@
-
-T9705-1.hs:3:5:
-    Pattern synonyms not allowed in class/instance declarations
-      pattern P = ()
+\r
+T9705-1.hs:3:5: error:\r
+    Pattern synonyms not allowed in class declaration:\r
+      pattern P = ()\r
index 23f85fa..9a3309f 100644 (file)
@@ -1,4 +1,4 @@
-
-T9705-2.hs:6:5:
-    Pattern synonyms not allowed in class/instance declarations
-      pattern P = ()
+\r
+T9705-2.hs:6:5: error:\r
+    Pattern synonyms not allowed in instance declaration:\r
+      pattern P = ()\r
diff --git a/testsuite/tests/rename/should_fail/T5001.hs b/testsuite/tests/rename/should_fail/T5001.hs
new file mode 100644 (file)
index 0000000..3b01646
--- /dev/null
@@ -0,0 +1,10 @@
+{-# LANGUAGE DefaultSignatures #-}
+module T5001b where
+
+class GEnum a where
+     genum :: [a]
+     default genum :: [a]
+     genum = undefined
+
+instance GEnum Int where
+     {-# INLINE genum #-}
diff --git a/testsuite/tests/rename/should_fail/T5001.stderr b/testsuite/tests/rename/should_fail/T5001.stderr
new file mode 100644 (file)
index 0000000..34317cf
--- /dev/null
@@ -0,0 +1,4 @@
+\r
+T5001.hs:10:17: error:\r
+    The INLINE pragma for ‘genum’ lacks an accompanying binding\r
+      (The INLINE pragma must be given where ‘genum’ is declared)\r
index 80471a6..5438ea5 100644 (file)
@@ -135,3 +135,4 @@ test('T9032',
      ['$MAKE -s --no-print-directory T9032'])
 test('T10618', normal, compile_fail, [''])
 test('T10668', normal, compile_fail, [''])
+test('T5001', normal, compile_fail, [''])
index 5afea21..4e2d7a0 100644 (file)
@@ -1,4 +1,4 @@
-
-tcfail021.hs:8:5:
-    Pattern bindings (except simple variables) not allowed in instance declarations
-      ((==), (/=)) = (\ x -> \ y -> True, \ x -> \ y -> False)
+\r
+tcfail021.hs:8:5: error:\r
+    Pattern bindings (except simple variables) not allowed in instance declaration:\r
+      ((==), (/=)) = (\ x -> \ y -> True, \ x -> \ y -> False)\r