From 21c801bc0a90ef9b7c112f489ef48b1b9812b29e Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Thu, 11 Feb 2021 22:26:09 -0800
Subject: [PATCH] Construct record datacons

---
 .../src/Ide/Plugin/Tactic/CodeGen.hs               | 10 +++++++---
 .../src/Ide/Plugin/Tactic/GHC.hs                   | 14 +++++++++++++-
 test/functional/Tactic.hs                          |  1 +
 test/testdata/tactic/RecordCon.hs                  |  9 +++++++++
 test/testdata/tactic/RecordCon.hs.expected         |  9 +++++++++
 5 files changed, 39 insertions(+), 4 deletions(-)
 create mode 100644 test/testdata/tactic/RecordCon.hs
 create mode 100644 test/testdata/tactic/RecordCon.hs.expected

diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs
index 1cab232a7a..12236b6661 100644
--- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs
+++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/CodeGen.hs
@@ -18,7 +18,7 @@ import           Data.Traversable
 import           DataCon
 import           Development.IDE.GHC.Compat
 import           GHC.Exts
-import           GHC.SourceGen (RdrNameStr)
+import           GHC.SourceGen (recordCon, RdrNameStr)
 import           GHC.SourceGen.Binds
 import           GHC.SourceGen.Expr
 import           GHC.SourceGen.Overloaded
@@ -187,8 +187,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) ->
@@ -210,6 +210,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
diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs
index 5cba1d20b6..9156082a65 100644
--- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/GHC.hs
+++ b/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
diff --git a/test/functional/Tactic.hs b/test/functional/Tactic.hs
index 6e33a96a90..0897a96069 100644
--- a/test/functional/Tactic.hs
+++ b/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 ""
   ]
 
 
diff --git a/test/testdata/tactic/RecordCon.hs b/test/testdata/tactic/RecordCon.hs
new file mode 100644
index 0000000000..651983e8a3
--- /dev/null
+++ b/test/testdata/tactic/RecordCon.hs
@@ -0,0 +1,9 @@
+data MyRecord a = Record
+    { field1 :: a
+    , field2 :: Int
+    }
+
+blah :: (a -> Int) -> a -> MyRecord a
+blah = _
+
+
diff --git a/test/testdata/tactic/RecordCon.hs.expected b/test/testdata/tactic/RecordCon.hs.expected
new file mode 100644
index 0000000000..33f74796f5
--- /dev/null
+++ b/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})
+
+