record-dot-preprocessor 0.2.15 → 0.2.16
raw patch · 14 files changed
+261/−119 lines, 14 filesdep ~ghcPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc
API changes (from Hackage documentation)
Files
- CHANGES.txt +4/−0
- LICENSE +1/−1
- README.md +1/−1
- examples/Both.hs +0/−5
- examples/Both2.hs +0/−3
- examples/Header_in.hs +30/−0
- examples/Preprocessor.hs +0/−5
- examples/Readme.hs +1/−0
- plugin/Compat.hs +89/−36
- plugin/RecordDotPreprocessor.hs +104/−44
- preprocessor/Lexer.hs +2/−1
- record-dot-preprocessor.cabal +5/−4
- test/PluginExample.hs +11/−11
- test/Test.hs +13/−8
CHANGES.txt view
@@ -1,5 +1,9 @@ Changelog for record-dot-preprocessor +0.2.16, released 2023-03-03+ #57, support GHC 9.4+ #54, skip polymorphic fields with forall+ #52, properly deal with nested block comments 0.2.15, released 2022-07-09 #50, support GHC 9.2 #50, add ghc version bounds
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2018-2022.+Copyright Neil Mitchell 2018-2023. Licensed under either of:
README.md view
@@ -1,6 +1,6 @@ # record-dot-preprocessor [](https://hackage.haskell.org/package/record-dot-preprocessor) [](https://www.stackage.org/package/record-dot-preprocessor) [](https://github.com/ndmitchell/record-dot-preprocessor/actions) -In almost every programming language `a.b` will get the `b` field from the `a` data type, and many different data types can have a `b` field. The reason this feature is ubiquitous is because it's _useful_. This feature has been [proposed for Haskell](https://github.com/ghc-proposals/ghc-proposals/pull/282) as `RecordDotSyntax`. The `record-dot-preprocessor` brings this feature to Haskell today. Some examples:+In almost every programming language `a.b` will get the `b` field from the `a` data type, and many different data types can have a `b` field. The reason this feature is ubiquitous is because it's _useful_. The `record-dot-preprocessor` brings this feature to modern GHC versions. This feature has been [proposed for Haskell](https://github.com/ghc-proposals/ghc-proposals/pull/282) as `RecordDotSyntax`. Since GHC 9.2 the [`OverloadedRecordDot`](https://downloads.haskell.org/~ghc/9.2.3/docs/html/users_guide/exts/overloaded_record_dot.html#extension-OverloadedRecordDot) and [`OverloadedRecordUpdate`](https://downloads.haskell.org/~ghc/9.2.3/docs/html/users_guide/exts/overloaded_record_update.html) extensions implement much the same functionality. Some examples: ```haskell data Company = Company {name :: String, owner :: Person}
examples/Both.hs view
@@ -1,10 +1,5 @@ -- 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 #-} -- also tests we put language extensions before imports--- 8.8+ doesn't need it to be set explicitly-{-# LANGUAGE ExistentialQuantification #-}- import Control.Exception import Data.Version import Data.Proxy
examples/Both2.hs view
@@ -1,8 +1,5 @@ -- Test DuplicateRecordFields extension -{-# OPTIONS_GHC -Werror -Wall -Wno-type-defaults -Wno-partial-type-signatures #-} -- can we produce -Wall clean code-{-# LANGUAGE DuplicateRecordFields #-}- main :: IO () main = test1 >> putStrLn "All worked"
+ examples/Header_in.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wall #-}++{-# OPTIONS_GHC -Werror #-}+{-# OPTIONS_GHC -Wincomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++#if __GLASGOW_HASKELL__ >= 902+{-# OPTIONS_GHC -Wno-ambiguous-fields #-}+#endif
examples/Preprocessor.hs view
@@ -1,10 +1,5 @@ -- Test for things only supported by the preprocessor -{-# OPTIONS_GHC -Werror -Wall -Wno-type-defaults #-} -- can we produce -Wall clean code-{-# LANGUAGE ScopedTypeVariables #-}---- can you deal with modules and existing extensions-module Main(main) where import Data.Function import Data.Char
examples/Readme.hs view
@@ -9,5 +9,6 @@ nameAfterOwner :: Company -> Company nameAfterOwner c = c{name = c.owner.name ++ "'s Company"} +main :: IO () main = putStrLn $ display $ nameAfterOwner c where c = Company "A" $ Person "B" 3
plugin/Compat.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {- HLINT ignore "Use camelCase" -}+{- HLINT ignore "Unused LANGUAGE pragma" -} -- | Module containing the plugin. module Compat(module Compat) where@@ -25,7 +29,9 @@ #else import GHC.Types.Basic import GHC.Unit.Types+#if __GLASGOW_HASKELL__ < 902 import GHC.Parser.Annotation+#endif import GHC.Rename.HsType as Compat import GHC.Types.Unique.Supply #endif@@ -41,55 +47,79 @@ import DynFlags import HscTypes #endif+#if __GLASGOW_HASKELL__ >= 904+import GHC.Types.PkgQual (RawPkgQual(NoRawPkgQual))+#endif import Data.IORef as Compat ------------------------------------------------------------------------ UTILITIES+-- LOCATIONS -noL :: e -> GenLocated SrcSpan e-noL = noLoc+class WithoutLoc a b | b -> a where+ -- | Without location information+ --+ -- Different GHC versions want different kind of location information in+ -- different places. This class is intended to abstract over this.+ noL :: a -> b -#if __GLASGOW_HASKELL__ < 902-noLA :: e -> GenLocated SrcSpan e-noLA = noL+#if __GLASGOW_HASKELL__ >= 902+instance WithoutLoc a (GenLocated (SrcAnn ann) a) where+ noL = reLocA . noLoc+#endif -emptyComments :: NoExtField-emptyComments = noE+instance WithoutLoc a (Located a) where+ noL = noLoc -noAnn :: NoExtField-noAnn = noE+instance WithoutLoc (HsTupArg p) (HsTupArg p) where noL = id+instance WithoutLoc (HsLocalBindsLR p q) (HsLocalBindsLR p q) where noL = id +#if __GLASGOW_HASKELL__ < 902 reLocA :: Located e -> Located e reLocA = id reLoc :: Located e -> Located e reLoc = id+#endif -mkNonDetFastString :: FastString -> FastString-mkNonDetFastString = id+---------------------------------------------------------------------+-- TREE EXTENSIONS -noL' :: e -> GenLocated SrcSpan e-noL' = noL+class WithoutExt a where+ -- | No extension+ --+ -- Different GHC versions want different kinds of annotations. This class is+ -- intended to abstract over this.+ noE :: a -#else-noLA :: e -> LocatedAn ann e-noLA = reLocA . noL+#if __GLASGOW_HASKELL__ >= 902+instance WithoutExt (EpAnn a) where+ noE = EpAnnNotUsed -noL' :: a -> a-noL' = id+instance WithoutExt EpAnnComments where+ noE = emptyComments+#endif -mkNonDetFastString :: FastString -> NonDetFastString-mkNonDetFastString = NonDetFastString+#if __GLASGOW_HASKELL__ >= 810+instance WithoutExt NoExtField where+ noE = noExtField+#else+instance WithoutExt NoExt where+ noE = NoExt #endif -#if __GLASGOW_HASKELL__ < 810-type NoExtField = NoExt+---------------------------------------------------------------------+-- UTILITIES -noE :: NoExt-noE = NoExt+#if __GLASGOW_HASKELL__ < 902++mkNonDetFastString :: FastString -> FastString+mkNonDetFastString = id+ #else-noE :: NoExtField-noE = noExtField++mkNonDetFastString :: FastString -> NonDetFastString+mkNonDetFastString = NonDetFastString+ #endif realSrcLoc :: SrcLoc -> Maybe RealSrcLoc@@ -102,7 +132,7 @@ #if __GLASGOW_HASKELL__ >= 902 hsLTyVarBndrToType :: (Anno (IdP (GhcPass p)) ~ SrcSpanAnn' (EpAnn NameAnn)) => LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p)-hsLTyVarBndrToType x = noLA $ HsTyVar noAnn NotPromoted $ noLA $ hsLTyVarName x+hsLTyVarBndrToType x = noL $ HsTyVar noE NotPromoted $ noL $ hsLTyVarName x #elif __GLASGOW_HASKELL__ >= 900 hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p) hsLTyVarBndrToType x = noL $ HsTyVar noE NotPromoted $ noL $ hsLTyVarName x@@ -137,8 +167,8 @@ #else -- GHC 9.2+-mkAppType expr typ = noLA $ HsAppType noSrcSpan expr (HsWC noE typ)-mkTypeAnn expr typ = noLA $ ExprWithTySig noAnn expr (hsTypeToHsSigWcType typ)+mkAppType expr typ = noL $ HsAppType noSrcSpan expr (HsWC noE typ)+mkTypeAnn expr typ = noL $ ExprWithTySig noE expr (hsTypeToHsSigWcType typ) #endif @@ -148,10 +178,16 @@ mkFunTy a b = noL $ HsFunTy noE a b newFunBind a b = FunBind noE a b WpHole [] +#elif __GLASGOW_HASKELL__ < 904++-- GHC 9.0 and 9.2+mkFunTy a b = noL $ HsFunTy noE (HsUnrestrictedArrow NormalSyntax) a b+newFunBind a b = FunBind noE (reLocA a) b []+ #else --- GHC 9.0-mkFunTy a b = noLA $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b+-- GHC >= 9.4+mkFunTy a b = noL $ HsFunTy noE (HsUnrestrictedArrow $ L NoTokenLoc HsNormalTok) a b newFunBind a b = FunBind noE (reLocA a) b [] #endif@@ -173,7 +209,7 @@ -- 8.10 compat_m_pats :: [Pat GhcPs] -> [LPat GhcPs]-compat_m_pats = map noLA+compat_m_pats = map noL #endif @@ -192,10 +228,16 @@ qualifiedImplicitImport x = noL $ ImportDecl noE NoSourceText (noL x) Nothing False False QualifiedPost {- qualified -} True {- implicit -} Nothing Nothing +#elif __GLASGOW_HASKELL__ < 904++-- GHC 9.0 and 9.2+qualifiedImplicitImport x = noL $ ImportDecl noE NoSourceText (noL x) Nothing NotBoot False+ QualifiedPost {- qualified -} True {- implicit -} Nothing Nothing+ #else --- GHC 9.0-qualifiedImplicitImport x = noLA $ ImportDecl noAnn NoSourceText (noLA x) Nothing NotBoot False+-- GHC >= 9.4+qualifiedImplicitImport x = noL $ ImportDecl noE NoSourceText (noL x) NoRawPkgQual NotBoot False QualifiedPost {- qualified -} True {- implicit -} Nothing Nothing #endif@@ -223,4 +265,15 @@ freeTyVars = freeKiTyVarsAllVars . extractHsTyRdrTyVars #else freeTyVars = map reLoc . extractHsTyRdrTyVars+#endif++#if __GLASGOW_HASKELL__ >= 902+isLHsForAllTy :: LHsType GhcPs -> Bool+isLHsForAllTy (L _ (HsForAllTy {})) = True+isLHsForAllTy _ = False+#endif++#if __GLASGOW_HASKELL__ >= 904+rdrNameFieldOcc :: FieldOcc GhcPs -> LocatedN RdrName+rdrNameFieldOcc = foLabel #endif
plugin/RecordDotPreprocessor.hs view
@@ -38,11 +38,19 @@ -- | GHC plugin. plugin :: GHC.Plugin plugin = GHC.defaultPlugin- { GHC.parsedResultAction = parsedResultAction+ { GHC.parsedResultAction = \_cliOptions _modSummary -> ignoreMessages parsedResultAction , GHC.pluginRecompile = GHC.purePlugin } where- parsedResultAction _cliOptions _modSummary x = do+#if __GLASGOW_HASKELL__ >= 904+ ignoreMessages :: (HsParsedModule -> GHC.Hsc HsParsedModule) -> GHC.ParsedResult -> GHC.Hsc GHC.ParsedResult+ ignoreMessages f (GHC.ParsedResult modl msgs) =+ (\modl' -> GHC.ParsedResult modl' msgs) <$> f modl+#else+ ignoreMessages = id+#endif++ parsedResultAction x = do hscenv <- dropRnTraceFlags <$> HscMain.getHscEnv uniqSupply <- GHC.liftIO (GHC.mkSplitUniqSupply '0') uniqSupplyRef <- GHC.liftIO $ newIORef uniqSupply@@ -50,7 +58,6 @@ let ?uniqSupply = uniqSupplyRef pure x{GHC.hpm_module = onModule <$> GHC.hpm_module x} - --------------------------------------------------------------------- -- PLUGIN GUTS @@ -67,7 +74,15 @@ var_setField = GHC.mkRdrQual mod_records $ GHC.mkVarOcc "setField" var_dot = GHC.mkRdrUnqual $ GHC.mkVarOcc "." +#if __GLASGOW_HASKELL__ >= 904+mod_base_records :: GHC.ModuleName+mod_base_records = GHC.mkModuleName "GHC.Records" +-- | GHC.Records.getField (as opposed to GHC.Records.Extra.getField)+var_base_getField :: GHC.RdrName+var_base_getField = GHC.mkRdrQual mod_base_records $ GHC.mkVarOcc "getField"+#endif+ onModule :: PluginEnv => Module -> Module onModule x = x { hsmodImports = onImports $ hsmodImports x , hsmodDecls = concatMap (onDecl (unLoc <$> hsmodName x)) $ hsmodDecls x@@ -75,7 +90,12 @@ onImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]-onImports = (:) $ qualifiedImplicitImport mod_records+onImports = (++) [+ qualifiedImplicitImport mod_records+#if __GLASGOW_HASKELL__ >= 904+ , qualifiedImplicitImport mod_base_records+#endif+ ] {- instance Z.HasField "name" (Company) (String) where hasField _r = (\_x -> _r{name=_x}, (name:: (Company) -> String) _r)@@ -86,53 +106,71 @@ instanceTemplate :: FieldOcc GhcPs -> HsType GhcPs -> HsType GhcPs -> InstDecl GhcPs instanceTemplate selector record field = ClsInstD noE $ ClsInstDecl #if __GLASGOW_HASKELL__ >= 902- (noAnn, mempty) (hsTypeToHsSigType $ reLocA typ)+ (noE, mempty) (hsTypeToHsSigType $ reLocA typ) #else noE (HsIB noE typ) #endif (unitBag has) [] [] [] Nothing where+ typ' :: HsType GhcPs -> LHsType GhcPs typ' a = mkHsAppTys- (noLA (HsTyVar noAnn GHC.NotPromoted (noLA var_HasField)))- [noLA (HsTyLit noE (HsStrTy GHC.NoSourceText (GHC.occNameFS $ GHC.occName $ unLoc $ rdrNameFieldOcc selector)))- ,noLA record- ,noLA a+ (noL (HsTyVar noE GHC.NotPromoted (noL var_HasField)))+ [fieldNameAsType+ ,noL record+ ,noL a ] typ = noL $ makeEqQualTy field (unLoc . typ') + fieldNameAsType :: LHsType GhcPs+ fieldNameAsType = noL (HsTyLit noE (HsStrTy GHC.NoSourceText (GHC.occNameFS $ GHC.occName $ unLoc $ rdrNameFieldOcc selector)))+ has :: LHsBindLR GhcPs GhcPs- has = noLA $ newFunBind (noL var_hasField) (mg1 eqn)+ has = noL $ newFunBind (noL var_hasField) (mg1 eqn) where eqn :: Match GhcPs (LHsExpr GhcPs) eqn = Match- { m_ext = noAnn- , m_ctxt = FunRhs (noLA var_hasField) GHC.Prefix NoSrcStrict- , m_pats = compat_m_pats [VarPat noE $ noLA vR]- , m_grhss = GRHSs emptyComments [noL $ GRHS noAnn [] $ noLA $ ExplicitTuple noAnn [ noL' $ Present noAnn set, noL' $ Present noAnn get] GHC.Boxed] (noL' $ EmptyLocalBinds noE)+ { m_ext = noE+ , m_ctxt = FunRhs (noL var_hasField) GHC.Prefix NoSrcStrict+ , m_pats = compat_m_pats [VarPat noE $ noL vR]+ , m_grhss = GRHSs noE [noL $ GRHS noE [] $ noL $ ExplicitTuple noE [ noL $ Present noE set, noL $ Present noE get] GHC.Boxed] (noL $ EmptyLocalBinds noE) }- set = noLA $ HsLam noE $ mg1 Match- { m_ext = noAnn+ set = noL $ HsLam noE $ mg1 Match+ { m_ext = noE , m_ctxt = LambdaExpr- , m_pats = compat_m_pats [VarPat noE $ noLA vX]- , m_grhss = GRHSs emptyComments [noL $ GRHS noAnn [] $ noLA update] (noL' $ EmptyLocalBinds noE)+ , m_pats = compat_m_pats [VarPat noE $ noL vX]+ , m_grhss = GRHSs noE [noL $ GRHS noE [] $ noL update] (noL $ EmptyLocalBinds noE) } update :: HsExpr GhcPs- update = RecordUpd noAnn (noLA $ GHC.HsVar noE $ noLA vR)+ update = RecordUpd noE (noL $ GHC.HsVar noE $ noL vR) #if __GLASGOW_HASKELL__ >= 902 $ Left #endif- [noLA $ HsRecField+#if __GLASGOW_HASKELL__ >= 904+ [noL $ HsFieldBind+#else+ [noL $ HsRecField+#endif #if __GLASGOW_HASKELL__ >= 902- noAnn+ noE #endif- (noL (Unambiguous noE (rdrNameFieldOcc selector))) (noLA $ GHC.HsVar noE $ noLA vX) False]+ (noL (Unambiguous noE (rdrNameFieldOcc selector))) (noL $ GHC.HsVar noE $ noL vX) False]+#if __GLASGOW_HASKELL__ >= 904+ get :: LHsExpr GhcPs+ get =+ (noL $ GHC.HsVar noE $ noL $ var_base_getField)+ `mkAppType`+ fieldNameAsType+ `mkApp`+ (noL $ GHC.HsVar noE $ noL $ vR)+#else get = mkApp- (mkParen $ mkTypeAnn (noLA $ GHC.HsVar noE $ rdrNameFieldOcc selector) (mkFunTy (noLA record) (noLA field)))- (noLA $ GHC.HsVar noE $ noLA vR)+ (mkParen $ mkTypeAnn (noL $ GHC.HsVar noE $ rdrNameFieldOcc selector) (mkFunTy (noL record) (noL field)))+ (noL $ GHC.HsVar noE $ noL vR)+#endif mg1 :: Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs)- mg1 x = MG noE (noLA [noLA x]) GHC.Generated+ mg1 x = MG noE (noL [noL x]) GHC.Generated vR = GHC.mkRdrUnqual $ GHC.mkVarOcc "r" vX = GHC.mkRdrUnqual $ GHC.mkVarOcc "x"@@ -140,7 +178,7 @@ onDecl :: PluginEnv => Maybe GHC.ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs] onDecl modName o@(L _ (GHC.TyClD _ x)) = o :- [ noLA $ InstD noE $ instanceTemplate field (unLoc record) (unbang typ)+ [ noL $ InstD noE $ instanceTemplate field (unLoc record) (unbang typ) | let fields = nubOrdOn (\(_,_,x,_) -> mkNonDetFastString $ GHC.occNameFS $ GHC.rdrNameOcc $ unLoc $ rdrNameFieldOcc x) $ getFields modName x , (record, _, field, typ) <- fields] onDecl _ x = [descendBi onExp x]@@ -159,7 +197,7 @@ defVars vars = [v | L _ v <- hsLTyVarLocNames vars] -- A value of this data declaration will have this type.- result = foldl (\x y -> noL $ HsAppTy noE (reLocA x) $ hsLTyVarBndrToType y) (noL $ HsTyVar noAnn GHC.NotPromoted tyName) $ hsq_explicit tcdTyVars+ result = foldl (\x y -> noL $ HsAppTy noE (reLocA x) $ hsLTyVarBndrToType y) (noL $ HsTyVar noE GHC.NotPromoted tyName) $ hsq_explicit tcdTyVars tyName = case (tcdLName, modName) of (L l (GHC.Unqual name), Just modName') -> L l (GHC.Qual modName' name) _ -> tcdLName@@ -172,9 +210,12 @@ [ (unLoc con_name, unLoc name, unLoc ty) | ConDeclField {cd_fld_names, cd_fld_type = ty} <- universeBi args, null (freeTyVars' ty \\ resultVars),+ not $ isLHsForAllTy ty, name <- cd_fld_names ]-#if __GLASGOW_HASKELL__ >= 901+#if __GLASGOW_HASKELL__ >= 904+ ConDeclGADT {con_g_args = RecConGADT (L _ args) _, con_res_ty, con_names} ->+#elif __GLASGOW_HASKELL__ >= 901 ConDeclGADT {con_g_args = RecConGADT (L _ args), con_res_ty, con_names} -> #else ConDeclGADT {con_args = RecCon (L _ args), con_res_ty, con_names} ->@@ -182,6 +223,7 @@ [ (unLoc con_name, unLoc name, unLoc ty) | ConDeclField {cd_fld_names, cd_fld_type = ty} <- universeBi args, null (freeTyVars ty \\ freeTyVars con_res_ty),+ not $ isLHsForAllTy ty, name <- cd_fld_names, con_name <- con_names ]@@ -213,7 +255,7 @@ , Just sels <- getSelectors rhs -- Don't bracket here. The argument came in as a section so it's -- already enclosed in brackets.- = reLocA $ setL o $ foldl1 (\x y -> noL $ OpApp noAnn (reLocA x) (mkVar var_dot) (reLocA y))+ = reLocA $ setL o $ foldl1 (\x y -> noL $ OpApp noE (reLocA x) (mkVar var_dot) (reLocA y)) $ map ( \ sel -> reLoc $ mkVar var_getField `mkAppType` sel) $ reverse sels -- Turn a{b=c, ...} into setField calls@@ -223,20 +265,28 @@ onExp (L o upd@RecordUpd{rupd_expr,rupd_flds= fld:flds}) #endif | adjacentBy 1 rupd_expr fld- = onExp $ f rupd_expr $ fld:flds+ = onExp $ f rupd_expr $ map unLoc $ fld:flds where+ f :: LHsExpr GhcPs -> [HsRecUpdField GhcPs] -> LHsExpr GhcPs f expr [] = expr- f expr (L _ (HsRecField { hsRecFieldLbl = fmap rdrNameAmbiguousFieldOcc -> lbl- , hsRecFieldArg = arg- , hsRecPun = pun } ) : flds)+#if __GLASGOW_HASKELL__ >= 904+ f expr (HsFieldBind { hfbLHS = (fmap rdrNameAmbiguousFieldOcc . reLoc) -> lbl+ , hfbRHS = arg+ , hfbPun = pun+ } : flds)+#else+ f expr (HsRecField { hsRecFieldLbl = fmap rdrNameAmbiguousFieldOcc -> lbl+ , hsRecFieldArg = arg+ , hsRecPun = pun+ } : flds)+#endif | let sel = mkSelector lbl- , let arg2 = if pun then noLA $ HsVar noE (reLocA lbl) else arg+ , let arg2 = if pun then noL $ HsVar noE (reLocA lbl) else arg , let expr2 = mkParen $ mkVar var_setField `mkAppType` sel `mkApp` expr `mkApp` arg2 -- 'expr' never needs bracketing. = f expr2 flds onExp x = descend onExp x - mkSelector :: Located GHC.RdrName -> LHsType GhcPs mkSelector (L o x) = reLocA $ L o $ HsTyLit noE $ HsStrTy GHC.NoSourceText $ GHC.occNameFS $ GHC.rdrNameOcc x @@ -282,13 +332,13 @@ isDot _ = False mkVar :: GHC.RdrName -> LHsExpr GhcPs-mkVar = noLA . HsVar noE . noLA+mkVar = noL . HsVar noE . noL mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs-mkParen = noLA . HsPar noAnn+mkParen = mkHsPar mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-mkApp x y = noLA $ HsApp noAnn x y+mkApp x y = noL $ HsApp noE x y #if __GLASGOW_HASKELL__ >= 902 -- | Are the end of a and the start of b next to each other, no white space@@ -318,22 +368,32 @@ makeEqQualTy rArg fAbs = HsQualTy noE (-#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904 Just $ #endif- noLA qualCtx+ noL qualCtx )- (noLA (fAbs tyVar))+ (noL (fAbs tyVar)) where var = GHC.nameRdrName $ GHC.mkUnboundName $ GHC.mkTyVarOcc "aplg" tyVar :: HsType GhcPs- tyVar = HsTyVar noAnn GHC.NotPromoted (noLA var)+ tyVar = HsTyVar noE GHC.NotPromoted (noL var) var_tilde = GHC.mkOrig GHC.gHC_TYPES $ GHC.mkClsOcc "~" eqQual :: HsType GhcPs- eqQual = HsOpTy noE (noLA (HsParTy noAnn (noLA rArg))) (noLA var_tilde) (noLA tyVar)+ eqQual =+ HsOpTy+#if __GLASGOW_HASKELL__ >= 904+ EpAnnNotUsed+ GHC.NotPromoted -- TODO: Is this right?+#else+ noE+#endif+ (noL (HsParTy noE (noL rArg)))+ (noL var_tilde)+ (noL tyVar) qualCtx :: HsContext GhcPs- qualCtx = [noLA (HsParTy noAnn (noLA eqQual))]+ qualCtx = [noL (HsParTy noE (noL eqQual))]
preprocessor/Lexer.hs view
@@ -40,7 +40,7 @@ go line col xs | (lexeme, xs) <- lexerLexeme xs , (whitespace, xs) <- lexerWhitespace xs- , (line2, col2) <- reposition line col $ whitespace ++ lexeme+ , (line2, col2) <- reposition line col $ lexeme ++ whitespace = Lexeme{..} : go line2 col2 xs @@ -88,6 +88,7 @@ lexerWhitespace ('{':'-':xs) = seen "{-" $ f 1 xs where f 1 ('-':'}':xs) = seen "-}" $ lexerWhitespace xs+ f i ('-':'}':xs) = seen "-}" $ f (i-1) xs f i ('{':'-':xs) = seen "{-" $ f (i+1) xs f i (x:xs) = seen [x] $ f i xs f i [] = ([], [])
record-dot-preprocessor.cabal view
@@ -1,14 +1,14 @@ cabal-version: 1.18 build-type: Simple name: record-dot-preprocessor-version: 0.2.15+version: 0.2.16 license: BSD3 x-license: BSD-3-Clause OR Apache-2.0 license-file: LICENSE category: Development author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2018-2022+copyright: Neil Mitchell 2018-2023 synopsis: Preprocessor to allow record.field syntax description: In almost every programming language @a.b@ will get the @b@ field from the @a@ data type, and many different data types can have a @b@ field.@@ -19,10 +19,11 @@ extra-doc-files: README.md CHANGES.txt-tested-with: GHC==9.0, GHC==8.10, GHC==8.8, GHC==8.6+tested-with: GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8, GHC==8.6 extra-source-files: examples/Both.hs examples/Both2.hs+ examples/Header_in.hs examples/Preprocessor.hs examples/Readme.hs @@ -38,7 +39,7 @@ build-depends: base >= 4.8 && < 5, uniplate,- ghc >=8.6 && <9.3,+ ghc >=8.6 && <9.5, extra exposed-modules: RecordDotPreprocessor
test/PluginExample.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} #if __GLASGOW_HASKELL__ < 806 @@ -16,19 +17,18 @@ #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 -Werror -Wall -Wno-type-defaults -Wno-partial-type-signatures -Wno-incomplete-record-updates -Wno-unused-top-binds #-}-#if __GLASGOW_HASKELL__ >=902-{-# OPTIONS_GHC -Wno-ambiguous-fields #-}-#endif-{-# LANGUAGE PartialTypeSignatures, GADTs, StandaloneDeriving, KindSignatures #-}-#if __GLASGOW_HASKELL__ < 808--- 8.8+ doesn't need it to be set explicitly-{-# LANGUAGE ExistentialQuantification #-}-#endif +#include "../examples/Header_in.hs"+ module PluginExample where+ #include "../examples/Both.hs"++data PolyField = PolyField+ { polyField :: forall a. a -> IO ()+ }++data PolyGieldGADTs where+ PolyFieldGADTs :: { a' :: forall a. a } -> PolyGieldGADTs #endif
test/Test.hs view
@@ -20,29 +20,34 @@ -- TODO: If you pass `--installed` should create temp files with the magic string in front args <- getArgs files <- listFiles "examples"+ header <- readFile "examples/Header_in.hs" let installed = "--installed" `elem` args unless installed $ do putStrLn "# PluginExample.hs" PluginExample.main forM_ (reverse files) $ \file ->- when (takeExtension file == ".hs" && not ("_out.hs" `isSuffixOf` file)) $+ when (takeExtension file == ".hs" && not ("_out.hs" `isSuffixOf` file) && not ("_in.hs" `isSuffixOf` file)) $ do+ src <- readFile' file if installed then do- src <- readFile' file forM_ [("Preprocessor", "{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}")- ,("Plugin", "{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}\n" ++- "{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}")] $+ ,("Plugin", "{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}")+ ] $ \(name,prefix) -> withTempDir $ \dir -> when (compilerVersion >= makeVersion [8,6] && not (blacklist name (takeBaseName file))) $ do+ let inp = dir </> takeFileName file putStrLn $ "# " ++ name ++ " " ++ takeFileName file- writeFile (dir </> takeFileName file) $ prefix ++ "\n" ++ src- system_ $ "runhaskell -package=record-dot-preprocessor " ++ dir </> takeFileName file- else do+ writeFile inp $ prefix ++ "\n" ++ header ++ "\nmodule Main where\n" ++ src+ system_ $ "runhaskell -package=record-dot-preprocessor " ++ inp+ else withTempDir $ \dir -> do+ let inp = dir </> takeFileName file let out = dropExtension file ++ "_out.hs"+ writeFile inp $ header ++ "\n" ++ "module Main where\n" ++ src putStrLn $ "# Preprocessor " ++ takeFileName file- withArgs [file,file,out] Preprocessor.main+ withArgs [file,inp,out] Preprocessor.main system_ $ "runhaskell " ++ out putStrLn "Success" -- Blacklist tests we know aren't compatible blacklist "Plugin" "Preprocessor" = True+blacklist "Plugin" "Both2" = True blacklist _ _ = False