Fix #15843 by extending Template Haskell AST for tuples to support sections

2 files changed, 28 insertions, 17 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 303c7a08d3..25f5ec0ab1 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1332,12 +1332,20 @@ repE e@(HsDo _ ctxt (dL->L _ sts))
   = notHandled "monad comprehension and [: :]" (ppr e)
 
 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
-repE e@(ExplicitTuple _ es boxed)
-  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
-  | isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
-                       ; repTup xs }
-  | otherwise     = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
-                       ; repUnboxedTup xs }
+repE (ExplicitTuple _ es boxity) =
+  let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ))
+      tupArgToCoreExp a
+        | L _ (Present _ e) <- dL a = do { e' <- repLE e
+                                         ; coreJust expQTyConName e' }
+        | otherwise = coreNothing expQTyConName
+
+  in do { args <- mapM tupArgToCoreExp es
+        ; expQTy <- lookupType expQTyConName
+        ; let maybeExpQTy = mkTyConApp maybeTyCon [expQTy]
+              listArg = coreList' maybeExpQTy args
+        ; if isBoxed boxity
+          then repTup listArg
+          else repUnboxedTup listArg }
 
 repE (ExplicitSum _ alt arity e)
  = do { e1 <- repLE e
@@ -2077,10 +2085,10 @@ repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
 
-repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)
 repTup (MkC es) = rep2 tupEName [es]
 
-repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repUnboxedTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)
 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
 
 repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index b4be2f0000..12f22e8dd3 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -891,17 +891,11 @@ cvtl e = wrapL (cvt e)
                             ; return $ HsLamCase noExt
                                                    (mkMatchGroup FromSource ms')
                             }
-    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar noExt e' }
+    cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
                                  -- Note [Dropping constructors]
                                  -- Singleton tuples treated like nothing (just parens)
-    cvt (TupE es)      = do { es' <- mapM cvtl es
-                            ; return $ ExplicitTuple noExt
-                                             (map (noLoc . (Present noExt)) es')
-                                                                         Boxed }
-    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
-                                   ; return $ ExplicitTuple noExt
-                                           (map (noLoc . (Present noExt)) es')
-                                                                       Unboxed }
+    cvt (TupE es)        = cvt_tup es Boxed
+    cvt (UnboxedTupE es) = cvt_tup es Unboxed
     cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
                                        ; unboxedSumChecks alt arity
                                        ; return $ ExplicitSum noExt
@@ -1013,6 +1007,15 @@ cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x
 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 
+cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
+cvt_tup es boxity = do { let cvtl_maybe Nothing  = return missingTupArg
+                             cvtl_maybe (Just e) = fmap (Present noExt) (cvtl e)
+                       ; es' <- mapM cvtl_maybe es
+                       ; return $ ExplicitTuple
+                                    noExt
+                                    (map noLoc es')
+                                    boxity }
+
 {- Note [Operator assocation]
 We must be quite careful about adding parens:
   * Infix (UInfix ...) op arg      Needs parens round the first arg