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