WIP: Fix code generation for HKD records via plugin

examples/HkdPlugin.hs

@@ -0,0 +1,51 @@
+-- Test for everything that is supported by both the plugin and the preprocessor
+
+{-# OPTIONS_GHC -Werror -Wall -Wno-type-defaults -Wno-partial-type-signatures -Wincomplete-record-updates -Wno-unused-top-binds #-} -- can we produce -Wall clean code
+{-# LANGUAGE PartialTypeSignatures, GADTs, StandaloneDeriving, DataKinds, KindSignatures, TypeFamilies #-} -- also tests we put language extensions before imports
+
+import Data.Functor.Identity
+import Control.Monad (unless)
+import Database.Beam
+import qualified Database.Beam as Beam
+
+-- ---------------------------------------------------------------------
+-- Deal with HKD
+
+data Foo f = Foo {
+  bar :: C f Int,
+  baz :: String
+  }
+
+data Foo1 f = Foo1 {
+  bar1 :: Beam.C f Int,
+  baz1 :: String
+  }
+
+data Foo2 f = Foo2 {
+  bar2 :: C (Nullable f) Int,
+  baz2 :: String
+  }
+
+(===) :: (Show a, Eq a) => a -> a -> IO ()
+a === b = unless (a == b) (fail $ "Mismatch, " ++ show a ++ " /= " ++ show b)
+
+main :: IO ()
+main = test1 >> putStrLn "All worked"
+
+tstObj :: Foo Identity
+tstObj = Foo 1 "test"
+
+tstObj1 :: Foo1 Identity
+tstObj1 = Foo1 1 "test"
+
+tstObj2 :: Foo2 Identity
+tstObj2 = Foo2 (Just 1) "test"
+
+test1 :: IO ()
+test1 = do
+  tstObj.baz === "test"
+  tstObj.bar === 1
+  tstObj1.baz1 === "test"
+  tstObj1.bar1 === 1
+  tstObj2.baz2 === "test"
+  tstObj2.bar2 === Just 1

plugin/RecordDotPreprocessor.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards, ViewPatterns, NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards, ViewPatterns, NamedFieldPuns, PatternSynonyms, OverloadedStrings #-}
 {- HLINT ignore "Use camelCase" -}
 
 -- | Module containing the plugin.
@@ -11,10 +11,10 @@ import Compat
 import Bag
 import qualified GHC
 import qualified GhcPlugins as GHC
+import qualified PrelNames as GHC
 import SrcLoc
 import TcEvidence
 
-
 ---------------------------------------------------------------------
 -- PLUGIN WRAPPER
 
@@ -52,22 +52,25 @@ onModule x = x { hsmodImports = onImports $ hsmodImports x
 onImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]
 onImports = (:) $ qualifiedImplicitImport mod_records
 
-
 {-
 instance Z.HasField "name" (Company) (String) where hasField _r = (\_x -> _r{name=_x}, (name:: (Company) -> String) _r)
 
 instance HasField "selector" Record Field where
     hasField r = (\x -> r{selector=x}, (name :: Record -> Field) r)
 -}
 instanceTemplate :: FieldOcc GhcPs -> HsType GhcPs -> HsType GhcPs -> InstDecl GhcPs
-instanceTemplate selector record field = ClsInstD noE $ ClsInstDecl noE (HsIB noE typ) (unitBag has) [] [] [] Nothing
+instanceTemplate selector record field = instance'
     where
-        typ = mkHsAppTys
-            (noL (HsTyVar noE GHC.NotPromoted (noL var_HasField)))
-            [noL (HsTyLit noE (HsStrTy GHC.NoSourceText (GHC.occNameFS $ GHC.occName $ unLoc $ rdrNameFieldOcc selector)))
-            ,noL record
-            ,noL field
-            ]
+        instance' = ClsInstD noE $ ClsInstDecl noE (HsIB noE typ) (unitBag has) [] [] [] Nothing
+
+        typ' a = mkHsAppTys
+          (noL (HsTyVar noE GHC.NotPromoted (noL var_HasField)))
+          [noL (HsTyLit noE (HsStrTy GHC.NoSourceText (GHC.occNameFS $ GHC.occName $ unLoc $ rdrNameFieldOcc selector)))
+          ,noL record
+          ,noL a
+          ]
+
+        typ = noL $ makeEqQualTy field (unLoc . typ')
 
         has :: LHsBindLR GhcPs GhcPs
         has = noL $ FunBind noE (noL var_hasField) (mg1 eqn) WpHole []
@@ -228,3 +231,23 @@ adjacentBy i (L (srcSpanEnd -> RealSrcLoc a) _) (L (srcSpanStart -> RealSrcLoc b
     srcLocLine a == srcLocLine b &&
     srcLocCol a + i == srcLocCol b
 adjacentBy _ _ _ = False
+
+
+makeEqQualTy :: HsType GhcPs -> (HsType GhcPs -> HsType GhcPs) -> HsType GhcPs
+makeEqQualTy rArg fAbs = let
+  var = GHC.nameRdrName $ GHC.mkUnboundName $ GHC.mkTyVarOcc "aplg"
+
+  tyVar :: HsType GhcPs
+  tyVar = HsTyVar noE GHC.NotPromoted (noL var)
+
+  var_tilde = GHC.mkOrig GHC.gHC_TYPES $ GHC.mkClsOcc "~"
+
+  eqQual :: HsType GhcPs
+  eqQual = HsOpTy noE (noL rArg) (noLoc var_tilde) (noLoc tyVar)
+
+  qualCtx :: HsContext GhcPs
+  qualCtx = [noLoc (HsParTy noE (noLoc eqQual))]
+
+  qualType :: HsType GhcPs
+  qualType = HsQualTy noE (noL qualCtx) (noL (fAbs tyVar))
+  in qualType

record-dot-preprocessor.cabal

@@ -69,12 +69,14 @@ test-suite record-dot-preprocessor-test
         base == 4.*,
         extra,
         record-hasfield,
-        filepath
+        filepath,
+        beam-core
     if impl(ghc >= 8.6)
         build-depends:
             record-dot-preprocessor
     other-modules:
         PluginExample
+        PluginHkdExample
         Preprocessor
         Edit
         Lexer

test/PluginExample.hs

@@ -16,9 +16,9 @@ main = pure ()
 #else
 
 {-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}
-{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, TypeOperators, GADTs, UndecidableInstances #-}
 -- things that are now treated as comments
-{-# OPTIONS_GHC -Werror -Wall -Wno-type-defaults -Wno-partial-type-signatures -Wincomplete-record-updates -Wno-unused-top-binds #-}
+{-# OPTIONS_GHC -Wall -Wno-type-defaults -Wno-partial-type-signatures -Wincomplete-record-updates -Wno-unused-top-binds #-}
 {-# LANGUAGE PartialTypeSignatures, GADTs, StandaloneDeriving, KindSignatures #-}
 module PluginExample where
 #include "../examples/Both.hs"

test/PluginHkdExample.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE CPP #-}
+
+#if __GLASGOW_HASKELL__ < 806
+
+module PluginHkdExample where
+main :: IO ()
+main = pure ()
+
+#elif mingw32_HOST_OS
+
+module PluginHkdExample where
+import RecordDotPreprocessor () -- To check the plugin compiles
+main :: IO ()
+main = pure ()
+
+#else
+
+{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}
+{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, TypeOperators, GADTs, UndecidableInstances #-}
+-- things that are now treated as comments
+{-# OPTIONS_GHC -Wall -Wno-type-defaults -Wno-partial-type-signatures -Wincomplete-record-updates -Wno-unused-top-binds #-}
+{-# LANGUAGE PartialTypeSignatures, GADTs, StandaloneDeriving, KindSignatures #-}
+module PluginHkdExample where
+#include "../examples/HkdPlugin.hs"
+
+#endif

test/Test.hs

@@ -3,6 +3,7 @@ module Test(main) where
 
 import qualified Preprocessor
 import qualified PluginExample -- To test the plugin
+import qualified PluginHkdExample -- To test the plugin on hkd
 import GHC.Records.Extra() -- To ensure the runtime dependency is present
 
 import System.Directory.Extra
@@ -23,10 +24,13 @@ main = do
     files <- listFiles "examples"
     let installed = "--installed" `elem` args
     unless installed $ do
-        putStrLn "# Plugin Example.hs"
+        putStrLn "# PluginExample.hs"
         PluginExample.main
+    unless installed $ do
+        putStrLn "# PluginHkdExample.hs"
+        PluginHkdExample.main
     forM_ (reverse files) $ \file ->
-        when (takeExtension file == ".hs" && not ("_out.hs" `isSuffixOf` file)) $
+        when (takeExtension file == ".hs" && not ("_out.hs" `isSuffixOf` file) && not("HkdPlugin.hs" `isSuffixOf` file)) $
             if installed then do
                 src <- readFile' file
                 forM_ [("Preprocessor", "{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}")