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 /compiler/hsSyn/Convert.hs | |
| 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
Diffstat (limited to 'compiler/hsSyn/Convert.hs')
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 34 |
1 files changed, 34 insertions, 0 deletions
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 -------------------------------------------------------------------- |