packages feed

large-anon 0.3.2 → 0.3.3

raw patch · 21 files changed

+152/−675 lines, 21 filesdep −fourmoludep ~basedep ~containersdep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: fourmolu

Dependency ranges changed: base, containers, ghc, ghc-tcplugin-api, hashable, text

API changes (from Hackage documentation)

- Data.Record.Anon: Pair :: f a -> g a -> Product (f :: k -> Type) (g :: k -> Type) (a :: k)
- Data.Record.Anon: data () => Product (f :: k -> Type) (g :: k -> Type) (a :: k)
- Data.Record.Anon: [Reflected] :: c => Reflected c
+ Data.Record.Anon: [Reflected] :: forall c. c => Reflected c
- Data.Record.Anon: class () => HasField (x :: k) r a | x r -> a
+ Data.Record.Anon: class HasField (x :: k) r a | x r -> a
- Data.Record.Anon: class () => KnownSymbol (n :: Symbol)
+ Data.Record.Anon: class KnownSymbol (n :: Symbol)
- Data.Record.Anon: data () => Dict (c :: k -> Constraint) (a :: k)
+ Data.Record.Anon: data Dict (c :: k -> Constraint) (a :: k)
- Data.Record.Anon: data Field n
+ Data.Record.Anon: data Field (n :: Symbol)
- Data.Record.Anon: data () => Proxy (t :: k)
+ Data.Record.Anon: data Proxy (t :: k)
- Data.Record.Anon: hashVal :: forall proxy. KnownHash s => proxy s -> Int
+ Data.Record.Anon: hashVal :: KnownHash s => proxy s -> Int
- Data.Record.Anon: newtype () => ( (f :: k -> Type) -.-> (g :: k -> Type) ) (a :: k)
+ Data.Record.Anon: newtype ( (f :: k -> Type) -.-> (g :: k -> Type) ) (a :: k)
- Data.Record.Anon: newtype () => I a
+ Data.Record.Anon: newtype I a
- Data.Record.Anon: newtype () => K a (b :: k)
+ Data.Record.Anon: newtype K a (b :: k)
- Data.Record.Anon.Advanced: ap :: Record (f -.-> g) r -> Record f r -> Record g r
+ Data.Record.Anon.Advanced: ap :: forall {k} (f :: k -> Type) (g :: k -> Type) (r :: Row k). Record (f -.-> g) r -> Record f r -> Record g r
- Data.Record.Anon.Advanced: applyPending :: Record f r -> Record f r
+ Data.Record.Anon.Advanced: applyPending :: forall {k} (f :: k -> Type) (r :: Row k). Record f r -> Record f r
- Data.Record.Anon.Advanced: cmap :: AllFields r c => Proxy c -> (forall x. c x => f x -> g x) -> Record f r -> Record g r
+ Data.Record.Anon.Advanced: cmap :: forall {k} (r :: Row k) c f g. AllFields r c => Proxy c -> (forall (x :: k). c x => f x -> g x) -> Record f r -> Record g r
- Data.Record.Anon.Advanced: cmapM :: (Applicative m, AllFields r c) => Proxy c -> (forall x. c x => f x -> m (g x)) -> Record f r -> m (Record g r)
+ Data.Record.Anon.Advanced: cmapM :: forall {k} m (r :: Row k) c f g. (Applicative m, AllFields r c) => Proxy c -> (forall (x :: k). c x => f x -> m (g x)) -> Record f r -> m (Record g r)
- Data.Record.Anon.Advanced: collapse :: Record (K a) r -> [a]
+ Data.Record.Anon.Advanced: collapse :: forall {k} a (r :: Row k). Record (K a :: k -> Type) r -> [a]
- Data.Record.Anon.Advanced: cpure :: AllFields r c => Proxy c -> (forall x. c x => f x) -> Record f r
+ Data.Record.Anon.Advanced: cpure :: forall {k} (r :: Row k) c f. AllFields r c => Proxy c -> (forall (x :: k). c x => f x) -> Record f r
- Data.Record.Anon.Advanced: czipWith :: AllFields r c => Proxy c -> (forall x. c x => f x -> g x -> h x) -> Record f r -> Record g r -> Record h r
+ Data.Record.Anon.Advanced: czipWith :: forall {k} (r :: Row k) c f g h. AllFields r c => Proxy c -> (forall (x :: k). c x => f x -> g x -> h x) -> Record f r -> Record g r -> Record h r
- Data.Record.Anon.Advanced: czipWithM :: (Applicative m, AllFields r c) => Proxy c -> (forall x. c x => f x -> g x -> m (h x)) -> Record f r -> Record g r -> m (Record h r)
+ Data.Record.Anon.Advanced: czipWithM :: forall {k} m (r :: Row k) c f g h. (Applicative m, AllFields r c) => Proxy c -> (forall (x :: k). c x => f x -> g x -> m (h x)) -> Record f r -> Record g r -> m (Record h r)
- Data.Record.Anon.Advanced: distribute :: (Functor m, KnownFields r) => m (Record f r) -> Record (m :.: f) r
+ Data.Record.Anon.Advanced: distribute :: forall {k} m (r :: Row k) (f :: k -> Type). (Functor m, KnownFields r) => m (Record f r) -> Record (m :.: f) r
- Data.Record.Anon.Advanced: distribute' :: (Functor m, KnownFields r) => m (Record I r) -> Record m r
+ Data.Record.Anon.Advanced: distribute' :: forall m (r :: Row Type). (Functor m, KnownFields r) => m (Record I r) -> Record m r
- Data.Record.Anon.Advanced: empty :: Record f '[]
+ Data.Record.Anon.Advanced: empty :: forall {k} (f :: k -> Type). Record f ('[] :: [Pair Symbol k])
- Data.Record.Anon.Advanced: get :: RowHasField n r a => Field n -> Record f r -> f a
+ Data.Record.Anon.Advanced: get :: forall {k} (n :: Symbol) (r :: Row k) (a :: k) f. RowHasField n r a => Field n -> Record f r -> f a
- Data.Record.Anon.Advanced: inject :: SubRow r r' => Record f r' -> Record f r -> Record f r
+ Data.Record.Anon.Advanced: inject :: forall {k} (r :: Row k) (r' :: Row k) (f :: k -> Type). SubRow r r' => Record f r' -> Record f r -> Record f r
- Data.Record.Anon.Advanced: insert :: Field n -> f a -> Record f r -> Record f ((n := a) : r)
+ Data.Record.Anon.Advanced: insert :: forall {b} (n :: Symbol) f (a :: b) (r :: Row b). Field n -> f a -> Record f r -> Record f ((n ':= a) ': r)
- Data.Record.Anon.Advanced: insertA :: Applicative m => Field n -> m (f a) -> m (Record f r) -> m (Record f ((n ':= a) : r))
+ Data.Record.Anon.Advanced: insertA :: forall {b} m (n :: Symbol) f (a :: b) (r :: Row b). Applicative m => Field n -> m (f a) -> m (Record f r) -> m (Record f ((n ':= a) ': r))
- Data.Record.Anon.Advanced: lens :: SubRow r r' => Record f r -> (Record f r', Record f r' -> Record f r)
+ Data.Record.Anon.Advanced: lens :: forall {k} (r :: Row k) (r' :: Row k) (f :: k -> Type). SubRow r r' => Record f r -> (Record f r', Record f r' -> Record f r)
- Data.Record.Anon.Advanced: letInsertAs :: forall r r' f n a. Proxy r -> Field n -> f a -> Record f r' -> (forall r''. Let r'' ((n := a) : r') => Record f r'' -> Record f r) -> Record f r
+ Data.Record.Anon.Advanced: letInsertAs :: forall {k} (r :: Row k) (r' :: Row k) f (n :: Symbol) (a :: k). Proxy r -> Field n -> f a -> Record f r' -> (forall (r'' :: [Pair Symbol k]). Let r'' ((n ':= a) ': r') => Record f r'' -> Record f r) -> Record f r
- Data.Record.Anon.Advanced: letRecordT :: forall r f. (forall r'. Let r' r => Proxy r' -> Record f r) -> Record f r
+ Data.Record.Anon.Advanced: letRecordT :: forall {k} (r :: Row k) (f :: k -> Type). (forall (r' :: Row k). Let r' r => Proxy r' -> Record f r) -> Record f r
- Data.Record.Anon.Advanced: map :: (forall x. f x -> g x) -> Record f r -> Record g r
+ Data.Record.Anon.Advanced: map :: forall {k} f g (r :: Row k). (forall (x :: k). () => f x -> g x) -> Record f r -> Record g r
- Data.Record.Anon.Advanced: mapM :: Applicative m => (forall x. f x -> m (g x)) -> Record f r -> m (Record g r)
+ Data.Record.Anon.Advanced: mapM :: forall {k} m f g (r :: Row k). Applicative m => (forall (x :: k). () => f x -> m (g x)) -> Record f r -> m (Record g r)
- Data.Record.Anon.Advanced: merge :: Record f r -> Record f r' -> Record f (Merge r r')
+ Data.Record.Anon.Advanced: merge :: forall {k} (f :: k -> Type) (r :: Row k) (r' :: Row k). Record f r -> Record f r' -> Record f (Merge r r')
- Data.Record.Anon.Advanced: project :: SubRow r r' => Record f r -> Record f r'
+ Data.Record.Anon.Advanced: project :: forall {k} (r :: Row k) (r' :: Row k) (f :: k -> Type). SubRow r r' => Record f r -> Record f r'
- Data.Record.Anon.Advanced: pure :: KnownFields r => (forall x. f x) -> Record f r
+ Data.Record.Anon.Advanced: pure :: forall {k} (r :: Row k) f. KnownFields r => (forall (x :: k). () => f x) -> Record f r
- Data.Record.Anon.Advanced: reflectAllFields :: Record (Dict c) r -> Reflected (AllFields r c)
+ Data.Record.Anon.Advanced: reflectAllFields :: forall {k} (c :: k -> Constraint) (r :: Row k). Record (Dict c) r -> Reflected (AllFields r c)
- Data.Record.Anon.Advanced: reflectKnownFields :: Record (K String) r -> Reflected (KnownFields r)
+ Data.Record.Anon.Advanced: reflectKnownFields :: forall {k} (r :: Row k). Record (K String :: k -> Type) r -> Reflected (KnownFields r)
- Data.Record.Anon.Advanced: reflectSubRow :: Record (InRow r) r' -> Reflected (SubRow r r')
+ Data.Record.Anon.Advanced: reflectSubRow :: forall {k} (r :: Row k) (r' :: Row k). Record (InRow r) r' -> Reflected (SubRow r r')
- Data.Record.Anon.Advanced: reifyAllFields :: AllFields r c => proxy c -> Record (Dict c) r
+ Data.Record.Anon.Advanced: reifyAllFields :: forall {k} (r :: Row k) (c :: k -> Constraint) proxy. AllFields r c => proxy c -> Record (Dict c) r
- Data.Record.Anon.Advanced: reifyKnownFields :: KnownFields r => proxy r -> Record (K String) r
+ Data.Record.Anon.Advanced: reifyKnownFields :: forall {k} (r :: Row k) proxy. KnownFields r => proxy r -> Record (K String :: k -> Type) r
- Data.Record.Anon.Advanced: reifySubRow :: (KnownFields r', SubRow r r') => Record (InRow r) r'
+ Data.Record.Anon.Advanced: reifySubRow :: forall {k} (r' :: Row k) (r :: Row k). (KnownFields r', SubRow r r') => Record (InRow r) r'
- Data.Record.Anon.Advanced: sequenceA :: Applicative m => Record (m :.: f) r -> m (Record f r)
+ Data.Record.Anon.Advanced: sequenceA :: forall {k} m (f :: k -> Type) (r :: Row k). Applicative m => Record (m :.: f) r -> m (Record f r)
- Data.Record.Anon.Advanced: sequenceA' :: Applicative m => Record m r -> m (Record I r)
+ Data.Record.Anon.Advanced: sequenceA' :: forall m (r :: Row Type). Applicative m => Record m r -> m (Record I r)
- Data.Record.Anon.Advanced: set :: RowHasField n r a => Field n -> f a -> Record f r -> Record f r
+ Data.Record.Anon.Advanced: set :: forall {k} (n :: Symbol) (r :: Row k) (a :: k) f. RowHasField n r a => Field n -> f a -> Record f r -> Record f r
- Data.Record.Anon.Advanced: someRecord :: [(String, Some f)] -> SomeRecord f
+ Data.Record.Anon.Advanced: someRecord :: forall {k} (f :: k -> Type). [(String, Some f)] -> SomeRecord f
- Data.Record.Anon.Advanced: toList :: KnownFields r => Record (K a) r -> [(String, a)]
+ Data.Record.Anon.Advanced: toList :: forall {k} (r :: Row k) a. KnownFields r => Record (K a :: k -> Type) r -> [(String, a)]
- Data.Record.Anon.Advanced: zip :: Record f r -> Record g r -> Record (Product f g) r
+ Data.Record.Anon.Advanced: zip :: forall {k} (f :: k -> Type) (r :: Row k) (g :: k -> Type). Record f r -> Record g r -> Record (Product f g) r
- Data.Record.Anon.Advanced: zipWith :: (forall x. f x -> g x -> h x) -> Record f r -> Record g r -> Record h r
+ Data.Record.Anon.Advanced: zipWith :: forall {k} f g h (r :: Row k). (forall (x :: k). () => f x -> g x -> h x) -> Record f r -> Record g r -> Record h r
- Data.Record.Anon.Advanced: zipWithM :: Applicative m => (forall x. f x -> g x -> m (h x)) -> Record f r -> Record g r -> m (Record h r)
+ Data.Record.Anon.Advanced: zipWithM :: forall {k} m f g h (r :: Row k). Applicative m => (forall (x :: k). () => f x -> g x -> m (h x)) -> Record f r -> Record g r -> m (Record h r)
- Data.Record.Anon.Overloading: setField :: forall x r a. HasField x r a => r -> a -> r
+ Data.Record.Anon.Overloading: setField :: forall {k} (x :: k) r a. HasField x r a => r -> a -> r
- Data.Record.Anon.Simple: applyPending :: Record r -> Record r
+ Data.Record.Anon.Simple: applyPending :: forall (r :: Row Type). Record r -> Record r
- Data.Record.Anon.Simple: data Record r
+ Data.Record.Anon.Simple: data Record (r :: Row Type)
- Data.Record.Anon.Simple: empty :: Record '[]
+ Data.Record.Anon.Simple: empty :: Record ('[] :: [Pair Symbol Type])
- Data.Record.Anon.Simple: fromAdvanced :: Record I r -> Record r
+ Data.Record.Anon.Simple: fromAdvanced :: forall (r :: Row Type). Record I r -> Record r
- Data.Record.Anon.Simple: get :: RowHasField n r a => Field n -> Record r -> a
+ Data.Record.Anon.Simple: get :: forall (n :: Symbol) (r :: Row Type) a. RowHasField n r a => Field n -> Record r -> a
- Data.Record.Anon.Simple: inject :: SubRow r r' => Record r' -> Record r -> Record r
+ Data.Record.Anon.Simple: inject :: forall (r :: Row Type) (r' :: Row Type). SubRow r r' => Record r' -> Record r -> Record r
- Data.Record.Anon.Simple: insert :: Field n -> a -> Record r -> Record ((n := a) : r)
+ Data.Record.Anon.Simple: insert :: forall (n :: Symbol) a (r :: Row Type). Field n -> a -> Record r -> Record ((n ':= a) ': r)
- Data.Record.Anon.Simple: insertA :: Applicative m => Field n -> m a -> m (Record r) -> m (Record ((n := a) : r))
+ Data.Record.Anon.Simple: insertA :: forall m (n :: Symbol) a (r :: Row Type). Applicative m => Field n -> m a -> m (Record r) -> m (Record ((n ':= a) ': r))
- Data.Record.Anon.Simple: lens :: SubRow r r' => Record r -> (Record r', Record r' -> Record r)
+ Data.Record.Anon.Simple: lens :: forall (r :: Row Type) (r' :: Row Type). SubRow r r' => Record r -> (Record r', Record r' -> Record r)
- Data.Record.Anon.Simple: letInsertAs :: forall r r' n a. Proxy r -> Field n -> a -> Record r' -> (forall r''. Let r'' ((n := a) : r') => Record r'' -> Record r) -> Record r
+ Data.Record.Anon.Simple: letInsertAs :: forall (r :: Row Type) (r' :: Row Type) (n :: Symbol) a. Proxy r -> Field n -> a -> Record r' -> (forall (r'' :: [Pair Symbol Type]). Let r'' ((n ':= a) ': r') => Record r'' -> Record r) -> Record r
- Data.Record.Anon.Simple: letRecordT :: forall r. (forall r'. Let r' r => Proxy r' -> Record r) -> Record r
+ Data.Record.Anon.Simple: letRecordT :: forall (r :: Row Type). (forall (r' :: Row Type). Let r' r => Proxy r' -> Record r) -> Record r
- Data.Record.Anon.Simple: merge :: Record r -> Record r' -> Record (Merge r r')
+ Data.Record.Anon.Simple: merge :: forall (r :: Row Type) (r' :: Row Type). Record r -> Record r' -> Record (Merge r r')
- Data.Record.Anon.Simple: project :: SubRow r r' => Record r -> Record r'
+ Data.Record.Anon.Simple: project :: forall (r :: Row Type) (r' :: Row Type). SubRow r r' => Record r -> Record r'
- Data.Record.Anon.Simple: sequenceA :: Applicative m => Record m r -> m (Record r)
+ Data.Record.Anon.Simple: sequenceA :: forall m (r :: Row Type). Applicative m => Record m r -> m (Record r)
- Data.Record.Anon.Simple: set :: RowHasField n r a => Field n -> a -> Record r -> Record r
+ Data.Record.Anon.Simple: set :: forall (n :: Symbol) (r :: Row Type) a. RowHasField n r a => Field n -> a -> Record r -> Record r
- Data.Record.Anon.Simple: toAdvanced :: Record r -> Record I r
+ Data.Record.Anon.Simple: toAdvanced :: forall (r :: Row Type). Record r -> Record I r

Files

CHANGELOG.md view
@@ -1,5 +1,13 @@ # Revision history for large-anon +## 0.3.3 -- 2025-07-19++* Support ghc 9.8 (Gabriele Sales)+* Support ghc 9.10 and ghc 9.12+* Use ghc-tcplugin-api 0.16.1+* Remove `fourmolu` tests from the test suite (they were causing CI problems);+  this affects the test suite only.+ ## 0.3.2 -- 2025-03-11  * Use ghc-tcplugin-api 0.14 (Chan Siu Man, #169)
− fourmolu-preprocessor/Main.hs 
@@ -1,15 +0,0 @@-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
large-anon.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               large-anon-version:            0.3.2+version:            0.3.3 synopsis:           Scalable anonymous records description:        The @large-anon@ package provides support for anonymous                     records in Haskell, with a focus on compile-time (and@@ -15,7 +15,10 @@ tested-with:        GHC ==8.10.7                     GHC ==9.2.8                     GHC ==9.4.8-                    GHC ==9.6.6+                    GHC ==9.6.7+                    GHC ==9.8.4+                    GHC ==9.10.2+                    GHC ==9.12.2  library   exposed-modules:@@ -64,7 +67,6 @@       Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow       Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow       Data.Record.Anon.Internal.Plugin.TC.Solver-      Data.Record.Anon.Internal.Plugin.TC.TyConSubst        Data.Record.Anon.Internal.Plugin.Source       Data.Record.Anon.Internal.Plugin.Source.FreshT@@ -73,21 +75,21 @@       Data.Record.Anon.Internal.Plugin.Source.Options    build-depends:-    , aeson            >= 1.4.4 && < 2.3-    , base             >= 4.14  && < 4.19-    , containers       >= 0.6.2 && < 0.8-    , deepseq          >= 1.4.4 && < 1.6-    , ghc              >= 8.10  && < 9.7-    , ghc-tcplugin-api >= 0.14  && < 0.15-    , hashable         >= 1.3   && < 1.5-    , mtl              >= 2.2.1 && < 2.4-    , optics-core      >= 0.3   && < 0.5-    , primitive        >= 0.8   && < 0.10-    , record-hasfield  >= 1.0   && < 1.1-    , sop-core         >= 0.5   && < 0.6-    , syb              >= 0.7   && < 0.8-    , tagged           >= 0.8.6 && < 0.9-    , typelet          >= 0.1   && < 0.2+    , aeson            >= 1.4.4  && < 2.3+    , base             >= 4.14   && < 4.22+    , containers       >= 0.6.2  && < 0.9+    , deepseq          >= 1.4.4  && < 1.6+    , ghc              >= 8.10   && < 9.13+    , ghc-tcplugin-api >= 0.16.1 && < 0.17+    , hashable         >= 1.3    && < 1.6+    , mtl              >= 2.2.1  && < 2.4+    , optics-core      >= 0.3    && < 0.5+    , primitive        >= 0.8    && < 0.10+    , record-hasfield  >= 1.0    && < 1.1+    , sop-core         >= 0.5    && < 0.6+    , syb              >= 0.7    && < 0.8+    , tagged           >= 0.8.6  && < 0.9+    , typelet          >= 0.1    && < 0.2        -- large-generics 0.2 starts using 'SmallArray' instead of 'Vector'     , large-generics   >= 0.2   && < 0.3@@ -97,11 +99,8 @@       Haskell2010   ghc-options:       -Wall-      -Wredundant-constraints       -Wno-unticked-promoted-constructors--  if impl(ghc >= 8.10)-    ghc-options:+      -Wredundant-constraints       -Wunused-packages    if flag(debug)@@ -138,8 +137,6 @@       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@@ -170,7 +167,6 @@     , optics-core     , parsec     , QuickCheck-    , record-dot-preprocessor     , record-hasfield     , sop-core     , Stream@@ -188,40 +184,15 @@    -- Not sure why, but ghc warns about record-hasfield being unused,   -- despite it actually being required. So for now we just disable this check.-  -- if impl(ghc >= 8.10)-  --   ghc-options: -Wunused-packages+  -- ghc-options: -Wunused-packages -  if impl(ghc >= 9.2) && !flag(disableFourmoluExec)-    build-tool-depends:-      large-anon:large-anon-testsuite-fourmolu-preprocessor+  if impl(ghc < 9.10)+    build-depends: record-dot-preprocessor   else     cpp-options:-      -DNO_FOURMOLU--Executable large-anon-testsuite-fourmolu-preprocessor-  main-is:-      Main.hs-  hs-source-dirs:-      fourmolu-preprocessor-  build-depends:-    , base     >= 4.16   && < 4.19-    , fourmolu >= 0.10.1 && < 0.16-    , text     >= 1.2    && < 2.1-  default-language:-      Haskell2010-  ghc-options:-      -Wall--  -- Fourmolu is only compatible with RDP syntax from ghc 9.2 and up.-  if impl(ghc < 9.2) || flag(disableFourmoluExec)-    buildable: False+      -DNO_RECORD_DOT_PREPROCESSOR  Flag debug   Description: Enable internal debugging features-  Default: False-  Manual: True--Flag disableFourmoluExec-  Description: Disable executable large-anon-testsuite-fourmolu-preprocessor   Default: False   Manual: True
src/Data/Record/Anon/Internal/Plugin/Source.hs view
@@ -39,11 +39,11 @@  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+  | RecordCon _ext (L _ nm) HsRecFields{rec_flds, rec_dotdot} <- expr   , Unqual nm' <- nm-  , Nothing    <- dotdot+  , Nothing    <- rec_dotdot   , Just mode  <- parseMode (occNameString nm')-  , Just flds' <- mapM getField flds+  , Just flds' <- mapM getField rec_flds   = do names <- lift $ getLargeAnonNames mode        e'    <- anonRec options names l flds'        when debug $ lift $ issueWarning l (debugMsg e')@@ -163,4 +163,8 @@ -- -- > \x -> e simpleLam :: RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs+#if __GLASGOW_HASKELL__ >= 912+simpleLam x body = mkHsLam (noLocA [nlVarPat x]) body+#else simpleLam x body = mkHsLam [nlVarPat x] body+#endif
src/Data/Record/Anon/Internal/Plugin/Source/GhcShim.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}  -- | Thin shim around the GHC API --@@ -16,6 +18,9 @@     -- * Exact-print annotations   , reLoc, reLocA #endif+#if __GLASGOW_HASKELL__ >= 910+  , reLocA+#endif      -- * Names   , lookupName@@ -272,7 +277,7 @@      let msg :: Err.DiagnosticMessage         msg = mkPlainError [] errMsg-#else+#elif __GLASGOW_HASKELL__ < 908     let printOrThrow :: Err.Messages GhcMessage -> IO ()         printOrThrow = printOrThrowDiagnostics                          logger@@ -282,6 +287,16 @@     let msg :: Err.UnknownDiagnostic         msg = Err.UnknownDiagnostic $                 mkPlainError [] errMsg+#else+    let printOrThrow :: Err.Messages GhcMessage -> IO ()+        printOrThrow = printOrThrowDiagnostics+                         logger+                         (initPrintConfig dynFlags)+                         (initDiagOpts dynFlags)++    let msg :: Err.UnknownDiagnostic opts+        msg = Err.mkSimpleUnknownDiagnostic $+                mkPlainError [] errMsg #endif     liftIO $ printOrThrow . Err.mkMessages . bag $       Err.MsgEnvelope {@@ -289,6 +304,9 @@         , errMsgContext    = neverQualify         , errMsgDiagnostic = GhcUnknownMessage msg         , errMsgSeverity   = SevWarning+#if __GLASGOW_HASKELL__ >= 908+        , errMsgReason     = Err.ResolvedDiagnosticReason Err.WarningWithoutFlag+#endif         } #else     liftIO $ printOrThrowWarnings dynFlags . bag $@@ -321,11 +339,19 @@   defExt = NoLayoutInfo #endif -#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 910 instance HasDefaultExt (EpAnn ann) where   defExt = noAnn+#elif __GLASGOW_HASKELL__ >= 910+instance NoAnn ann => HasDefaultExt (EpAnn ann) where+  defExt = noAnn #endif +#if __GLASGOW_HASKELL__ >= 906+instance HasDefaultExt SourceText where+  defExt = NoSourceText+#endif+ {-------------------------------------------------------------------------------   Exact-print annotations -------------------------------------------------------------------------------}@@ -338,6 +364,13 @@ reLocA = id #endif +#if __GLASGOW_HASKELL__ >= 910+reLocA ::+     (HasLoc (GenLocated a e), HasAnnotation b)+  => GenLocated a e -> GenLocated b e+reLocA = reLoc+#endif+ {-------------------------------------------------------------------------------   mkLabel -------------------------------------------------------------------------------}@@ -347,8 +380,7 @@             $ HsOverLabel defExt #if __GLASGOW_HASKELL__ < 902                  Nothing -- RebindableSyntax-#elif __GLASGOW_HASKELL__ >= 906-                 NoSourceText+#elif __GLASGOW_HASKELL__ >= 906 && __GLASGOW_HASKELL__ < 912+                 defExt #endif-                  n
src/Data/Record/Anon/Internal/Plugin/TC/Constraints/AllFields.hs view
@@ -19,7 +19,6 @@ import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI import Data.Record.Anon.Internal.Plugin.TC.NameResolution import Data.Record.Anon.Internal.Plugin.TC.Parsing-import Data.Record.Anon.Internal.Plugin.TC.TyConSubst  import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow  as KnownRow import qualified Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow as ParsedRow@@ -48,12 +47,12 @@ -------------------------------------------------------------------------------}  instance Outputable CAllFields where-  ppr (CAllFields parsedFields typeConstraint typeKind typeFields) = parens $+  ppr CAllFields{..} = parens $       text "CAllFields" <+> braces (vcat [-          text "allFieldsParsedFields"   <+> text "=" <+> ppr parsedFields-        , text "allFieldsTypeFields    " <+> text "=" <+> ppr typeFields-        , text "allFieldsTypeConstraint" <+> text "=" <+> ppr typeConstraint-        , text "allFieldsTypeKind"       <+> text "=" <+> ppr typeKind+          text "allFieldsParsedFields"   <+> text "=" <+> ppr allFieldsParsedFields+        , text "allFieldsTypeFields    " <+> text "=" <+> ppr allFieldsTypeFields+        , text "allFieldsTypeConstraint" <+> text "=" <+> ppr allFieldsTypeConstraint+        , text "allFieldsTypeKind"       <+> text "=" <+> ppr allFieldsTypeKind         ])  {-------------------------------------------------------------------------------@@ -89,11 +88,11 @@ evidenceAllFields ::      ResolvedNames   -> CAllFields-  -> KnownRow (Type, EvVar)+  -> KnownRow (Type, EvExpr)   -> TcPluginM 'Solve EvTerm evidenceAllFields ResolvedNames{..} CAllFields{..} fields = do     fields' <- mapM dictForField (KnownRow.inRowOrder fields)-    return $+    return $ EvExpr $       evDataConApp         (classDataCon clsAllFields)         typeArgsEvidence@@ -115,11 +114,11 @@         , allFieldsTypeConstraint         ] -    dictForField :: KnownField (Type, EvVar) -> TcPluginM 'Solve EvExpr+    dictForField :: KnownField (Type, EvExpr) -> TcPluginM 'Solve EvExpr     dictForField KnownField{ knownFieldInfo = (fieldType, dict) } = do         return $ mkCoreApps (Var idMkDictAny) $ concat [             map Type (typeArgsDict ++ [fieldType])-          , [Var dict]+          , [dict]           ]  {-------------------------------------------------------------------------------@@ -140,16 +139,9 @@            <- KnownRow.traverse fields $ \_nm _ix typ -> fmap (typ,) $                 newWanted loc $                   mkAppTy allFieldsTypeConstraint typ-        ev <- evidenceAllFields rn cr $ second getEvVar <$> fields'+        ev <- evidenceAllFields rn cr $ second ctEvExpr <$> fields'         return (             Just (ev, orig)           , map (mkNonCanonical . snd . knownFieldInfo) $               KnownRow.inRowOrder fields'           )-  where-    getEvVar :: CtEvidence -> EvVar-    getEvVar ct = case ctev_dest ct of-      EvVarDest var -> var-      HoleDest  _   -> error "impossible (we don't ask for primitive equality)"--
src/Data/Record/Anon/Internal/Plugin/TC/Constraints/KnownFields.hs view
@@ -16,7 +16,6 @@ import Data.Record.Anon.Internal.Plugin.TC.Parsing import Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (KnownRow) import Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow (Fields)-import Data.Record.Anon.Internal.Plugin.TC.TyConSubst  import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownField as KnownField import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow   as KnownRow@@ -43,11 +42,11 @@ -------------------------------------------------------------------------------}  instance Outputable CKnownFields where-  ppr (CKnownFields parsedFields typeRecord typeKind) = parens $+  ppr CKnownFields{..} = parens $       text "CKnownFields" <+> braces (vcat [-          text "knownFieldsParsedFields" <+> text "=" <+> ppr parsedFields-        , text "knownFieldsTypeRecord"   <+> text "=" <+> ppr typeRecord-        , text "knownFieldsTypeKind"     <+> text "=" <+> ppr typeKind+          text "knownFieldsParsedFields" <+> text "=" <+> ppr knownFieldsParsedFields+        , text "knownFieldsTypeRecord"   <+> text "=" <+> ppr knownFieldsTypeRecord+        , text "knownFieldsTypeKind"     <+> text "=" <+> ppr knownFieldsTypeKind         ])  {-------------------------------------------------------------------------------@@ -86,7 +85,7 @@   -> TcPluginM 'Solve EvTerm evidenceKnownFields ResolvedNames{..} CKnownFields{..} r = do     fields <- mapM KnownField.toExpr (KnownRow.inRowOrder r)-    return $+    return $ EvExpr $       evDataConApp         (classDataCon clsKnownFields)         typeArgsEvidence
src/Data/Record/Anon/Internal/Plugin/TC/Constraints/KnownHash.hs view
@@ -13,7 +13,6 @@ import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI import Data.Record.Anon.Internal.Plugin.TC.NameResolution import Data.Record.Anon.Internal.Plugin.TC.Parsing-import Data.Record.Anon.Internal.Plugin.TC.TyConSubst  {-------------------------------------------------------------------------------   Definition@@ -70,7 +69,7 @@   -> CKnownHash   -> TcPluginM 'Solve EvTerm evidenceKnownFieldLabel ResolvedNames{..} CKnownHash{..} =-    return $+    return $ EvExpr $       evDataConApp         (classDataCon clsKnownHash)         typeArgsEvidence
src/Data/Record/Anon/Internal/Plugin/TC/Constraints/RowHasField.hs view
@@ -16,7 +16,6 @@ import Data.Record.Anon.Internal.Plugin.TC.Parsing import Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (KnownRowField(..)) import Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow (Fields, FieldLabel(..))-import Data.Record.Anon.Internal.Plugin.TC.TyConSubst  import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow  as KnownRow import qualified Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow as ParsedRow@@ -57,14 +56,14 @@ -------------------------------------------------------------------------------}  instance Outputable CRowHasField where-  ppr (CRowHasField label record typeKind typeLabel typeRow typeField) = parens $+  ppr CRowHasField{..} = parens $       text "CRowHasField" <+> braces (vcat [-          text "hasFieldLabel"     <+> text "=" <+> ppr label-        , text "hasFieldRecord"    <+> text "=" <+> ppr record-        , text "hasFieldTypeKind"  <+> text "=" <+> ppr typeKind-        , text "hasFieldTypeLabel" <+> text "=" <+> ppr typeLabel-        , text "hasFieldTypeRow"   <+> text "=" <+> ppr typeRow-        , text "hasFieldTypeField" <+> text "=" <+> ppr typeField+          text "hasFieldLabel"     <+> text "=" <+> ppr hasFieldLabel+        , text "hasFieldRecord"    <+> text "=" <+> ppr hasFieldRecord+        , text "hasFieldTypeKind"  <+> text "=" <+> ppr hasFieldTypeKind+        , text "hasFieldTypeLabel" <+> text "=" <+> ppr hasFieldTypeLabel+        , text "hasFieldTypeRow"   <+> text "=" <+> ppr hasFieldTypeRow+        , text "hasFieldTypeField" <+> text "=" <+> ppr hasFieldTypeField         ])  {-------------------------------------------------------------------------------@@ -104,7 +103,7 @@   -> Int        -- ^ Field index   -> TcPluginM 'Solve EvTerm evidenceHasField ResolvedNames{..} CRowHasField{..} i = do-    return $+    return $ EvExpr $       evDataConApp         (classDataCon clsRowHasField)         typeArgsEvidence
src/Data/Record/Anon/Internal/Plugin/TC/Constraints/SubRow.hs view
@@ -16,7 +16,6 @@ import Data.Record.Anon.Internal.Plugin.TC.Row.KnownField (KnownField(..)) import Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (Source(..), Target (..), KnownRowField(..)) import Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow (Fields)-import Data.Record.Anon.Internal.Plugin.TC.TyConSubst  import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow  as KnownRow import qualified Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow as ParsedRow@@ -50,13 +49,13 @@ -------------------------------------------------------------------------------}  instance Outputable CSubRow where-  ppr (CSubRow parsedLHS parsedRHS typeLHS typeRHS typeKind) = parens $+  ppr CSubRow{..} = parens $       text "CSubRow" <+> braces (vcat [-          text "subrowParsedLHS"   <+> text "=" <+> ppr parsedLHS-        , text "subrowParsedRHS"   <+> text "=" <+> ppr parsedRHS-        , text "subrowTypeLHS"     <+> text "=" <+> ppr typeLHS-        , text "subrowTypeRHS"     <+> text "=" <+> ppr typeRHS-        , text "subrowTypeKind"    <+> text "=" <+> ppr typeKind+          text "subrowParsedLHS"   <+> text "=" <+> ppr subrowParsedLHS+        , text "subrowParsedRHS"   <+> text "=" <+> ppr subrowParsedRHS+        , text "subrowTypeLHS"     <+> text "=" <+> ppr subrowTypeLHS+        , text "subrowTypeRHS"     <+> text "=" <+> ppr subrowTypeRHS+        , text "subrowTypeKind"    <+> text "=" <+> ppr subrowTypeKind         ])  {-------------------------------------------------------------------------------@@ -71,16 +70,10 @@ parseSubRow tcs rn@ResolvedNames{..} =     parseConstraint' clsSubRow $ \ args ->       case args of-        [typeKind, typeLHS, typeRHS] -> do-          fieldsLHS <- ParsedRow.parseFields tcs rn typeLHS-          fieldsRHS <- ParsedRow.parseFields tcs rn typeRHS-          return $ CSubRow {-                subrowParsedLHS = fieldsLHS-              , subrowParsedRHS = fieldsRHS-              , subrowTypeLHS   = typeLHS-              , subrowTypeRHS   = typeRHS-              , subrowTypeKind  = typeKind-              }+        [subrowTypeKind, subrowTypeLHS, subrowTypeRHS] -> do+          subrowParsedLHS <- ParsedRow.parseFields tcs rn subrowTypeLHS+          subrowParsedRHS <- ParsedRow.parseFields tcs rn subrowTypeRHS+          return $ CSubRow {..}         _ -> pprPanic "parseSubRow: expected 3 arguments" $                text "args" <+> ppr args @@ -94,7 +87,7 @@   -> [(Target (KnownField Type), Source (KnownRowField Type))]   -> TcPluginM 'Solve EvTerm evidenceSubRow ResolvedNames{..} CSubRow{..} fields = do-    return $+    return $ EvExpr $       evDataConApp         (classDataCon clsSubRow)         typeArgsEvidence
src/Data/Record/Anon/Internal/Plugin/TC/GhcTcPluginAPI.hs view
@@ -12,6 +12,7 @@ module Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI (     -- * Standard exports     module GHC.TcPlugin.API+  , module GHC.TcPlugin.API.TyConSubst   , module GHC.Builtin.Names   , module GHC.Builtin.Types   , module GHC.Builtin.Types.Prim@@ -26,11 +27,9 @@  import GHC.Stack -#if __GLASGOW_HASKELL__ < 900-import Data.List.NonEmpty (NonEmpty, toList)-#endif- import GHC.TcPlugin.API+import GHC.TcPlugin.API.TyConSubst+ import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim@@ -45,7 +44,9 @@ import GHC.Tc.Types.Constraint (Ct(..)) #endif -#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 908+import GHC.Tc.Types.Constraint (Ct(..), CanEqLHS(..), EqCt(..))+#elif __GLASGOW_HASKELL__ >= 902 import GHC.Tc.Types.Constraint (Ct(..), CanEqLHS(..)) #endif @@ -56,8 +57,18 @@     CFunEqCan{..} -> Just (cc_fsk, mkTyConApp cc_fun cc_tyargs)     _otherwise    -> Nothing #endif-#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ >= 908 isCanonicalVarEq = \case+    CEqCan (EqCt {..})+      | TyVarLHS var <- eq_lhs+      -> Just (var, eq_rhs)+      | TyFamLHS tyCon args <- eq_lhs+      , Just var            <- getTyVar_maybe eq_rhs+      -> Just (var, mkTyConApp tyCon args)+    _otherwise+      -> Nothing+#elif __GLASGOW_HASKELL__ >= 902+isCanonicalVarEq = \case     CEqCan{..}       | TyVarLHS var <- cc_lhs       -> Just (var, cc_rhs)@@ -71,11 +82,6 @@ -- TODO: Ideally we would actually show the location information obviously instance Outputable CtLoc where   ppr _ = text "<CtLoc>"--#if __GLASGOW_HASKELL__ < 900-instance Outputable a => Outputable (NonEmpty a) where-  ppr = ppr . toList-#endif  #if __GLASGOW_HASKELL__ >= 902 instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
src/Data/Record/Anon/Internal/Plugin/TC/Parsing.hs view
@@ -26,7 +26,6 @@ import GHC.Stack  import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI-import Data.Record.Anon.Internal.Plugin.TC.TyConSubst  {-------------------------------------------------------------------------------   Basic infrastructure
src/Data/Record/Anon/Internal/Plugin/TC/Rewriter.hs view
@@ -9,7 +9,6 @@ import Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow (Fields) import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI import Data.Record.Anon.Internal.Plugin.TC.NameResolution-import Data.Record.Anon.Internal.Plugin.TC.TyConSubst  import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownField as KnownField import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow   as KnownRow
src/Data/Record/Anon/Internal/Plugin/TC/Row/ParsedRow.hs view
@@ -32,7 +32,6 @@ import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI import Data.Record.Anon.Internal.Plugin.TC.NameResolution (ResolvedNames(..)) import Data.Record.Anon.Internal.Plugin.TC.Parsing-import Data.Record.Anon.Internal.Plugin.TC.TyConSubst (TyConSubst)  import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow as KnownRow
src/Data/Record/Anon/Internal/Plugin/TC/Solver.hs view
@@ -17,7 +17,6 @@ import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI import Data.Record.Anon.Internal.Plugin.TC.NameResolution import Data.Record.Anon.Internal.Plugin.TC.Parsing-import Data.Record.Anon.Internal.Plugin.TC.TyConSubst  {-------------------------------------------------------------------------------   Top-level solver
− src/Data/Record/Anon/Internal/Plugin/TC/TyConSubst.hs 
@@ -1,330 +0,0 @@-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}--module Data.Record.Anon.Internal.Plugin.TC.TyConSubst (-    TyConSubst -- opaque-  , mkTyConSubst-  , splitTyConApp_upTo-  ) where--import Data.Bifunctor-import Data.Either (partitionEithers)-import Data.Foldable (toList, asum)-import Data.List.NonEmpty (NonEmpty(..))-import Data.Map (Map)--import qualified Data.Map as Map--import Data.Record.Anon.Internal.Plugin.TC.EquivClasses-import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI hiding ((<>))--{--------------------------------------------------------------------------------  The main type--  TODO: maybe this could be sped up with-  <https://hackage.haskell.org/package/union-find>?--------------------------------------------------------------------------------}---- | Substitution for recognizing 'TyCon' applications modulo equalities------ During constraint solving the set of " given " constraints includes so-called--- "canonical equalities": equalities of the form------ > var ~ typ                  (CTyEqCan)--- > var ~ TyCon arg1 .. argN   (CFunEqCan, the TyCon will be a type family)------ The problem we want to solve is recognizing if some type τ is of the form------ > TyCon arg1 arg2 .. argN   (0 <= N)------ modulo those canonical equalities. We limit the scope of what we try to do:------ o We are only interested in recognizing types of the form above---   (as opposed to general parsing-modulo-equalities).--- o We will only use the canonical equalities as-is: we will not attempt to---   derive any additional equalities from them (i.e. if, say, we know that---   @x ~ T1@ and @x ~ T2@, we will not attempt to use the fact that this means---   that @T1 ~ T2@, nor any derived conclusions thereof). We /will/ however---   try to apply the canononical equalities as often as is necessary (e.g.,---   first applying @x ~ T y@, then applying @y ~ T2@).------ We solve this problem by constructing a 'TyConSubst': a possibly--- non-deterministic substitution mapping type variables to types of the form--- above (that is, a type constructor applied to some arguments).------ We detail the construction of this substitution below (see documentation of--- 'Classified' and 'process'), but once we have this substitution, the--- recognition problem becomes easy:------ 1. Without loss of generality, let τ be of the form @t arg1 arg2 .. argN@--- 2. If @t@ is a 'TyCon', we're done.--- 3. Otherwise, if @t@ is a variable @x@, lookup @x@ in the substitution; if---    there is one (or more) mappings for @x@, then we have successfully---    recognized τ to be of the form above. There is no need to apply the---    substitution repeatedly.------ The substitution is non-deterministic because there might be multiple--- matches. For example, if we have------ > type family Foo where--- >   Foo = Int------ then we might well have equalities @x ~ Int, x ~ Foo@ in scope, and so a type--- @x@ would match two different 'TyCon's. What we do know, however, is that if--- τ matches both @t arg1 .. argN@ and @t' arg1' .. argM'@ (possibly @N /= M@),--- then------ > t arg1 .. argN ~ t' arg1' .. argM'------ If @t == t'@, we can conclude that the arguments are equal only if @t@ is--- injective.-data TyConSubst = TyConSubst {-      -- | Mapping from (canonical) variables to 'TyCon' applications-      tyConSubstMap :: Map TcTyVar (NonEmpty (TyCon, [Type]))--      -- | Map each variable to the canonical representative-      ---      -- See 'Classified' for a detailed discussion of canonical variables.-    , tyConSubstCanon :: Map TcTyVar TcTyVar-    }--{--------------------------------------------------------------------------------  Basic functionality for working with 'TyConSubst'--------------------------------------------------------------------------------}---- | Empty substitution------ The canonical variables map is established once when the initial substitution--- is generated and not updated thereafter.-tyConSubstEmpty :: Map TcTyVar TcTyVar -> TyConSubst-tyConSubstEmpty canon = TyConSubst {-      tyConSubstMap   = Map.empty-    , tyConSubstCanon = canon-    }---- | Lookup a variable in the substitution-tyConSubstLookup :: TcTyVar -> TyConSubst -> Maybe (NonEmpty (TyCon, [Type]))-tyConSubstLookup var TyConSubst{..} = Map.lookup var' tyConSubstMap-  where-    var' :: TcTyVar-    var' = canonicalize tyConSubstCanon var---- | Extend substitution with new bindings-tyConSubstExtend ::-     [(TcTyVar, (TyCon, [Type]))]-  -> TyConSubst -> TyConSubst-tyConSubstExtend new subst@TyConSubst{..} = subst {-      tyConSubstMap = Map.unionWith (<>)-                        (Map.fromList $ map (uncurry aux) new)-                        tyConSubstMap-    }-  where-    aux :: TcTyVar -> (TyCon, [Type]) -> (TcTyVar, NonEmpty (TyCon, [Type]))-    aux var s = (canonicalize tyConSubstCanon var, s :| [])--{--------------------------------------------------------------------------------  Classification--------------------------------------------------------------------------------}---- | Classified canonical equality constraints------ The first step in the construction of the 'TyConSubst' is to classify the--- available canonical equalities as one of three categories, defined below.-data Classified = Classified {-      -- | " Obviously " productive mappings-      ---      -- An equality @var := TyCon args@ is productive, because as soon as we-      -- apply it, we are done: we have successfully recognized a type as being-      -- an application of a concrete type constructor (note that we only ever-      -- apply the substitution to the head @t@ of a type @t args@, never to the-      -- arguments).-      classifiedProductive :: [(TcTyVar, (TyCon, [Type]))]--      -- | Extend equivalence class of variables-      ---      -- An equality @var1 := var2@ we will regard as extending the equivalence-      -- classes of variables (see 'constructEquivClasses').-    , classifiedExtendEquivClass :: [(TcTyVar, TcTyVar)]--      -- | Substitutions we need to reconsider later-      ---      -- An equality @var1 := var2 args@ (with @args@ a non-empty list of-      -- arguments) is most problematic. Applying it /may/ allow us to make-      -- progress, but it may not (consider for example @var := var arg@). We-      -- will reconsider such equalities at the end (see 'process').-    , classifiedReconsider :: [(TcTyVar, (TcTyVar, NonEmpty Type))]-    }--instance Semigroup Classified where-  c1 <> c2 = Classified {-        classifiedProductive       = combine classifiedProductive-      , classifiedExtendEquivClass = combine classifiedExtendEquivClass-      , classifiedReconsider       = combine classifiedReconsider-      }-    where-      combine :: (Classified -> [a]) -> [a]-      combine f = f c1 ++ f c2--instance Monoid Classified where-  mempty = Classified [] [] []--productive :: TcTyVar -> (TyCon, [Type]) -> Classified-productive var (tyCon, args) = mempty {-      classifiedProductive = [(var, (tyCon, args))]-    }--extendEquivClass :: TcTyVar -> TcTyVar -> Classified-extendEquivClass var var' = mempty {-      classifiedExtendEquivClass = [(var, var')]-    }--reconsider :: TcTyVar -> (TcTyVar, NonEmpty Type) -> Classified-reconsider var (var', args) = mempty {-      classifiedReconsider = [(var, (var', args))]-    }---- | Classify a set of given constraints------ See 'Classified' for details.-classify :: [Ct] -> Classified-classify = go mempty-  where-    go :: Classified -> [Ct] -> Classified-    go acc []     = acc-    go acc (c:cs) =-        case isCanonicalVarEq c of-          Just (var, splitAppTys -> (fn, args))-            | Just tyCon <- tyConAppTyCon_maybe fn ->-                go (productive var (tyCon, args) <> acc) cs-            | Just var' <- getTyVar_maybe fn, null args ->-                go (extendEquivClass var var' <> acc) cs-            | Just var' <- getTyVar_maybe fn, x:xs <- args ->-                go (reconsider var (var', x :| xs) <> acc) cs-          _otherwise ->-            go acc cs--{--------------------------------------------------------------------------------  Processing--------------------------------------------------------------------------------}---- | Construct 'TyCon' substitution from classified equality constraints------ The difficult part in constructing this substitution are the equalities of--- the form @var1 ~ var2 args@, which we ear-marked as "to reconsider" during--- classification.------ We will do this iteratively:------ o We first construct a set of variable equivalence classes based on---   'classifiedExtendEquivClass' (using 'constructEquivClasses'), and use that---   along with the "obviously productive" equalities ('classifiedProductive')---   as the initial value of the accumulator (a 'TyConSubst').--- o We then repeatedly consider the remaining equalities. Whenever there is---   a substitution available in the accumulator for @var2@ which turns it into---   a type of the form @TyCon args'@, we add @var1 := TyCon args' args@ to the---   accumulator.--- o We keep doing this until we can make no more progress.------ The functions for working with 'TyConSubst' take the variable equivalence--- classes into acocunt, so we do not need to do that here.------ Two observations:------ o This process must terminate: there are a finite number of constraints---   to consider, and whenever we apply a substitution from the accumulator,---   we get an "obviously productive" substitution: we do not create new work---   in the loop.--- o We may end up ignoring some substitutions: if there is a substitution---   @var1 := var2 args@ and we don't have any (productive) substitutions for---   @var2@, we will just ignore it.------ A note on recursive bindings: a direct or indirect recursive binding------ > x := x args1      x := y args1--- >                   y := x args2------ where @args1, args2@ are non-empty lists of arguments, /cannot/ be relevant:--- if they were, that would imply that there is some type constructor (regular--- datatype or type family) which can be applied to an arbitrary number of--- arguments. Such datatypes or type families cannot be defined in Haskell.--- We therefore take no special care in handling recursive bindings, other than--- to note (as we did above) that the process must terminate.-process :: Classified -> TyConSubst-process Classified{..} =-    go initSubst classifiedReconsider-  where-    initSubst :: TyConSubst-    initSubst =-          tyConSubstExtend classifiedProductive-        $ tyConSubstEmpty (constructEquivClasses classifiedExtendEquivClass)--    go :: TyConSubst-       -> [(TcTyVar, (TcTyVar, NonEmpty Type))]-       -> TyConSubst-    go acc rs =-        let (prod, rest) = tryApply makeProductive rs in-        if null prod-          then acc -- No other equations can be made productive-          else go (tyConSubstExtend prod acc) rest-      where-        makeProductive ::-             (TcTyVar, (TcTyVar, NonEmpty Type))-          -> Maybe (NonEmpty (TcTyVar, (TyCon, [Type])))-        makeProductive (var, (var', args)) =-            fmap (fmap (uncurry aux)) (tyConSubstLookup var' acc)-          where-            aux :: TyCon -> [Type] -> (TcTyVar, (TyCon, [Type]))-            aux tyCon args' = (var, (tyCon, (args' ++ toList args)))---- | Construct 'TyConSubst'------ This is the main function that builds the 'TyConSubst' from the set of--- " given " constraints. The actual work is done by 'classify' and 'process'.-mkTyConSubst :: [Ct] -> TyConSubst-mkTyConSubst = process . classify--{--------------------------------------------------------------------------------  Using--------------------------------------------------------------------------------}---- | Like 'splitTyConApp_maybe', but taking canonical equalities into account------ See 'TyConSubst' for a detailed discussion.-splitTyConApp_upTo :: TyConSubst -> Type -> Maybe (NonEmpty (TyCon, [Type]))-splitTyConApp_upTo subst typ = asum [-      -- Direct match-      do tyCon <- tyConAppTyCon_maybe fn-         return ((tyCon, args) :| [])--      -- Indirect match-    , do var <- getTyVar_maybe fn-         fmap (fmap (second (++ args))) $ tyConSubstLookup var subst-    ]-  where-    (fn, args) = splitAppTys typ--{--------------------------------------------------------------------------------  Outputable--------------------------------------------------------------------------------}--instance Outputable TyConSubst where-  ppr TyConSubst{..} = parens $-          text "TyConSubst"-      <+> ppr tyConSubstMap-      <+> ppr tyConSubstCanon--{--------------------------------------------------------------------------------  Internal auxiliary--------------------------------------------------------------------------------}---- | Attempt to apply a non-deterministic function to a list of values------ Returns the successful results as well as the inputs on which the function--- failed.-tryApply :: forall a b. (a -> Maybe (NonEmpty b)) -> [a] -> ([b], [a])-tryApply f = first (concat . map toList) . partitionEithers . map f'-  where-    f' :: a -> Either (NonEmpty b) a-    f' a = maybe (Right a) Left $ f a
src/Data/Record/Anon/Internal/Util/StrictArray.hs view
@@ -275,16 +275,17 @@ #endif  #ifdef DEBUG-boundsCheckM :: HasCallStack => SmallMutableArray s a -> Int -> r -> r-boundsCheckM arr i k =-    if 0 <= i && i < sizeofSmallMutableArray arr+boundsCheckM :: HasCallStack => SmallMutableArray s a -> Int -> ST s r -> ST s r+boundsCheckM arr i k = do+    sz <- getSizeofSmallMutableArray arr+    if 0 <= i && i < sz       then k       else error $ concat [                "StrictArray: index " ++ show i ++ " out of bounds"-             , " (array size: " ++ show (sizeofSmallMutableArray arr) ++ ")"+             , " (array size: " ++ show sz ++ ")"              ] #else-boundsCheckM :: SmallMutableArray s a -> Int -> r -> r+boundsCheckM :: SmallMutableArray s a -> Int -> ST s r -> ST s r boundsCheckM _arr _i k = k #endif
test/Test/Sanity/BlogPost.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                   #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}@@ -12,6 +13,20 @@ {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} +#if defined(NO_RECORD_DOT_PREPROCESSOR)++module Test.Sanity.BlogPost (tests) where++import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+    testCaseInfo "Test.Sanity.BlogPost" $+      return "Blogposts tests (no record-dot-preprocessor)"++#else+ {-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Anon.Plugin #-}  module Test.Sanity.BlogPost (@@ -388,3 +403,5 @@  parseString :: Parser String parseString = Parsec.tokenPrim id (\pos _ _ -> pos) Just++#endif
− test/Test/Sanity/Fourmolu/OverloadedRecordDot.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE CPP #-}--#ifdef NO_FOURMOLU--module Test.Sanity.Fourmolu.OverloadedRecordDot (tests) where--import Test.Tasty-import Test.Tasty.HUnit--tests :: TestTree-tests =-    testCaseInfo "Test.Sanity.Fourmolu.OverloadedRecordDot" $-      return "Fourmolu tests disabled"--#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
− test/Test/Sanity/Fourmolu/OverloadedRecordUpdate.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE CPP #-}--#ifdef NO_FOURMOLU--module Test.Sanity.Fourmolu.OverloadedRecordUpdate (tests) where--import Test.Tasty-import Test.Tasty.HUnit--tests :: TestTree-tests =-    testCaseInfo "Test.Sanity.Fourmolu.OverloadedRecordUpdate" $-      return "Fourmolu tests disabled"--#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
test/TestLargeAnon.hs view
@@ -11,8 +11,6 @@ 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@@ -52,8 +50,6 @@         , Test.Sanity.OverloadedRecordUpdate.tests         , Test.Sanity.RebindableSyntax.Disabled.tests         , Test.Sanity.RebindableSyntax.Enabled.tests-        , Test.Sanity.Fourmolu.OverloadedRecordDot.tests-        , Test.Sanity.Fourmolu.OverloadedRecordUpdate.tests         , Test.Sanity.Regression.tests         ]     , testGroup "Prop" [