summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/DsMeta.hs14
-rw-r--r--testsuite/tests/partial-sigs/should_compile/PatternSplice.hs6
-rw-r--r--testsuite/tests/partial-sigs/should_compile/all.T1
-rw-r--r--testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.hs2
-rw-r--r--testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr13
-rw-r--r--testsuite/tests/th/TH_repPatSig.hs16
-rw-r--r--testsuite/tests/th/TH_repPatSig.stderr4
-rw-r--r--testsuite/tests/th/TH_repPatSigTVar.hs11
-rw-r--r--testsuite/tests/th/TH_repPatSigTVar.stderr8
-rw-r--r--testsuite/tests/th/TH_repPatSig_asserts.hs44
-rw-r--r--testsuite/tests/th/all.T6
11 files changed, 101 insertions, 24 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index d8fdb54183..6b40a04446 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1616,14 +1616,9 @@ repP (ConPatIn dc details)
repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
-repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
- -- The problem is to do with scoped type variables.
- -- To implement them, we have to implement the scoping rules
- -- here in DsMeta, and I don't want to do that today!
- -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
- -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
- -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
-
+repP (SigPatIn p t) = do { p' <- repLP p
+ ; t' <- repLTy (hsSigWcType t)
+ ; repPsig p' t' }
repP (SplicePat splice) = repSplice splice
repP other = notHandled "Exotic pattern" (ppr other)
@@ -1841,6 +1836,9 @@ repPlist (MkC ps) = rep2 listPName [ps]
repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
+repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
--------------- Expressions -----------------
repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
diff --git a/testsuite/tests/partial-sigs/should_compile/PatternSplice.hs b/testsuite/tests/partial-sigs/should_compile/PatternSplice.hs
new file mode 100644
index 0000000000..710a861b48
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/PatternSplice.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module PatternSplice where
+
+foo $( [p| (x :: _) |] ) = x
diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T
index 17c769e653..d2c68366ff 100644
--- a/testsuite/tests/partial-sigs/should_compile/all.T
+++ b/testsuite/tests/partial-sigs/should_compile/all.T
@@ -38,6 +38,7 @@ test('PatBind', normal, compile, ['-ddump-types -fno-warn-partial-type-signature
# Bug
test('PatBind2', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
test('PatternSig', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
+test('PatternSplice', normal, compile, ['-fno-warn-partial-type-signatures'])
test('Recursive', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
test('ScopedNamedWildcards', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
test('ScopedNamedWildcardsGood', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.hs
index 1015fd53d1..39740c4842 100644
--- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.hs
+++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.hs
@@ -2,4 +2,4 @@
{-# LANGUAGE ScopedTypeVariables #-}
module ExtraConstraintsWildcardInPatternSplice where
-foo $( [p| (x :: _) |] ) = x
+foo $( [p| (_ :: _) |] ) = ()
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr
index 784f437966..d1f5270d64 100644
--- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr
+++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr
@@ -1,4 +1,13 @@
ExtraConstraintsWildcardInPatternSplice.hs:5:8: error:
- Type signatures in patterns not (yet) handled by Template Haskell
- x :: _
+ • Found type wildcard ‘_’ standing for ‘w’
+ Where: ‘w’ is a rigid type variable bound by
+ the inferred type of foo :: w -> ()
+ at ExtraConstraintsWildcardInPatternSplice.hs:5:1-29
+ To use the inferred type, enable PartialTypeSignatures
+ • In a pattern type signature: _
+ In the pattern: _ :: _
+ In an equation for ‘foo’: foo (_ :: _) = ()
+ • Relevant bindings include
+ foo :: w -> ()
+ (bound at ExtraConstraintsWildcardInPatternSplice.hs:5:1)
diff --git a/testsuite/tests/th/TH_repPatSig.hs b/testsuite/tests/th/TH_repPatSig.hs
index 3f504ff372..47aee26e13 100644
--- a/testsuite/tests/th/TH_repPatSig.hs
+++ b/testsuite/tests/th/TH_repPatSig.hs
@@ -1,17 +1,17 @@
{-# LANGUAGE ScopedTypeVariables #-}
--- test the representation of unboxed literals
module Main
where
-import Language.Haskell.TH
+import TH_repPatSig_asserts
-$(
- [d|
- foo :: Int -> Int
- foo (x :: Int) = x
- |]
- )
+assertFoo [d| foo :: Int -> Int
+ foo (x :: Int) = x
+ |]
+
+assertCon [| \(x :: Either Char Int -> (Char, Int)) -> x |]
+
+assertVar [| \(x :: Maybe a) -> case x of Just y -> (y :: a) |]
main :: IO ()
main = return ()
diff --git a/testsuite/tests/th/TH_repPatSig.stderr b/testsuite/tests/th/TH_repPatSig.stderr
deleted file mode 100644
index 7269068d7d..0000000000
--- a/testsuite/tests/th/TH_repPatSig.stderr
+++ /dev/null
@@ -1,4 +0,0 @@
-
-TH_repPatSig.hs:10:3:
- Type signatures in patterns not (yet) handled by Template Haskell
- x :: Int
diff --git a/testsuite/tests/th/TH_repPatSigTVar.hs b/testsuite/tests/th/TH_repPatSigTVar.hs
new file mode 100644
index 0000000000..53f896bc19
--- /dev/null
+++ b/testsuite/tests/th/TH_repPatSigTVar.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main
+where
+
+import Language.Haskell.TH
+
+$([d| f = \(_ :: Either a b) -> $(sigE (varE 'undefined) (varT ''c)) |])
+
+main :: IO ()
+main = return ()
diff --git a/testsuite/tests/th/TH_repPatSigTVar.stderr b/testsuite/tests/th/TH_repPatSigTVar.stderr
new file mode 100644
index 0000000000..fb02dd9fb8
--- /dev/null
+++ b/testsuite/tests/th/TH_repPatSigTVar.stderr
@@ -0,0 +1,8 @@
+
+TH_repPatSigTVar.hs:8:64: error:
+ • Not in scope: type variable ‘c’
+ • In the Template Haskell quotation ''c
+ In the untyped splice: $(sigE (varE 'undefined) (varT ''c))
+ In the Template Haskell quotation
+ [d| f = \ (_ :: Either a b)
+ -> $(sigE (varE 'undefined) (varT ''c)) |]
diff --git a/testsuite/tests/th/TH_repPatSig_asserts.hs b/testsuite/tests/th/TH_repPatSig_asserts.hs
new file mode 100644
index 0000000000..42ade65ab4
--- /dev/null
+++ b/testsuite/tests/th/TH_repPatSig_asserts.hs
@@ -0,0 +1,44 @@
+module TH_repPatSig_asserts where
+
+import Language.Haskell.TH
+
+assertFoo :: Q [Dec] -> Q [Dec]
+assertFoo decsQ = do
+ decs <- decsQ
+ case decs of
+ [ SigD _ (AppT (AppT ArrowT (ConT t1)) (ConT t2)),
+ FunD _ [Clause [SigP (VarP _) (ConT t3)] (NormalB (VarE _)) []] ]
+ | t1 == ''Int && t2 == ''Int && t3 == ''Int -> return []
+ _ -> do reportError $ "Unexpected quote contents: " ++ show decs
+ return []
+
+assertCon :: Q Exp -> Q [Dec]
+assertCon expQ = do
+ exp <- expQ
+ case exp of
+ LamE [SigP (VarP _) (AppT (AppT ArrowT (AppT (AppT (ConT eitherT)
+ (ConT charT1))
+ (ConT intT1)))
+ (AppT (AppT (TupleT 2) (ConT charT2))
+ (ConT intT2)))]
+ (VarE _)
+ | eitherT == ''Either &&
+ charT1 == ''Char &&
+ charT2 == ''Char &&
+ intT1 == ''Int &&
+ intT2 == ''Int -> return []
+ _ -> do reportError $ "Unexpected quote contents: " ++ show exp
+ return []
+
+assertVar :: Q Exp -> Q [Dec]
+assertVar expQ = do
+ exp <- expQ
+ case exp of
+ LamE [SigP (VarP x) (AppT (ConT _) (VarT a))]
+ (CaseE (VarE x1) [Match (ConP _ [VarP y])
+ (NormalB (SigE (VarE y1) (VarT a1))) []])
+ | x1 == x &&
+ y1 == y &&
+ a1 == a -> return []
+ _ -> do reportError $ "Unexpected quote contents: " ++ show exp
+ return []
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 4f21121f9a..e0a97fa286 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -24,7 +24,11 @@ test('TH_repPrimOutput', normal, compile_and_run, [''])
test('TH_repPrimOutput2', normal, compile_and_run, [''])
test('TH_repGuard', normal, compile, ['-v0'])
test('TH_repGuardOutput', normal, compile_and_run, [''])
-test('TH_repPatSig', normal, compile_fail, [''])
+test('TH_repPatSig',
+ extra_clean(['TH_repPatSig_asserts.hi', 'TH_repPatSig_asserts.o']),
+ multimod_compile,
+ ['TH_repPatSig.hs', '-v0 ' + config.ghc_th_way_flags])
+test('TH_repPatSigTVar', normal, compile_fail, ['-v0'])
test('TH_overlaps', normal, compile, ['-v0'])
View Lorry Controller Status