Commit 613d7455 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Template Haskell support for unboxed sums

This adds new constructors `UnboxedSumE`, `UnboxedSumT`, and
`UnboxedSumP` to represent unboxed sums in Template Haskell.

One thing you can't currently do is, e.g., `reify ''(#||#)`, since I
don't believe unboxed sum type/data constructors can be written in
prefix form.  I will look at fixing that as part of #12514.

Fixes #12478.

Test Plan: make test TEST=T12478_{1,2,3}

Reviewers: osa1, goldfire, austin, bgamari

Reviewed By: goldfire, bgamari

Subscribers: thomie

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

GHC Trac Issues: #12478
parent 1766bb3c
...@@ -977,6 +977,9 @@ repTy (HsTupleTy HsUnboxedTuple tys) = do ...@@ -977,6 +977,9 @@ repTy (HsTupleTy HsUnboxedTuple tys) = do
repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
tcon <- repTupleTyCon (length tys) tcon <- repTupleTyCon (length tys)
repTapps tcon tys1 repTapps tcon tys1
repTy (HsSumTy tys) = do tys1 <- repLTys tys
tcon <- repUnboxedSumTyCon (length tys)
repTapps tcon tys1
repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
`nlHsAppTy` ty2) `nlHsAppTy` ty2)
repTy (HsParTy t) = repLTy t repTy (HsParTy t) = repLTy t
...@@ -1176,6 +1179,10 @@ repE e@(ExplicitTuple es boxed) ...@@ -1176,6 +1179,10 @@ repE e@(ExplicitTuple es boxed)
| otherwise = do { xs <- repLEs [e | L _ (Present e) <- es] | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
; repUnboxedTup xs } ; repUnboxedTup xs }
repE (ExplicitSum alt arity e _)
= do { e1 <- repLE e
; repUnboxedSum e1 alt arity }
repE (RecordCon { rcon_con_name = c, rcon_flds = flds }) repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
= do { x <- lookupLOcc c; = do { x <- lookupLOcc c;
fs <- repFields flds; fs <- repFields flds;
...@@ -1584,6 +1591,7 @@ repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' ...@@ -1584,6 +1591,7 @@ repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e'
repP (TuplePat ps boxed _) repP (TuplePat ps boxed _)
| isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
| otherwise = do { qs <- repLPs ps; repPunboxedTup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity }
repP (ConPatIn dc details) repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc = do { con_str <- lookupLOcc dc
; case details of ; case details of
...@@ -1793,6 +1801,14 @@ repPtup (MkC ps) = rep2 tupPName [ps] ...@@ -1793,6 +1801,14 @@ repPtup (MkC ps) = rep2 tupPName [ps]
repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
repPunboxedSum (MkC p) alt arity
= do { dflags <- getDynFlags
; rep2 unboxedSumPName [ p
, mkIntExprInt dflags alt
, mkIntExprInt dflags arity ] }
repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ) repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
...@@ -1849,6 +1865,14 @@ repTup (MkC es) = rep2 tupEName [es] ...@@ -1849,6 +1865,14 @@ repTup (MkC es) = rep2 tupEName [es]
repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
repUnboxedSum (MkC e) alt arity
= do { dflags <- getDynFlags
; rep2 unboxedSumEName [ e
, mkIntExprInt dflags alt
, mkIntExprInt dflags arity ] }
repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
...@@ -2185,6 +2209,11 @@ repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ) ...@@ -2185,6 +2209,11 @@ repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
repUnboxedTupleTyCon i = do dflags <- getDynFlags repUnboxedTupleTyCon i = do dflags <- getDynFlags
rep2 unboxedTupleTName [mkIntExprInt dflags i] rep2 unboxedTupleTName [mkIntExprInt dflags i]
repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
-- Note: not Core TH.SumArity; it's easier to be direct here
repUnboxedSumTyCon arity = do dflags <- getDynFlags
rep2 unboxedSumTName [mkIntExprInt dflags arity]
repArrowTyCon :: DsM (Core TH.TypeQ) repArrowTyCon :: DsM (Core TH.TypeQ)
repArrowTyCon = rep2 arrowTName [] repArrowTyCon = rep2 arrowTName []
......
...@@ -771,6 +771,10 @@ cvtl e = wrapL (cvt e) ...@@ -771,6 +771,10 @@ cvtl e = wrapL (cvt e)
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple ; return $ ExplicitTuple
(map (noLoc . Present) es') Unboxed } (map (noLoc . Present) es') Unboxed }
cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
; unboxedSumChecks alt arity
; return $ ExplicitSum
alt arity e' placeHolderType }
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
; return $ HsIf (Just noSyntaxExpr) x' y' z' } ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
cvt (MultiIfE alts) cvt (MultiIfE alts)
...@@ -1045,6 +1049,10 @@ cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') } ...@@ -1045,6 +1049,10 @@ cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }
cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors] cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] } cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] } cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
cvtp (UnboxedSumP p alt arity)
= do { p' <- cvtPat p
; unboxedSumChecks alt arity
; return $ SumPat p' alt arity placeHolderType }
cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
; return $ ConPatIn s' (PrefixCon ps') } ; return $ ConPatIn s' (PrefixCon ps') }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
...@@ -1138,6 +1146,16 @@ cvtTypeKind ty_str ty ...@@ -1138,6 +1146,16 @@ cvtTypeKind ty_str ty
| otherwise | otherwise
-> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Unboxed n)))) -> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Unboxed n))))
tys' tys'
UnboxedSumT n
| n < 2
-> failWith $
vcat [ text "Illegal sum arity:" <+> text (show n)
, nest 2 $
text "Sums must have an arity of at least 2" ]
| length tys' == n -- Saturated
-> returnL (HsSumTy tys')
| otherwise
-> mk_apps (HsTyVar (noLoc (getRdrName (sumTyCon n)))) tys'
ArrowT ArrowT
| [x',y'] <- tys' -> returnL (HsFunTy x' y') | [x',y'] <- tys' -> returnL (HsFunTy x' y')
| otherwise -> mk_apps (HsTyVar (noLoc (getRdrName funTyCon))) tys' | otherwise -> mk_apps (HsTyVar (noLoc (getRdrName funTyCon))) tys'
...@@ -1348,6 +1366,22 @@ overloadedLit _ = False ...@@ -1348,6 +1366,22 @@ overloadedLit _ = False
cvtFractionalLit :: Rational -> FractionalLit cvtFractionalLit :: Rational -> FractionalLit
cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r } cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
-- Checks that are performed when converting unboxed sum expressions and
-- patterns alike.
unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
unboxedSumChecks alt arity
| alt > arity
= failWith $ text "Sum alternative" <+> text (show alt)
<+> text "exceeds its arity," <+> text (show arity)
| alt <= 0
= failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)
, nest 2 $ text "Sum alternatives must start from 1" ]
| arity < 2
= failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)
, nest 2 $ text "Sums must have an arity of at least 2" ]
| otherwise
= return ()
-------------------------------------------------------------------- --------------------------------------------------------------------
-- Turning Name back into RdrName -- Turning Name back into RdrName
-------------------------------------------------------------------- --------------------------------------------------------------------
......
...@@ -38,7 +38,7 @@ templateHaskellNames = [ ...@@ -38,7 +38,7 @@ templateHaskellNames = [
floatPrimLName, doublePrimLName, rationalLName, stringPrimLName, floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
charPrimLName, charPrimLName,
-- Pat -- Pat
litPName, varPName, tupPName, unboxedTupPName, litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,
conPName, tildePName, bangPName, infixPName, conPName, tildePName, bangPName, infixPName,
asPName, wildPName, recPName, listPName, sigPName, viewPName, asPName, wildPName, recPName, listPName, sigPName, viewPName,
-- FieldPat -- FieldPat
...@@ -50,7 +50,7 @@ templateHaskellNames = [ ...@@ -50,7 +50,7 @@ templateHaskellNames = [
-- Exp -- Exp
varEName, conEName, litEName, appEName, infixEName, varEName, conEName, litEName, appEName, infixEName,
infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
tupEName, unboxedTupEName, tupEName, unboxedTupEName, unboxedSumEName,
condEName, multiIfEName, letEName, caseEName, doEName, compEName, condEName, multiIfEName, letEName, caseEName, doEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName, fromEName, fromThenEName, fromToEName, fromThenToEName,
listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
...@@ -93,7 +93,8 @@ templateHaskellNames = [ ...@@ -93,7 +93,8 @@ templateHaskellNames = [
prefixPatSynName, infixPatSynName, recordPatSynName, prefixPatSynName, infixPatSynName, recordPatSynName,
-- Type -- Type
forallTName, varTName, conTName, appTName, equalityTName, forallTName, varTName, conTName, appTName, equalityTName,
tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName, tupleTName, unboxedTupleTName, unboxedSumTName,
arrowTName, listTName, sigTName, litTName,
promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
wildCardTName, wildCardTName,
-- TyLit -- TyLit
...@@ -236,12 +237,14 @@ stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey ...@@ -236,12 +237,14 @@ stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey
charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey
-- data Pat = ... -- data Pat = ...
litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName, litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,
asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,
sigPName, viewPName :: Name
litPName = libFun (fsLit "litP") litPIdKey litPName = libFun (fsLit "litP") litPIdKey
varPName = libFun (fsLit "varP") varPIdKey varPName = libFun (fsLit "varP") varPIdKey
tupPName = libFun (fsLit "tupP") tupPIdKey tupPName = libFun (fsLit "tupP") tupPIdKey
unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey
conPName = libFun (fsLit "conP") conPIdKey conPName = libFun (fsLit "conP") conPIdKey
infixPName = libFun (fsLit "infixP") infixPIdKey infixPName = libFun (fsLit "infixP") infixPIdKey
tildePName = libFun (fsLit "tildeP") tildePIdKey tildePName = libFun (fsLit "tildeP") tildePIdKey
...@@ -268,8 +271,8 @@ clauseName = libFun (fsLit "clause") clauseIdKey ...@@ -268,8 +271,8 @@ clauseName = libFun (fsLit "clause") clauseIdKey
-- data Exp = ... -- data Exp = ...
varEName, conEName, litEName, appEName, infixEName, infixAppName, varEName, conEName, litEName, appEName, infixEName, infixAppName,
sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
unboxedTupEName, condEName, multiIfEName, letEName, caseEName, unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
doEName, compEName, staticEName, unboundVarEName :: Name caseEName, doEName, compEName, staticEName, unboundVarEName :: Name
varEName = libFun (fsLit "varE") varEIdKey varEName = libFun (fsLit "varE") varEIdKey
conEName = libFun (fsLit "conE") conEIdKey conEName = libFun (fsLit "conE") conEIdKey
litEName = libFun (fsLit "litE") litEIdKey litEName = libFun (fsLit "litE") litEIdKey
...@@ -282,6 +285,7 @@ lamEName = libFun (fsLit "lamE") lamEIdKey ...@@ -282,6 +285,7 @@ lamEName = libFun (fsLit "lamE") lamEIdKey
lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey
tupEName = libFun (fsLit "tupE") tupEIdKey tupEName = libFun (fsLit "tupE") tupEIdKey
unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey
condEName = libFun (fsLit "condE") condEIdKey condEName = libFun (fsLit "condE") condEIdKey
multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey
letEName = libFun (fsLit "letE") letEIdKey letEName = libFun (fsLit "letE") letEIdKey
...@@ -414,16 +418,16 @@ infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey ...@@ -414,16 +418,16 @@ infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey
recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
-- data Type = ... -- data Type = ...
forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName, forallTName, varTName, conTName, tupleTName, unboxedTupleTName,
listTName, appTName, sigTName, equalityTName, litTName, unboxedSumTName, arrowTName, listTName, appTName, sigTName, equalityTName,
promotedTName, promotedTupleTName, litTName, promotedTName, promotedTupleTName, promotedNilTName,
promotedNilTName, promotedConsTName, promotedConsTName, wildCardTName :: Name
wildCardTName :: Name
forallTName = libFun (fsLit "forallT") forallTIdKey forallTName = libFun (fsLit "forallT") forallTIdKey
varTName = libFun (fsLit "varT") varTIdKey varTName = libFun (fsLit "varT") varTIdKey
conTName = libFun (fsLit "conT") conTIdKey conTName = libFun (fsLit "conT") conTIdKey
tupleTName = libFun (fsLit "tupleT") tupleTIdKey tupleTName = libFun (fsLit "tupleT") tupleTIdKey
unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey
unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey
arrowTName = libFun (fsLit "arrowT") arrowTIdKey arrowTName = libFun (fsLit "arrowT") arrowTIdKey
listTName = libFun (fsLit "listT") listTIdKey listTName = libFun (fsLit "listT") listTIdKey
appTName = libFun (fsLit "appT") appTIdKey appTName = libFun (fsLit "appT") appTIdKey
...@@ -727,23 +731,24 @@ liftStringIdKey :: Unique ...@@ -727,23 +731,24 @@ liftStringIdKey :: Unique
liftStringIdKey = mkPreludeMiscIdUnique 230 liftStringIdKey = mkPreludeMiscIdUnique 230
-- data Pat = ... -- data Pat = ...
litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,
tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, listPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,
sigPIdKey, viewPIdKey :: Unique listPIdKey, sigPIdKey, viewPIdKey :: Unique
litPIdKey = mkPreludeMiscIdUnique 240 litPIdKey = mkPreludeMiscIdUnique 240
varPIdKey = mkPreludeMiscIdUnique 241 varPIdKey = mkPreludeMiscIdUnique 241
tupPIdKey = mkPreludeMiscIdUnique 242 tupPIdKey = mkPreludeMiscIdUnique 242
unboxedTupPIdKey = mkPreludeMiscIdUnique 243 unboxedTupPIdKey = mkPreludeMiscIdUnique 243
conPIdKey = mkPreludeMiscIdUnique 244 unboxedSumPIdKey = mkPreludeMiscIdUnique 244
infixPIdKey = mkPreludeMiscIdUnique 245 conPIdKey = mkPreludeMiscIdUnique 245
tildePIdKey = mkPreludeMiscIdUnique 246 infixPIdKey = mkPreludeMiscIdUnique 246
bangPIdKey = mkPreludeMiscIdUnique 247 tildePIdKey = mkPreludeMiscIdUnique 247
asPIdKey = mkPreludeMiscIdUnique 248 bangPIdKey = mkPreludeMiscIdUnique 248
wildPIdKey = mkPreludeMiscIdUnique 249 asPIdKey = mkPreludeMiscIdUnique 249
recPIdKey = mkPreludeMiscIdUnique 250 wildPIdKey = mkPreludeMiscIdUnique 250
listPIdKey = mkPreludeMiscIdUnique 251 recPIdKey = mkPreludeMiscIdUnique 251
sigPIdKey = mkPreludeMiscIdUnique 252 listPIdKey = mkPreludeMiscIdUnique 252
viewPIdKey = mkPreludeMiscIdUnique 253 sigPIdKey = mkPreludeMiscIdUnique 253
viewPIdKey = mkPreludeMiscIdUnique 254
-- type FieldPat = ... -- type FieldPat = ...
fieldPatIdKey :: Unique fieldPatIdKey :: Unique
...@@ -761,7 +766,7 @@ clauseIdKey = mkPreludeMiscIdUnique 262 ...@@ -761,7 +766,7 @@ clauseIdKey = mkPreludeMiscIdUnique 262
-- data Exp = ... -- data Exp = ...
varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
unboxedTupEIdKey, condEIdKey, multiIfEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,
letEIdKey, caseEIdKey, doEIdKey, compEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey, listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
...@@ -778,22 +783,23 @@ lamEIdKey = mkPreludeMiscIdUnique 278 ...@@ -778,22 +783,23 @@ lamEIdKey = mkPreludeMiscIdUnique 278
lamCaseEIdKey = mkPreludeMiscIdUnique 279 lamCaseEIdKey = mkPreludeMiscIdUnique 279
tupEIdKey = mkPreludeMiscIdUnique 280 tupEIdKey = mkPreludeMiscIdUnique 280
unboxedTupEIdKey = mkPreludeMiscIdUnique 281 unboxedTupEIdKey = mkPreludeMiscIdUnique 281
condEIdKey = mkPreludeMiscIdUnique 282 unboxedSumEIdKey = mkPreludeMiscIdUnique 282
multiIfEIdKey = mkPreludeMiscIdUnique 283 condEIdKey = mkPreludeMiscIdUnique 283
letEIdKey = mkPreludeMiscIdUnique 284 multiIfEIdKey = mkPreludeMiscIdUnique 284
caseEIdKey = mkPreludeMiscIdUnique 285 letEIdKey = mkPreludeMiscIdUnique 285
doEIdKey = mkPreludeMiscIdUnique 286 caseEIdKey = mkPreludeMiscIdUnique 286
compEIdKey = mkPreludeMiscIdUnique 287 doEIdKey = mkPreludeMiscIdUnique 287
fromEIdKey = mkPreludeMiscIdUnique 288 compEIdKey = mkPreludeMiscIdUnique 288
fromThenEIdKey = mkPreludeMiscIdUnique 289 fromEIdKey = mkPreludeMiscIdUnique 289
fromToEIdKey = mkPreludeMiscIdUnique 290 fromThenEIdKey = mkPreludeMiscIdUnique 290
fromThenToEIdKey = mkPreludeMiscIdUnique 291 fromToEIdKey = mkPreludeMiscIdUnique 291
listEIdKey = mkPreludeMiscIdUnique 292 fromThenToEIdKey = mkPreludeMiscIdUnique 292
sigEIdKey = mkPreludeMiscIdUnique 293 listEIdKey = mkPreludeMiscIdUnique 293
recConEIdKey = mkPreludeMiscIdUnique 294 sigEIdKey = mkPreludeMiscIdUnique 294
recUpdEIdKey = mkPreludeMiscIdUnique 295 recConEIdKey = mkPreludeMiscIdUnique 295
staticEIdKey = mkPreludeMiscIdUnique 296 recUpdEIdKey = mkPreludeMiscIdUnique 296
unboundVarEIdKey = mkPreludeMiscIdUnique 297 staticEIdKey = mkPreludeMiscIdUnique 297
unboundVarEIdKey = mkPreludeMiscIdUnique 298
-- type FieldExp = ... -- type FieldExp = ...
fieldExpIdKey :: Unique fieldExpIdKey :: Unique
...@@ -907,27 +913,27 @@ infixPatSynIdKey = mkPreludeMiscIdUnique 370 ...@@ -907,27 +913,27 @@ infixPatSynIdKey = mkPreludeMiscIdUnique 370
recordPatSynIdKey = mkPreludeMiscIdUnique 371 recordPatSynIdKey = mkPreludeMiscIdUnique 371
-- data Type = ... -- data Type = ...
forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey, forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
listTIdKey, appTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,
promotedTIdKey, promotedTupleTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey, promotedTupleTIdKey,
promotedNilTIdKey, promotedConsTIdKey, promotedNilTIdKey, promotedConsTIdKey, wildCardTIdKey :: Unique
wildCardTIdKey :: Unique
forallTIdKey = mkPreludeMiscIdUnique 380 forallTIdKey = mkPreludeMiscIdUnique 380
varTIdKey = mkPreludeMiscIdUnique 381 varTIdKey = mkPreludeMiscIdUnique 381
conTIdKey = mkPreludeMiscIdUnique 382 conTIdKey = mkPreludeMiscIdUnique 382
tupleTIdKey = mkPreludeMiscIdUnique 383 tupleTIdKey = mkPreludeMiscIdUnique 383
unboxedTupleTIdKey = mkPreludeMiscIdUnique 384 unboxedTupleTIdKey = mkPreludeMiscIdUnique 384
arrowTIdKey = mkPreludeMiscIdUnique 385 unboxedSumTIdKey = mkPreludeMiscIdUnique 385
listTIdKey = mkPreludeMiscIdUnique 386 arrowTIdKey = mkPreludeMiscIdUnique 386
appTIdKey = mkPreludeMiscIdUnique 387 listTIdKey = mkPreludeMiscIdUnique 387
sigTIdKey = mkPreludeMiscIdUnique 388 appTIdKey = mkPreludeMiscIdUnique 388
equalityTIdKey = mkPreludeMiscIdUnique 389 sigTIdKey = mkPreludeMiscIdUnique 389
litTIdKey = mkPreludeMiscIdUnique 390 equalityTIdKey = mkPreludeMiscIdUnique 390
promotedTIdKey = mkPreludeMiscIdUnique 391 litTIdKey = mkPreludeMiscIdUnique 391
promotedTupleTIdKey = mkPreludeMiscIdUnique 392 promotedTIdKey = mkPreludeMiscIdUnique 392
promotedNilTIdKey = mkPreludeMiscIdUnique 393 promotedTupleTIdKey = mkPreludeMiscIdUnique 393
promotedConsTIdKey = mkPreludeMiscIdUnique 394 promotedNilTIdKey = mkPreludeMiscIdUnique 394
wildCardTIdKey = mkPreludeMiscIdUnique 395 promotedConsTIdKey = mkPreludeMiscIdUnique 395
wildCardTIdKey = mkPreludeMiscIdUnique 396
-- data TyLit = ... -- data TyLit = ...
numTyLitIdKey, strTyLitIdKey :: Unique numTyLitIdKey, strTyLitIdKey :: Unique
......
...@@ -1819,7 +1819,8 @@ reify_tc_app tc tys ...@@ -1819,7 +1819,8 @@ reify_tc_app tc tys
tc_binders = tyConBinders tc tc_binders = tyConBinders tc
tc_res_kind = tyConResKind tc tc_res_kind = tyConResKind tc
r_tc | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2)
| isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2)
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
| isTupleTyCon tc = if isPromotedDataCon tc | isTupleTyCon tc = if isPromotedDataCon tc
then TH.PromotedTupleT arity then TH.PromotedTupleT arity
......
...@@ -213,6 +213,8 @@ template-haskell ...@@ -213,6 +213,8 @@ template-haskell
- Version number XXXXX (was 2.9.0.0) - Version number XXXXX (was 2.9.0.0)
- Added support for unboxed sums :ghc-ticket:`12478`.
time time
~~~~ ~~~~
......
...@@ -24,6 +24,7 @@ module Language.Haskell.TH( ...@@ -24,6 +24,7 @@ module Language.Haskell.TH(
Info(..), ModuleInfo(..), Info(..), ModuleInfo(..),
InstanceDec, InstanceDec,
ParentName, ParentName,
SumAlt, SumArity,
Arity, Arity,
Unlifted, Unlifted,
-- *** Language extension lookup -- *** Language extension lookup
...@@ -95,7 +96,7 @@ module Language.Haskell.TH( ...@@ -95,7 +96,7 @@ module Language.Haskell.TH(
intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL, intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,
charL, stringL, stringPrimL, charPrimL, charL, stringL, stringPrimL, charPrimL,
-- *** Patterns -- *** Patterns
litP, varP, tupP, conP, uInfixP, parensP, infixP, litP, varP, tupP, unboxedSumP, conP, uInfixP, parensP, infixP,
tildeP, bangP, asP, wildP, recP, tildeP, bangP, asP, wildP, recP,
listP, sigP, viewP, listP, sigP, viewP,
fieldPat, fieldPat,
...@@ -106,8 +107,8 @@ module Language.Haskell.TH( ...@@ -106,8 +107,8 @@ module Language.Haskell.TH(
-- *** Expressions -- *** Expressions
dyn, varE, conE, litE, appE, uInfixE, parensE, staticE, dyn, varE, conE, litE, appE, uInfixE, parensE, staticE,
infixE, infixApp, sectionL, sectionR, infixE, infixApp, sectionL, sectionR,
lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE, lamE, lam1E, lamCaseE, tupE, unboxedSumE, condE, multiIfE, letE, caseE,
listE, sigE, recConE, recUpdE, stringE, fieldExp, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,
-- **** Ranges -- **** Ranges
fromE, fromThenE, fromToE, fromThenToE, fromE, fromThenE, fromToE, fromThenToE,
...@@ -120,8 +121,8 @@ module Language.Haskell.TH( ...@@ -120,8 +121,8 @@ module Language.Haskell.TH(
-- *** Types -- *** Types
forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT, forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT,
listT, tupleT, sigT, litT, promotedT, promotedTupleT, promotedNilT, listT, tupleT, unboxedSumT, sigT, litT, promotedT, promotedTupleT,
promotedConsT, promotedNilT, promotedConsT,
-- **** Type literals -- **** Type literals
numTyLit, strTyLit, numTyLit, strTyLit,
-- **** Strictness -- **** Strictness
......
...@@ -80,12 +80,19 @@ rationalL = RationalL ...@@ -80,12 +80,19 @@ rationalL = RationalL
litP :: Lit -> PatQ litP :: Lit -> PatQ
litP l = return (LitP l) litP l = return (LitP l)
varP :: Name -> PatQ varP :: Name -> PatQ
varP v = return (VarP v) varP v = return (VarP v)
tupP :: [PatQ] -> PatQ tupP :: [PatQ] -> PatQ
tupP ps = do { ps1 <- sequence ps; return (TupP ps1)} tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
unboxedTupP :: [PatQ] -> PatQ unboxedTupP :: [PatQ] -> PatQ
unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)} unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}
unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ
unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) }
conP :: Name -> [PatQ] -> PatQ conP :: Name -> [PatQ] -> PatQ
conP n ps = do ps' <- sequence ps conP n ps = do ps' <- sequence ps
return (ConP n ps') return (ConP n ps')
...@@ -266,6 +273,9 @@ tupE es = do { es1 <- sequence es; return (TupE es1)} ...@@ -266,6 +273,9 @@ tupE es = do { es1 <- sequence es; return (TupE es1)}
unboxedTupE :: [ExpQ] -> ExpQ unboxedTupE :: [ExpQ] -> ExpQ
unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)} unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ
unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) }
condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)} condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}
...@@ -627,6 +637,9 @@ tupleT i = return (TupleT i) ...@@ -627,6 +637,9 @@ tupleT i = return (TupleT i)
unboxedTupleT :: Int -> TypeQ unboxedTupleT :: Int -> TypeQ
unboxedTupleT i = return (UnboxedTupleT i) unboxedTupleT i = return (UnboxedTupleT i)
unboxedSumT :: SumArity -> TypeQ
unboxedSumT arity = return (UnboxedSumT arity)
sigT :: TypeQ -> Kind -> TypeQ sigT :: TypeQ -> Kind -> TypeQ
sigT t k sigT t k
= do = do
......
...@@ -149,6 +149,7 @@ pprExp i (LamCaseE ms) = parensIf (i > noPrec) ...@@ -149,6 +149,7 @@ pprExp i (LamCaseE ms) = parensIf (i > noPrec)
$ text "\\case" $$ nest nestDepth (ppr ms) $ text "\\case" $$ nest nestDepth (ppr ms)
pprExp _ (TupE es) = parens (commaSep es) pprExp _ (TupE es) = parens (commaSep es)
pprExp _ (UnboxedTupE es) = hashParens (commaSep es) pprExp _ (UnboxedTupE es) = hashParens (commaSep es)