diff options
-rw-r--r-- | compiler/deSugar/Desugar.hs | 2 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 6 | ||||
-rw-r--r-- | compiler/main/HscTypes.hs | 5 | ||||
-rw-r--r-- | ghc/InteractiveUI.hs | 1 | ||||
-rw-r--r-- | testsuite/tests/patsyn/should_run/all.T | 5 | ||||
-rw-r--r-- | testsuite/tests/patsyn/should_run/ghci.script | 8 | ||||
-rw-r--r-- | testsuite/tests/patsyn/should_run/ghci.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/patsyn/should_run/ghci.stdout | 3 |
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] |