Handle types w/ type variables in signatures inside patterns (DsMeta)
authorMikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>
Sat, 5 Nov 2016 22:06:39 +0000 (22:06 +0000)
committerMatthew Pickering <matthewtpickering@gmail.com>
Sat, 5 Nov 2016 22:07:30 +0000 (22:07 +0000)
The comment indicated that scoping of type variables was a large problem
but Simon fixed it in e21e13fb52b99b14770cc5857df57bbcc9c85102.

Thus, we can implement repP for signatures very easily in the usual way
now.

Reviewers: goldfire, simonpj, austin, bgamari

Reviewed By: simonpj

Subscribers: mpickering, simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D2490

GHC Trac Issues: #12164

compiler/deSugar/DsMeta.hs
testsuite/tests/partial-sigs/should_compile/PatternSplice.hs [new file with mode: 0644]
testsuite/tests/partial-sigs/should_compile/all.T
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.hs
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr
testsuite/tests/th/TH_repPatSig.hs
testsuite/tests/th/TH_repPatSig.stderr [deleted file]
testsuite/tests/th/TH_repPatSigTVar.hs [new file with mode: 0644]
testsuite/tests/th/TH_repPatSigTVar.stderr [new file with mode: 0644]
testsuite/tests/th/TH_repPatSig_asserts.hs [new file with mode: 0644]
testsuite/tests/th/all.T

index d8fdb54..6b40a04 100644 (file)
@@ -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 (file)
index 0000000..710a861
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module PatternSplice where
+
+foo $( [p| (x :: _) |] ) = x
index 17c769e..d2c6836 100644 (file)
@@ -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'])
index 1015fd5..39740c4 100644 (file)
@@ -2,4 +2,4 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module ExtraConstraintsWildcardInPatternSplice where
 
-foo $( [p| (x :: _) |] ) = x
+foo $( [p| (_ :: _) |] ) = ()
index 784f437..d1f5270 100644 (file)
@@ -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)
index 3f504ff..47aee26 100644 (file)
@@ -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 (file)
index 7269068..0000000
+++ /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 (file)
index 0000000..53f896b
--- /dev/null
@@ -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 (file)
index 0000000..fb02dd9
--- /dev/null
@@ -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 (file)
index 0000000..42ade65
--- /dev/null
@@ -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 []
index 4f21121..e0a97fa 100644 (file)
@@ -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'])