Use infix notation for destructing and splitting infix data cons

plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs

@@ -1,5 +1,7 @@
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TupleSections    #-}
+{-# LANGUAGE ViewPatterns     #-}
+
 module Ide.Plugin.Tactic.CodeGen where
 
 import           Control.Monad.Except
@@ -12,6 +14,7 @@ import           Data.Traversable
 import           DataCon
 import           Development.IDE.GHC.Compat
 import           GHC.Exts
+import           GHC.SourceGen (RdrNameStr)
 import           GHC.SourceGen.Binds
 import           GHC.SourceGen.Expr
 import           GHC.SourceGen.Overloaded
@@ -55,10 +58,7 @@ destructMatches f f2 t jdg = do
           let hy' = zip names $ coerce args
               dcon_name = nameOccName $ dataConName dc
 
-          let pat :: Pat GhcPs
-              pat = conP (fromString $ occNameString dcon_name)
-                  $ fmap bvar' names
-              j = f2 hy'
+          let j = f2 hy'
                 $ withPositionMapping dcon_name names
                 $ introducingPat hy'
                 $ withNewGoal g jdg
@@ -67,10 +67,36 @@ destructMatches f f2 t jdg = do
           pure ( rose ("match " <> show dc <> " {" <>
                           intercalate ", " (fmap show names) <> "}")
                     $ pure tr
-               , match [pat] $ unLoc sg
+               , match [mkDestructPat dc names] $ unLoc sg
                )
 
 
+------------------------------------------------------------------------------
+-- | Produces a pattern for a data con and the names of its fields.
+mkDestructPat :: DataCon -> [OccName] -> Pat GhcPs
+mkDestructPat dcon names
+  | isTupleDataCon dcon =
+      tuple pat_args
+  | otherwise =
+      infixifyPatIfNecessary dcon $
+        conP
+          (coerceName $ dataConName dcon)
+          pat_args
+  where
+    pat_args = fmap bvar' names
+
+
+infixifyPatIfNecessary :: DataCon -> Pat GhcPs -> Pat GhcPs
+infixifyPatIfNecessary dcon x
+  | dataConIsInfix dcon =
+      case x of
+        ConPatIn op (PrefixCon [lhs, rhs]) ->
+          ConPatIn op $ InfixCon lhs rhs
+        y -> y
+  | otherwise = x
+
+
+
 unzipTrace :: [(Trace, a)] -> (Trace, [a])
 unzipTrace l =
   let (trs, as) = unzip l
@@ -144,10 +170,26 @@ buildDataCon jdg dc apps = do
                   ) $ zip args [0..]
   pure
     . (rose (show dc) $ pure tr,)
-    . noLoc
-    . foldl' (@@)
-        (HsVar noExtField $ noLoc $ Unqual $ nameOccName $ dataConName dc)
-    $ fmap unLoc sgs
+    $ mkCon dc sgs
+
+
+mkCon :: DataCon -> [LHsExpr GhcPs] -> LHsExpr GhcPs
+mkCon dcon (fmap unLoc -> args)
+  | isTupleDataCon dcon =
+      noLoc $ tuple args
+  | dataConIsInfix dcon
+  , (lhs : rhs : args') <- args =
+      noLoc $ foldl' (@@) (op lhs (coerceName dcon_name) rhs) args'
+  | otherwise =
+      noLoc $ foldl' (@@) (bvar' $ occName $ dcon_name) args
+  where
+    dcon_name = dataConName dcon
+
+
+
+coerceName :: HasOccName a => a -> RdrNameStr
+coerceName = fromString . occNameString . occName
+
 
 
 ------------------------------------------------------------------------------

test/functional/Tactic.hs

@@ -100,6 +100,7 @@ tests = testGroup
   , goldenTest "GoldenFmapTree.hs"          4 11 Auto ""
   , goldenTest "GoldenGADTDestruct.hs"      7 17 Destruct "gadt"
   , goldenTest "GoldenGADTAuto.hs"          7 13 Auto ""
+  , goldenTest "GoldenSwapMany.hs"          2 12 Auto ""
   ]
 
 

test/testdata/tactic/GoldenFoldr.hs.expected

@@ -2,4 +2,4 @@ foldr2 :: (a -> b -> b) -> b -> [a] -> b
 foldr2 = (\ f_b b l_a
    -> case l_a of
         [] -> b
-        ((:) a l_a4) -> f_b a (foldr2 f_b b l_a4))
+        (a : l_a4) -> f_b a (foldr2 f_b b l_a4))

test/testdata/tactic/GoldenListFmap.hs.expected

@@ -2,4 +2,4 @@ fmapList :: (a -> b) -> [a] -> [b]
 fmapList = (\ fab l_a
    -> case l_a of
         [] -> []
-        ((:) a l_a3) -> (:) (fab a) (fmapList fab l_a3))
+        (a : l_a3) -> fab a : fmapList fab l_a3)

test/testdata/tactic/GoldenPureList.hs.expected

@@ -1,2 +1,2 @@
 pureList :: a -> [a]
-pureList = (\ a -> (:) a [])
+pureList = (\ a -> a : [])

test/testdata/tactic/GoldenSwap.hs.expected

@@ -1,2 +1,2 @@
 swap :: (a, b) -> (b, a)
-swap = (\ p_ab -> case p_ab of { ((,) a b) -> (,) b a })
+swap = (\ p_ab -> case p_ab of { (a, b) -> (b, a) })

test/testdata/tactic/GoldenSwapMany.hs

@@ -0,0 +1,2 @@
+swapMany :: (a, b, c, d, e) -> (e, d, c, b, a)
+swapMany = _

test/testdata/tactic/GoldenSwapMany.hs.expected

@@ -0,0 +1,2 @@
+swapMany :: (a, b, c, d, e) -> (e, d, c, b, a)
+swapMany = (\ pabcde -> case pabcde of { (a, b, c, d, e) -> (e, d, c, b, a) })