From 3a6c23069a9c102f98bd75afb2a30363bf9db4d1 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 19 Oct 2020 13:44:18 -0700 Subject: [PATCH 1/4] Use infix notation for destructing and splitting tuples --- .../tactics/src/Ide/Plugin/Tactic/CodeGen.hs | 28 +++++++++++++------ test/testdata/tactic/GoldenSwap.hs.expected | 2 +- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs b/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs index f89a9964dd..2c246a3706 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs +++ b/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs @@ -55,10 +55,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 +64,23 @@ 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 = + conP (fromString $ occNameString $ nameOccName $ dataConName dcon) + pat_args + where + pat_args = fmap bvar' names + + unzipTrace :: [(Trace, a)] -> (Trace, [a]) unzipTrace l = let (trs, as) = unzip l @@ -143,11 +153,11 @@ buildDataCon jdg dc apps = do $ CType arg ) $ zip args [0..] pure - . (rose (show dc) $ pure tr,) + . (rose (show dc) $ pure tr,) . noLoc - . foldl' (@@) - (HsVar noExtField $ noLoc $ Unqual $ nameOccName $ dataConName dc) - $ fmap unLoc sgs + $ case isTupleDataCon dc of + True -> tuple $ fmap unLoc sgs + False -> foldl' (@@) (bvar' dcon_name) $ fmap unLoc sgs ------------------------------------------------------------------------------ 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) }) From 73f0330db6c28e58335540fc8b0a6c5d53d0261e Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 19 Oct 2020 13:46:52 -0700 Subject: [PATCH 2/4] Small whitespace cleanup --- plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs b/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs index 2c246a3706..8cdeb9019e 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs +++ b/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs @@ -153,10 +153,10 @@ buildDataCon jdg dc apps = do $ CType arg ) $ zip args [0..] pure - . (rose (show dc) $ pure tr,) + . (rose (show dc) $ pure tr,) . noLoc $ case isTupleDataCon dc of - True -> tuple $ fmap unLoc sgs + True -> tuple $ fmap unLoc sgs False -> foldl' (@@) (bvar' dcon_name) $ fmap unLoc sgs From 3131240b9bbf9a5f94b4e3fa51496e948b56e96c Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 19 Oct 2020 14:11:44 -0700 Subject: [PATCH 3/4] Add a larger tuple test --- test/functional/Tactic.hs | 1 + test/testdata/tactic/GoldenSwapMany.hs | 2 ++ test/testdata/tactic/GoldenSwapMany.hs.expected | 2 ++ 3 files changed, 5 insertions(+) create mode 100644 test/testdata/tactic/GoldenSwapMany.hs create mode 100644 test/testdata/tactic/GoldenSwapMany.hs.expected 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/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) }) From 59efaaca9816719b9a55ba2df78b37c5185d7eda Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 19 Oct 2020 14:49:30 -0700 Subject: [PATCH 4/4] Better destruct and split for infix datacons Fixes #468 --- .../tactics/src/Ide/Plugin/Tactic/CodeGen.hs | 46 ++++++++++++++++--- test/testdata/tactic/GoldenFoldr.hs.expected | 2 +- .../tactic/GoldenListFmap.hs.expected | 2 +- .../tactic/GoldenPureList.hs.expected | 2 +- 4 files changed, 42 insertions(+), 10 deletions(-) diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs b/plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs index 8cdeb9019e..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 @@ -75,12 +78,25 @@ mkDestructPat dcon names | isTupleDataCon dcon = tuple pat_args | otherwise = - conP (fromString $ occNameString $ nameOccName $ dataConName dcon) - pat_args + 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 @@ -154,10 +170,26 @@ buildDataCon jdg dc apps = do ) $ zip args [0..] pure . (rose (show dc) $ pure tr,) - . noLoc - $ case isTupleDataCon dc of - True -> tuple $ fmap unLoc sgs - False -> foldl' (@@) (bvar' dcon_name) $ 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/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 : [])