record-dot-preprocessor 0.2.14 → 0.2.15
raw patch · 5 files changed
+163/−58 lines, 5 filesdep ~ghc
Dependency ranges changed: ghc
Files
- CHANGES.txt +3/−0
- plugin/Compat.hs +62/−8
- plugin/RecordDotPreprocessor.hs +93/−46
- record-dot-preprocessor.cabal +2/−4
- test/PluginExample.hs +3/−0
CHANGES.txt view
@@ -1,5 +1,8 @@ Changelog for record-dot-preprocessor +0.2.15, released 2022-07-09+ #50, support GHC 9.2+ #50, add ghc version bounds 0.2.14, released 2022-02-11 #48, do not derive HasField for existentials 0.2.13, released 2021-11-03
plugin/Compat.hs view
@@ -1,12 +1,22 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE TypeFamilies #-} {- HLINT ignore "Use camelCase" -} -- | Module containing the plugin. module Compat(module Compat) where import GHC+#if __GLASGOW_HASKELL__ > 901+import GHC.Types.SourceText ( SourceText(NoSourceText) )+import GHC.Data.FastString (FastString, NonDetFastString (NonDetFastString))+#elif __GLASGOW_HASKELL__ >=900+import GHC.Data.FastString (FastString)+#else+import FastString (FastString)+#endif+ #if __GLASGOW_HASKELL__ < 900 import BasicTypes import TcEvidence@@ -39,7 +49,42 @@ noL :: e -> GenLocated SrcSpan e noL = noLoc +#if __GLASGOW_HASKELL__ < 902+noLA :: e -> GenLocated SrcSpan e+noLA = noL++emptyComments :: NoExtField+emptyComments = noE++noAnn :: NoExtField+noAnn = noE++reLocA :: Located e -> Located e+reLocA = id++reLoc :: Located e -> Located e+reLoc = id++mkNonDetFastString :: FastString -> FastString+mkNonDetFastString = id++noL' :: e -> GenLocated SrcSpan e+noL' = noL++#else+noLA :: e -> LocatedAn ann e+noLA = reLocA . noL++noL' :: a -> a+noL' = id++mkNonDetFastString :: FastString -> NonDetFastString+mkNonDetFastString = NonDetFastString+#endif+ #if __GLASGOW_HASKELL__ < 810+type NoExtField = NoExt+ noE :: NoExt noE = NoExt #else@@ -55,7 +100,10 @@ #endif realSrcLoc _ = Nothing -#if __GLASGOW_HASKELL__ >= 900+#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+#elif __GLASGOW_HASKELL__ >= 900 hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p) hsLTyVarBndrToType x = noL $ HsTyVar noE NotPromoted $ noL $ hsLTyVarName x #endif@@ -80,12 +128,18 @@ mkAppType expr typ = noL $ HsAppType (HsWC noE typ) expr mkTypeAnn expr typ = noL $ ExprWithTySig (HsWC noE (HsIB noE typ)) expr -#else+#elif __GLASGOW_HASKELL__ < 901 --- GHC 8.8++-- GHC 8.8-9.0 mkAppType expr typ = noL $ HsAppType noE expr (HsWC noE typ) mkTypeAnn expr typ = noL $ ExprWithTySig noE expr (HsWC noE (HsIB noE typ)) +#else++-- GHC 9.2++mkAppType expr typ = noLA $ HsAppType noSrcSpan expr (HsWC noE typ)+mkTypeAnn expr typ = noLA $ ExprWithTySig noAnn expr (hsTypeToHsSigWcType typ)+ #endif #if __GLASGOW_HASKELL__ < 811@@ -97,8 +151,8 @@ #else -- GHC 9.0-mkFunTy a b = noL $ HsFunTy noE (HsUnrestrictedArrow NormalSyntax) a b-newFunBind a b = FunBind noE a b []+mkFunTy a b = noLA $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b+newFunBind a b = FunBind noE (reLocA a) b [] #endif @@ -119,7 +173,7 @@ -- 8.10 compat_m_pats :: [Pat GhcPs] -> [LPat GhcPs]-compat_m_pats = map noL+compat_m_pats = map noLA #endif @@ -141,7 +195,7 @@ #else -- GHC 9.0-qualifiedImplicitImport x = noL $ ImportDecl noE NoSourceText (noL x) Nothing NotBoot False+qualifiedImplicitImport x = noLA $ ImportDecl noAnn NoSourceText (noLA x) Nothing NotBoot False QualifiedPost {- qualified -} True {- implicit -} Nothing Nothing #endif@@ -168,5 +222,5 @@ #elif __GLASGOW_HASKELL__ < 810 freeTyVars = freeKiTyVarsAllVars . extractHsTyRdrTyVars #else-freeTyVars = extractHsTyRdrTyVars+freeTyVars = map reLoc . extractHsTyRdrTyVars #endif
plugin/RecordDotPreprocessor.hs view
@@ -11,6 +11,11 @@ import Data.Tuple.Extra import Compat import qualified GHC+#if __GLASGOW_HASKELL__ > 901+import qualified GHC.Types.SourceText as GHC+#elif __GLASGOW_HASKELL__ >= 900+import qualified GHC.Driver.Types as GHC+#endif #if __GLASGOW_HASKELL__ < 900 import Bag import qualified GhcPlugins as GHC@@ -20,7 +25,7 @@ #else import GHC.Data.Bag import qualified GHC.Driver.Plugins as GHC-import qualified GHC.Driver.Types as GHC+ import qualified GHC.Driver.Main as HscMain import qualified GHC.Builtin.Names as GHC import qualified GHC.Plugins as GHC@@ -79,40 +84,55 @@ 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 = ClsInstD noE $ ClsInstDecl+#if __GLASGOW_HASKELL__ >= 902+ (noAnn, mempty) (hsTypeToHsSigType $ reLocA typ)+#else+ noE (HsIB noE typ)+#endif+ (unitBag has) [] [] [] Nothing where 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+ (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 ] typ = noL $ makeEqQualTy field (unLoc . typ') has :: LHsBindLR GhcPs GhcPs- has = noL $ newFunBind (noL var_hasField) (mg1 eqn)+ has = noLA $ newFunBind (noL var_hasField) (mg1 eqn) where+ eqn :: Match GhcPs (LHsExpr GhcPs) eqn = Match- { 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)+ { 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) }- set = noL $ HsLam noE $ mg1 Match- { m_ext = noE+ set = noLA $ HsLam noE $ mg1 Match+ { m_ext = noAnn , m_ctxt = LambdaExpr- , m_pats = compat_m_pats [VarPat noE $ noL vX]- , m_grhss = GRHSs noE [noL $ GRHS noE [] $ noL update] (noL $ EmptyLocalBinds noE)+ , m_pats = compat_m_pats [VarPat noE $ noLA vX]+ , m_grhss = GRHSs emptyComments [noL $ GRHS noAnn [] $ noLA update] (noL' $ EmptyLocalBinds noE) }- update = RecordUpd noE (noL $ GHC.HsVar noE $ noL vR)- [noL $ HsRecField (noL (Unambiguous noE (rdrNameFieldOcc selector))) (noL $ GHC.HsVar noE $ noL vX) False]+ update :: HsExpr GhcPs+ update = RecordUpd noAnn (noLA $ GHC.HsVar noE $ noLA vR)+#if __GLASGOW_HASKELL__ >= 902+ $ Left+#endif+ [noLA $ HsRecField+#if __GLASGOW_HASKELL__ >= 902+ noAnn+#endif+ (noL (Unambiguous noE (rdrNameFieldOcc selector))) (noLA $ GHC.HsVar noE $ noLA vX) False] get = mkApp- (mkParen $ mkTypeAnn (noL $ GHC.HsVar noE $ rdrNameFieldOcc selector) (mkFunTy (noL record) (noL field)))- (noL $ GHC.HsVar noE $ noL vR)+ (mkParen $ mkTypeAnn (noLA $ GHC.HsVar noE $ rdrNameFieldOcc selector) (mkFunTy (noLA record) (noLA field)))+ (noLA $ GHC.HsVar noE $ noLA vR) mg1 :: Match GhcPs (LHsExpr GhcPs) -> MatchGroup GhcPs (LHsExpr GhcPs)- mg1 x = MG noE (noL [noL x]) GHC.Generated+ mg1 x = MG noE (noLA [noLA x]) GHC.Generated vR = GHC.mkRdrUnqual $ GHC.mkVarOcc "r" vX = GHC.mkRdrUnqual $ GHC.mkVarOcc "x"@@ -120,8 +140,8 @@ onDecl :: PluginEnv => Maybe GHC.ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs] onDecl modName o@(L _ (GHC.TyClD _ x)) = o :- [ noL $ InstD noE $ instanceTemplate field (unLoc record) (unbang typ)- | let fields = nubOrdOn (\(_,_,x,_) -> GHC.occNameFS $ GHC.rdrNameOcc $ unLoc $ rdrNameFieldOcc x) $ getFields modName x+ [ noLA $ 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] @@ -132,13 +152,14 @@ getFields :: PluginEnv => Maybe GHC.ModuleName -> TyClDecl GhcPs -> [(LHsType GhcPs, IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)] getFields modName DataDecl{tcdDataDefn=HsDataDefn{..}, ..} = concatMap ctor dd_cons where- ctor (L _ con) = [(result, name, fld, ty) | (name, fld, ty) <- conClosedFields (defVars tcdTyVars) con]+ ctor :: LConDecl GhcPs -> [(LHsType GhcPs, GHC.RdrName, FieldOcc GhcPs, HsType GhcPs)]+ ctor (L _ con) = [(reLocA result, name, fld, ty) | (name, fld, ty) <- conClosedFields (defVars tcdTyVars) con] defVars :: LHsQTyVars GhcPs -> [GHC.RdrName] defVars vars = [v | L _ v <- hsLTyVarLocNames vars] -- A value of this data declaration will have this type.- result = foldl (\x y -> noL $ HsAppTy noE x $ hsLTyVarBndrToType y) (noL $ HsTyVar noE GHC.NotPromoted tyName) $ hsq_explicit tcdTyVars+ result = foldl (\x y -> noL $ HsAppTy noE (reLocA x) $ hsLTyVarBndrToType y) (noL $ HsTyVar noAnn 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@@ -153,7 +174,11 @@ null (freeTyVars' ty \\ resultVars), name <- cd_fld_names ]+#if __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} ->+#endif [ (unLoc con_name, unLoc name, unLoc ty) | ConDeclField {cd_fld_names, cd_fld_type = ty} <- universeBi args, null (freeTyVars ty \\ freeTyVars con_res_ty),@@ -171,34 +196,41 @@ -- x := a | a b | a.b | a + b -- y := a | a b | a{b=1} onExp :: LHsExpr GhcPs -> LHsExpr GhcPs-onExp (L o (OpApp _ lhs mid@(isDot -> True) rhs))+onExp (reLoc -> L o (OpApp _ lhs mid@(isDot -> True) rhs)) | adjacent lhs mid, adjacent mid rhs , (lhsOp, lhs) <- getOpRHS $ onExp lhs , (lhsApp, lhs) <- getAppRHS lhs , (rhsApp, rhs) <- getAppLHS rhs , (rhsRec, rhs) <- getRec rhs , Just sel <- getSelector rhs- = onExp $ setL o $ lhsOp $ rhsApp $ lhsApp $ rhsRec $ mkParen $ mkVar var_getField `mkAppType` sel `mkApp` lhs+ = onExp $ reLocA $ setL o $ reLoc $ lhsOp $ rhsApp $ lhsApp $ rhsRec $ mkParen $ mkVar var_getField `mkAppType` sel `mkApp` lhs -- Turn (.foo.bar) into getField calls-onExp (L o (SectionR _ mid@(isDot -> True) rhs))+onExp (reLoc -> L o (SectionR _ mid@(isDot -> True) rhs)) | adjacent mid rhs- , srcSpanStart o == srcSpanStart (getLoc mid)- , srcSpanEnd o == srcSpanEnd (getLoc rhs)+ , srcSpanStart o == srcSpanStart (getLoc $ reLoc mid)+ , srcSpanEnd o == srcSpanEnd (getLoc $ reLoc rhs) , Just sels <- getSelectors rhs -- Don't bracket here. The argument came in as a section so it's -- already enclosed in brackets.- = setL o $ foldl1 (\x y -> noL $ OpApp noE x (mkVar var_dot) y) $ map (mkVar var_getField `mkAppType`) $ reverse sels+ = reLocA $ setL o $ foldl1 (\x y -> noL $ OpApp noAnn (reLocA x) (mkVar var_dot) (reLocA y))+ $ map ( \ sel -> reLoc $ mkVar var_getField `mkAppType` sel) $ reverse sels -- Turn a{b=c, ...} into setField calls-onExp (L o upd@RecordUpd{rupd_expr,rupd_flds=fld:flds})+#if __GLASGOW_HASKELL__ >= 902+onExp (L o upd@RecordUpd{rupd_expr,rupd_flds= Left (fld:flds)})+#else+onExp (L o upd@RecordUpd{rupd_expr,rupd_flds= fld:flds})+#endif | adjacentBy 1 rupd_expr fld = onExp $ f rupd_expr $ fld:flds where f expr [] = expr- f expr (L _ (HsRecField (fmap rdrNameAmbiguousFieldOcc -> lbl) arg pun) : flds)+ f expr (L _ (HsRecField { hsRecFieldLbl = fmap rdrNameAmbiguousFieldOcc -> lbl+ , hsRecFieldArg = arg+ , hsRecPun = pun } ) : flds) | let sel = mkSelector lbl- , let arg2 = if pun then noL $ HsVar noE lbl else arg+ , let arg2 = if pun then noLA $ 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 @@ -206,10 +238,10 @@ mkSelector :: Located GHC.RdrName -> LHsType GhcPs-mkSelector (L o x) = L o $ HsTyLit noE $ HsStrTy GHC.NoSourceText $ GHC.occNameFS $ GHC.rdrNameOcc x+mkSelector (L o x) = reLocA $ L o $ HsTyLit noE $ HsStrTy GHC.NoSourceText $ GHC.occNameFS $ GHC.rdrNameOcc x getSelector :: LHsExpr GhcPs -> Maybe (LHsType GhcPs)-getSelector (L _ (HsVar _ (L o sym)))+getSelector (L _ (HsVar _ (reLoc -> L o sym))) | not $ GHC.isQual sym = Just $ mkSelector $ L o sym getSelector _ = Nothing@@ -241,7 +273,7 @@ -- | Lens on: [r]{f1=x1}{f2=x2} getRec :: LHsExpr GhcPs -> (LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs) -- important to copy the location back over, since we check the whitespace hasn't changed-getRec (L l r@RecordUpd{}) = first (\c x -> L l r{rupd_expr=setL (getLoc $ rupd_expr r) $ c x}) $ getRec $ rupd_expr r+getRec (L l r@RecordUpd{}) = first (\c x -> L l r{rupd_expr=reLocA $ setL (getLoc $ reLoc $ rupd_expr r) $ reLoc $ c x }) $ getRec $ rupd_expr r getRec x = (id, x) -- | Is it equal to: .@@ -250,21 +282,28 @@ isDot _ = False mkVar :: GHC.RdrName -> LHsExpr GhcPs-mkVar = noL . HsVar noE . noL+mkVar = noLA . HsVar noE . noLA mkParen :: LHsExpr GhcPs -> LHsExpr GhcPs-mkParen = noL . HsPar noE+mkParen = noLA . HsPar noAnn mkApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-mkApp x y = noL $ HsApp noE x y+mkApp x y = noLA $ HsApp noAnn x y +#if __GLASGOW_HASKELL__ >= 902 -- | Are the end of a and the start of b next to each other, no white space-adjacent :: Located a -> Located b -> Bool-adjacent = adjacentBy 0+adjacent :: GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool -- | Are the end of a and the start of b next to each other, no white space+adjacentBy :: Int -> GenLocated (SrcAnn ann) a -> GenLocated (SrcAnn ann) b -> Bool+#else+adjacent :: Located a -> Located b -> Bool adjacentBy :: Int -> Located a -> Located b -> Bool-adjacentBy i (L (realSrcLoc . srcSpanEnd -> Just a) _) (L (realSrcLoc . srcSpanStart -> Just b) _) =++#endif+adjacent = adjacentBy 0++adjacentBy i (reLoc -> L (realSrcLoc . srcSpanEnd -> Just a) _) (reLoc -> L (realSrcLoc . srcSpanStart -> Just b) _) = srcLocFile a == srcLocFile b && srcLocLine a == srcLocLine b && srcLocCol a + i == srcLocCol b@@ -276,17 +315,25 @@ -- 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))+makeEqQualTy rArg fAbs+ = HsQualTy noE+ (+#if __GLASGOW_HASKELL__ >= 902+ Just $+#endif+ noLA qualCtx+ )+ (noLA (fAbs tyVar)) where var = GHC.nameRdrName $ GHC.mkUnboundName $ GHC.mkTyVarOcc "aplg" tyVar :: HsType GhcPs- tyVar = HsTyVar noE GHC.NotPromoted (noL var)+ tyVar = HsTyVar noAnn GHC.NotPromoted (noLA 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)+ eqQual = HsOpTy noE (noLA (HsParTy noAnn (noLA rArg))) (noLA var_tilde) (noLA tyVar) qualCtx :: HsContext GhcPs- qualCtx = [noL (HsParTy noE (noL eqQual))]+ qualCtx = [noLA (HsParTy noAnn (noLA eqQual))]
record-dot-preprocessor.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.18 build-type: Simple name: record-dot-preprocessor-version: 0.2.14+version: 0.2.15 license: BSD3 x-license: BSD-3-Clause OR Apache-2.0 license-file: LICENSE@@ -38,10 +38,8 @@ build-depends: base >= 4.8 && < 5, uniplate,- ghc,+ ghc >=8.6 && <9.3, extra- if impl(ghc < 8.6)- buildable: False exposed-modules: RecordDotPreprocessor RecordDotPreprocessor.Lib
test/PluginExample.hs view
@@ -19,6 +19,9 @@ {-# 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