Use infix notation for destructing and splitting infix data cons in tactics (#519)

The tactics plugin is a bit stupid when working with infix-defined datacons, both in expressions and patterns. For example it will produce (,) a b and (:) a as rather than the more natural (a, b) and a : as. This PR makes it do the right thing.

The solution is to inspect the data con when building an expression or pattern. Unfortunately tuples are extra special in GHC, so this introduces a special case for tuples, and another for everyday infix things (like list).

There's a bit of annoying fiddling in order to build the infix pattern. The logic is in infixifyPatIfNecessary, which is the only thing I'm not super comfortable with in the diff.

Fixes #468

Author: isovector

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) })