From de4e387436d2878cdf88cb349c02c7ecbef2cffa Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 19 Oct 2020 22:31:04 -0700 Subject: [PATCH] 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 --- .../tactics/src/Ide/Plugin/Tactic/CodeGen.hs | 62 ++++++++++++++++--- test/functional/Tactic.hs | 1 + test/testdata/tactic/GoldenFoldr.hs.expected | 2 +- .../tactic/GoldenListFmap.hs.expected | 2 +- .../tactic/GoldenPureList.hs.expected | 2 +- test/testdata/tactic/GoldenSwap.hs.expected | 2 +- test/testdata/tactic/GoldenSwapMany.hs | 2 + .../tactic/GoldenSwapMany.hs.expected | 2 + 8 files changed, 61 insertions(+), 14 deletions(-) create mode 100644 test/testdata/tactic/GoldenSwapMany.hs create mode 100644 test/testdata/tactic/GoldenSwapMany.hs.expected diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs b/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs index f89a9964dd..89947e1443 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs +++ b/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 + ------------------------------------------------------------------------------ diff --git a/test/functional/Tactic.hs b/test/functional/Tactic.hs index 38594eae61..97ef227056 100644 --- a/test/functional/Tactic.hs +++ b/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 "" ] diff --git a/test/testdata/tactic/GoldenFoldr.hs.expected b/test/testdata/tactic/GoldenFoldr.hs.expected index fe0463b75f..9fde1acaeb 100644 --- a/test/testdata/tactic/GoldenFoldr.hs.expected +++ b/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)) diff --git a/test/testdata/tactic/GoldenListFmap.hs.expected b/test/testdata/tactic/GoldenListFmap.hs.expected index 26766d57c3..6d183a9578 100644 --- a/test/testdata/tactic/GoldenListFmap.hs.expected +++ b/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) diff --git a/test/testdata/tactic/GoldenPureList.hs.expected b/test/testdata/tactic/GoldenPureList.hs.expected index 9410eea557..c02e91622d 100644 --- a/test/testdata/tactic/GoldenPureList.hs.expected +++ b/test/testdata/tactic/GoldenPureList.hs.expected @@ -1,2 +1,2 @@ pureList :: a -> [a] -pureList = (\ a -> (:) a []) +pureList = (\ a -> a : []) diff --git a/test/testdata/tactic/GoldenSwap.hs.expected b/test/testdata/tactic/GoldenSwap.hs.expected index 4281fc81d9..57a3a114f4 100644 --- a/test/testdata/tactic/GoldenSwap.hs.expected +++ b/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) }) diff --git a/test/testdata/tactic/GoldenSwapMany.hs b/test/testdata/tactic/GoldenSwapMany.hs new file mode 100644 index 0000000000..b1f6c0fb2a --- /dev/null +++ b/test/testdata/tactic/GoldenSwapMany.hs @@ -0,0 +1,2 @@ +swapMany :: (a, b, c, d, e) -> (e, d, c, b, a) +swapMany = _ diff --git a/test/testdata/tactic/GoldenSwapMany.hs.expected b/test/testdata/tactic/GoldenSwapMany.hs.expected new file mode 100644 index 0000000000..a37687cc3c --- /dev/null +++ b/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) })