Support pattern synonyms in GHCi (fixes #9900)wip/T9900

This involves recognizing lines starting with `"pattern "` as declarations,
keeping non-exported pattern synonyms in `deSugar`, and including
pattern synonyms in the result of `hscDeclsWithLocation`.

8 files changed, 27 insertions, 5 deletions

diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index ac354643b0..46955437d4 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -184,7 +184,7 @@ deSugar hsc_env
                 mg_fam_insts    = fam_insts,
                 mg_inst_env     = inst_env,
                 mg_fam_inst_env = fam_inst_env,
-                mg_patsyns      = filter ((`elemNameSet` export_set) . patSynName) patsyns,
+                mg_patsyns      = patsyns,
                 mg_rules        = ds_rules_for_imps,
                 mg_binds        = ds_binds,
                 mg_foreign      = ds_fords,
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index c5cb9a182b..5af28cbba7 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -128,6 +128,7 @@ import CostCentre
 import ProfInit
 import TyCon
 import Name
+import ConLike
 import SimplStg         ( stg2stg )
 import Cmm
 import CmmParse         ( parseCmmFile )
@@ -1505,6 +1506,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
     liftIO $ linkDecls hsc_env src_span cbc
 
     let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
+        patsyns = mg_patsyns simpl_mg
 
         ext_ids = [ id | id <- bindersOfBinds core_binds
                        , isExternalName (idName id)
@@ -1515,11 +1517,11 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
             -- The DFunIds are in 'cls_insts' (see Note [ic_tythings] in HscTypes
             -- Implicit Ids are implicit in tcs
 
-        tythings =  map AnId ext_ids ++ map ATyCon tcs
+        tythings =  map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
 
     let icontext = hsc_IC hsc_env
         ictxt    = extendInteractiveContext icontext ext_ids tcs
-                                            cls_insts fam_insts defaults
+                                            cls_insts fam_insts defaults patsyns
     return (tythings, ictxt)
 
 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 909004e14d..29ee78c2b3 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -1403,8 +1403,9 @@ extendInteractiveContext :: InteractiveContext
                          -> [Id] -> [TyCon]
                          -> [ClsInst] -> [FamInst]
                          -> Maybe [Type]
+                         -> [PatSyn]
                          -> InteractiveContext
-extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults
+extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults new_patsyns
   = ictxt { ic_mod_index  = ic_mod_index ictxt + 1
                             -- Always bump this; even instances should create
                             -- a new mod_index (Trac #9426)
@@ -1413,7 +1414,7 @@ extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults
           , ic_instances  = (new_cls_insts ++ old_cls_insts, new_fam_insts ++ old_fam_insts)
           , ic_default    = defaults }
   where
-    new_tythings = map AnId ids ++ map ATyCon tcs
+    new_tythings = map AnId ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) new_patsyns
     old_tythings = filterOut (shadowed_by ids) (ic_tythings ictxt)
 
     -- Discard old instances that have been fully overrridden
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index d478336c36..b7c50f5aad 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -888,6 +888,7 @@ declPrefixes dflags = keywords ++ concat opt_keywords
 
     opt_keywords = [ ["foreign "  | xopt Opt_ForeignFunctionInterface dflags]
                    , ["deriving " | xopt Opt_StandaloneDeriving dflags]
+                   , ["pattern "  | xopt Opt_PatternSynonyms dflags]
                    ]
 
 -- | Entry point to execute some haskell code from user
diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T
index 40ec3e3b4e..2f496a6946 100644
--- a/testsuite/tests/patsyn/should_run/all.T
+++ b/testsuite/tests/patsyn/should_run/all.T
@@ -1,3 +1,7 @@
+# We only want to run these tests with GHCi
+def just_ghci( name, opts ):
+  opts.only_ways = ['ghci']
+
 test('eval', normal, compile_and_run, [''])
 test('match', normal, compile_and_run, [''])
 test('ex-prov-run', normal, compile_and_run, [''])
@@ -6,3 +10,4 @@ test('bidir-explicit-scope', normal, compile_and_run, [''])
 test('T9783', normal, compile_and_run, [''])
 test('match-unboxed', normal, compile_and_run, [''])
 test('unboxed-wrapper', normal, compile_and_run, [''])
+test('ghci', just_ghci, ghci_script, ['ghci.script'])
diff --git a/testsuite/tests/patsyn/should_run/ghci.script b/testsuite/tests/patsyn/should_run/ghci.script
new file mode 100644
index 0000000000..cd71e33235
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/ghci.script
@@ -0,0 +1,8 @@
+:set -XPatternSynonyms
+
+pattern Single x = [x]
+:i Single
+let foo (Single x) = Single (not x)
+:t foo
+foo [True]
+foo [True, False]
diff --git a/testsuite/tests/patsyn/should_run/ghci.stderr b/testsuite/tests/patsyn/should_run/ghci.stderr
new file mode 100644
index 0000000000..9593b15633
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/ghci.stderr
@@ -0,0 +1,2 @@
+*** Exception: <interactive>:6:5-35: Non-exhaustive patterns in function foo
+
diff --git a/testsuite/tests/patsyn/should_run/ghci.stdout b/testsuite/tests/patsyn/should_run/ghci.stdout
new file mode 100644
index 0000000000..796aa72d61
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/ghci.stdout
@@ -0,0 +1,3 @@
+pattern Single :: t -> [t] 	-- Defined at <interactive>:4:9
+foo :: [Bool] -> [Bool]
+[False]