Fix used-variable calculation (Trac #12548)
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 5 Dec 2016 13:17:35 +0000 (13:17 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 5 Dec 2016 17:40:03 +0000 (17:40 +0000)
The used-variable calculation for pattern synonyms is a little
tricky, for reasons described in RnBinds
Note [Pattern synonym builders don't yield dependencies]

It was right semantically, but the "unused-variable warning" was
wrong, which led to Trac #12548.

compiler/hsSyn/HsUtils.hs
compiler/rename/RnBinds.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcEnv.hs
testsuite/tests/rename/should_compile/T12548.hs [new file with mode: 0644]
testsuite/tests/rename/should_compile/all.T

index de77360..f1500bb 100644 (file)
@@ -78,7 +78,8 @@ module HsUtils(
   collectLStmtsBinders, collectStmtsBinders,
   collectLStmtBinders, collectStmtBinders,
 
-  hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors,
+  hsLTyClDeclBinders, hsTyClForeignBinders,
+  hsPatSynSelectors, getPatSynBinds,
   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
   hsDataDefnBinders,
 
@@ -976,6 +977,11 @@ addPatSynSelector bind sels
   = map (unLoc . recordPatSynSelectorId) as ++ sels
   | otherwise = sels
 
+getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
+getPatSynBinds binds
+  = [ psb | (_, lbinds) <- binds
+          , L _ (PatSynBind psb) <- bagToList lbinds ]
+
 -------------------
 hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
 hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
index 1eadf29..5683086 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
 
 {-
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -285,15 +285,24 @@ rnValBindsRHS :: HsSigCtxt
 rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
   = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
        ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds
-       ; case depAnalBinds binds_w_dus of
-           (anal_binds, anal_dus) -> return (valbind', valbind'_dus)
-              where
-                valbind' = ValBindsOut anal_binds sigs'
-                valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
-                               -- Put the sig uses *after* the bindings
-                               -- so that the binders are removed from
-                               -- the uses in the sigs
-       }
+       ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
+
+       ; let patsyn_fvs = foldr (unionNameSet . psb_fvs) emptyNameSet $
+                          getPatSynBinds anal_binds
+                -- The uses in binds_w_dus for PatSynBinds do not include
+                -- variables used in the patsyn builders; see
+                -- Note [Pattern synonym builders don't yield dependencies]
+                -- But psb_fvs /does/ include those builder fvs.  So we
+                -- add them back in here to avoid bogus warnings about
+                -- unused variables (Trac #12548)
+
+             valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
+                                     `plusDU` usesOnly patsyn_fvs
+                            -- Put the sig uses *after* the bindings
+                            -- so that the binders are removed from
+                            -- the uses in the sigs
+
+        ; return (ValBindsOut anal_binds sigs', valbind'_dus) }
 
 rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
 
@@ -665,18 +674,18 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
                 -- As well as dependency analysis, we need these for the
                 -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
 
-        ; let bind' = bind{ psb_args = details'
+              bind' = bind{ psb_args = details'
                           , psb_def = pat'
                           , psb_dir = dir'
                           , psb_fvs = fvs' }
-        ; let selector_names = case details' of
+              selector_names = case details' of
                                  RecordPatSyn names ->
                                   map (unLoc . recordPatSynSelectorId) names
                                  _ -> []
 
         ; fvs' `seq` -- See Note [Free-variable space leak]
           return (bind', name : selector_names , fvs1)
-          -- See Note [Pattern synonym builders don't yield dependencies]
+          -- Why fvs1?  See Note [Pattern synonym builders don't yield dependencies]
       }
   where
     lookupVar = wrapLocM lookupOccRn
@@ -702,17 +711,24 @@ f (P x) = C2 x
 In this case, 'P' needs to be typechecked in two passes:
 
 1. Typecheck the pattern definition of 'P', which fully determines the
-type of 'P'. This step doesn't require knowing anything about 'f',
-since the builder definition is not looked at.
+   type of 'P'. This step doesn't require knowing anything about 'f',
+   since the builder definition is not looked at.
 
 2. Typecheck the builder definition, which needs the typechecked
-definition of 'f' to be in scope.
+   definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind
+   in TcBinds.tcValBinds.
 
 This behaviour is implemented in 'tcValBinds', but it crucially
 depends on 'P' not being put in a recursive group with 'f' (which
 would make it look like a recursive pattern synonym a la 'pattern P =
 P' which is unsound and rejected).
 
+So:
+ * We do not include builder fvs in the Uses returned by rnPatSynBind
+   (which is then used for dependency analysis)
+ * But we /do/ include them in the psb_fvs for the PatSynBind
+ * In rnValBinds we record these builder uses, to avoid bogus
+   unused-variable warnings (Trac #12548)
 -}
 
 {- *********************************************************************
index d13af8b..2206480 100644 (file)
@@ -302,6 +302,7 @@ tcValBinds top_lvl binds sigs thing_inside
             { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
                    { thing <- thing_inside
                      -- See Note [Pattern synonym builders don't yield dependencies]
+                     --     in RnBinds
                    ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
                    ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
                    ; return (extra_binds, thing) }
index 779f9ed..6135800 100644 (file)
@@ -40,7 +40,7 @@ module TcEnv(
         wrongThingErr, pprBinders,
 
         tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
-        getPatSynBinds, getTypeSigNames,
+        getTypeSigNames,
         tcExtendRecEnv,         -- For knot-tying
 
         -- Instances
@@ -99,7 +99,6 @@ import Module
 import Outputable
 import Encoding
 import FastString
-import Bag
 import ListSetOps
 import Util
 import Maybes( MaybeErr(..) )
@@ -588,12 +587,6 @@ tcAddPatSynPlaceholders pat_syns thing_inside
                      | PSB{ psb_id = L _ name } <- pat_syns ]
        thing_inside
 
-getPatSynBinds :: [(RecFlag, LHsBinds Name)] -> [PatSynBind Name Name]
-getPatSynBinds binds
-  = [ psb | (_, lbinds) <- binds
-          , L _ (PatSynBind psb) <- bagToList lbinds ]
-
-
 getTypeSigNames :: [LSig Name] -> NameSet
 -- Get the names that have a user type sig
 getTypeSigNames sigs
diff --git a/testsuite/tests/rename/should_compile/T12548.hs b/testsuite/tests/rename/should_compile/T12548.hs
new file mode 100644 (file)
index 0000000..c19a7d2
--- /dev/null
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -Wunused-binds #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Foo (pattern P) where
+
+-- x is used!!
+x :: Int
+x = 0
+
+pattern P :: Int
+pattern P <- _ where
+        P = x
index 106ba0a..90d955b 100644 (file)
@@ -244,3 +244,4 @@ test('T12127',
      ['T12127', '-v0'])
 test('T12533', normal, compile, [''])
 test('T12597', normal, compile, [''])
+test('T12548', normal, compile, [''])