diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2016-08-23 14:20:36 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2016-08-23 15:35:18 -0400 |
commit | 613d745523f181991f6f916bbe58082b7970f7e6 (patch) | |
tree | b93c010d19b953271a828eb97fa8fcdb05c2a8c7 | |
parent | 1766bb3cfd1460796c78bd5651f89d53603586f9 (diff) | |
download | haskell-613d745523f181991f6f916bbe58082b7970f7e6.tar.gz |
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
-rw-r--r-- | compiler/deSugar/DsMeta.hs | 29 | ||||
-rw-r--r-- | compiler/hsSyn/Convert.hs | 34 | ||||
-rw-r--r-- | compiler/prelude/THNames.hs | 122 | ||||
-rw-r--r-- | compiler/typecheck/TcSplice.hs | 3 | ||||
-rw-r--r-- | docs/users_guide/8.2.1-notes.rst | 2 | ||||
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH.hs | 11 | ||||
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Lib.hs | 13 | ||||
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Ppr.hs | 29 | ||||
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Syntax.hs | 58 | ||||
-rw-r--r-- | libraries/template-haskell/changelog.md | 2 | ||||
-rw-r--r-- | testsuite/tests/th/T12478_1.hs | 12 | ||||
-rw-r--r-- | testsuite/tests/th/T12478_1.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/th/T12478_2.hs | 20 | ||||
-rw-r--r-- | testsuite/tests/th/T12478_2.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/th/T12478_3.hs | 14 | ||||
-rw-r--r-- | testsuite/tests/th/T12478_4.hs | 8 | ||||
-rw-r--r-- | testsuite/tests/th/T12478_4.stderr | 6 | ||||
-rw-r--r-- | testsuite/tests/th/all.T | 5 |
18 files changed, 277 insertions, 93 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 427a56f479..4dd0789e23 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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 [] diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index ee1f1066bc..c29db585a7 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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 -------------------------------------------------------------------- diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index e3a58cccdd..9ae54332d5 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -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 diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 6e09b99c12..d879e56be1 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -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 diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst index a9b30502d0..f0b931e356 100644 --- a/docs/users_guide/8.2.1-notes.rst +++ b/docs/users_guide/8.2.1-notes.rst @@ -213,6 +213,8 @@ template-haskell - Version number XXXXX (was 2.9.0.0) +- Added support for unboxed sums :ghc-ticket:`12478`. + time ~~~~ diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 5bd610cd76..984bbc6b4f 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -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 diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index d4529e1915..503f6ea84f 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -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 diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index ca74db7e45..49d0e7b0d8 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -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 '|' diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 62bdd10aac..8539e79bd2 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -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 @@ -1398,26 +1409,27 @@ data Lit = CharL Char -- | Pattern in Haskell given in @{}@ data Pat - = LitP Lit -- ^ @{ 5 or \'c\' }@ - | VarP Name -- ^ @{ x }@ - | TupP [Pat] -- ^ @{ (p1,p2) }@ - | UnboxedTupP [Pat] -- ^ @{ (\# p1,p2 \#) }@ - | 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@ - -- - -- See "Language.Haskell.TH.Syntax#infix" - | ParensP Pat -- ^ @{(p)}@ - -- - -- See "Language.Haskell.TH.Syntax#infix" - | TildeP Pat -- ^ @{ ~p }@ - | BangP Pat -- ^ @{ !p }@ - | AsP Name Pat -- ^ @{ x \@ p }@ - | WildP -- ^ @{ _ }@ - | RecP Name [FieldPat] -- ^ @f (Pt { pointx = x }) = g x@ - | ListP [ Pat ] -- ^ @{ [1,2,3] }@ - | SigP Pat Type -- ^ @{ p :: t }@ - | ViewP Exp Pat -- ^ @{ e -> p }@ + = LitP Lit -- ^ @{ 5 or \'c\' }@ + | 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@ + -- + -- See "Language.Haskell.TH.Syntax#infix" + | ParensP Pat -- ^ @{(p)}@ + -- + -- See "Language.Haskell.TH.Syntax#infix" + | TildeP Pat -- ^ @{ ~p }@ + | BangP Pat -- ^ @{ !p }@ + | AsP Name Pat -- ^ @{ x \@ p }@ + | WildP -- ^ @{ _ }@ + | RecP Name [FieldPat] -- ^ @f (Pt { pointx = x }) = g x@ + | ListP [ Pat ] -- ^ @{ [1,2,3] }@ + | SigP Pat Type -- ^ @{ p :: t }@ + | ViewP Exp Pat -- ^ @{ e -> p }@ deriving( Show, Eq, Ord, Data, Generic ) type FieldPat = (Name,Pat) @@ -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 -- ^ @[]@ diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index e9084e27f9..d6f0d46c02 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -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 diff --git a/testsuite/tests/th/T12478_1.hs b/testsuite/tests/th/T12478_1.hs new file mode 100644 index 0000000000..3d2ab1062b --- /dev/null +++ b/testsuite/tests/th/T12478_1.hs @@ -0,0 +1,12 @@ +{-# 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) diff --git a/testsuite/tests/th/T12478_1.stdout b/testsuite/tests/th/T12478_1.stdout new file mode 100644 index 0000000000..8437f925d5 --- /dev/null +++ b/testsuite/tests/th/T12478_1.stdout @@ -0,0 +1 @@ +TyConI (DataD [] Main.T [] Nothing [NormalC Main.T [(Bang NoSourceUnpackedness NoSourceStrictness,AppT (AppT (UnboxedSumT 2) (ConT GHC.Types.Int)) (ConT GHC.Types.Char))]] []) diff --git a/testsuite/tests/th/T12478_2.hs b/testsuite/tests/th/T12478_2.hs new file mode 100644 index 0000000000..bb0a73ba0f --- /dev/null +++ b/testsuite/tests/th/T12478_2.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedSums #-} +-- Essentially the same as TH_repUnboxedTuples, but for unboxed sums +module Main where + +import Language.Haskell.TH + +main :: IO () +main = case bar () of + (# a | #) -> print a + (# | b #) -> print b + +bar :: () -> (# String | Int #) +bar () = $( do e <- [| case (# 'b' | #) of + (# 'a' | #) -> (# "One" | #) + (# 'b' | #) -> (# | 2 #) + (# _ | #) -> (# "Three" | #) + (# | _ #) -> (# | 4 #) + |] + return e ) diff --git a/testsuite/tests/th/T12478_2.stdout b/testsuite/tests/th/T12478_2.stdout new file mode 100644 index 0000000000..0cfbf08886 --- /dev/null +++ b/testsuite/tests/th/T12478_2.stdout @@ -0,0 +1 @@ +2 diff --git a/testsuite/tests/th/T12478_3.hs b/testsuite/tests/th/T12478_3.hs new file mode 100644 index 0000000000..7c84eee50f --- /dev/null +++ b/testsuite/tests/th/T12478_3.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedSums #-} +module T12478_3 where + +import Language.Haskell.TH + +$(do let ubxSum = unboxedSumT 2 `appT` conT ''Int `appT` conT ''Int + x <- newName "x" + y <- newName "y" + + [d| swap :: $(ubxSum) -> $(ubxSum) + swap $(unboxedSumP (varP x) 1 2) = $(unboxedSumE (varE x) 2 2) + swap $(unboxedSumP (varP y) 2 2) = $(unboxedSumE (varE y) 1 2) + |]) diff --git a/testsuite/tests/th/T12478_4.hs b/testsuite/tests/th/T12478_4.hs new file mode 100644 index 0000000000..9017f32bd1 --- /dev/null +++ b/testsuite/tests/th/T12478_4.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedSums #-} +module T12478_4 where + +import Language.Haskell.TH + +f :: $(unboxedSumT 1 `appT` conT ''()) -> Int +f _ = 42 diff --git a/testsuite/tests/th/T12478_4.stderr b/testsuite/tests/th/T12478_4.stderr new file mode 100644 index 0000000000..6a68b3d15a --- /dev/null +++ b/testsuite/tests/th/T12478_4.stderr @@ -0,0 +1,6 @@ + +T12478_4.hs:7:8: error: + • Illegal sum arity: 1 + Sums must have an arity of at least 2 + When splicing a TH type: (# #) GHC.Tuple.() + • In the untyped splice: $(unboxedSumT 1 `appT` conT ''()) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index b05d601670..592e133e7d 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -421,4 +421,9 @@ test('T12130', extra_clean(['T12130a.hi','T12130a.o']), test('T12403', omit_ways(['ghci']), compile_and_run, ['-v0 -ddump-splices -dsuppress-uniques']) test('T12407', omit_ways(['ghci']), compile, ['-v0']) +test('T12478_1', omit_ways(['ghci']), compile_and_run, + ['-v0 -dsuppress-uniques']) +test('T12478_2', omit_ways(['ghci']), compile_and_run, ['-v0']) +test('T12478_3', omit_ways(['ghci']), compile, ['-v0']) +test('T12478_4', omit_ways(['ghci']), compile_fail, ['-v0']) test('T12513', omit_ways(['ghci']), compile_fail, ['-v0']) |