diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,7 @@ Changelog for record-dot-preprocessor +0.2.7, released 2020-10-02 + #29, deal with records containing type families in field types 0.2.6, released 2020-08-12 #30, don't warn about incomplete record updates #31, allow fields to have names that clash with functions diff --git a/examples/Both.hs b/examples/Both.hs --- a/examples/Both.hs +++ b/examples/Both.hs @@ -6,9 +6,12 @@ import Control.Exception import Data.Version import Data.Proxy +import Data.Functor.Identity (Identity(..)) +import qualified Data.Kind as T + main :: IO () -main = test1 >> test2 >> test3 >> test4 >> test5 >> test6 >> test7 >> test8 >> putStrLn "All worked" +main = test1 >> test2 >> test3 >> test4 >> test5 >> test6 >> test7 >> test8 >> test9 >> putStrLn "All worked" (===) :: (Show a, Eq a) => a -> a -> IO () a === b = if a == b then pure () else fail $ "Mismatch, " ++ show a ++ " /= " ++ show b @@ -202,3 +205,38 @@ quux.quux8 === "test" fails $ foo.quux8 fails $ length $ show $ quux{bar8=1} + +-- --------------------------------------------------------------------- +-- Deal with HKD + +-- Emulate simple HKD functionality +data Nullable (f :: T.Type -> T.Type) (a :: T.Type) + +type family C (f :: T.Type -> T.Type) (a :: T.Type) :: T.Type where + C Identity a = a + C (Nullable c) a = C c (Maybe a) + C f a = f a + + +data Foo9 f = Foo9 { + bar :: C f Int, + baz :: String + } + +data Foo92 f = Foo92 { + bar2 :: C (Nullable f) Int, + baz2 :: String + } + +tstObj :: Foo9 Identity +tstObj = Foo9 1 "test" + +tstObj2 :: Foo92 Identity +tstObj2 = Foo92 (Just 1) "test" + +test9 :: IO () +test9 = do + tstObj.baz === "test" + tstObj.bar === 1 + tstObj2.baz2 === "test" + tstObj2.bar2 === Just 1 diff --git a/plugin/RecordDotPreprocessor.hs b/plugin/RecordDotPreprocessor.hs --- a/plugin/RecordDotPreprocessor.hs +++ b/plugin/RecordDotPreprocessor.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, ViewPatterns, NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards, ViewPatterns, NamedFieldPuns, OverloadedStrings #-} {- HLINT ignore "Use camelCase" -} -- | Module containing the plugin. @@ -11,10 +11,10 @@ import Bag import qualified GHC import qualified GhcPlugins as GHC +import qualified PrelNames as GHC import SrcLoc import TcEvidence - --------------------------------------------------------------------- -- PLUGIN WRAPPER @@ -52,7 +52,6 @@ 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) @@ -62,13 +61,15 @@ instanceTemplate :: FieldOcc GhcPs -> HsType GhcPs -> HsType GhcPs -> InstDecl GhcPs instanceTemplate selector record field = ClsInstD noE $ ClsInstDecl noE (HsIB noE typ) (unitBag has) [] [] [] Nothing where - typ = mkHsAppTys + 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 field + ,noL a ] + typ = noL $ makeEqQualTy field (unLoc . typ') + has :: LHsBindLR GhcPs GhcPs has = noL $ FunBind noE (noL var_hasField) (mg1 eqn) WpHole [] where @@ -228,3 +229,24 @@ srcLocLine a == srcLocLine b && srcLocCol a + i == srcLocCol b adjacentBy _ _ _ = False + + +-- Given: +-- C f Int and \x -> HasField "field" Entity x +-- Returns: +-- ((C f Int) ~ aplg) => HasField "field" Entity aplg +makeEqQualTy :: HsType GhcPs -> (HsType GhcPs -> HsType GhcPs) -> HsType GhcPs +makeEqQualTy rArg fAbs = HsQualTy noE (noL qualCtx) (noL (fAbs tyVar)) + where + 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 (HsParTy noE (noL rArg))) (noLoc var_tilde) (noLoc tyVar) + + qualCtx :: HsContext GhcPs + qualCtx = [noL (HsParTy noE (noL eqQual))] diff --git a/preprocessor/Edit.hs b/preprocessor/Edit.hs --- a/preprocessor/Edit.hs +++ b/preprocessor/Edit.hs @@ -75,7 +75,7 @@ where (blanks, rest) = span (isPL "") o - prefix = "{-# LANGUAGE DuplicateRecordFields, DataKinds, FlexibleInstances, TypeApplications, FlexibleContexts, MultiParamTypeClasses, OverloadedLabels #-}" + prefix = "{-# LANGUAGE DuplicateRecordFields, DataKinds, FlexibleInstances, TypeApplications, FlexibleContexts, MultiParamTypeClasses, OverloadedLabels, TypeFamilies, TypeOperators, GADTs, UndecidableInstances #-}" imports = "import qualified GHC.Records.Extra as Z" -- if you import two things that have preprocessor_unused, and export them as modules, you don't want them to clash trailing modName = "_preprocessor_unused_" ++ uniq ++ " :: Z.HasField \"\" r a => r -> a;" ++ @@ -160,7 +160,7 @@ editAddInstances :: [PL] -> [PL] editAddInstances xs = xs ++ concatMap (\x -> [nl $ mkPL "", mkPL x]) - [ "instance Z.HasField \"" ++ fname ++ "\" " ++ rtyp ++ " (" ++ ftyp ++ ") " ++ + [ "instance (aplg ~ (" ++ ftyp ++ ")) => Z.HasField \"" ++ fname ++ "\" " ++ rtyp ++ " aplg " ++ "where hasField _r = (\\_x -> case _r of {" ++ intercalate " ; " [ if fname `elem` map fst fields then "(" ++ cname ++ " " ++ diff --git a/record-dot-preprocessor.cabal b/record-dot-preprocessor.cabal --- a/record-dot-preprocessor.cabal +++ b/record-dot-preprocessor.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: record-dot-preprocessor -version: 0.2.6 +version: 0.2.7 license: BSD3 x-license: BSD-3-Clause OR Apache-2.0 license-file: LICENSE @@ -59,12 +59,11 @@ Paren test-suite record-dot-preprocessor-test - default-language: Haskell2010 - type: exitcode-stdio-1.0 - main-is: Test.hs - hs-source-dirs: preprocessor, test - ghc-options: -main-is Test.main - + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: preprocessor, test + main-is: Test.hs + ghc-options: -main-is Test.main build-depends: base == 4.*, extra, diff --git a/test/PluginExample.hs b/test/PluginExample.hs --- a/test/PluginExample.hs +++ b/test/PluginExample.hs @@ -15,9 +15,11 @@ #else -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -w #-} -{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE PartialTypeSignatures, GADTs, StandaloneDeriving, KindSignatures #-} -- because it's now treated as a comment +{-# 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 -Werror -Wall -Wno-type-defaults -Wno-partial-type-signatures -Wno-incomplete-record-updates -Wno-unused-top-binds #-} +{-# LANGUAGE PartialTypeSignatures, GADTs, StandaloneDeriving, KindSignatures #-} module PluginExample where #include "../examples/Both.hs" diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,4 +1,3 @@ - module Test(main) where import qualified Preprocessor @@ -23,7 +22,7 @@ files <- listFiles "examples" let installed = "--installed" `elem` args unless installed $ do - putStrLn "# Plugin Example.hs" + putStrLn "# PluginExample.hs" PluginExample.main forM_ (reverse files) $ \file -> when (takeExtension file == ".hs" && not ("_out.hs" `isSuffixOf` file)) $