Commit 0cc0cc86 authored by cactus's avatar cactus

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`.
parent 6c86635d
......@@ -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,
......
......@@ -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)
......
......@@ -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
......
......@@ -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.
......
# 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'])
:set -XPatternSynonyms
pattern Single x = [x]
:i Single
let foo (Single x) = Single (not x)
:t foo
foo [True]
foo [True, False]
*** Exception: <interactive>:6:5-35: Non-exhaustive patterns in function foo
pattern Single :: t -> [t] -- Defined at <interactive>:4:9
foo :: [Bool] -> [Bool]
[False]
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment