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
repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
tcon <- repTupleTyCon (length tys)
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)
`nlHsAppTy` ty2)
repTy (HsParTy t) = repLTy t
......@@ -1176,6 +1179,10 @@ repE e@(ExplicitTuple es boxed)
| otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
; repUnboxedTup xs }
repE (ExplicitSum alt arity e _)
= do { e1 <- repLE e
; repUnboxedSum e1 alt arity }
repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
= do { x <- lookupLOcc c;
fs <- repFields flds;
......@@ -1584,6 +1591,7 @@ repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e'
repP (TuplePat ps boxed _)
| isBoxed boxed = do { qs <- repLPs ps; repPtup 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)
= do { con_str <- lookupLOcc dc
; case details of
......@@ -1793,6 +1801,14 @@ repPtup (MkC ps) = rep2 tupPName [ps]
repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
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 (MkC s) (MkC ps) = rep2 conPName [s, ps]
......@@ -1849,6 +1865,14 @@ repTup (MkC es) = rep2 tupEName [es]
repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
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 (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
......@@ -2185,6 +2209,11 @@ repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
repUnboxedTupleTyCon i = do dflags <- getDynFlags
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 = rep2 arrowTName []
......
......@@ -771,6 +771,10 @@ cvtl e = wrapL (cvt e)
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple
(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;
; return $ HsIf (Just noSyntaxExpr) x' y' z' }
cvt (MultiIfE alts)
......@@ -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 ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
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
; return $ ConPatIn s' (PrefixCon ps') }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
......@@ -1138,6 +1146,16 @@ cvtTypeKind ty_str ty
| otherwise
-> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Unboxed n))))
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
| [x',y'] <- tys' -> returnL (HsFunTy x' y')
| otherwise -> mk_apps (HsTyVar (noLoc (getRdrName funTyCon))) tys'
......@@ -1348,6 +1366,22 @@ overloadedLit _ = False
cvtFractionalLit :: Rational -> FractionalLit
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
--------------------------------------------------------------------
......
......@@ -38,7 +38,7 @@ templateHaskellNames = [
floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
charPrimLName,
-- Pat
litPName, varPName, tupPName, unboxedTupPName,
litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,
conPName, tildePName, bangPName, infixPName,
asPName, wildPName, recPName, listPName, sigPName, viewPName,
-- FieldPat
......@@ -50,7 +50,7 @@ templateHaskellNames = [
-- Exp
varEName, conEName, litEName, appEName, infixEName,
infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
tupEName, unboxedTupEName,
tupEName, unboxedTupEName, unboxedSumEName,
condEName, multiIfEName, letEName, caseEName, doEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName,
listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
......@@ -93,7 +93,8 @@ templateHaskellNames = [
prefixPatSynName, infixPatSynName, recordPatSynName,
-- Type
forallTName, varTName, conTName, appTName, equalityTName,
tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
tupleTName, unboxedTupleTName, unboxedSumTName,
arrowTName, listTName, sigTName, litTName,
promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
wildCardTName,
-- TyLit
......@@ -236,12 +237,14 @@ stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey
charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey
-- data Pat = ...
litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,
asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name
litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,
infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,
sigPName, viewPName :: Name
litPName = libFun (fsLit "litP") litPIdKey
varPName = libFun (fsLit "varP") varPIdKey
tupPName = libFun (fsLit "tupP") tupPIdKey
unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey
conPName = libFun (fsLit "conP") conPIdKey
infixPName = libFun (fsLit "infixP") infixPIdKey
tildePName = libFun (fsLit "tildeP") tildePIdKey
......@@ -268,8 +271,8 @@ clauseName = libFun (fsLit "clause") clauseIdKey
-- data Exp = ...
varEName, conEName, litEName, appEName, infixEName, infixAppName,
sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
doEName, compEName, staticEName, unboundVarEName :: Name
unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
caseEName, doEName, compEName, staticEName, unboundVarEName :: Name
varEName = libFun (fsLit "varE") varEIdKey
conEName = libFun (fsLit "conE") conEIdKey
litEName = libFun (fsLit "litE") litEIdKey
......@@ -282,6 +285,7 @@ lamEName = libFun (fsLit "lamE") lamEIdKey
lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey
tupEName = libFun (fsLit "tupE") tupEIdKey
unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey
condEName = libFun (fsLit "condE") condEIdKey
multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey
letEName = libFun (fsLit "letE") letEIdKey
......@@ -414,16 +418,16 @@ infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey
recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
-- data Type = ...
forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
listTName, appTName, sigTName, equalityTName, litTName,
promotedTName, promotedTupleTName,
promotedNilTName, promotedConsTName,
wildCardTName :: Name
forallTName, varTName, conTName, tupleTName, unboxedTupleTName,
unboxedSumTName, arrowTName, listTName, appTName, sigTName, equalityTName,
litTName, promotedTName, promotedTupleTName, promotedNilTName,
promotedConsTName, wildCardTName :: Name
forallTName = libFun (fsLit "forallT") forallTIdKey
varTName = libFun (fsLit "varT") varTIdKey
conTName = libFun (fsLit "conT") conTIdKey
tupleTName = libFun (fsLit "tupleT") tupleTIdKey
unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey
unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey
arrowTName = libFun (fsLit "arrowT") arrowTIdKey
listTName = libFun (fsLit "listT") listTIdKey
appTName = libFun (fsLit "appT") appTIdKey
......@@ -727,23 +731,24 @@ liftStringIdKey :: Unique
liftStringIdKey = mkPreludeMiscIdUnique 230
-- data Pat = ...
litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey,
tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, listPIdKey,
sigPIdKey, viewPIdKey :: Unique
litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,
infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,
listPIdKey, sigPIdKey, viewPIdKey :: Unique
litPIdKey = mkPreludeMiscIdUnique 240
varPIdKey = mkPreludeMiscIdUnique 241
tupPIdKey = mkPreludeMiscIdUnique 242
unboxedTupPIdKey = mkPreludeMiscIdUnique 243
conPIdKey = mkPreludeMiscIdUnique 244
infixPIdKey = mkPreludeMiscIdUnique 245
tildePIdKey = mkPreludeMiscIdUnique 246
bangPIdKey = mkPreludeMiscIdUnique 247
asPIdKey = mkPreludeMiscIdUnique 248
wildPIdKey = mkPreludeMiscIdUnique 249
recPIdKey = mkPreludeMiscIdUnique 250
listPIdKey = mkPreludeMiscIdUnique 251
sigPIdKey = mkPreludeMiscIdUnique 252
viewPIdKey = mkPreludeMiscIdUnique 253
unboxedSumPIdKey = mkPreludeMiscIdUnique 244
conPIdKey = mkPreludeMiscIdUnique 245
infixPIdKey = mkPreludeMiscIdUnique 246
tildePIdKey = mkPreludeMiscIdUnique 247
bangPIdKey = mkPreludeMiscIdUnique 248
asPIdKey = mkPreludeMiscIdUnique 249
wildPIdKey = mkPreludeMiscIdUnique 250
recPIdKey = mkPreludeMiscIdUnique 251
listPIdKey = mkPreludeMiscIdUnique 252
sigPIdKey = mkPreludeMiscIdUnique 253
viewPIdKey = mkPreludeMiscIdUnique 254
-- type FieldPat = ...
fieldPatIdKey :: Unique
......@@ -761,7 +766,7 @@ clauseIdKey = mkPreludeMiscIdUnique 262
-- data Exp = ...
varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,
letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
......@@ -778,22 +783,23 @@ lamEIdKey = mkPreludeMiscIdUnique 278
lamCaseEIdKey = mkPreludeMiscIdUnique 279
tupEIdKey = mkPreludeMiscIdUnique 280
unboxedTupEIdKey = mkPreludeMiscIdUnique 281
condEIdKey = mkPreludeMiscIdUnique 282
multiIfEIdKey = mkPreludeMiscIdUnique 283
letEIdKey = mkPreludeMiscIdUnique 284
caseEIdKey = mkPreludeMiscIdUnique 285
doEIdKey = mkPreludeMiscIdUnique 286
compEIdKey = mkPreludeMiscIdUnique 287
fromEIdKey = mkPreludeMiscIdUnique 288
fromThenEIdKey = mkPreludeMiscIdUnique 289
fromToEIdKey = mkPreludeMiscIdUnique 290
fromThenToEIdKey = mkPreludeMiscIdUnique 291
listEIdKey = mkPreludeMiscIdUnique 292
sigEIdKey = mkPreludeMiscIdUnique 293
recConEIdKey = mkPreludeMiscIdUnique 294
recUpdEIdKey = mkPreludeMiscIdUnique 295
staticEIdKey = mkPreludeMiscIdUnique 296
unboundVarEIdKey = mkPreludeMiscIdUnique 297
unboxedSumEIdKey = mkPreludeMiscIdUnique 282
condEIdKey = mkPreludeMiscIdUnique 283
multiIfEIdKey = mkPreludeMiscIdUnique 284
letEIdKey = mkPreludeMiscIdUnique 285
caseEIdKey = mkPreludeMiscIdUnique 286
doEIdKey = mkPreludeMiscIdUnique 287
compEIdKey = mkPreludeMiscIdUnique 288
fromEIdKey = mkPreludeMiscIdUnique 289
fromThenEIdKey = mkPreludeMiscIdUnique 290
fromToEIdKey = mkPreludeMiscIdUnique 291
fromThenToEIdKey = mkPreludeMiscIdUnique 292
listEIdKey = mkPreludeMiscIdUnique 293
sigEIdKey = mkPreludeMiscIdUnique 294
recConEIdKey = mkPreludeMiscIdUnique 295
recUpdEIdKey = mkPreludeMiscIdUnique 296
staticEIdKey = mkPreludeMiscIdUnique 297
unboundVarEIdKey = mkPreludeMiscIdUnique 298
-- type FieldExp = ...
fieldExpIdKey :: Unique
......@@ -907,27 +913,27 @@ infixPatSynIdKey = mkPreludeMiscIdUnique 370
recordPatSynIdKey = mkPreludeMiscIdUnique 371
-- data Type = ...
forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
listTIdKey, appTIdKey, sigTIdKey, equalityTIdKey, litTIdKey,
promotedTIdKey, promotedTupleTIdKey,
promotedNilTIdKey, promotedConsTIdKey,
wildCardTIdKey :: Unique
forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,
equalityTIdKey, litTIdKey, promotedTIdKey, promotedTupleTIdKey,
promotedNilTIdKey, promotedConsTIdKey, wildCardTIdKey :: Unique
forallTIdKey = mkPreludeMiscIdUnique 380
varTIdKey = mkPreludeMiscIdUnique 381
conTIdKey = mkPreludeMiscIdUnique 382
tupleTIdKey = mkPreludeMiscIdUnique 383
unboxedTupleTIdKey = mkPreludeMiscIdUnique 384
arrowTIdKey = mkPreludeMiscIdUnique 385
listTIdKey = mkPreludeMiscIdUnique 386
appTIdKey = mkPreludeMiscIdUnique 387
sigTIdKey = mkPreludeMiscIdUnique 388
equalityTIdKey = mkPreludeMiscIdUnique 389
litTIdKey = mkPreludeMiscIdUnique 390
promotedTIdKey = mkPreludeMiscIdUnique 391
promotedTupleTIdKey = mkPreludeMiscIdUnique 392
promotedNilTIdKey = mkPreludeMiscIdUnique 393
promotedConsTIdKey = mkPreludeMiscIdUnique 394
wildCardTIdKey = mkPreludeMiscIdUnique 395
unboxedSumTIdKey = mkPreludeMiscIdUnique 385
arrowTIdKey = mkPreludeMiscIdUnique 386
listTIdKey = mkPreludeMiscIdUnique 387
appTIdKey = mkPreludeMiscIdUnique 388
sigTIdKey = mkPreludeMiscIdUnique 389
equalityTIdKey = mkPreludeMiscIdUnique 390
litTIdKey = mkPreludeMiscIdUnique 391
promotedTIdKey = mkPreludeMiscIdUnique 392
promotedTupleTIdKey = mkPreludeMiscIdUnique 393
promotedNilTIdKey = mkPreludeMiscIdUnique 394
promotedConsTIdKey = mkPreludeMiscIdUnique 395
wildCardTIdKey = mkPreludeMiscIdUnique 396
-- data TyLit = ...
numTyLitIdKey, strTyLitIdKey :: Unique
......
......@@ -1819,7 +1819,8 @@ reify_tc_app tc tys
tc_binders = tyConBinders 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
| isTupleTyCon tc = if isPromotedDataCon tc
then TH.PromotedTupleT arity
......
......@@ -213,6 +213,8 @@ template-haskell
- Version number XXXXX (was 2.9.0.0)
- Added support for unboxed sums :ghc-ticket:`12478`.
time
~~~~
......
......@@ -24,6 +24,7 @@ module Language.Haskell.TH(
Info(..), ModuleInfo(..),
InstanceDec,
ParentName,
SumAlt, SumArity,
Arity,
Unlifted,
-- *** Language extension lookup
......@@ -95,7 +96,7 @@ module Language.Haskell.TH(
intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,
charL, stringL, stringPrimL, charPrimL,
-- *** Patterns
litP, varP, tupP, conP, uInfixP, parensP, infixP,
litP, varP, tupP, unboxedSumP, conP, uInfixP, parensP, infixP,
tildeP, bangP, asP, wildP, recP,
listP, sigP, viewP,
fieldPat,
......@@ -106,8 +107,8 @@ module Language.Haskell.TH(
-- *** Expressions
dyn, varE, conE, litE, appE, uInfixE, parensE, staticE,
infixE, infixApp, sectionL, sectionR,
lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE,
listE, sigE, recConE, recUpdE, stringE, fieldExp,
lamE, lam1E, lamCaseE, tupE, unboxedSumE, condE, multiIfE, letE, caseE,
appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,
-- **** Ranges
fromE, fromThenE, fromToE, fromThenToE,
......@@ -120,8 +121,8 @@ module Language.Haskell.TH(
-- *** Types
forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT,
listT, tupleT, sigT, litT, promotedT, promotedTupleT, promotedNilT,
promotedConsT,
listT, tupleT, unboxedSumT, sigT, litT, promotedT, promotedTupleT,
promotedNilT, promotedConsT,
-- **** Type literals
numTyLit, strTyLit,
-- **** Strictness
......
......@@ -80,12 +80,19 @@ rationalL = RationalL
litP :: Lit -> PatQ
litP l = return (LitP l)
varP :: Name -> PatQ
varP v = return (VarP v)
tupP :: [PatQ] -> PatQ
tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
unboxedTupP :: [PatQ] -> PatQ
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 n ps = do ps' <- sequence ps
return (ConP n ps')
......@@ -266,6 +273,9 @@ tupE es = do { es1 <- sequence es; return (TupE es1)}
unboxedTupE :: [ExpQ] -> ExpQ
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 x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}
......@@ -627,6 +637,9 @@ tupleT i = return (TupleT i)
unboxedTupleT :: Int -> TypeQ
unboxedTupleT i = return (UnboxedTupleT i)
unboxedSumT :: SumArity -> TypeQ
unboxedSumT arity = return (UnboxedSumT arity)
sigT :: TypeQ -> Kind -> TypeQ
sigT t k
= do
......
......@@ -149,6 +149,7 @@ 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 _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity
-- Nesting in Cond is to avoid potential problems in do statments
pprExp i (CondE guard true false)
= parensIf (i > noPrec) $ sep [text "if" <+> ppr guard,
......@@ -179,7 +180,7 @@ pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
pprExp _ (CompE []) = text "<<Empty CompExp>>"
-- This will probably break with fixity declarations - would need a ';'
pprExp _ (CompE ss) = text "[" <> ppr s
<+> text "|"
<+> bar
<+> commaSep ss'
<> text "]"
where s = last ss
......@@ -205,7 +206,7 @@ instance Ppr Stmt where
ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
ppr (LetS ds) = text "let" <+> (braces (semiSep ds))
ppr (NoBindS e) = ppr e
ppr (ParS sss) = sep $ punctuate (text "|")
ppr (ParS sss) = sep $ punctuate bar
$ map commaSep sss
------------------------------
......@@ -216,8 +217,8 @@ instance Ppr Match where
------------------------------
pprGuarded :: Doc -> (Guard, Exp) -> Doc
pprGuarded eqDoc (guard, expr) = case guard of
NormalG guardExpr -> char '|' <+> ppr guardExpr <+> eqDoc <+> ppr expr
PatG stmts -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$
NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr
PatG stmts -> bar <+> vcat (punctuate comma $ map ppr stmts) $$
nest nestDepth (eqDoc <+> ppr expr)
------------------------------
......@@ -266,6 +267,7 @@ pprPat i (LitP l) = pprLit i l
pprPat _ (VarP v) = pprName' Applied v
pprPat _ (TupP ps) = parens (commaSep ps)
pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)
pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity
pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s
<+> sep (map (pprPat appPrec) ps)
pprPat _ (ParensP p) = parens $ pprPat noPrec p
......@@ -389,7 +391,7 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs
pref :: [Doc] -> [Doc]
pref xs | isGadtDecl = xs
pref [] = [] -- No constructors; can't happen in H98
pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
pref (d:ds) = (char '=' <+> d):map (bar <+>) ds
maybeWhere :: Doc
maybeWhere | isGadtDecl = text "where"
......@@ -436,7 +438,7 @@ ppr_tf_head (TypeFamilyHead tc tvs res inj)
instance Ppr FunDep where
ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
ppr_list [] = empty
ppr_list xs = char '|' <+> commaSep xs
ppr_list xs = bar <+> commaSep xs
------------------------------
instance Ppr FamFlavour where
......@@ -452,7 +454,7 @@ instance Ppr FamilyResultSig where
------------------------------
instance Ppr InjectivityAnn where
ppr (InjectivityAnn lhs rhs) =
char '|' <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)
bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)
------------------------------
instance Ppr Foreign where
......@@ -655,6 +657,7 @@ pprParendType (ConT c) = ppr c
pprParendType (TupleT 0) = text "()"
pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
pprParendType ArrowT = parens (text "->")
pprParendType ListT = text "[]"
pprParendType (LitT l) = pprTyLit l
......@@ -795,3 +798,15 @@ commaSepWith pprFun = sep . punctuate comma . map pprFun
-- followed by space.
semiSep :: Ppr a => [a] -> Doc
semiSep = sep . punctuate semi . map ppr
-- Prints out the series of vertical bars that wraps an expression or pattern
-- used in an unboxed sum.
unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc
unboxedSumBars d alt arity = hashParens $
bars (alt-1) <> d <> bars (arity - alt)
where
bars i = hsep (replicate i bar)
-- Text containing the vertical bar character.
bar :: Doc
bar = char '|'
......@@ -1176,8 +1176,6 @@ mk_unboxed_tup_name n_commas space
occ = mkOccName ("(#" ++ replicate n_commas ',' ++ "#)")
tup_mod = mkModName "GHC.Tuple"
-----------------------------------------------------
-- Locations
-----------------------------------------------------
......@@ -1278,6 +1276,19 @@ In 'ClassOpI' and 'DataConI', name of the parent class or type
-}
type ParentName = Name
-- | In 'UnboxedSumE' and 'UnboxedSumP', the number associated with a
-- particular data constructor. 'SumAlt's are one-indexed and should never
-- exceed the value of its corresponding 'SumArity'. For example:
--
-- * @(\#_|\#)@ has 'SumAlt' 1 (out of a total 'SumArity' of 2)
--
-- * @(\#|_\#)@ has 'SumAlt' 2 (out of a total 'SumArity' of 2)
type SumAlt = Int
-- | In 'UnboxedSumE', 'UnboxedSumT', and 'UnboxedSumP', the total number of
-- 'SumAlt's. For example, @(\#|\#)@ has a 'SumArity' of 2.
type SumArity = Int
-- | In 'PrimTyConI', arity of the type constructor
type Arity = Int
......@@ -1402,6 +1413,7 @@ data Pat
| VarP Name -- ^ @{ x }@
| TupP [Pat] -- ^ @{ (p1,p2) }@
| UnboxedTupP [Pat] -- ^ @{ (\# p1,p2 \#) }@
| UnboxedSumP Pat SumAlt SumArity -- ^ @{ (\#|p|\#) }@
| ConP Name [Pat] -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@
| InfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@
| UInfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@
......@@ -1452,6 +1464,7 @@ data Exp
| LamCaseE [Match] -- ^ @{ \\case m1; m2 }@
| TupE [Exp] -- ^ @{ (e1,e2) } @
| UnboxedTupE [Exp] -- ^ @{ (\# e1,e2 \#) } @
| UnboxedSumE Exp SumAlt SumArity -- ^ @{ (\#|e|\#) }@
| CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@
| MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@
| LetE [Dec] Exp -- ^ @{ let x=e1; y=e2 in e3 }@
......@@ -1804,6 +1817,7 @@ data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> -> \<t
-- See Note [Representing concrete syntax in types]
| TupleT Int -- ^ @(,), (,,), etc.@
| UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@
| UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@
| ArrowT -- ^ @->@
| EqualityT -- ^ @~@
| ListT -- ^ @[]@
......
......@@ -8,6 +8,8 @@
`PatSynSigD`), and two new data types (`PatSynDir` and `PatSynArgs`),
among other changes. (#8761)
* Add support for unboxed sums. (#12478)
## 2.11.0.0 *May 2016*
* Bundled with GHC 8.0.1
......
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedSums #-}
module Main where
import Language.Haskell.TH
data T = T (# Int | Char #)
$(return [])
main :: IO ()
main = putStrLn $(reify ''T >>= stringE . show)
TyConI (DataD [] Main.T [] Nothing [NormalC Main.T [(Bang NoSourceUnpackedness NoSourceStrictness,AppT (AppT (UnboxedSumT 2) (ConT GHC.Types.Int)) (ConT GHC.Types.Char))]] [])
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedSums #-}