Fix panic when using pattern synonyms with DisambiguateRecordFields
authorAdam Gundry <adam@well-typed.com>
Tue, 29 Dec 2015 12:42:32 +0000 (13:42 +0100)
committerBen Gamari <ben@smart-cactus.org>
Tue, 29 Dec 2015 13:13:34 +0000 (14:13 +0100)
This fixes a `find_tycon` panic when constructing a record pattern
synonym when `DisambiguateRecordFields` (turned on by `RecordWildCards`)
is enabled.  The handling of record wild cards in such constructions
isn't completely satisfactory, but doing better will require the
`Parent` type to be more informative, as I'll explain on #11228.

Test Plan: New test patsyn/should_compile/T11283.hs

Reviewers: mpickering, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1695

GHC Trac Issues: #11283

compiler/rename/RnPat.hs
testsuite/tests/patsyn/should_compile/T11283.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/T11283.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/all.T

index 38c832c..8ee2141 100644 (file)
@@ -599,10 +599,10 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                    = rdr `elemLocalRdrEnv` lcl_env
                    || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env
                                     , case gre_par gre of
-                                        ParentIs p               -> p /= parent_tc
-                                        FldParent { par_is = p } -> p /= parent_tc
-                                        PatternSynonym           -> True
-                                        NoParent                 -> True ]
+                                        ParentIs p     -> Just p /= parent_tc
+                                        FldParent p _  -> Just p /= parent_tc
+                                        PatternSynonym -> False
+                                        NoParent       -> True ]
                    where
                      rdr = mkVarUnqual lbl
 
@@ -629,19 +629,23 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
     -- When disambiguation is on, return name of parent tycon.
     check_disambiguation disambig_ok mb_con
       | disambig_ok, Just con <- mb_con
-      = do { env <- getGlobalRdrEnv; return (Just (find_tycon env con)) }
+      = do { env <- getGlobalRdrEnv; return (find_tycon env con) }
       | otherwise = return Nothing
 
-    find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Name {- TyCon -}
+    find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Maybe Name {- TyCon -}
     -- Return the parent *type constructor* of the data constructor
-    -- That is, the parent of the data constructor.
+    -- (that is, the parent of the data constructor),
+    -- or 'Nothing' if it is a pattern synonym.
     -- That's the parent to use for looking up record fields.
     find_tycon env con
       | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con
-      = tyConName (dataConTyCon dc)   -- Special case for [], which is built-in syntax
-                                      -- and not in the GlobalRdrEnv (Trac #8448)
-      | [GRE { gre_par = ParentIs p }] <- lookupGRE_Name env con
-      = p
+      = Just (tyConName (dataConTyCon dc))
+        -- Special case for [], which is built-in syntax
+        -- and not in the GlobalRdrEnv (Trac #8448)
+      | [gre] <- lookupGRE_Name env con
+      = case gre_par gre of
+          ParentIs p -> Just p
+          _          -> Nothing
 
       | otherwise
       = pprPanic "find_tycon" (ppr con $$ ppr (lookupGRE_Name env con))
diff --git a/testsuite/tests/patsyn/should_compile/T11283.hs b/testsuite/tests/patsyn/should_compile/T11283.hs
new file mode 100644 (file)
index 0000000..ed7471d
--- /dev/null
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms, RecordWildCards #-}
+module T11283 where
+data P = MkP Bool
+pattern S{x} = MkP x
+d = S{x = True}
+e = S{..}
+f S{x=x} = x
diff --git a/testsuite/tests/patsyn/should_compile/T11283.stderr b/testsuite/tests/patsyn/should_compile/T11283.stderr
new file mode 100644 (file)
index 0000000..86d8575
--- /dev/null
@@ -0,0 +1,5 @@
+
+T11283.hs:6:5: warning:
+    • Fields of ‘S’ not initialised: x
+    • In the expression: S {..}
+      In an equation for ‘e’: e = S {..}
index e1c8243..880d6b2 100644 (file)
@@ -46,3 +46,4 @@ test('T10897', normal, multi_compile, ['T10897', [
                                       ], '-v0'])
 test('T11224b', normal, compile, [''])
 test('MoreEx', normal, compile, [''])
+test('T11283', normal, compile, [''])