large-anon 0.1.1 → 0.2

raw patch · 33 files changed

+1122/−280 lines, 33 filesdep +Streamdep +arrowsdep +deepseqdep ~basedep ~ghc-tcplugin-apinew-component:exe:large-anon-testsuite-fourmolu-preprocessorPVP ok

version bump matches the API change (PVP)

Dependencies added: Stream, arrows, deepseq, fourmolu

Dependency ranges changed: base, ghc-tcplugin-api

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• fourmolu-preprocessor/Main.hs +15/−0
• large-anon.cabal +41/−14
• src/Data/Record/Anon/Advanced.hs +10/−2
• src/Data/Record/Anon/Internal/Advanced.hs +24/−31
• src/Data/Record/Anon/Internal/Plugin.hs +10/−1
• src/Data/Record/Anon/Internal/Plugin/Source.hs +42/−51
• src/Data/Record/Anon/Internal/Plugin/Source/FreshT.hs +60/−0
• src/Data/Record/Anon/Internal/Plugin/Source/GhcShim.hs +132/−20
• src/Data/Record/Anon/Internal/Plugin/Source/Names.hs +16/−22
• src/Data/Record/Anon/Internal/Plugin/Source/NamingT.hs +0/−96
• src/Data/Record/Anon/Internal/Plugin/TC/GhcTcPluginAPI.hs +17/−0
• src/Data/Record/Anon/Internal/Plugin/TC/NameResolution.hs +0/−11
• src/Data/Record/Anon/Internal/Plugin/TC/Rewriter.hs +2/−2
• src/Data/Record/Anon/Internal/Simple.hs +30/−13
• src/Data/Record/Anon/Overloading.hs +45/−0
• src/Data/Record/Anon/Simple.hs +11/−2
• test/Test/Sanity/BlogPost.hs +12/−1
• test/Test/Sanity/Discovery.hs +4/−4
• test/Test/Sanity/DuplicateFields.hs +2/−2
• test/Test/Sanity/Fourmolu/OverloadedRecordDot.hs +91/−0
• test/Test/Sanity/Fourmolu/OverloadedRecordUpdate.hs +100/−0
• test/Test/Sanity/Generics.hs +5/−5
• test/Test/Sanity/Named/Record1.hs +1/−1
• test/Test/Sanity/Named/Record2.hs +1/−1
• test/Test/Sanity/OverloadedRecordDot.hs +84/−0
• test/Test/Sanity/OverloadedRecordUpdate.hs +115/−0
• test/Test/Sanity/PolyKinds.hs +1/−1
• test/Test/Sanity/RebindableSyntax/Disabled.hs +6/−0
• test/Test/Sanity/RebindableSyntax/Enabled.hs +9/−0
• test/Test/Sanity/RebindableSyntax/Tests.hs +216/−0
• test/Test/Sanity/Simple.hs +1/−0
• test/TestLargeAnon.hs +12/−0

@@ -1,5 +1,12 @@ # Revision history for large-anon +## 0.2 -- 2023-03-06++* Do not generate imports in the plugin (#129).+* Support ghc 9.4 (#131).+* Use `ANON`/`ANON_F` in `Show` instance (#103).+* Support `OverloadedRecordDot` and `OverloadedRecordUpdate` (#128).+ ## 0.1.1 -- 2022-07-22  * Support for ghc 9.2 (#116)

@@ -0,0 +1,15 @@+module Main (main) where++import Ormolu+import System.Environment++import qualified Data.Text.IO as Text++main :: IO ()+main = do+    _nameOrig:inputPath:outputPath:[] <- getArgs+    rendered <- ormoluFile config inputPath+    Text.writeFile outputPath rendered+  where+    config :: Config RegionIndices+    config = defaultConfig

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               large-anon-version:            0.1.1+version:            0.2 synopsis:           Scalable anonymous records description:        The @large-anon@ package provides support for anonymous                     records in Haskell, with a focus on compile-time (and@@ -11,15 +11,17 @@ maintainer:         edsko@well-typed.com category:           Records extra-source-files: CHANGELOG.md-tested-with:        GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2+                    test/Test/Sanity/RebindableSyntax/Tests.hs+tested-with:        GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4  library   exposed-modules:       Data.Record.Anon-      Data.Record.Anon.Simple       Data.Record.Anon.Advanced+      Data.Record.Anon.Overloading       Data.Record.Anon.Plugin       Data.Record.Anon.Plugin.Internal.Runtime+      Data.Record.Anon.Simple    other-modules:       -- Module organization:@@ -62,16 +64,17 @@       Data.Record.Anon.Internal.Plugin.TC.TyConSubst        Data.Record.Anon.Internal.Plugin.Source+      Data.Record.Anon.Internal.Plugin.Source.FreshT       Data.Record.Anon.Internal.Plugin.Source.GhcShim       Data.Record.Anon.Internal.Plugin.Source.Names-      Data.Record.Anon.Internal.Plugin.Source.NamingT       Data.Record.Anon.Internal.Plugin.Source.Options    build-depends:       base             >= 4.13  && < 4.18     , aeson            >= 1.4.4 && < 2.2     , containers       >= 0.6.2 && < 0.7-    , ghc-tcplugin-api >= 0.8   && < 0.9+    , deepseq          >= 1.4.4 && < 1.5+    , ghc-tcplugin-api >= 0.10  && < 0.11     , hashable         >= 1.3   && < 1.5     , mtl              >= 2.2.1 && < 2.3     , optics-core      >= 0.3   && < 0.5@@ -116,12 +119,12 @@   main-is:       TestLargeAnon.hs   other-modules:-      Test.Infra.Generics-      Test.Infra.MarkStrictness       Test.Infra.Discovery       Test.Infra.DynRecord       Test.Infra.DynRecord.Advanced       Test.Infra.DynRecord.Simple+      Test.Infra.Generics+      Test.Infra.MarkStrictness       Test.Prop.Record.Combinators.Constrained       Test.Prop.Record.Combinators.Simple       Test.Prop.Record.Model@@ -133,22 +136,29 @@       Test.Sanity.CheckIsSubRow       Test.Sanity.Discovery       Test.Sanity.DuplicateFields+      Test.Sanity.Fourmolu.OverloadedRecordDot+      Test.Sanity.Fourmolu.OverloadedRecordUpdate       Test.Sanity.Generics       Test.Sanity.HasField       Test.Sanity.Intersection       Test.Sanity.Merging       Test.Sanity.Named.Record1       Test.Sanity.Named.Record2+      Test.Sanity.OverloadedRecordDot+      Test.Sanity.OverloadedRecordUpdate       Test.Sanity.PolyKinds+      Test.Sanity.RebindableSyntax.Disabled+      Test.Sanity.RebindableSyntax.Enabled       Test.Sanity.RecordLens       Test.Sanity.Simple       Test.Sanity.SrcPlugin.WithoutTypelet       Test.Sanity.SrcPlugin.WithTypelet       Test.Sanity.TypeLevelMetadata   build-depends:-      base     , aeson     , aeson-pretty+    , arrows+    , base     , bytestring     , large-anon     , large-generics@@ -157,16 +167,15 @@     , parsec     , QuickCheck     , record-dot-preprocessor+    , record-hasfield     , sop-core+    , Stream     , tasty     , tasty-hunit     , tasty-quickcheck     , text     , typelet     , validation-selective--      -- required when using record-dot-preprocessor-    , record-hasfield   ghc-options:       -Wall       -Wredundant-constraints@@ -178,9 +187,27 @@   -- if impl(ghc >= 8.10)   --   ghc-options: -Wunused-packages -  if impl(ghc >= 9.0.1)-    -- Work around ghc problem. See more detailed discussion in large-records.-    ghc-options: -Wno-unused-imports+  if impl(ghc >= 9.2)+    build-tool-depends:+      large-anon:large-anon-testsuite-fourmolu-preprocessor++Executable large-anon-testsuite-fourmolu-preprocessor+  main-is:+      Main.hs+  hs-source-dirs:+      fourmolu-preprocessor+  build-depends:+    , base+    , fourmolu >= 0.10.1+    , text+  default-language:+      Haskell2010+  ghc-options:+      -Wall++  -- Fourmolu is only compatible with RDP syntax from ghc 9.2 and up.+  if impl(ghc < 9.2)+    buildable: False  Flag debug   Description: Enable internal debugging features

@@ -73,11 +73,14 @@     -- linear in size.   , letRecordT   , letInsertAs+    -- ** Supporting definitions+  , castEqual   ) where  import Prelude hiding (sequenceA, map, mapM, pure, zip, zipWith) -import TypeLet+import TypeLet (Let, Equal)+import qualified TypeLet  import Data.Record.Anon @@ -93,7 +96,6 @@ -- >>> import Prelude hiding (pure) -- >>> import qualified Prelude -- >>> import Data.Record.Anon--- >>> import TypeLet  {-------------------------------------------------------------------------------   Construction@@ -564,5 +566,11 @@   -> Record f r letInsertAs p n x r f = A.letInsertAs p n x r f +{-------------------------------------------------------------------------------+  Supporting definitions+-------------------------------------------------------------------------------}++castEqual :: Equal a b => a -> b+castEqual = TypeLet.castEqual  

@@ -79,6 +79,7 @@ import Prelude hiding (map, mapM, zip, zipWith, sequenceA, pure) import qualified Prelude +import Control.DeepSeq (NFData (..)) import Data.Aeson (ToJSON(..), FromJSON(..)) import Data.Bifunctor import Data.Coerce (coerce)@@ -92,15 +93,17 @@ import Data.Tagged import GHC.Exts (Any) import GHC.OverloadedLabels-import GHC.Records.Compat import GHC.TypeLits import TypeLet.UserAPI -import qualified Optics.Core as Optics+import qualified Optics.Core        as Optics+import qualified GHC.Records        as Base+import qualified GHC.Records.Compat as RecordHasfield -import qualified Data.Record.Generic.Eq   as Generic-import qualified Data.Record.Generic.JSON as Generic-import qualified Data.Record.Generic.Show as Generic+import qualified Data.Record.Generic.Eq     as Generic+import qualified Data.Record.Generic.JSON   as Generic+import qualified Data.Record.Generic.NFData as Generic+import qualified Data.Record.Generic.Show   as Generic  import Data.Record.Anon.Internal.Core.Canonical (Canonical) import Data.Record.Anon.Internal.Core.Diff (Diff)@@ -144,7 +147,7 @@ unsafeFromCanonical = NoPending  {--------------------------------------------------------------------------------  HasField+  HasField from @record-hasfield@ -------------------------------------------------------------------------------}  -- | Proxy for a field name, with 'IsLabel' instance@@ -164,7 +167,7 @@  instance forall k (n :: Symbol) (f :: k -> Type) (r :: Row k) (a :: k).        (KnownSymbol n, KnownHash n, RowHasField n r a)-    => HasField n (Record f r) (f a) where+    => RecordHasfield.HasField n (Record f r) (f a) where    -- INLINE pragma important: it makes the 'NoPendingCases' cases very close   -- to the performance of using a 'SmallArray' directly.@@ -222,14 +225,22 @@ get :: forall n f r a.      RowHasField n r a   => Field n -> Record f r -> f a-get (Field _) = getField @n @(Record f r)+get (Field _) = RecordHasfield.getField @n @(Record f r)  set :: forall n f r a.      RowHasField n r a   => Field n -> f a -> Record f r -> Record f r-set (Field _) = flip (setField @n @(Record f r))+set (Field _) = flip (RecordHasfield.setField @n @(Record f r))  {-------------------------------------------------------------------------------+  Compatibility with HasField from base+-------------------------------------------------------------------------------}++instance (KnownSymbol n, KnownHash n, RowHasField n r a)+      => Base.HasField n (Record f r) (f a) where+  getField = snd . RecordHasfield.hasField @n++{-------------------------------------------------------------------------------   Main API -------------------------------------------------------------------------------} @@ -521,7 +532,7 @@   => Metadata (Record f r) recordMetadata = Metadata {       recordName          = "Record"-    , recordConstructor   = "Record"+    , recordConstructor   = "ANON_F"     , recordSize          = length fields     , recordFieldMetadata = Rep $ smallArrayFromList fields     }@@ -555,32 +566,14 @@          ) => Ord (Record f r) where   compare = Generic.gcompare +instance RecordConstraints f r NFData => NFData (Record f r) where+  rnf = Generic.grnf+ instance RecordConstraints f r ToJSON => ToJSON (Record f r) where   toJSON = Generic.gtoJSON  instance RecordConstraints f r FromJSON => FromJSON (Record f r) where   parseJSON = Generic.gparseJSON--{--------------------------------------------------------------------------------  UTIL. Not sure if we still need this--------------------------------------------------------------------------------}--{---data Constrained (c :: k -> Constraint) (f :: k -> Type) (x :: k) where-  Constrained :: c x => f x -> Constrained c f x--constrain :: forall k (c :: k -> Constraint) (f :: k -> Type) (r :: Row k).-      AllFields r c-   => Proxy c -> Record f r -> Record (Constrained c f) r-constrain p (Record.toCanonical -> r) = Record.unsafeFromCanonical $-    Canon.fromLazyVector $-      V.zipWith aux (Canon.toLazyVector r) (fieldDicts (Proxy @r) p)-  where-    aux :: f Any -> DictAny c -> Constrained c f Any-    aux x DictAny = Constrained x---}  {-------------------------------------------------------------------------------   Constrained combinators

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Data.Record.Anon.Internal.Plugin (plugin) where  import GHC.TcPlugin.API@@ -21,10 +23,17 @@       GHC.Plugins.tcPlugin = \_args -> Just $         mkTcPlugin tcPlugin     , GHC.Plugins.parsedResultAction = \args _modSummary ->-        sourcePlugin args+        ignoreMessages $ sourcePlugin args     , GHC.Plugins.pluginRecompile =         GHC.Plugins.purePlugin     }+  where+#if __GLASGOW_HASKELL__ >= 904+    ignoreMessages f (GHC.Plugins.ParsedResult modl msgs) =+            (\modl' -> GHC.Plugins.ParsedResult modl' msgs) <$> f modl+#else+    ignoreMessages = id+#endif  tcPlugin :: TcPlugin tcPlugin = TcPlugin {

