Commit 7ffc59e2 authored by Alex D's avatar Alex D 🍄 Committed by Alex D

Fix #15843 by extending Template Haskell AST for tuples to support sections

parent 217258d0
Pipeline #7730 passed with stages
in 354 minutes and 26 seconds
......@@ -1332,12 +1332,20 @@ repE e@(HsDo _ ctxt (dL->L _ sts))
= notHandled "monad comprehension and [: :]" (ppr e)
repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitTuple _ es boxed)
| not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
| isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
; repTup xs }
| otherwise = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
; repUnboxedTup xs }
repE (ExplicitTuple _ es boxity) =
let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ))
tupArgToCoreExp a
| L _ (Present _ e) <- dL a = do { e' <- repLE e
; coreJust expQTyConName e' }
| otherwise = coreNothing expQTyConName
in do { args <- mapM tupArgToCoreExp es
; expQTy <- lookupType expQTyConName
; let maybeExpQTy = mkTyConApp maybeTyCon [expQTy]
listArg = coreList' maybeExpQTy args
; if isBoxed boxity
then repTup listArg
else repUnboxedTup listArg }
repE (ExplicitSum _ alt arity e)
= do { e1 <- repLE e
......@@ -2077,10 +2085,10 @@ repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
repLamCase (MkC ms) = rep2 lamCaseEName [ms]
repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)
repTup (MkC es) = rep2 tupEName [es]
repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repUnboxedTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)
repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
......
......@@ -891,17 +891,11 @@ cvtl e = wrapL (cvt e)
; return $ HsLamCase noExt
(mkMatchGroup FromSource ms')
}
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
-- Note [Dropping constructors]
-- Singleton tuples treated like nothing (just parens)
cvt (TupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple noExt
(map (noLoc . (Present noExt)) es')
Boxed }
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple noExt
(map (noLoc . (Present noExt)) es')
Unboxed }
cvt (TupE es) = cvt_tup es Boxed
cvt (UnboxedTupE es) = cvt_tup es Unboxed
cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
; unboxedSumChecks alt arity
; return $ ExplicitSum noExt
......@@ -1013,6 +1007,15 @@ cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x
cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup es boxity = do { let cvtl_maybe Nothing = return missingTupArg
cvtl_maybe (Just e) = fmap (Present noExt) (cvtl e)
; es' <- mapM cvtl_maybe es
; return $ ExplicitTuple
noExt
(map noLoc es')
boxity }
{- Note [Operator assocation]
We must be quite careful about adding parens:
* Infix (UInfix ...) op arg Needs parens round the first arg
......
......@@ -151,6 +151,9 @@ import Language.Haskell.TH.Lib.Internal hiding
, derivClause
, standaloneDerivWithStrategyD
, tupE
, unboxedTupE
, Role
, InjectivityAnn
)
......@@ -319,3 +322,12 @@ mkBytes
-> Word -- ^ Number of bytes
-> Bytes
mkBytes = Bytes
-------------------------------------------------------------------------------
-- * Tuple expressions
tupE :: [ExpQ] -> ExpQ
tupE es = do { es1 <- sequence es; return (TupE $ map Just es1)}
unboxedTupE :: [ExpQ] -> ExpQ
unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE $ map Just es1)}
......@@ -286,11 +286,11 @@ lam1E p e = lamE [p] e
lamCaseE :: [MatchQ] -> ExpQ
lamCaseE ms = sequence ms >>= return . LamCaseE
tupE :: [ExpQ] -> ExpQ
tupE es = do { es1 <- sequence es; return (TupE es1)}
tupE :: [Maybe ExpQ] -> ExpQ
tupE es = do { es1 <- traverse sequence es; return (TupE es1)}
unboxedTupE :: [ExpQ] -> ExpQ
unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
unboxedTupE :: [Maybe ExpQ] -> ExpQ
unboxedTupE es = do { es1 <- traverse sequence es; return (UnboxedTupE es1)}
unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ
unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) }
......
......@@ -150,8 +150,8 @@ pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat ap
<+> text "->" <+> ppr e
pprExp i (LamCaseE ms) = parensIf (i > noPrec)
$ text "\\case" $$ nest nestDepth (ppr ms)
pprExp _ (TupE es) = parens (commaSep es)
pprExp _ (UnboxedTupE es) = hashParens (commaSep es)
pprExp _ (TupE es) = parens (commaSepWith (pprMaybeExp noPrec) es)
pprExp _ (UnboxedTupE es) = hashParens (commaSepWith (pprMaybeExp noPrec) es)
pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity
-- Nesting in Cond is to avoid potential problems in do statements
pprExp i (CondE guard true false)
......
......@@ -846,35 +846,38 @@ instance Lift () where
instance (Lift a, Lift b) => Lift (a, b) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b)
= liftM TupE $ sequence [lift a, lift b]
= liftM TupE $ sequence $ map (fmap Just) [lift a, lift b]
instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b, c)
= liftM TupE $ sequence [lift a, lift b, lift c]
= liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c]
instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b, c, d)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d]
= liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c, lift d]
instance (Lift a, Lift b, Lift c, Lift d, Lift e)
=> Lift (a, b, c, d, e) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b, c, d, e)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]
= liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b
, lift c, lift d, lift e ]
instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
=> Lift (a, b, c, d, e, f) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b, c, d, e, f)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
= liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
, lift d, lift e, lift f ]
instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
=> Lift (a, b, c, d, e, f, g) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (a, b, c, d, e, f, g)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
= liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
, lift d, lift e, lift f, lift g ]
-- | @since 2.16.0.0
instance Lift (# #) where
......@@ -885,48 +888,53 @@ instance Lift (# #) where
instance (Lift a) => Lift (# a #) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (# a #)
= liftM UnboxedTupE $ sequence [lift a]
= liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a]
-- | @since 2.16.0.0
instance (Lift a, Lift b) => Lift (# a, b #) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (# a, b #)
= liftM UnboxedTupE $ sequence [lift a, lift b]
= liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b]
-- | @since 2.16.0.0
instance (Lift a, Lift b, Lift c)
=> Lift (# a, b, c #) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (# a, b, c #)
= liftM UnboxedTupE $ sequence [lift a, lift b, lift c]
= liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b, lift c]
-- | @since 2.16.0.0
instance (Lift a, Lift b, Lift c, Lift d)
=> Lift (# a, b, c, d #) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (# a, b, c, d #)
= liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d]
= liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b
, lift c, lift d ]
-- | @since 2.16.0.0
instance (Lift a, Lift b, Lift c, Lift d, Lift e)
=> Lift (# a, b, c, d, e #) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (# a, b, c, d, e #)
= liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e]
= liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b
, lift c, lift d, lift e ]
-- | @since 2.16.0.0
instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
=> Lift (# a, b, c, d, e, f #) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (# a, b, c, d, e, f #)
= liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
= liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
, lift d, lift e, lift f ]
-- | @since 2.16.0.0
instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
=> Lift (# a, b, c, d, e, f, g #) where
liftTyped x = unsafeTExpCoerce (lift x)
lift (# a, b, c, d, e, f, g #)
= liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
= liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
, lift d, lift e, lift f
, lift g ]
-- | @since 2.16.0.0
instance (Lift a, Lift b) => Lift (# a | b #) where
......@@ -1901,8 +1909,28 @@ data Exp
-- See "Language.Haskell.TH.Syntax#infix"
| LamE [Pat] Exp -- ^ @{ \\ p1 p2 -> e }@
| LamCaseE [Match] -- ^ @{ \\case m1; m2 }@
| TupE [Exp] -- ^ @{ (e1,e2) } @
| UnboxedTupE [Exp] -- ^ @{ (\# e1,e2 \#) } @
| TupE [Maybe Exp] -- ^ @{ (e1,e2) } @
--
-- The 'Maybe' is necessary for handling
-- tuple sections.
--
-- > (1,)
--
-- translates to
--
-- > TupE [Just (LitE (IntegerL 1)),Nothing]
| UnboxedTupE [Maybe Exp] -- ^ @{ (\# e1,e2 \#) } @
--
-- The 'Maybe' is necessary for handling
-- tuple sections.
--
-- > (# 'c', #)
--
-- translates to
--
-- > UnboxedTupE [Just (LitE (CharL 'c')),Nothing]
| UnboxedSumE Exp SumAlt SumArity -- ^ @{ (\#|e|\#) }@
| CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@
| MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@
......
......@@ -2,6 +2,11 @@
## 2.16.0.0 *TBA*
* Add support for tuple sections. (#15843) The type signatures of `TupE` and
`UnboxedTupE` have changed from `[Exp] -> Exp` to `[Maybe Exp] -> Exp`.
The type signatures of `tupE` and `unboxedTupE` remain the same for
backwards compatibility.
* Introduce a `liftTyped` method to the `Lift` class and set the default
implementations of `lift` in terms of `liftTyped`.
......
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UnboxedTuples #-}
module Main where
import Language.Haskell.TH
import T15843a
ppr_and_show a = print a >> (putStrLn $ pprint a)
main :: IO ()
main = do
mapM_ (\q -> runQ q >>= ppr_and_show)
[first_of_2, second_of_2, empty_2, full_2, third_of_3]
mapM_ (\q -> runQ (fmap unType q) >>= ppr_and_show)
[first_of_2_T, second_of_2_T]
runQ (fmap unType empty_2_T) >>= ppr_and_show
runQ (fmap unType full_2_T) >>= ppr_and_show
runQ (fmap unType third_of_3_T) >>= ppr_and_show
print $ "(909,) applied to 'c' should be (909, 'c') ===> "
++ (show $ (909, 'c') == ($first_of_2 'c'))
print $ "(,909) applied to False should be (False, 909) ===> "
++ (show $ (False, 909) == ($second_of_2 False))
print $ "(,,909) applied to 606 and True should be (606, True, 909) ===> "
++ (show $ (606, True, 909) == ($third_of_3 606 True))
mapM_ (\q -> runQ q >>= ppr_and_show)
[unb0, unb1, unb2, unb3, unb4]
TupE [Just (LitE (IntegerL 909)),Nothing]
(909,)
TupE [Nothing,Just (LitE (IntegerL 909))]
(, 909)
ConE GHC.Tuple.(,)
GHC.Tuple.(,)
TupE [Just (LitE (IntegerL 909)),Just (LitE (IntegerL 606))]
(909, 606)
TupE [Nothing,Nothing,Just (LitE (IntegerL 909))]
(, , 909)
TupE [Just (LitE (IntegerL 909)),Nothing]
(909,)
TupE [Nothing,Just (LitE (IntegerL 909))]
(, 909)
ConE GHC.Tuple.(,)
GHC.Tuple.(,)
TupE [Just (LitE (IntegerL 909)),Just (LitE (IntegerL 606))]
(909, 606)
TupE [Nothing,Nothing,Just (LitE (IntegerL 909))]
(, , 909)
"(909,) applied to 'c' should be (909, 'c') ===> True"
"(,909) applied to False should be (False, 909) ===> True"
"(,,909) applied to 606 and True should be (606, True, 909) ===> True"
ConE GHC.Prim.(#,#)
GHC.Prim.(#,#)
UnboxedTupE [Just (LitE (CharL 'c')),Just (ConE GHC.Types.False)]
(# 'c', GHC.Types.False #)
UnboxedTupE [Just (LitE (CharL 'c')),Nothing]
(# 'c', #)
UnboxedTupE [Nothing,Just (ConE GHC.Types.False)]
(# , GHC.Types.False #)
AppE (UnboxedTupE [Nothing,Just (ConE GHC.Types.False)]) (LitE (CharL 'c'))
(# , GHC.Types.False #) 'c'
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UnboxedTuples #-}
module T15843a where
import Language.Haskell.TH
first_of_2 = [| (909,) |]
second_of_2 = [| (,909) |]
empty_2 = [| (,) |]
full_2 = [| (909,606) |]
third_of_3 = [| (,,909) |]
first_of_2_T = [|| (909,) ||]
second_of_2_T = [|| (,909) ||]
empty_2_T = [|| (,) ||]
full_2_T = [|| (909,606) ||]
third_of_3_T = [|| (,,909) ||]
unb0 = [| (# , #) |]
unb1 = [| (# 'c', False #) |]
unb2 = [| (# 'c', #) |]
unb3 = [| (# ,False #) |]
unb4 = [| (# ,False #) 'c' |]
......@@ -12,4 +12,4 @@ nestedTuple n = do
xs <- replicateM n (newName "x")
return $ LamE [foldr (\v prev -> ParensP (ConP 'Cons [VarP v,prev]))
(ConP 'Nil []) xs]
(TupE $ map VarE xs)
(TupE $ map (Just . VarE) xs)
CaseE (UnboxedTupE [LitE (CharL 'b'),ConE GHC.Types.False]) [Match (UnboxedTupP [LitP (CharL 'a'),ConP GHC.Types.True []]) (NormalB (UnboxedTupE [LitE (StringL "One"),LitE (IntegerL 1)])) [],Match (UnboxedTupP [LitP (CharL 'b'),ConP GHC.Types.False []]) (NormalB (UnboxedTupE [LitE (StringL "Two"),LitE (IntegerL 2)])) [],Match (UnboxedTupP [WildP,WildP]) (NormalB (UnboxedTupE [LitE (StringL "Three"),LitE (IntegerL 3)])) []]
CaseE (UnboxedTupE [Just (LitE (CharL 'b')),Just (ConE GHC.Types.False)]) [Match (UnboxedTupP [LitP (CharL 'a'),ConP GHC.Types.True []]) (NormalB (UnboxedTupE [Just (LitE (StringL "One")),Just (LitE (IntegerL 1))])) [],Match (UnboxedTupP [LitP (CharL 'b'),ConP GHC.Types.False []]) (NormalB (UnboxedTupE [Just (LitE (StringL "Two")),Just (LitE (IntegerL 2))])) [],Match (UnboxedTupP [WildP,WildP]) (NormalB (UnboxedTupE [Just (LitE (StringL "Three")),Just (LitE (IntegerL 3))])) []]
case (# 'b', GHC.Types.False #) of
(# 'a', GHC.Types.True #) -> (# "One", 1 #)
(# 'b', GHC.Types.False #) -> (# "Two", 2 #)
......
......@@ -461,6 +461,9 @@ test('T15783', normal, multimod_compile,
test('T15792', normal, compile, ['-v0 -dsuppress-uniques'])
test('T15815', normal, multimod_compile,
['T15815B', '-v0 ' + config.ghc_th_way_flags])
test('T15843', [], multimod_compile_and_run,
['T15843.hs',
'-v0 ' + config.ghc_th_way_flags])
test('T15845', normal, compile, ['-v0 -dsuppress-uniques'])
test('T15437', expect_broken(15437), multimod_compile,
['T15437', '-v0 ' + config.ghc_th_way_flags])
......
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