Make sure record pattern synonym selectors are in scope in GHCi.
authorMatthew Pickering <matthewtpickering@gmail.com>
Sun, 1 May 2016 22:11:30 +0000 (00:11 +0200)
committerBen Gamari <ben@smart-cactus.org>
Sun, 1 May 2016 22:12:01 +0000 (00:12 +0200)
Beforehand, when a record pattern synonym was defined in GHCi
the selectors would not be in scope. This is because of `is_sub_bndr`
in `HscTypes.icExtendGblRdrEnv` was throwing away the selectors.

This was broken by the fix to #10520 but it is easy to resolve.

Reviewers: austin, bgamari, simonpj

Reviewed By: simonpj

Subscribers: thomie

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

GHC Trac Issues: #11985

compiler/main/HscTypes.hs
testsuite/tests/patsyn/should_run/T11985.script [new file with mode: 0644]
testsuite/tests/patsyn/should_run/T11985.stdout [new file with mode: 0644]
testsuite/tests/patsyn/should_run/all.T

index 541f0af..800958b 100644 (file)
@@ -1504,9 +1504,9 @@ icExtendGblRdrEnv env tythings
        | is_sub_bndr thing
        = env
        | otherwise
-       = foldl extendGlobalRdrEnv env1 (localGREsFromAvail avail)
+       = foldl extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)
        where
-          env1  = shadowNames env (availNames avail)
+          env1  = shadowNames env (concatMap availNames avail)
           avail = tyThingAvailInfo thing
 
     -- Ugh! The new_tythings may include record selectors, since they
@@ -1829,19 +1829,21 @@ tyThingsTyCoVars tts =
 
 -- | The Names that a TyThing should bring into scope.  Used to build
 -- the GlobalRdrEnv for the InteractiveContext.
-tyThingAvailInfo :: TyThing -> AvailInfo
+tyThingAvailInfo :: TyThing -> [AvailInfo]
 tyThingAvailInfo (ATyCon t)
    = case tyConClass_maybe t of
-        Just c  -> AvailTC n (n : map getName (classMethods c)
+        Just c  -> [AvailTC n (n : map getName (classMethods c)
                                  ++ map getName (classATs c))
-                             []
+                             [] ]
              where n = getName c
-        Nothing -> AvailTC n (n : map getName dcs) flds
+        Nothing -> [AvailTC n (n : map getName dcs) flds]
              where n    = getName t
                    dcs  = tyConDataCons t
                    flds = tyConFieldLabels t
+tyThingAvailInfo (AConLike (PatSynCon p))
+  = map patSynAvail ((getName p) : map flSelector (patSynFieldLabels p))
 tyThingAvailInfo t
-   = avail (getName t)
+   = [avail (getName t)]
 
 {-
 ************************************************************************
diff --git a/testsuite/tests/patsyn/should_run/T11985.script b/testsuite/tests/patsyn/should_run/T11985.script
new file mode 100644 (file)
index 0000000..efeba01
--- /dev/null
@@ -0,0 +1,4 @@
+:set -XPatternSynonyms
+
+pattern Point{x, y} = (x, y)
+(1, 2) { x = 3}
diff --git a/testsuite/tests/patsyn/should_run/T11985.stdout b/testsuite/tests/patsyn/should_run/T11985.stdout
new file mode 100644 (file)
index 0000000..3f9e8ad
--- /dev/null
@@ -0,0 +1 @@
+(3,2)
index a0bd3ce..d98a1ff 100644 (file)
@@ -12,4 +12,5 @@ test('match-unboxed', normal, compile_and_run, [''])
 test('unboxed-wrapper', normal, compile_and_run, [''])
 test('records-run', normal, compile_and_run, [''])
 test('ghci', just_ghci, ghci_script, ['ghci.script'])
+test('T11985', just_ghci, ghci_script, ['T11985.script'])
 test('T11224', normal, compile_and_run, [''])