Construct record datacons (#1356)

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

Author: isovector

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs

@@ -189,8 +189,8 @@ buildDataCon
     -> DataCon            -- ^ The data con to build
     -> [Type]             -- ^ Type arguments for the data con
     -> RuleM (Trace, LHsExpr GhcPs)
-buildDataCon jdg dc apps = do
-  let args = dataConInstOrigArgTys' dc apps
+buildDataCon jdg dc tyapps = do
+  let args = dataConInstOrigArgTys' dc tyapps
   (tr, sgs)
       <- fmap unzipTrace
        $ traverse ( \(arg, n) ->

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen/Utils.hs

@@ -2,13 +2,14 @@
 
 module Ide.Plugin.Tactic.CodeGen.Utils where
 
-import           Data.List
-import           DataCon
-import           Development.IDE.GHC.Compat
-import           GHC.Exts
-import           GHC.SourceGen (RdrNameStr)
-import           GHC.SourceGen.Overloaded
-import           Name
+import Data.List
+import DataCon
+import Development.IDE.GHC.Compat
+import GHC.Exts
+import GHC.SourceGen (recordConE, RdrNameStr)
+import GHC.SourceGen.Overloaded
+import Ide.Plugin.Tactic.GHC (getRecordFields)
+import Name
 
 
 ------------------------------------------------------------------------------
@@ -20,6 +21,10 @@ mkCon dcon (fmap unLoc -> args)
   | dataConIsInfix dcon
   , (lhs : rhs : args') <- args =
       noLoc $ foldl' (@@) (op lhs (coerceName dcon_name) rhs) args'
+  | Just fields <- getRecordFields dcon =
+      noLoc $ recordConE (coerceName dcon_name) $ do
+        (arg, (field, _)) <- zip args fields
+        pure (coerceName field, arg)
   | otherwise =
       noLoc $ foldl' (@@) (bvar' $ occName dcon_name) args
   where

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs

@@ -9,7 +9,7 @@ import           Control.Monad.State
 import qualified Data.Map as M
 import           Data.Maybe (isJust)
 import           Data.Traversable
-import qualified DataCon as DataCon
+import           DataCon
 import           Development.IDE.GHC.Compat
 import           Generics.SYB (mkT, everywhere)
 import           Ide.Plugin.Tactic.Types
@@ -88,6 +88,18 @@ freshTyvars t = do
       ) t
 
 
+------------------------------------------------------------------------------
+-- | Given a datacon, extract its record fields' names and types. Returns
+-- nothing if the datacon is not a record.
+getRecordFields :: DataCon -> Maybe [(OccName, CType)]
+getRecordFields dc =
+  case dataConFieldLabels dc of
+    [] -> Nothing
+    lbls -> for lbls $ \lbl -> do
+      (_, ty) <- dataConFieldType_maybe dc $ flLabel lbl
+      pure (mkVarOccFS $ flLabel lbl, CType ty)
+
+
 ------------------------------------------------------------------------------
 -- | Is this an algebraic type?
 algebraicTyCon :: Type -> Maybe TyCon

test/functional/Tactic.hs

@@ -117,6 +117,7 @@ tests = testGroup
   , expectFail "GoldenFish.hs"              5 18 Auto ""
   , goldenTest "GoldenArbitrary.hs"         25 13 Auto ""
   , goldenTest "FmapBoth.hs"                2 12 Auto ""
+  , goldenTest "RecordCon.hs"               7  8 Auto ""
   , goldenTest "FmapJoin.hs"                2 14 Auto ""
   , goldenTest "Fgmap.hs"                   2 9  Auto ""
   , goldenTest "FmapJoinInLet.hs"           4 19 Auto ""

test/testdata/tactic/RecordCon.hs

@@ -0,0 +1,9 @@
+data MyRecord a = Record
+    { field1 :: a
+    , field2 :: Int
+    }
+
+blah :: (a -> Int) -> a -> MyRecord a
+blah = _
+
+

test/testdata/tactic/RecordCon.hs.expected

@@ -0,0 +1,9 @@
+data MyRecord a = Record
+    { field1 :: a
+    , field2 :: Int
+    }
+
+blah :: (a -> Int) -> a -> MyRecord a
+blah = (\ fai a -> Record {field1 = a, field2 = fai a})
+
+