Support pattern synonyms in GHCi (fixes #9900)
authorDr. ERDI Gergo <gergo@erdi.hu>
Sun, 28 Dec 2014 03:51:00 +0000 (11:51 +0800)
committerDr. ERDI Gergo <gergo@erdi.hu>
Sun, 28 Dec 2014 11:37:33 +0000 (19:37 +0800)
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`.

compiler/deSugar/Desugar.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.hs
ghc/InteractiveUI.hs
testsuite/tests/patsyn/should_run/all.T
testsuite/tests/patsyn/should_run/ghci.script [new file with mode: 0644]
testsuite/tests/patsyn/should_run/ghci.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_run/ghci.stdout [new file with mode: 0644]

index ac35464..70fa88e 100644 (file)
@@ -24,7 +24,6 @@ import Coercion
 import InstEnv
 import Class
 import Avail
-import PatSyn
 import CoreSyn
 import CoreSubst
 import PprCore
@@ -184,7 +183,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,
index c5cb9a1..4fe74c6 100644 (file)
@@ -97,6 +97,7 @@ import CoreLint         ( lintInteractiveExpr )
 import DsMeta           ( templateHaskellNames )
 import VarEnv           ( emptyTidyEnv )
 import Panic
+import ConLike
 
 import GHC.Exts
 #endif
@@ -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)
index 909004e..29ee78c 100644 (file)
@@ -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
index 7125f6d..9941a60 100644 (file)
@@ -892,6 +892,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.
index 40ec3e3..2f496a6 100644 (file)
@@ -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 (file)
index 0000000..cd71e33
--- /dev/null
@@ -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 (file)
index 0000000..9593b15
--- /dev/null
@@ -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 (file)
index 0000000..796aa72
--- /dev/null
@@ -0,0 +1,3 @@
+pattern Single :: t -> [t]     -- Defined at <interactive>:4:9
+foo :: [Bool] -> [Bool]
+[False]