Skip to content

Commit

Permalink
Use infix notation for destructing and splitting infix data cons in t…
Browse files Browse the repository at this point in the history
…actics (haskell#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 haskell#468
  • Loading branch information
isovector authored Oct 20, 2020
1 parent 1a869ad commit de4e387
Show file tree
Hide file tree
Showing 8 changed files with 61 additions and 14 deletions.
62 changes: 52 additions & 10 deletions plugins/tactics/src/Ide/Plugin/Tactic/CodeGen.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Ide.Plugin.Tactic.CodeGen where

import Control.Monad.Except
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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



------------------------------------------------------------------------------
Expand Down
1 change: 1 addition & 0 deletions test/functional/Tactic.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 ""
]


Expand Down
2 changes: 1 addition & 1 deletion test/testdata/tactic/GoldenFoldr.hs.expected
Original file line number Diff line number Diff line change
Expand Up @@ -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))
2 changes: 1 addition & 1 deletion test/testdata/tactic/GoldenListFmap.hs.expected
Original file line number Diff line number Diff line change
Expand Up @@ -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)
2 changes: 1 addition & 1 deletion test/testdata/tactic/GoldenPureList.hs.expected
Original file line number Diff line number Diff line change
@@ -1,2 +1,2 @@
pureList :: a -> [a]
pureList = (\ a -> (:) a [])
pureList = (\ a -> a : [])
2 changes: 1 addition & 1 deletion test/testdata/tactic/GoldenSwap.hs.expected
Original file line number Diff line number Diff line change
@@ -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) })
2 changes: 2 additions & 0 deletions test/testdata/tactic/GoldenSwapMany.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
swapMany :: (a, b, c, d, e) -> (e, d, c, b, a)
swapMany = _
2 changes: 2 additions & 0 deletions test/testdata/tactic/GoldenSwapMany.hs.expected
Original file line number Diff line number Diff line change
@@ -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) })

0 comments on commit de4e387

Please sign in to comment.