packages feed

record-dot-preprocessor 0.2.13 → 0.2.14

raw patch · 7 files changed

+99/−14 lines, 7 files

Files

CHANGES.txt view
@@ -1,5 +1,7 @@ Changelog for record-dot-preprocessor +0.2.14, released 2022-02-11+    #48, do not derive HasField for existentials 0.2.13, released 2021-11-03     #46, make sure [a|b/|] gets treated as quasi quotes 0.2.12, released 2021-09-01
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2018-2021.+Copyright Neil Mitchell 2018-2022.  Licensed under either of:
examples/Both.hs view
@@ -2,6 +2,8 @@  {-# 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@@ -217,6 +219,16 @@     C (Nullable c) a = C c (Maybe a)     C f a = f a +-- Existential typed field xc' need to be omitted from types, otherwise+-- compiler produce following error:+--    • Illegal instance declaration for+--        ‘GHC.Records.Extra.HasField "xc'" (Existential a) aplg’+--        The liberal coverage condition fails in class ‘GHC.Records.Extra.HasField’+--          for functional dependency: ‘x r -> a’+--        Reason: lhs types ‘"xc'"’, ‘Existential a’+--          do not jointly determine rhs type ‘aplg’+--        Un-determined variable: aplg+data Existential a = forall b. Bar { xa :: a, xb :: !a, xc' :: b }  data Foo9 f = Foo9 {   bar :: C f Int,
plugin/Compat.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ImplicitParams #-} {- HLINT ignore "Use camelCase" -}  -- | Module containing the plugin.@@ -8,16 +10,28 @@ #if __GLASGOW_HASKELL__ < 900 import BasicTypes import TcEvidence+import RnTypes as Compat+import UniqSupply #else import GHC.Types.Basic import GHC.Unit.Types import GHC.Parser.Annotation+import GHC.Rename.HsType as Compat+import GHC.Types.Unique.Supply #endif #if __GLASGOW_HASKELL__ < 810 import HsSyn as Compat #else import GHC.Hs as Compat #endif+#if __GLASGOW_HASKELL__ < 808+import System.IO.Unsafe as Compat (unsafePerformIO)+import TcRnTypes+import IOEnv+import DynFlags+import HscTypes+#endif+import Data.IORef as Compat  --------------------------------------------------------------------- -- UTILITIES@@ -130,4 +144,29 @@ qualifiedImplicitImport x = noL $ ImportDecl noE NoSourceText (noL x) Nothing NotBoot False     QualifiedPost {- qualified -} True {- implicit -} Nothing Nothing +#endif++type PluginEnv = (?hscenv :: HscEnv, ?uniqSupply :: IORef UniqSupply)++dropRnTraceFlags :: HscEnv -> HscEnv+#if __GLASGOW_HASKELL__ < 808+dropRnTraceFlags env@HscEnv{hsc_dflags = dflags} =  env{hsc_dflags = dopt_unset dflags Opt_D_dump_rn_trace}+#else+dropRnTraceFlags = id+#endif++freeTyVars :: PluginEnv => LHsType GhcPs -> [Located RdrName]+#if __GLASGOW_HASKELL__ < 808+{-# NOINLINE freeTyVars #-}+freeTyVars  = freeKiTyVarsAllVars . runRnM . extractHsTyRdrTyVars+  where+    runRnM :: RnM a -> a+    runRnM rnm = unsafePerformIO $ do+      let env = Env ?hscenv ?uniqSupply unused unused+      runIOEnv env rnm+    unused = error "never called"+#elif __GLASGOW_HASKELL__ < 810+freeTyVars = freeKiTyVarsAllVars . extractHsTyRdrTyVars+#else+freeTyVars = extractHsTyRdrTyVars #endif
plugin/RecordDotPreprocessor.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards, ViewPatterns, NamedFieldPuns, OverloadedStrings #-}+{-# LANGUAGE RecordWildCards, ViewPatterns, NamedFieldPuns, OverloadedStrings, LambdaCase #-}+{-# LANGUAGE ImplicitParams, ScopedTypeVariables #-} {- HLINT ignore "Use camelCase" -}  -- | Module containing the plugin.@@ -13,27 +14,36 @@ #if __GLASGOW_HASKELL__ < 900 import Bag import qualified GhcPlugins as GHC+import qualified HscMain import qualified PrelNames as GHC import SrcLoc #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 import GHC.Types.SrcLoc #endif - --------------------------------------------------------------------- -- PLUGIN WRAPPER  -- | GHC plugin. plugin :: GHC.Plugin plugin = GHC.defaultPlugin-    { GHC.parsedResultAction = \_cliOptions _modSummary x -> pure x{GHC.hpm_module = onModule <$> GHC.hpm_module x}+    { GHC.parsedResultAction = parsedResultAction     , GHC.pluginRecompile = GHC.purePlugin     }+    where+        parsedResultAction _cliOptions _modSummary x = do+            hscenv <- dropRnTraceFlags <$> HscMain.getHscEnv+            uniqSupply <- GHC.liftIO (GHC.mkSplitUniqSupply '0')+            uniqSupplyRef <- GHC.liftIO $ newIORef uniqSupply+            let ?hscenv = hscenv+            let ?uniqSupply = uniqSupplyRef+            pure x{GHC.hpm_module = onModule <$> GHC.hpm_module x}   ---------------------------------------------------------------------@@ -53,7 +63,7 @@ var_dot = GHC.mkRdrUnqual $ GHC.mkVarOcc "."  -onModule :: Module -> Module+onModule :: PluginEnv => Module -> Module onModule x = x { hsmodImports = onImports $ hsmodImports x                , hsmodDecls = concatMap (onDecl (unLoc <$> hsmodName x)) $ hsmodDecls x                }@@ -108,7 +118,7 @@         vX = GHC.mkRdrUnqual $ GHC.mkVarOcc "x"  -onDecl :: Maybe GHC.ModuleName -> LHsDecl GhcPs -> [LHsDecl GhcPs]+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@@ -119,15 +129,13 @@ unbang (HsBangTy _ _ x) = unLoc x unbang x = x -getFields :: Maybe GHC.ModuleName -> TyClDecl GhcPs -> [(LHsType GhcPs, IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)]+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 _ ConDeclH98{con_args=RecCon (L _ fields),con_name=L _ name}) = concatMap (field name) fields-        ctor (L _ ConDeclGADT{con_args=RecCon (L _ fields),con_names=names}) = concat [field name fld | L _ name <- names, fld <- fields]-        ctor _ = []+        ctor (L _ con) = [(result, name, fld, ty) | (name, fld, ty) <- conClosedFields (defVars tcdTyVars) con] -        field name (L _ ConDeclField{cd_fld_type=L _ ty, ..}) = [(result, name, fld, ty) | L _ fld <- cd_fld_names]-        field _ _ = error "unknown field declaration in getFields"+        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@@ -136,6 +144,25 @@             _ -> tcdLName getFields _ _ = [] +-- Extract filed and its type from declaration, omitting fields with existential/higher-kind types.+conClosedFields :: PluginEnv => [GHC.RdrName] -> ConDecl GhcPs -> [(IdP GhcPs, FieldOcc GhcPs, HsType GhcPs)]+conClosedFields resultVars = \case+    ConDeclH98 {con_args = RecCon (L _ args), con_name, con_ex_tvs} ->+        [ (unLoc con_name, unLoc name, unLoc ty)+            | ConDeclField {cd_fld_names, cd_fld_type = ty} <- universeBi args,+                null (freeTyVars' ty \\ resultVars),+                name <- cd_fld_names+        ]+    ConDeclGADT {con_args = RecCon (L _ args), con_res_ty, con_names} ->+         [ (unLoc con_name, unLoc name, unLoc ty)+         | ConDeclField {cd_fld_names, cd_fld_type = ty} <- universeBi args,+             null (freeTyVars ty \\ freeTyVars con_res_ty),+             name <- cd_fld_names,+             con_name <- con_names+         ]+    _ -> []+    where+        freeTyVars' ty = unLoc <$> freeTyVars ty  -- At this point infix expressions have not had associativity/fixity applied, so they are bracketed -- a + b + c ==> (a + b) + c
record-dot-preprocessor.cabal view
@@ -1,14 +1,14 @@ cabal-version:      1.18 build-type:         Simple name:               record-dot-preprocessor-version:            0.2.13+version:            0.2.14 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-2021+copyright:          Neil Mitchell 2018-2022 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.
test/PluginExample.hs view
@@ -20,6 +20,11 @@ -- 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 #-}+#if __GLASGOW_HASKELL__ < 808+-- 8.8+ doesn't need it to be set explicitly+{-# LANGUAGE ExistentialQuantification #-}+#endif+ module PluginExample where #include "../examples/Both.hs"