@@ -1,7 +1,9 @@-{-# LANGUAGE NamedFieldPuns  #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections   #-}-{-# LANGUAGE ViewPatterns    #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE ViewPatterns        #-}  module Data.Record.Anon.Internal.Plugin.Source (sourcePlugin) where @@ -9,9 +11,9 @@ import Control.Monad.Trans import Data.Generics (everywhereM, mkM) +import Data.Record.Anon.Internal.Plugin.Source.FreshT import Data.Record.Anon.Internal.Plugin.Source.GhcShim import Data.Record.Anon.Internal.Plugin.Source.Names-import Data.Record.Anon.Internal.Plugin.Source.NamingT import Data.Record.Anon.Internal.Plugin.Source.Options  {-------------------------------------------------------------------------------@@ -19,32 +21,31 @@ -------------------------------------------------------------------------------}  sourcePlugin :: [String] -> HsParsedModule -> Hsc HsParsedModule-sourcePlugin opts+sourcePlugin rawOpts              parsed@HsParsedModule{-                 hpm_module = L l modl@HsModule{-                     hsmodDecls   = decls-                   , hsmodImports = imports-                   }+                 hpm_module = L l modl@HsModule{hsmodDecls = decls}                } = do-    (decls', modls) <- runNamingHsc $-                         everywhereM-                           (mkM $ transformExpr $ parseOpts opts)-                           decls++    decls' <- runFreshHsc $+                everywhereM+                  (mkM $ transformExpr opts)+                  decls     return $ parsed {-        hpm_module = L l $ modl {-            hsmodDecls   = decls'-          , hsmodImports = imports ++ map (importDecl True) modls-          }+        hpm_module = L l $ modl { hsmodDecls = decls' }       }+  where+    opts :: Options+    opts = parseOpts rawOpts -transformExpr :: Options -> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)+transformExpr :: Options -> LHsExpr GhcPs -> FreshT Hsc (LHsExpr GhcPs) transformExpr options@Options{debug} e@(reLoc -> L l expr)   | RecordCon _ext (L _ nm) (HsRecFields flds dotdot) <- expr   , Unqual nm' <- nm   , Nothing    <- dotdot   , Just mode  <- parseMode (occNameString nm')   , Just flds' <- mapM getField flds-  = do e' <- anonRec options mode l flds'+  = do names <- lift $ getLargeAnonNames mode+       e'    <- anonRec options names l flds'        when debug $ lift $ issueWarning l (debugMsg e')        return e' @@ -54,10 +55,17 @@     getField ::          LHsRecField GhcPs (LHsExpr GhcPs)       -> Maybe (FastString, LHsExpr GhcPs)+#if __GLASGOW_HASKELL__ < 904     getField (L _ (HsRecField                     { hsRecFieldLbl = L _ fieldOcc                     , hsRecFieldArg = arg                     , hsRecPun = pun }))+#else+    getField (L _ (HsFieldBind+                    { hfbLHS = L _ fieldOcc+                    , hfbRHS = arg+                    , hfbPun = pun }))+#endif       | FieldOcc _ (L _ nm) <- fieldOcc       , Unqual nm' <- nm       , not pun@@ -78,46 +86,37 @@  anonRec ::      Options-  -> Mode+  -> LargeAnonNames   -> SrcSpan   -> [(FastString, LHsExpr GhcPs)]-  -> NamingT Hsc (LHsExpr GhcPs)-anonRec Options{typelet, noapply} mode l = \fields ->+  -> FreshT Hsc (LHsExpr GhcPs)+anonRec Options{typelet, noapply} names@LargeAnonNames{..} l = \fields ->     applyDiff =<< go fields   where-    LargeAnonNames{..} = largeAnonNames mode--    go :: [(FastString, LHsExpr GhcPs)] -> NamingT Hsc (LHsExpr GhcPs)+    go :: [(FastString, LHsExpr GhcPs)] -> FreshT Hsc (LHsExpr GhcPs)     go fields       | null fields = do-          useName largeAnon_empty           return $ mkVar l largeAnon_empty       | not typelet = do-          recordWithoutTypelet mode l fields+          lift $ recordWithoutTypelet names l fields       | otherwise = do           p       <- freshVar l "p"           fields' <- mapM (\(n, e) -> (n,e,) <$> freshVar l "xs") fields-          recordWithTypelet mode l p fields'+          lift $ recordWithTypelet names l p fields' -    applyDiff :: LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs)+    applyDiff :: LHsExpr GhcPs -> FreshT Hsc (LHsExpr GhcPs)     applyDiff e       | noapply   = return e-      | otherwise = do-          useName largeAnon_applyPending-          return $ mkVar l largeAnon_applyPending `mkHsApp` e+      | otherwise = return $ mkVar l largeAnon_applyPending `mkHsApp` e  recordWithoutTypelet ::-     Mode+     LargeAnonNames   -> SrcSpan   -> [(FastString, LHsExpr GhcPs)]-  -> NamingT Hsc (LHsExpr GhcPs)-recordWithoutTypelet mode l = \fields -> do-    useName largeAnon_empty-    useName largeAnon_insert+  -> Hsc (LHsExpr GhcPs)+recordWithoutTypelet LargeAnonNames{..} l = \fields -> do     return $ go fields   where-    LargeAnonNames{..} = largeAnonNames mode-     go :: [(FastString, LHsExpr GhcPs)] -> LHsExpr GhcPs     go []         = mkVar l largeAnon_empty     go ((n,e):fs) = mkVar l largeAnon_insert `mkHsApps` [mkLabel l n, e, go fs]@@ -126,25 +125,17 @@ -- -- See documentation of 'letRecordT' and 'letInsertAs'. recordWithTypelet ::-     Mode+     LargeAnonNames   -> SrcSpan   -> RdrName                                -- ^ Fresh var for the proxy   -> [(FastString, LHsExpr GhcPs, RdrName)] -- ^ Fresh var for each insert-  -> NamingT Hsc (LHsExpr GhcPs)-recordWithTypelet mode l p = \fields -> do-    useName largeAnon_empty-    useName largeAnon_insert-    useName largeAnon_letRecordT-    useName largeAnon_letInsertAs-    useName typelet_castEqual-+  -> Hsc (LHsExpr GhcPs)+recordWithTypelet LargeAnonNames{..} l p = \fields -> do     return $       mkHsApp (mkVar l largeAnon_letRecordT) $         simpleLam p $ mkHsApp (mkVar l typelet_castEqual) $           go (mkVar l largeAnon_empty) $ reverse fields   where-    LargeAnonNames{..} = largeAnonNames mode-     go ::          LHsExpr GhcPs       -> [(FastString, LHsExpr GhcPs, RdrName)]

@@ -0,0 +1,60 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Fresh name generation+module Data.Record.Anon.Internal.Plugin.Source.FreshT (+    -- * Monad definition+    FreshT -- opaque+  , runFreshT+  , runFreshHsc+    -- * Generate fresh names+  , fresh+  , freshVar+  ) where++import Control.Monad.Reader++import Data.Record.Anon.Internal.Plugin.Source.GhcShim++{-------------------------------------------------------------------------------+  Monad definition+-------------------------------------------------------------------------------}++-- | Fresh name generation+newtype FreshT m a = WrapFreshT {+      unwrapNamingT :: ReaderT NameCacheIO m a+    }+  deriving (Functor, Applicative, Monad)++instance MonadTrans FreshT where+  lift = WrapFreshT . lift++runFreshT :: NameCacheIO -> FreshT m a -> m a+runFreshT ncVar = flip runReaderT ncVar . unwrapNamingT++runFreshHsc :: FreshT Hsc a -> Hsc a+runFreshHsc ma = do+    env <- getHscEnv+    runFreshT (hscNameCacheIO env) ma++{-------------------------------------------------------------------------------+  Key features of FreshT+-------------------------------------------------------------------------------}++fresh :: MonadIO m => SrcSpan -> RdrName -> FreshT m RdrName+fresh l name = WrapFreshT $ ReaderT $ \nc -> do+    newUniq <- liftIO $ takeUniqFromNameCacheIO nc+    return $ Exact $ mkInternalName newUniq (newOccName (rdrNameOcc name)) l+  where+    -- Even when we generate fresh names, ghc can still complain about name+    -- shadowing, because this check only considers the 'OccName', not the+    -- unique. We therefore prefix the name with an underscore to avoid the+    -- warning.+    newOccName :: OccName -> OccName+    newOccName n = mkOccName (occNameSpace n) . ("_" ++) $ occNameString n++{-------------------------------------------------------------------------------+  Derived convenience functions+-------------------------------------------------------------------------------}++freshVar :: MonadIO m => SrcSpan -> String -> FreshT m RdrName+freshVar l = fresh l . mkRdrUnqual . mkVarOcc

@@ -16,6 +16,14 @@   , reLoc, reLocA #endif +    -- * Names+  , lookupName++    -- * NameCache+  , NameCacheIO+  , hscNameCacheIO+  , takeUniqFromNameCacheIO+     -- * Miscellaneous   , importDecl   , issueWarning@@ -32,7 +40,6 @@   , module HscMain   , module HscTypes   , module Name-  , module NameCache   , module OccName   , module Outputable   , module RdrName@@ -42,7 +49,6 @@   , module GHC.Data.FastString   , module GHC.Driver.Main   , module GHC.Types.Name-  , module GHC.Types.Name.Cache   , module GHC.Types.Name.Occurrence   , module GHC.Types.Name.Reader   , module GHC.Types.Unique.Supply@@ -58,51 +64,142 @@ #endif   ) where +import GHC.Stack+ #if __GLASGOW_HASKELL__ < 900 +import Data.IORef import Data.List (foldl') -import Bag (listToBag)-import BasicTypes (Origin(Generated), PromotionFlag(NotPromoted))+import GHC hiding (lookupName)++import Bag (Bag, listToBag)+import BasicTypes (Origin(Generated), PromotionFlag(NotPromoted), SourceText(NoSourceText))+import DynFlags (getDynFlags) import ErrUtils (mkWarnMsg) import FastString (FastString)-import GHC-import GhcPlugins+import Finder (findImportedModule) import HscMain (getHscEnv) import HscTypes+import IfaceEnv (lookupOrigIO)+import MonadUtils import Name (mkInternalName) import NameCache (NameCache(nsUniqs)) import OccName import Outputable import RdrName (RdrName(Exact), rdrNameOcc, mkRdrQual, mkRdrUnqual) import UniqSupply (takeUniqFromSupply)+import Unique (Unique)  #else -import GHC-import GHC.Data.Bag (listToBag)+import GHC hiding (lookupName)++import GHC.Data.Bag (listToBag, Bag) import GHC.Data.FastString (FastString) import GHC.Driver.Main (getHscEnv)+import GHC.Driver.Session (getDynFlags)+import GHC.Types.Name (mkInternalName)+import GHC.Types.Name.Occurrence+import GHC.Types.Name.Reader (RdrName(Exact), rdrNameOcc, mkRdrQual, mkRdrUnqual)+import GHC.Types.SrcLoc (LayoutInfo(NoLayoutInfo))+import GHC.Types.Unique (Unique)+import GHC.Types.Unique.Supply (takeUniqFromSupply)+import GHC.Utils.Monad+import GHC.Utils.Outputable  #if __GLASGOW_HASKELL__ >= 902-import GHC.Driver.Errors import GHC.Driver.Env.Types-import GHC.Types.SourceText+import GHC.Driver.Errors+import GHC.Types.SourceText (SourceText(NoSourceText))+import GHC.Unit.Finder (findImportedModule, FindResult(Found))+import GHC.Unit.Types (IsBootInterface(NotBoot)) #else+import GHC.Driver.Finder (findImportedModule) import GHC.Driver.Types+import GHC.Types.Basic (SourceText(NoSourceText)) #endif-import GHC.Plugins-import GHC.Types.Name (mkInternalName)++#if __GLASGOW_HASKELL__ < 904+import Data.IORef++import GHC.Iface.Env (lookupOrigIO) import GHC.Types.Name.Cache (NameCache(nsUniqs))-import GHC.Types.Name.Occurrence-import GHC.Types.Name.Reader (RdrName(Exact), rdrNameOcc, mkRdrQual, mkRdrUnqual)-import GHC.Types.Unique.Supply (takeUniqFromSupply) import GHC.Utils.Error (mkWarnMsg)-import GHC.Utils.Outputable+#else+import GHC.Driver.Config.Diagnostic (initDiagOpts)+import GHC.Driver.Errors.Types (GhcMessage(..))+import GHC.Iface.Env (lookupNameCache)+import GHC.Rename.Names (renamePkgQual)+import GHC.Types.Error (MsgEnvelope(..), mkMessages)+import GHC.Types.Name.Cache (NameCache, takeUniqFromNameCache)+import GHC.Types.PkgQual (RawPkgQual(NoRawPkgQual))+import GHC.Utils.Error (mkPlainError)+#endif  #endif  {-------------------------------------------------------------------------------+  Names+-------------------------------------------------------------------------------}++lookupName ::+     HasCallStack+  => ModuleName+  -> Maybe FastString -- ^ Optional package name+  -> String -> Hsc Name+lookupName modl pkg = lookupOccName modl pkg . mkVarOcc++lookupOccName ::+     HasCallStack+  => ModuleName+  -> Maybe FastString -- ^ Optional package name+  -> OccName -> Hsc Name+lookupOccName modlName mPkgName name = do+    env <- getHscEnv++#if __GLASGOW_HASKELL__ >= 904+    let pkgq :: PkgQual+        pkgq = renamePkgQual (hsc_unit_env env) modlName mPkgName+#else+    let pkgq :: Maybe FastString+        pkgq = mPkgName+#endif++    mModl <- liftIO $ findImportedModule env modlName pkgq+    case mModl of+      Found _ modl -> liftIO $ lookupOrigIO env modl name+      _otherwise   -> error $ "lookupName: name not found"++#if __GLASGOW_HASKELL__ >= 904+lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name+lookupOrigIO env modl occ = lookupNameCache (hsc_NC env) modl occ+#endif++{-------------------------------------------------------------------------------+  NameCache+-------------------------------------------------------------------------------}++#if __GLASGOW_HASKELL__ < 904+type NameCacheIO = IORef NameCache++takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique+takeUniqFromNameCacheIO = flip atomicModifyIORef aux+  where+    aux :: NameCache -> (NameCache, Unique)+    aux nc = let (newUniq, us) = takeUniqFromSupply (nsUniqs nc)+             in (nc { nsUniqs = us }, newUniq)+#else+type NameCacheIO = NameCache++takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique+takeUniqFromNameCacheIO = takeUniqFromNameCache+#endif++hscNameCacheIO :: HscEnv -> NameCacheIO+hscNameCacheIO = hsc_NC++{-------------------------------------------------------------------------------   Miscellaneous -------------------------------------------------------------------------------} @@ -112,7 +209,11 @@       ideclExt       = defExt     , ideclSourceSrc = NoSourceText     , ideclName      = reLocA $ noLoc name+#if __GLASGOW_HASKELL__ >= 904+    , ideclPkgQual   = NoRawPkgQual+#else     , ideclPkgQual   = Nothing+#endif     , ideclSafe      = False     , ideclImplicit  = False     , ideclAs        = Nothing@@ -132,14 +233,26 @@ issueWarning :: SrcSpan -> SDoc -> Hsc () issueWarning l errMsg = do     dynFlags <- getDynFlags-#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ == 902     logger <- getLogger-    liftIO $ printOrThrowWarnings logger dynFlags . listToBag . (:[]) $+    liftIO $ printOrThrowWarnings logger dynFlags . bag $       mkWarnMsg l neverQualify errMsg+#elif __GLASGOW_HASKELL__ >= 904+    logger <- getLogger+    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dynFlags) . mkMessages . bag $+      MsgEnvelope {+          errMsgSpan       = l+        , errMsgContext    = neverQualify+        , errMsgDiagnostic = GhcUnknownMessage $ mkPlainError [] errMsg+        , errMsgSeverity   = SevWarning+        } #else-    liftIO $ printOrThrowWarnings dynFlags . listToBag . (:[]) $+    liftIO $ printOrThrowWarnings dynFlags . bag $       mkWarnMsg dynFlags l neverQualify errMsg #endif+  where+    bag :: a -> Bag a+    bag = listToBag . (:[])  #if __GLASGOW_HASKELL__ < 900 mkHsApps ::@@ -185,7 +298,6 @@ reLocA :: Located a -> Located a reLocA = id #endif-  {-------------------------------------------------------------------------------   mkLabel

@@ -1,12 +1,12 @@+{-# LANGUAGE RecordWildCards #-}+ -- | Names used in code generation -- -- Intended for unqualified. module Data.Record.Anon.Internal.Plugin.Source.Names (     -- * large-anon     LargeAnonNames(..)-  , largeAnonNames-    -- * typelet-  , typelet_castEqual+  , getLargeAnonNames   ) where  import Data.Record.Anon.Internal.Plugin.Source.GhcShim@@ -18,35 +18,29 @@  -- | Named required for code generation ----- All names are expected to be qualified with the full module name+-- All names are expected to be exact. data LargeAnonNames = LargeAnonNames {       largeAnon_empty        :: RdrName     , largeAnon_insert       :: RdrName     , largeAnon_applyPending :: RdrName     , largeAnon_letRecordT   :: RdrName     , largeAnon_letInsertAs  :: RdrName+    , typelet_castEqual      :: RdrName     } -largeAnonNames :: Mode -> LargeAnonNames-largeAnonNames mode = LargeAnonNames {-      largeAnon_empty        = mkRdrQual modl $ mkVarOcc "empty"-    , largeAnon_insert       = mkRdrQual modl $ mkVarOcc "insert"-    , largeAnon_applyPending = mkRdrQual modl $ mkVarOcc "applyPending"-    , largeAnon_letRecordT   = mkRdrQual modl $ mkVarOcc "letRecordT"-    , largeAnon_letInsertAs  = mkRdrQual modl $ mkVarOcc "letInsertAs"-    }+getLargeAnonNames :: Mode -> Hsc LargeAnonNames+getLargeAnonNames mode = do+    -- We avoid importing names from other packages; see detailed discussion+    -- in "Data.Record.Anon.Plugin.Internal.Runtime".+    largeAnon_empty        <- Exact <$> lookupName modl Nothing "empty"+    largeAnon_insert       <- Exact <$> lookupName modl Nothing "insert"+    largeAnon_applyPending <- Exact <$> lookupName modl Nothing "applyPending"+    largeAnon_letRecordT   <- Exact <$> lookupName modl Nothing "letRecordT"+    largeAnon_letInsertAs  <- Exact <$> lookupName modl Nothing "letInsertAs"+    typelet_castEqual      <- Exact <$> lookupName modl Nothing "castEqual"+    return LargeAnonNames{..}   where     modl :: ModuleName     modl = case mode of              Simple   -> mkModuleName "Data.Record.Anon.Simple"              Advanced -> mkModuleName "Data.Record.Anon.Advanced"--{--------------------------------------------------------------------------------  Typelet--------------------------------------------------------------------------------}--typelet :: ModuleName-typelet = mkModuleName "TypeLet"--typelet_castEqual :: RdrName-typelet_castEqual = mkRdrQual typelet $ mkVarOcc "castEqual"

@@ -1,96 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Naming things is hard-module Data.Record.Anon.Internal.Plugin.Source.NamingT (-    -- * Monad definition-    NamingT -- opaque-  , runNamingT-  , runNamingHsc-    -- * Key features of NamingT-  , useName-  , fresh-    -- * Convenience derived features-  , freshVar-  ) where--import Control.Monad.Reader-import Control.Monad.State-import Data.Bifunctor-import Data.IORef-import Data.Set (Set)--import qualified Data.Set as Set--import Data.Record.Anon.Internal.Plugin.Source.GhcShim--{--------------------------------------------------------------------------------  Monad definition--------------------------------------------------------------------------------}--data Env = Env {-      envNameCache :: IORef NameCache-    }---- | Naming things is hard------ The 'NamingT' monad transformer that provides two things:------ 1. Keep track of the imports we need for the names that we use.--- 2. Generation of fresh names.-newtype NamingT m a = WrapNamingT {-      unwrapNamingT :: StateT (Set ModuleName) (ReaderT Env m) a-    }-  deriving (Functor, Applicative, Monad)--instance MonadTrans NamingT where-  lift = WrapNamingT . lift . lift--runNamingT :: Functor m => IORef NameCache -> NamingT m a -> m (a, [ModuleName])-runNamingT ncVar =-      fmap (second Set.toList)-    . flip runReaderT env-    . flip runStateT  Set.empty-    . unwrapNamingT-  where-    env :: Env-    env = Env { envNameCache = ncVar }--runNamingHsc :: NamingT Hsc a -> Hsc (a, [ModuleName])-runNamingHsc ma = do-    env <- getHscEnv-    runNamingT (hsc_NC env) ma--{--------------------------------------------------------------------------------  Key features of NamingT--------------------------------------------------------------------------------}--useName :: Monad m => RdrName -> NamingT m ()-useName (Qual modl _) = WrapNamingT $ modify (Set.insert modl)-useName _otherwise    = error "useName: expected qualified name"--fresh :: MonadIO m => SrcSpan -> RdrName -> NamingT m RdrName-fresh l name = WrapNamingT $ do-    ncVar <- asks envNameCache-    liftIO $ atomicModifyIORef ncVar aux-  where-    aux :: NameCache -> (NameCache, RdrName)-    aux nc = (-          nc { nsUniqs = us }-        , Exact $ mkInternalName newUniq (newOccName (rdrNameOcc name)) l-        )-      where-        (newUniq, us) = takeUniqFromSupply (nsUniqs nc)--    -- Even when we generate fresh names, ghc can still complain about name-    -- shadowing, because this check only considers the 'OccName', not the-    -- unique. We therefore prefix the name with an underscore to avoid the-    -- warning.-    newOccName :: OccName -> OccName-    newOccName n = mkOccName (occNameSpace n) . ("_" ++) $ occNameString n--{--------------------------------------------------------------------------------  Derived convenience functions--------------------------------------------------------------------------------}--freshVar :: MonadIO m => SrcSpan -> String -> NamingT m RdrName-freshVar l = fresh l . mkRdrUnqual . mkVarOcc

@@ -20,8 +20,11 @@      -- * New functonality   , isCanonicalVarEq+  , getModule   ) where +import GHC.Stack+ #if __GLASGOW_HASKELL__ < 900 import Data.List.NonEmpty (NonEmpty, toList) #endif@@ -81,3 +84,17 @@ instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where   ppr (L l e) = parens $ text "L" <+> ppr l <+> ppr e #endif++getModule :: (HasCallStack, MonadTcPlugin m) => String -> String -> m Module+getModule pkg modl = do+    let modl' = mkModuleName modl+    pkg' <- resolveImport modl' (Just $ fsLit pkg)+    res  <- findImportedModule modl' pkg'+    case res of+      Found _ m  -> return m+      _otherwise -> error $ concat [+          "getModule: could not find "+        , modl+        , " in package "+        , pkg+        ]

@@ -69,14 +69,3 @@     tyConSimpleFieldTypes <- getTyCon       "SimpleFieldTypes"      return $ ResolvedNames {..}--{--------------------------------------------------------------------------------  Auxiliary--------------------------------------------------------------------------------}--getModule :: MonadTcPlugin m => String -> String -> m Module-getModule pkg modl = do-    r <- findImportedModule (mkModuleName modl) (OtherPkg $ stringToUnitId pkg)-    case r of-      Found _ m  -> return m-      _otherwise -> panic $ "Could not find " ++ modl ++ " in package " ++ pkg

@@ -60,8 +60,8 @@         return TcPluginNoRewrite       Just knownFields ->         return TcPluginRewriteTo {-            tcRewriterWanteds = []-          , tcPluginReduction =+            tcRewriterNewWanteds = []+          , tcPluginReduction    =                mkTyFamAppReduction                  "large-anon"                  Nominal

@@ -64,21 +64,24 @@  import Prelude hiding (sequenceA) +import Control.DeepSeq (NFData(..)) import Data.Aeson (ToJSON(..), FromJSON(..)) import Data.Bifunctor import Data.Record.Generic import Data.Record.Generic.Eq import Data.Record.Generic.JSON+import Data.Record.Generic.NFData import Data.Record.Generic.Show import Data.Tagged-import GHC.Exts+import GHC.Exts (Any) import GHC.OverloadedLabels-import GHC.Records.Compat import GHC.TypeLits import TypeLet import Data.Primitive.SmallArray -import qualified Optics.Core as Optics+import qualified GHC.Records        as Base+import qualified GHC.Records.Compat as RecordHasfield+import qualified Optics.Core        as Optics  import Data.Record.Anon.Plugin.Internal.Runtime @@ -109,8 +112,11 @@ -- NOTE: For some applications it is useful to have an additional functor -- parameter @f@, so that every field has type @f x@ instead. -- See "Data.Record.Anon.Advanced".-newtype Record r = SimpleRecord { toAdvanced :: A.Record I r }+newtype Record r = SimpleRecord (A.Record I r) +toAdvanced :: Record r -> A.Record I r+toAdvanced (SimpleRecord r) = r+ {-------------------------------------------------------------------------------   Interop with advanced API -------------------------------------------------------------------------------}@@ -158,19 +164,19 @@   HasField -------------------------------------------------------------------------------} -instance HasField  n            (A.Record I r) (I a)-      => HasField (n :: Symbol) (    Record   r)    a where-  hasField = aux . hasField @n . toAdvanced+instance RecordHasfield.HasField  n            (A.Record I r) (I a)+      => RecordHasfield.HasField (n :: Symbol) (  Record   r)    a where+  hasField = aux . RecordHasfield.hasField @n . toAdvanced     where       aux :: (I a -> A.Record I r, I a) -> (a -> Record r, a)       aux (setX, x) = (fromAdvanced . setX . I, unI x)  instance Optics.LabelOptic n Optics.A_Lens (A.Record I r) (A.Record I r) (I a) (I a)       => Optics.LabelOptic n Optics.A_Lens (    Record   r) (    Record   r)    a     a where-  labelOptic = toAdvanced Optics.% fromLabel @n Optics.% fromI+  labelOptic = isoAdvanced Optics.% fromLabel @n Optics.% fromI     where-      toAdvanced :: Optics.Iso' (Record r) (A.Record I r)-      toAdvanced = Optics.coerced+      isoAdvanced :: Optics.Iso' (Record r) (A.Record I r)+      isoAdvanced = Optics.coerced        fromI :: Optics.Iso' (I a) a       fromI = Optics.coerced@@ -179,15 +185,23 @@ -- -- This is just a wrapper around 'getField'. get :: forall n r a. RowHasField n r a => Field n -> Record r -> a-get (Field _) = getField @n @(Record r)+get (Field _) = RecordHasfield.getField @n @(Record r)  -- | Update field in the record -- -- This is just a wrapper around 'setField'. set :: forall n r a. RowHasField n r a => Field n -> a -> Record r -> Record r-set (Field _) = flip (setField @n @(Record r))+set (Field _) = flip (RecordHasfield.setField @n @(Record r))  {-------------------------------------------------------------------------------+  Compatibility with HasField from base+-------------------------------------------------------------------------------}++instance RecordHasfield.HasField  n            (A.Record I r) (I a)+      => Base.HasField           (n :: Symbol) (  Record   r)    a where+  getField = snd . RecordHasfield.hasField @n++{-------------------------------------------------------------------------------   Constraints -------------------------------------------------------------------------------} @@ -229,7 +243,7 @@ recordMetadata :: forall r. KnownFields r => Metadata (Record r) recordMetadata = Metadata {       recordName          = "Record"-    , recordConstructor   = "Record"+    , recordConstructor   = "ANON"     , recordSize          = length fields     , recordFieldMetadata = Rep $ smallArrayFromList fields     }@@ -254,6 +268,9 @@          , RecordConstraints r Ord          ) => Ord (Record r) where   compare = gcompare++instance RecordConstraints r NFData => NFData (Record r) where+  rnf = grnf  instance RecordConstraints r ToJSON => ToJSON (Record r) where   toJSON = gtoJSON

@@ -0,0 +1,45 @@+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++-- Not a fan of @AllowAmbiguousTypes@, but no choice here, /must/ be enabled+-- to export a 'getField' of the correct type.+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Restore \"regular\" environment when using @RebindableSyntax@+--+-- The @RebindableSyntax@ extension is currently required when using+-- @OverloadedRecordUpdate@, but when using this extension, a number of+-- functions are suddenly no longer in scope that normally are. This module+-- restores those functions to their standard definition.+module Data.Record.Anon.Overloading (+    module Prelude+  , Control.Arrow.app+  , Control.Arrow.arr+  , Control.Arrow.first+  , Control.Arrow.loop+  , (Control.Arrow.>>>)+  , (Control.Arrow.|||)+  , Data.String.fromString+  , GHC.OverloadedLabels.fromLabel+  , GHC.Records.getField+    -- * New definitions+  , ifThenElse+  , setField+  ) where++import qualified Control.Arrow+import qualified Data.String+import qualified GHC.OverloadedLabels+import qualified GHC.Records+import qualified GHC.Records.Compat++{-------------------------------------------------------------------------------+  Other exports+-------------------------------------------------------------------------------}++ifThenElse :: Bool -> a -> a -> a+ifThenElse b x y = if b then x else y++setField :: forall x r a. GHC.Records.Compat.HasField x r a => r -> a -> r+setField = fst . GHC.Records.Compat.hasField @x

@@ -40,11 +40,14 @@     -- linear in size.   , letRecordT   , letInsertAs+    -- ** Supporting definitions+  , castEqual   ) where  import Prelude hiding (sequenceA) -import TypeLet+import TypeLet (Let, Equal)+import qualified TypeLet  import Data.Record.Anon @@ -58,7 +61,6 @@ -- >>> :set -XTypeOperators -- >>> :set -fplugin=TypeLet -fplugin=Data.Record.Anon.Plugin -- >>> :set -dppr-cols=200--- >>> import TypeLet -- >>> import Data.Record.Anon  {-------------------------------------------------------------------------------@@ -275,4 +277,11 @@                  -- ^ Assign type variable to new partial record, and continue   -> Record r letInsertAs p n x r f = S.letInsertAs p n x r f++{-------------------------------------------------------------------------------+  Supporting definitions+-------------------------------------------------------------------------------}++castEqual :: Equal a b => a -> b+castEqual = TypeLet.castEqual 

@@ -77,7 +77,7 @@       show magenta   where     expected :: String-    expected = "Record {red = 1.0, green = 0.0, blue = 1.0}"+    expected = "ANON {red = 1.0, green = 0.0, blue = 1.0}"  test_toJSON :: Assertion test_toJSON =@@ -134,6 +134,17 @@     headerToJSON "" = Aeson.Null     headerToJSON xs = toJSON xs +-- | Aeson config with specific field ordering+--+-- For some reason this function results in a Core Lint warning in ghc 9.0+--+-- > *** Core Lint warnings : in result of CorePrep ***+-- > <no location info>: warning:+-- >     Unsafe coercion: between unboxed and boxed value+-- >       From: Int+-- >         To: Int#+--+-- No idea why; this is just regular Haskell code. aesonPrettyConfig :: Aeson.Pretty.Config aesonPrettyConfig = Aeson.Pretty.defConfig {       Aeson.Pretty.confCompare = compare `on` (fieldIndex . Text.unpack)

@@ -61,7 +61,7 @@           Dyn.S.toRecord r example2   where     expected :: String-    expected = "Record {a = 1, b = True, c = 'a'}"+    expected = "ANON {a = 1, b = True, c = 'a'}"  test_simple_toLens :: Assertion test_simple_toLens = do@@ -81,7 +81,7 @@           Dyn.S.toLens (Proxy @ExpectedSimple) example1      expectedGet :: String-    expectedGet = "Record {a = 1, c = 'a'}"+    expectedGet = "ANON {a = 1, c = 'a'}"      expectedMissingField :: Either NotSubRow ()     expectedMissingField = Left ["c"]@@ -114,7 +114,7 @@           Dyn.A.toRecord r example2   where     expected :: String-    expected = "Record {a = 1, b = True, c = 'a'}"+    expected = "ANON_F {a = 1, b = True, c = 'a'}"  test_advanced_toLens :: Assertion test_advanced_toLens = do@@ -130,7 +130,7 @@          Dyn.A.toLens (Proxy @ExpectedAdvanced) example1      expectedGet :: String-    expectedGet = "Record {a = 1, c = 'a'}"+    expectedGet = "ANON_F {a = 1, c = 'a'}"  {-------------------------------------------------------------------------------   Example 'DynRecord' values

@@ -130,7 +130,7 @@   where     expectedSame, expectedDiff :: String     expectedSame = concat [-          "Record {a = I 'a'"+          "ANON_F {a = I 'a'"         ,       ", b = I 1"         ,       ", c = I ()"         ,       ", b = I 2"@@ -138,7 +138,7 @@         ,         "}"         ]     expectedDiff = concat [-          "Record {a = I 'a'"+          "ANON_F {a = I 'a'"         ,       ", b = I 1"         ,       ", c = I ()"         ,       ", b = I True"

@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 902++module Test.Sanity.Fourmolu.OverloadedRecordDot (tests) where++import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+    testCaseInfo "Test.Sanity.Fourmolu.OverloadedRecordDot" $+      return "Skipped for ghc < 9.2"++#else++-- | Test with Fourmolu, using RDP+--+-- We use fourmolu as a preprocessor. This is obviously a weird usage of a+-- formatter, but the point here is to ensure that large-anon /can/ be used+-- with fourmolu, without it changing the code in incorrect ways.+--+-- To manually check the output of Fourmolu, use+--+-- > cabal run large-anon-testsuite-fourmolu-preprocessor x test/Test/Sanity/Fourmolu/OverloadedRecordDot.hs /dev/stdout+{-# OPTIONS_GHC -F -pgmF=large-anon-testsuite-fourmolu-preprocessor #-}++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Anon.Plugin #-}++module Test.Sanity.Fourmolu.OverloadedRecordDot (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Anon+import Data.Record.Anon.Simple++tests :: TestTree+tests = testGroup "Test.Sanity.Fourmolu.OverloadedRecordDot" [+      testCase "definition" test_definition+    , testGroup "Simple" [+          testCase "get" test_simple_get+        , testCase "set" test_simple_set+        ]+    , testGroup "Nested" [+          testCase "get" test_nested_get+        ]+    ]++test_definition :: Assertion+test_definition = do+    assertEqual "" expected $ show r+  where+    r :: Record [ "a" := Int, "b" := Bool ]+    r = ANON { a = 5, b = True }++    expected :: String+    expected = "ANON {a = 5, b = True}"++test_simple_get :: Assertion+test_simple_get =+    -- Without OverloadedRecordDot, fourmolu turns this into @r . b@+    assertEqual "" True $ r.b+  where+    r :: Record [ "a" := Int, "b" := Bool ]+    r = ANON { a = 5, b = True }++test_simple_set :: Assertion+test_simple_set = do+    assertEqual "" expected $+      -- record-dot-preprocessor doesn't want any whitespace in @r{a@+      -- but fortunately that is precisely the syntax that fourmolu generates+      r{a = 6}+  where+    r, expected :: Record [ "a" := Int, "b" := Bool ]+    r        = ANON { a = 5, b = True }+    expected = ANON { a = 6, b = True }++test_nested_get :: Assertion+test_nested_get =+    assertEqual "" 'x' $ r.b.d+  where+    r :: Record [ "a" := Int, "b" := Record [ "c" := Bool, "d" := Char ] ]+    r = ANON { a = 5, b = ANON { c = True, d = 'x' } }++#endif

@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 902++module Test.Sanity.Fourmolu.OverloadedRecordUpdate (tests) where++import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+    testCaseInfo "Test.Sanity.Fourmolu.OverloadedRecordUpdate" $+      return "Skipped for ghc < 9.2"++#else++-- | Test with Fourmolu, without RDP+--+-- See "Test.Sanity.Fourmolu.OverloadedRecordDot" for additional discussion.+{-# OPTIONS_GHC -F -pgmF=large-anon-testsuite-fourmolu-preprocessor #-}++{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE OverloadedRecordDot    #-}+{-# LANGUAGE OverloadedRecordUpdate #-}+{-# LANGUAGE RebindableSyntax       #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeOperators          #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Anon.Plugin #-}++module Test.Sanity.Fourmolu.OverloadedRecordUpdate (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Anon+import Data.Record.Anon.Overloading+import Data.Record.Anon.Simple++tests :: TestTree+tests = testGroup "Test.Sanity.Fourmolu.OverloadedRecordUpdate" [+      testCase "definition" test_definition+    , testGroup "Simple" [+          testCase "get" test_simple_get+        , testCase "set" test_simple_set+        ]+    , testGroup "Nested" [+          testCase "get" test_nested_get+        , testCase "set" test_nested_set+        ]+    ]++test_definition :: Assertion+test_definition = do+    assertEqual "" expected $ show r+  where+    r :: Record [ "a" := Int, "b" := Bool ]+    r = ANON { a = 5, b = True }++    expected :: String+    expected = "ANON {a = 5, b = True}"++test_simple_get :: Assertion+test_simple_get =+    -- Without OverloadedRecordDot, fourmolu turns this into @r . b@+    assertEqual "" True $ r.b+  where+    r :: Record [ "a" := Int, "b" := Bool ]+    r = ANON { a = 5, b = True }++test_simple_set :: Assertion+test_simple_set = do+    assertEqual "" expected $+      -- record-dot-preprocessor doesn't want any whitespace in @r{a@+      -- but fortunately that is precisely the syntax that fourmolu generates+      r{a = 6}+  where+    r, expected :: Record [ "a" := Int, "b" := Bool ]+    r        = ANON { a = 5, b = True }+    expected = ANON { a = 6, b = True }++test_nested_get :: Assertion+test_nested_get =+    assertEqual "" 'x' $ r.b.d+  where+    r :: Record [ "a" := Int, "b" := Record [ "c" := Bool, "d" := Char ] ]+    r = ANON { a = 5, b = ANON { c = True, d = 'x' } }++test_nested_set :: Assertion+test_nested_set = do+    -- fourmolu will parse this as "illegal overloaded record update"+    -- when OverloadedRecordUpdate is not enabled.+    assertEqual "" expected $+      r{b.c = False}+  where+    r, expected :: Record [ "a" := Int, "b" := Record [ "c" := Bool, "d" := Char ] ]+    r        = ANON { a = 5, b = ANON { c = True,  d = 'a' } }+    expected = ANON { a = 5, b = ANON { c = False, d = 'a' } }++#endif

@@ -69,9 +69,9 @@  test_Show :: Assertion test_Show = do-    assertEqual "R1" (show (R1.Record (I True) (I 'a') (I ()))) $ show record1-    assertEqual "R2" (show (R2.Record (I 'a')  (I True)))       $ show record2-    assertEqual "R3" (show (R2.Record (K ())   (K ())))         $ show record3+    assertEqual "R1" (show (R1.ANON_F (I True) (I 'a') (I ()))) $ show record1+    assertEqual "R2" (show (R2.ANON_F (I 'a')  (I True)))       $ show record2+    assertEqual "R3" (show (R2.ANON_F (K ())   (K ())))         $ show record3  test_Eq :: Assertion test_Eq = do@@ -82,9 +82,9 @@  test_Ord :: Assertion test_Ord = do-    assertEqual "R1" (compare (R1.Record (I True) (I 'a') (I ())) (R1.Record (I False) (I 'a') (I ()))) $+    assertEqual "R1" (compare (R1.ANON_F (I True) (I 'a') (I ())) (R1.ANON_F (I False) (I 'a') (I ()))) $       compare record1 (Anon.set #x (I False) record1)-    assertEqual "R2" (compare (R2.Record (I 'a') (I True)) (R2.Record (I 'a') (I False))) $+    assertEqual "R2" (compare (R2.ANON_F (I 'a') (I True)) (R2.ANON_F (I 'a') (I False))) $       compare record2 (Anon.set #x (I False) record2)  -- Test 'describeRecord'

@@ -6,7 +6,7 @@   ) where  -- | Non-anonymous record (for comparison with equivalent anonymous record)-data Record f = Record { x :: f Bool, y :: f Char, z :: f () }+data Record f = ANON_F { x :: f Bool, y :: f Char, z :: f () }  deriving instance (Show (f Bool), Show (f Char), Show (f ())) => Show (Record f) deriving instance (Eq   (f Bool), Eq   (f Char), Eq   (f ())) => Eq   (Record f)

@@ -6,7 +6,7 @@   ) where  -- | Non-anonymous record (for comparison with equivalent anonymous record)-data Record f = Record { y :: f Char, x :: f Bool }+data Record f = ANON_F { y :: f Char, x :: f Bool }  deriving instance (Show (f Char), Show (f Bool)) => Show (Record f) deriving instance (Eq   (f Char), Eq   (f Bool)) => Eq   (Record f)

@@ -0,0 +1,84 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 902++module Test.Sanity.OverloadedRecordDot (tests) where++import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+    testCaseInfo "Test.Sanity.OverloadedRecordDot" $+      return "Skipped for ghc < 9.2"++#else++{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeOperators       #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Anon.Plugin #-}++module Test.Sanity.OverloadedRecordDot (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Anon++import qualified Data.Record.Anon.Simple   as S+import qualified Data.Record.Anon.Advanced as A++tests :: TestTree+tests = testGroup "Test.Sanity.OverloadedRecordDot" [+      testGroup "Simple" [+          testCase "topLevel" test_simple_topLevel+        , testCase "nested"   test_simple_nested+        ]+    , testGroup "Advanced" [+          testCase "topLevel" test_advanced_topLevel+        , testCase "nested"   test_advanced_nested+        ]+    ]++{-------------------------------------------------------------------------------+  Simple API+-------------------------------------------------------------------------------}++test_simple_topLevel :: Assertion+test_simple_topLevel =+    assertEqual "" True $ r.b+  where+    r :: S.Record [ "a" := Int, "b" := Bool ]+    r = ANON { a = 5, b = True }++test_simple_nested :: Assertion+test_simple_nested =+    assertEqual "" 'x' $ r.b.d+  where+    r :: S.Record [ "a" := Int, "b" := S.Record [ "c" := Bool, "d" := Char ] ]+    r = ANON { a = 5, b = ANON { c = True, d = 'x' } }++{-------------------------------------------------------------------------------+  Advanced API+-------------------------------------------------------------------------------}++test_advanced_topLevel :: Assertion+test_advanced_topLevel =+    assertEqual "" Nothing $ r.b+  where+    r :: A.Record Maybe [ "a" := Int, "b" := Bool ]+    r = ANON_F { a = Just 5, b = Nothing }++-- It only makes sense to consider what happens if we test ANON_F instead+-- ANON: if the outer record is also ANON_F, then we can't just chain record+-- selectors; after all there is some functor in the way now.+test_advanced_nested :: Assertion+test_advanced_nested =+    assertEqual "" "xyz" $ r.b.d+  where+    r :: S.Record [ "a" := Int, "b" := A.Record [] [ "c" := Bool, "d" := Char ] ]+    r = ANON { a = 5, b = ANON_F { c = [], d = "xyz" } }++#endif

@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 902++module Test.Sanity.OverloadedRecordUpdate (tests) where++import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+    testCaseInfo "Test.Sanity.OverloadedRecordUpdate" $+      return "Skipped for ghc < 9.2"++#else++{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE NamedFieldPuns         #-}+{-# LANGUAGE OverloadedRecordDot    #-}+{-# LANGUAGE OverloadedRecordUpdate #-}+{-# LANGUAGE RebindableSyntax       #-}+{-# LANGUAGE TypeOperators          #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Anon.Plugin #-}++module Test.Sanity.OverloadedRecordUpdate (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Anon+import Data.Record.Anon.Overloading++import qualified Data.Record.Anon.Simple   as S+import qualified Data.Record.Anon.Advanced as A++tests :: TestTree+tests = testGroup "Test.Sanity.OverloadedRecordUpdate" [+      testGroup "Simple" [+          testCase "topLevel" test_simple_topLevel+        , testCase "nested"   test_simple_nested+        , testCase "punned"   test_simple_punned+        ]+    , testGroup "Advanced" [+          testCase "topLevel" test_advanced_topLevel+        , testCase "nested"   test_advanced_nested+        , testCase "punned"   test_advanced_punned+        ]+    ]++{-------------------------------------------------------------------------------+  Simple API+-------------------------------------------------------------------------------}++test_simple_topLevel :: Assertion+test_simple_topLevel = do+    assertEqual "" expected $+      r { a = 6 }+  where+    r, expected :: S.Record [ "a" := Int, "b" := Bool ]+    r        = ANON { a = 5, b = True }+    expected = ANON { a = 6, b = True }++-- NOTE: nested updates rely on OverloadedRecordDot in addition to+-- OverloadedRecordUpdate.+test_simple_nested :: Assertion+test_simple_nested = do+    assertEqual "" expected $+      r{b.c = False}+  where+    r, expected :: S.Record [ "a" := Int, "b" := S.Record [ "c" := Bool, "d" := Char ] ]+    r        = ANON { a = 5, b = ANON { c = True,  d = 'a' } }+    expected = ANON { a = 5, b = ANON { c = False, d = 'a' } }++test_simple_punned :: Assertion+test_simple_punned =+    assertEqual "" expected $+      let c = False in r{b.c}+  where+    r, expected :: S.Record [ "a" := Int, "b" := S.Record [ "c" := Bool, "d" := Char ] ]+    r        = ANON { a = 5, b = ANON { c = True,  d = 'a' } }+    expected = ANON { a = 5, b = ANON { c = False, d = 'a' } }++{-------------------------------------------------------------------------------+  Advanced API+-------------------------------------------------------------------------------}++test_advanced_topLevel :: Assertion+test_advanced_topLevel = do+    assertEqual "" expected $+      r { a = Nothing }+  where+    r, expected :: A.Record Maybe [ "a" := Int, "b" := Bool ]+    r        = ANON_F { a = Just 5,  b = Just True }+    expected = ANON_F { a = Nothing, b = Just True }++test_advanced_nested :: Assertion+test_advanced_nested = do+    assertEqual "" expected $+      r{b.d = Just 'a'}+  where+    r, expected :: S.Record [ "a" := Int, "b" := A.Record Maybe [ "c" := Bool, "d" := Char ] ]+    r        = ANON { a = 5, b = ANON_F { c = Just True, d = Nothing  } }+    expected = ANON { a = 5, b = ANON_F { c = Just True, d = Just 'a' } }++test_advanced_punned :: Assertion+test_advanced_punned = do+    assertEqual "" expected $+      let d = Just 'a' in r{b.d}+  where+    r, expected :: S.Record [ "a" := Int, "b" := A.Record Maybe [ "c" := Bool, "d" := Char ] ]+    r        = ANON { a = 5, b = ANON_F { c = Just True, d = Nothing  } }+    expected = ANON { a = 5, b = ANON_F { c = Just True, d = Just 'a' } }++#endif

@@ -34,7 +34,7 @@       show exampleRecord1'   where     expected :: String-    expected = "Record {a = True, b = 1234}"+    expected = "ANON_F {a = True, b = 1234}"  -- | 'HasField' (and 'KnownHash', but that's no different for polykinds) test_hasField :: Assertion

@@ -0,0 +1,6 @@+{-# LANGUAGE CPP #-}++#define MODULE_NAME     Test.Sanity.RebindableSyntax.Disabled+#define TESTGROUP_NAME "Test.Sanity.RebindableSyntax.Disabled"++#include "Tests.hs"

@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}++#define MODULE_NAME     Test.Sanity.RebindableSyntax.Enabled+#define TESTGROUP_NAME "Test.Sanity.RebindableSyntax.Enabled"++#define REBINDABLE_SYNTAX 1++#include "Tests.hs"+

@@ -0,0 +1,216 @@+{-# LANGUAGE Arrows                #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NPlusKPatterns        #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE OverloadedLists       #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}++#ifdef REBINDABLE_SYNTAX+{-# LANGUAGE RebindableSyntax #-}+#endif++module MODULE_NAME (tests) where++import Control.Applicative (Alternative)+import Control.Arrow (Arrow, ArrowApply, returnA)+import Control.Arrow.Operations (ArrowCircuit(delay))+import Control.Arrow.Transformer.Stream (StreamArrow (..))+import Control.Monad (guard)+import Data.Proxy+import Data.Text (Text)+import GHC.Exts (IsList(..))+import GHC.OverloadedLabels (IsLabel(..))+import GHC.TypeLits (KnownSymbol, symbolVal)+import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.Stream as Stream++#ifdef REBINDABLE_SYNTAX+import Data.Record.Anon.Overloading+#endif++{-------------------------------------------------------------------------------+  Make sure RebindableSyntax causes no issues++  Mostly this is a matter of making sure the right definitions are in scope.+  We go through the special cases mentioned in+  <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/rebindable_syntax.html>+  one by one.++  This code is compiled in the context of two modules:++  - "Test.Sanity.RebindableSyntax.Disabled" and+  - "Test.Sanity.RebindableSyntax.Enabled"++  in which rebindable syntax is disabled and enabled, respectively. The+  @.Enabled@ test verifies that we export everything we need to export from+  "Data.Record.Anon.Overloading", and the @.Disabled@ test is there to help+  ensure that we are not exporting anything that we do not need to export.+-------------------------------------------------------------------------------}++test_rebindableSyntax :: Assertion+test_rebindableSyntax = do+    -- An integer literal 368 means “fromInteger (368::Integer)”, rather than+    -- “Prelude.fromInteger (368::Integer)”.+    assertEqual "integerLiteral" 368  $ (368   :: Word)++    -- Fractional literals are handled in just the same way, except that the+    -- translation is fromRational (3.68::Rational).+    assertEqual "fractionalLiteral" 3.68 $ (3.68  :: Float)++    -- String literals are also handled the same way, except that the+    -- translation is fromString ("368"::String).+    assertEqual "stringLiteral" "368" $ ("368" :: Text)++    -- The equality test in an overloaded numeric pattern uses whatever (==) is+    -- in scope.+    let numericPattern :: Word -> Bool+        numericPattern 0 = True+        numericPattern _ = False+    assertEqual "numericPattern" False $ numericPattern 1++    -- The subtraction operation, and the greater-than-or-equal test, in n+k+    -- patterns use whatever (-) and (>=) are in scope.+    let nPlusKPattern :: Word -> Word+        nPlusKPattern 0       = 0+        nPlusKPattern (n + 1) = n+        nPlusKPattern _       = error "impossible"+    assertEqual "nPlusKPattern" 5 $ nPlusKPattern 6++    -- Negation (e.g. “- (f x)”) means “negate (f x)”, both in numeric patterns,+    -- and expressions.+    let negationInPattern :: Int -> Int+        negationInPattern (-1) = 0+        negationInPattern n    = n+    let negationInExpression :: Int -> Int+        negationInExpression = succ+    assertEqual "negationInPattern"    0    $ negationInPattern (-1)+    assertEqual "negationInExpression" (-6) $ - (negationInExpression 5)++    -- Conditionals (e.g. “if e1 then e2 else e3”) means “ifThenElse e1 e2 e3”.+    -- However case expressions are unaffected.+    assertEqual "ifThenElse" 'a' $ if True then 'a' else 'b'++    -- “Do” notation is translated using whatever functions (>>=), (>>), and+    -- fail, are in scope (not the Prelude versions). List comprehensions, mdo+    -- (The recursive do-notation), and parallel array comprehensions, are+    -- unaffected.+    let doNotation :: forall m. (MonadFail m, Alternative m) => m (Maybe Int) -> m Int+        doNotation mInt = do+             Just i <- mInt+             guard (i > 0)+             return i+    assertEqual "doNotation1" (Just 5) $ doNotation (Just (Just 5))+    assertEqual "doNotation2" Nothing  $ doNotation (Just Nothing)+    assertEqual "doNotation3" Nothing  $ doNotation (Nothing)++    -- Arrow notation (see Arrow notation) uses whatever arr, (>>>), first, app,+    -- (|||) and loop functions are in scope. But unlike the other constructs,+    -- the types of these functions must match the Prelude types very closely.+    -- Details are in flux; if you want to use this, ask!+    --+    -- These examples are from+    -- <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/arrows.html#arrow-notation>+    let arr1 ::+             Arrow arr+          => arr Int a -> arr Int a+        arr1 f = proc x -> f -< x+1++        arr2 ::+             ArrowApply arr+          => (Int -> arr Int a) -> arr Int a+        arr2 f = proc x -> f x -<< x+1++        arr3 ::+             Arrow arr+          => arr Int Int -> arr Int Int -> arr Int Int+        arr3 f h = proc x -> do+            y <- f -< x+1+            let z = x+y+            t <- h -< x*z+            returnA -< t+z++        -- Disabled for now+        -- https://gitlab.haskell.org/ghc/ghc/-/issues/23061+        -- arr4 ::+        --      ArrowChoice arr+        --   => (Int -> Int -> Bool) -> arr Int t -> arr (Int, Int) t+        -- arr4 p f = proc (x,y) ->+        --     if p x y+        --       then f -< x+1+        --       else f -< y+2++        counter :: ArrowCircuit a => a Bool Int+        counter = proc reset -> do+            rec output <- returnA -< if reset then 0 else next+                next   <- delay 0 -< output+1+            returnA -< output++    assertEqual "arr1" 7   $ arr1 id  6+    assertEqual "arr2" 13  $ arr2 (+) 6+    assertEqual "arr3" 380 $ arr3 (* 2) (* 3) 6+    assertEqual "counter" [0,1,2,3, 0,1,2,3,4, 0,1,2,3,4, 0,1,2,3,4, 0] $+        case counter of+          StreamArrow f ->+            Stream.take 20 (f $ Stream.cycle [False, False, False, False, True])++    -- List notation, such as [x,y] or [m..n] can also be treated via rebindable+    -- syntax if you use -XOverloadedLists.+    --+    -- <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/overloaded_lists.html#overloaded-lists>+    let list1, list2, list3, list4, list5, list6, list7 :: CustomList Int+        list1 = []          -- Empty list+        list2 = [1]         -- 1 : []+        list3 = [1,2,10]    -- 1 : 2 : 10 : []+        list4 = [1 .. ]     -- enumFrom 1+        list5 = [1,2 ..]    -- enumFromThen 1 2+        list6 = [1 .. 2]    -- enumFromTo 1 2+        list7 = [1,2 .. 10] -- enumFromThenTo 1 2 10+    assertEqual "list1" (           WrapCL []         ) $ list1+    assertEqual "list2" (           WrapCL [1]        ) $ list2+    assertEqual "list3" (           WrapCL [1,2,10]   ) $ list3+    assertEqual "list4" (takeCL 5 $ WrapCL [1 .. ])     $ takeCL 5 list4+    assertEqual "list5" (takeCL 5 $ WrapCL [1,2 ..]   ) $ takeCL 5 list5+    assertEqual "list6" (           WrapCL [1 .. 2]   ) $ list6+    assertEqual "list7" (           WrapCL [1,2 .. 10]) $ list7++    -- An overloaded label “#foo” means “fromLabel @"foo"”, rather than+    -- “GHC.OverloadedLabels.fromLabel @"foo"”.+    --+    -- <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/overloaded_labels.html#overloaded-labels>+    let overloadedLabel :: Label+        overloadedLabel = #hi+    assertEqual "overloadedLabel" (Label "hi") $ overloadedLabel++tests :: TestTree+tests = testGroup TESTGROUP_NAME [+      testCase "rebindableSyntax" test_rebindableSyntax+    ]++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++newtype CustomList a = WrapCL { unwrapCL :: [a] }+  deriving (Show, Eq)++instance IsList (CustomList a) where+  type Item (CustomList a) = a++  fromList = WrapCL+  toList   = unwrapCL++takeCL :: Int -> CustomList a -> CustomList a+takeCL n (WrapCL xs) = WrapCL (take n xs)++newtype Label = Label String+  deriving (Show, Eq)++instance KnownSymbol x => IsLabel x Label where+  fromLabel = Label $ symbolVal (Proxy @x)

@@ -15,6 +15,7 @@  import Data.Record.Anon import Data.Record.Anon.Simple (Record)+ import qualified Data.Record.Anon.Simple as Anon  tests :: TestTree

@@ -10,11 +10,17 @@ import qualified Test.Sanity.CheckIsSubRow import qualified Test.Sanity.Discovery import qualified Test.Sanity.DuplicateFields+import qualified Test.Sanity.Fourmolu.OverloadedRecordDot+import qualified Test.Sanity.Fourmolu.OverloadedRecordUpdate import qualified Test.Sanity.Generics import qualified Test.Sanity.HasField import qualified Test.Sanity.Intersection import qualified Test.Sanity.Merging+import qualified Test.Sanity.OverloadedRecordDot+import qualified Test.Sanity.OverloadedRecordUpdate import qualified Test.Sanity.PolyKinds+import qualified Test.Sanity.RebindableSyntax.Disabled+import qualified Test.Sanity.RebindableSyntax.Enabled import qualified Test.Sanity.RecordLens import qualified Test.Sanity.Simple import qualified Test.Sanity.SrcPlugin.WithoutTypelet@@ -40,6 +46,12 @@         , Test.Sanity.SrcPlugin.WithTypelet.tests         , Test.Sanity.Intersection.tests         , Test.Sanity.BlogPost.tests+        , Test.Sanity.OverloadedRecordDot.tests+        , Test.Sanity.OverloadedRecordUpdate.tests+        , Test.Sanity.RebindableSyntax.Disabled.tests+        , Test.Sanity.RebindableSyntax.Enabled.tests+        , Test.Sanity.Fourmolu.OverloadedRecordDot.tests+        , Test.Sanity.Fourmolu.OverloadedRecordUpdate.tests         ]     , testGroup "Prop" [           Test.Prop.Record.Combinators.Simple.tests