From d6b0d56816a77107bfae90f6259dec4995258a8f Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sat, 30 Apr 2022 11:24:53 -0400 Subject: [PATCH] Support \cases We desugar `\cases` expressions to ordinary lambda expressions, much like `\case` expressions are currently desguared. Addresses one part of #157. --- CHANGES.md | 3 ++ Language/Haskell/TH/Desugar/Core.hs | 44 +++++++++++++++++++++++------ Test/Run.hs | 1 + Test/Splices.hs | 5 ++++ 4 files changed, 45 insertions(+), 8 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 76a2b10..f9d81d5 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -18,6 +18,9 @@ Version 1.14 [????.??.??] desugar a `UInfixT` would be. * `th-desugar` now supports `DefaultD` (i.e., `default` declarations) and `OpaqueP` (i.e., `OPAQUE` pragmas), which were added in GHC 9.4. +* `th-desugar` now desugars `LamCasesE` (i.e., `\cases` expressions), which was + added in GHC 9.4. A `\cases` expression is desugared to an ordinary lambda + expression, much like `\case` is currently desugared. * Fix an inconsistency which caused non-exhaustive `case` expressions to be desugared into uses of `EmptyCase`. Non-exhaustive `case` expressions are now desugared into code that throws a "`Non-exhaustive patterns in...`" error at diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs index 16f1bee..189d366 100644 --- a/Language/Haskell/TH/Desugar/Core.hs +++ b/Language/Haskell/TH/Desugar/Core.hs @@ -247,6 +247,35 @@ dsExp (ProjectionE fields) = comp :: DExp -> String -> DExp comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc #endif +#if __GLASGOW_HASKELL__ >= 903 +dsExp (LamCasesE clauses) = do + clauses' <- dsClauses CaseAlt clauses + numArgs <- + case clauses' of + (DClause pats _:_) -> return $ length pats + [] -> fail "\\cases expression must have at least one alternative" + args <- replicateM numArgs (newUniqueName "x") + return $ DLamE args $ DCaseE (mkUnboxedTupleDExp (map DVarE args)) + (map dClauseToUnboxedTupleMatch clauses') +#endif + +-- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns +-- into a match on a single unboxed tuple pattern. That is, convert this: +-- +-- @ +-- f x y z = rhs +-- @ +-- +-- To this: +-- +-- @ +-- f (# x, y, z #) = rhs +-- @ +-- +-- This is used to desugar @\\cases@ expressions into lambda expressions. +dClauseToUnboxedTupleMatch :: DClause -> DMatch +dClauseToUnboxedTupleMatch (DClause pats rhs) = + DMatch (mkUnboxedTupleDPat pats) rhs #if __GLASGOW_HASKELL__ >= 809 dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp @@ -844,7 +873,7 @@ dsLetDecs decs = do -- 'DLetDec's to support parallel assignment of implicit params. dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp) dsLetDec (FunD name clauses) = do - clauses' <- dsClauses name clauses + clauses' <- dsClauses (FunRhs name) clauses return ([DFunD name clauses'], id) dsLetDec (ValD pat body where_decs) = do (pat', vars) <- dsPatX pat @@ -1042,19 +1071,19 @@ dsTySynEqn n (TySynEqn lhss rhs) = do -- | Desugar clauses to a function definition dsClauses :: DsMonad q - => Name -- ^ Name of the function + => MatchContext -- ^ The context in which the clauses arise -> [Clause] -- ^ Clauses to desugar -> q [DClause] dsClauses _ [] = return [] -dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do +dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do -- this case is necessary to maintain the roundtrip property. - rest' <- dsClauses n rest + rest' <- dsClauses mc rest exp' <- dsExp exp (where_decs', ip_binder) <- dsLetDecs where_decs let exp_with_wheres = maybeDLetE where_decs' (ip_binder exp') (pats', exp'') <- dsPatsOverExp pats exp_with_wheres return $ DClause pats' exp'' : rest' -dsClauses n clauses@(Clause outer_pats _ _ : _) = do +dsClauses mc clauses@(Clause outer_pats _ _ : _) = do arg_names <- replicateM (length outer_pats) (newUniqueName "arg") let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names) clause <- DClause (map DVarP arg_names) <$> @@ -1063,8 +1092,7 @@ dsClauses n clauses@(Clause outer_pats _ _ : _) = do where clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch] clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do - let failure_exp = maybeDCaseE (FunRhs n) - scrutinee failure_matches + let failure_exp = maybeDCaseE mc scrutinee failure_matches exp <- dsBody body where_decs failure_exp (pats', exp') <- dsPatsOverExp pats exp uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats' @@ -1263,7 +1291,7 @@ dsDerivStrategy (ViaStrategy ty) = DViaStrategy <$> dsType ty dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir dsPatSynDir _ Unidir = pure DUnidir dsPatSynDir _ ImplBidir = pure DImplBidir -dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses n clauses +dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses #endif -- | Desugar a @Pred@, flattening any internal tuples diff --git a/Test/Run.hs b/Test/Run.hs index dd46fa4..92fefdf 100644 --- a/Test/Run.hs +++ b/Test/Run.hs @@ -149,6 +149,7 @@ tests = test [ "sections" ~: $test1_sections @=? $(dsSplice test1_sections) #endif #if __GLASGOW_HASKELL__ >= 903 , "opaque_pragma" ~: $test55_opaque_pragma @=? $(dsSplice test55_opaque_pragma) + , "lambda_cases" ~: $test56_lambda_cases @=? $(dsSplice test56_lambda_cases) #endif ] diff --git a/Test/Splices.hs b/Test/Splices.hs index 8c94694..d2eaee8 100644 --- a/Test/Splices.hs +++ b/Test/Splices.hs @@ -345,6 +345,10 @@ test55_opaque_pragma = f x = x {-# OPAQUE f #-} in f "Hello, World!" |] + +test56_lambda_cases = + [| (\cases (Just x) (Just y) -> x ++ y + _ _ -> "") (Just "Hello") (Just "World") |] #endif type family TFExpand x @@ -769,5 +773,6 @@ test_exprs = [ test1_sections #endif #if __GLASGOW_HASKELL__ >= 903 , test55_opaque_pragma + , test56_lambda_cases #endif ]