record-dot-preprocessor 0.2.6 → 0.2.7
raw patch · 7 files changed
+82/−20 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGES.txt +2/−0
- examples/Both.hs +39/−1
- plugin/RecordDotPreprocessor.hs +27/−5
- preprocessor/Edit.hs +2/−2
- record-dot-preprocessor.cabal +6/−7
- test/PluginExample.hs +5/−3
- test/Test.hs +1/−2
CHANGES.txt view
@@ -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
examples/Both.hs view
@@ -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
plugin/RecordDotPreprocessor.hs view
@@ -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))]
preprocessor/Edit.hs view
@@ -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 ++ " " ++
record-dot-preprocessor.cabal view
@@ -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,
test/PluginExample.hs view
@@ -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"
test/Test.hs view
@@ -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)) $