Commit b0121209 authored by mikhail.vorozhtsov's avatar mikhail.vorozhtsov Committed by Matthew Pickering

Handle types w/ type variables in signatures inside patterns (DsMeta)

The comment indicated that scoping of type variables was a large problem
but Simon fixed it in e21e13fb.

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
parent 2cdd9bd5
......@@ -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
......
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
module PatternSplice where
foo $( [p| (x :: _) |] ) = x
......@@ -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'])
......
......@@ -2,4 +2,4 @@
{-# LANGUAGE ScopedTypeVariables #-}
module ExtraConstraintsWildcardInPatternSplice where
foo $( [p| (x :: _) |] ) = x
foo $( [p| (_ :: _) |] ) = ()
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)
{-# 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 ()
......
TH_repPatSig.hs:10:3:
Type signatures in patterns not (yet) handled by Template Haskell
x :: Int
{-# LANGUAGE ScopedTypeVariables #-}
module Main
where
import Language.Haskell.TH
$([d| f = \(_ :: Either a b) -> $(sigE (varE 'undefined) (varT ''c)) |])
main :: IO ()
main = return ()
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)) |]
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 []
......@@ -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'])
......
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