[commit: ghc] wip/T9900: Support pattern synonyms in GHCi (fixes #9900) (20acaa7)
git at git.haskell.org
git at git.haskell.org
Sun Dec 21 11:22:38 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T9900
Link : http://ghc.haskell.org/trac/ghc/changeset/20acaa7785d910d36d46c4eae9e9cce4000635d1/ghc
>---------------------------------------------------------------
commit 20acaa7785d910d36d46c4eae9e9cce4000635d1
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Sun Dec 21 15:01:15 2014 +0800
Support pattern synonyms in GHCi (fixes #9900)
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`.
>---------------------------------------------------------------
20acaa7785d910d36d46c4eae9e9cce4000635d1
compiler/deSugar/Desugar.hs | 2 +-
compiler/main/HscMain.hs | 6 ++++--
compiler/main/HscTypes.hs | 5 +++--
ghc/InteractiveUI.hs | 1 +
testsuite/tests/patsyn/should_run/all.T | 5 +++++
testsuite/tests/patsyn/should_run/ghci.script | 8 ++++++++
testsuite/tests/patsyn/should_run/ghci.stderr | 2 ++
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 ac35464..4695543 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 c5cb9a1..5af28cb 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 909004e..29ee78c 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 4a296da..b66db24 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -887,6 +887,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 40ec3e3..2f496a6 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 0000000..cd71e33
--- /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 0000000..9593b15
--- /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 0000000..796aa72
--- /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]
More information about the ghc-commits
mailing list