packages feed

large-anon 0.2.1 → 0.3.0

raw patch · 21 files changed

+795/−247 lines, 21 filesdep ~containersdep ~primitivePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: containers, primitive

API changes (from Hackage documentation)

Files

CHANGELOG.md view
@@ -1,6 +1,26 @@ # Revision history for large-anon -## 0.2.1 -- 2023-07-05+## 0.3 -- 2023-07-04++* Critical bugfix (#146): incremental record construction was fundamentally+  broken. This is a major version dump because the internal representation+  is different, so if any code happens to rely on that, it will need to be+  updated. Specifically, indices into the underlying representation of the+  record are now interpreted from the _end_ of the array, rather than the+  start; this is necessary to ensure that inserting new fields (which are+  prepended to the record row) do not affect the indices of old fields.+  With thanks to Johannes Gerer for the bug report and initial investigation.+* One somewhat unfortunate consequence of this new design is that we can no+  longer resolve constraints `HasField` constraints unless _all_ fields in the+  record are known. Previously, we had limited support for resolving `HasField`+  constraints for rows such as `(a := Int ': r)`. However, since this+  support did not extend to other constraints, it was probably not very useful+  anyway; `large-anon` is quite explicit about not supporting inductive+  reasoning.+* Add `disableFourmoluExec` flag to disable the Fourmolu tests in the test suite+  (#145; together with Johannes Gerer).++## 0.2.1 -- 2023-06-05  * Add `distribute` (Johannes Gerer, #142)
large-anon.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               large-anon-version:            0.2.1+version:            0.3.0 synopsis:           Scalable anonymous records description:        The @large-anon@ package provides support for anonymous                     records in Haskell, with a focus on compile-time (and@@ -12,7 +12,7 @@ category:           Records extra-source-files: CHANGELOG.md                     test/Test/Sanity/RebindableSyntax/Tests.hs-tested-with:        GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.5+tested-with:        GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.5  library   exposed-modules:@@ -127,6 +127,7 @@       Test.Infra.MarkStrictness       Test.Prop.Record.Combinators.Constrained       Test.Prop.Record.Combinators.Simple+      Test.Prop.Record.Diff       Test.Prop.Record.Model       Test.Prop.Record.Model.Generator       Test.Prop.Record.Model.Orphans@@ -150,6 +151,7 @@       Test.Sanity.RebindableSyntax.Disabled       Test.Sanity.RebindableSyntax.Enabled       Test.Sanity.RecordLens+      Test.Sanity.Regression       Test.Sanity.Simple       Test.Sanity.SrcPlugin.WithoutTypelet       Test.Sanity.SrcPlugin.WithTypelet@@ -160,6 +162,7 @@     , arrows     , base     , bytestring+    , containers     , large-anon     , large-generics     , mtl@@ -187,9 +190,12 @@   -- if impl(ghc >= 8.10)   --   ghc-options: -Wunused-packages -  if impl(ghc >= 9.2)+  if impl(ghc >= 9.2) && !flag(disableFourmoluExec)     build-tool-depends:       large-anon:large-anon-testsuite-fourmolu-preprocessor+  else+    cpp-options:+      -DNO_FOURMOLU  Executable large-anon-testsuite-fourmolu-preprocessor   main-is:@@ -206,10 +212,15 @@       -Wall    -- Fourmolu is only compatible with RDP syntax from ghc 9.2 and up.-  if impl(ghc < 9.2)+  if impl(ghc < 9.2) || flag(disableFourmoluExec)     buildable: False  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/Advanced.hs view
@@ -332,8 +332,7 @@ -- :} -- -- 'HasField' constraints can be resolved for merged records, subject to the--- same condition discussed in 'get': all fields in the record must be known up--- to the requested field (in case of shadowing). So the record /may/ be fully+-- same condition discussed in 'get': all fields in the record must be fully -- known: -- -- >>> :{@@ -341,15 +340,7 @@ -- example r = get #b r -- :} ----- but it doesn't have to be:------ >>> :{--- example :: Record I (Merge '[ "a" := Bool ] r) -> I Bool--- example = get #a--- :}------ However, just like in the case of unknown fields (see example in 'get'),--- if earlier parts in the record are unknown we get type error:+-- If parts in the record are unknown we get type error: -- -- >>> :{ -- example :: Record I (Merge r '[ "b" := Char ]) -> I Char
src/Data/Record/Anon/Internal/Advanced.hs view
@@ -111,14 +111,12 @@ import Data.Record.Anon.Internal.Core.Diff (Diff) import Data.Record.Anon.Internal.Core.FieldName import Data.Record.Anon.Internal.Reflection (Reflected(..))-import Data.Record.Anon.Internal.Util.StrictArray (StrictArray)  import Data.Record.Anon.Plugin.Internal.Runtime -import qualified Data.Record.Anon.Internal.Core.Canonical   as Canon-import qualified Data.Record.Anon.Internal.Core.Diff        as Diff-import qualified Data.Record.Anon.Internal.Reflection       as Unsafe-import qualified Data.Record.Anon.Internal.Util.StrictArray as Strict+import qualified Data.Record.Anon.Internal.Core.Canonical as Canon+import qualified Data.Record.Anon.Internal.Core.Diff      as Diff+import qualified Data.Record.Anon.Internal.Reflection     as Unsafe  {-------------------------------------------------------------------------------   Definition@@ -164,6 +162,10 @@ data Field n where   Field :: (KnownSymbol n, KnownHash n) => Proxy n -> Field n +-- | 'Show' instance relies on the 'IsLabel' instance+instance Show (Field n) where+  show (Field p) = "#" ++ symbolVal p+ instance (n ~ n', KnownSymbol n, KnownHash n) => IsLabel n' (Field n) where   fromLabel = Field (Proxy @n) @@ -348,12 +350,12 @@   => m (Record f r) -> Record (m :.: f) r distribute =       unsafeFromCanonical-    . Canon.fromList+    . Canon.fromRowOrderList     . (\cs -> fieldVec cs <$> indices)     . fmap toCanonical   where     indices :: [Int]-    indices = [0 .. pred (length $ proxy fieldNames (Proxy @r))]+    indices = Canon.arrayIndicesInRowOrder (length $ proxy fieldNames (Proxy @r))      fieldVec :: m (Canonical f) -> Int -> (m :.: f) Any     fieldVec cs idx = Comp $ flip Canon.getAtIndex idx <$> cs@@ -366,7 +368,8 @@  pure :: forall f r. KnownFields r => (forall x. f x) -> Record f r pure f = unsafeFromCanonical $-    Canon.fromList $ Prelude.map (const f) (proxy fieldNames (Proxy @r))+    Canon.fromRowOrderList $+      Prelude.map (const f) (proxy fieldNames (Proxy @r))  ap :: Record (f -.-> g) r -> Record f r -> Record g r ap (toCanonical -> r) (toCanonical -> r') = unsafeFromCanonical $@@ -395,7 +398,7 @@   => proxy r -> Record (K String) r reifyKnownFields _ =     unsafeFromCanonical $-      Canon.fromList $ co $ proxy fieldNames (Proxy @r)+      Canon.fromRowOrderList $ co $ proxy fieldNames (Proxy @r)   where     co :: [String] -> [K String Any]     co = coerce@@ -410,7 +413,7 @@      AllFields r c   => proxy c -> Record (Dict c) r reifyAllFields _ = unsafeFromCanonical $-    Canon.fromVector . Strict.fromLazy $+    Canon.fromRowOrderArray $       fmap aux $ proxy fieldDicts (Proxy @r)   where     aux :: DictAny c -> Dict c Any@@ -421,7 +424,7 @@   -> Reflected (AllFields r c) reflectAllFields dicts =     Unsafe.reflectAllFields $ Tagged $-      fmap aux $ Strict.toLazy $ Canon.toVector $ toCanonical dicts+      fmap aux $ Canon.toRowOrderArray $ toCanonical dicts   where     aux :: Dict c Any -> DictAny c     aux Dict = DictAny@@ -442,9 +445,9 @@   where     ixs :: Record (K Int) r'     ixs = unsafeFromCanonical $-            Canon.fromVector $ co $ proxy projectIndices (Proxy @'(r, r'))+           Canon.fromRowOrderList $ co $ proxy projectIndices (Proxy @'(r, r')) -    co :: StrictArray Int -> StrictArray (K Int Any)+    co :: [Int] -> [K Int Any]     co = coerce      aux :: forall x. K Int x -> K String x -> InRow r x@@ -457,7 +460,7 @@   -> Reflected (SubRow r r') reflectSubRow (toCanonical -> ixs) =     Unsafe.reflectSubRow $ Tagged $-      (\inRow@(InRow p) -> aux inRow p) <$> Canon.toVector ixs+      (\inRow@(InRow p) -> aux inRow p) <$> Canon.toRowOrderList ixs   where     aux :: forall x n. RowHasField n r x => InRow r x -> Proxy n -> Int     aux _ _ = proxy rowHasField (Proxy @'(n, r, x))@@ -490,8 +493,11 @@ someRecord :: forall k (f :: k -> Type). [(String, Some f)] -> SomeRecord f someRecord fields =     mkSomeRecord $-      unsafeFromCanonical . Canon.fromList $-        Prelude.zipWith aux [0..] (Prelude.map (first someSymbolVal) fields)+      unsafeFromCanonical . Canon.fromRowOrderList $+        Prelude.zipWith+          aux+          (Canon.arrayIndicesInRowOrder (length fields))+          (Prelude.map (first someSymbolVal) fields)   where     aux :: Int -> (SomeSymbol, Some f) -> Product (InRow r) f Any     aux i (SomeSymbol n, Some fx) = Pair (unsafeInRow i n) (co fx)@@ -516,7 +522,7 @@  recordToRep :: Record f r -> Rep I (Record f r) recordToRep (toCanonical -> r) =-    Rep $ co . Strict.toLazy . Canon.toVector $ r+    Rep $ co $ Canon.toRowOrderArray r   where     -- Second @Any@ is really (f (Any))     co :: SmallArray (f Any) -> SmallArray (I Any)@@ -524,7 +530,7 @@  repToRecord :: Rep I (Record f r) -> Record f r repToRecord (Rep r) =-    unsafeFromCanonical $ Canon.fromVector . Strict.fromLazy . co $ r+    unsafeFromCanonical $ Canon.fromRowOrderArray . co $ r   where     -- First @Any@ is really (f Any)@     co :: SmallArray (I Any) -> SmallArray (f Any)
src/Data/Record/Anon/Internal/Core/Canonical.hs view
@@ -20,15 +20,16 @@ -- > import Data.Record.Anonymous.Internal.Canonical (Canonical) -- > import qualified Data.Record.Anonymous.Internal.Canonical as Canon module Data.Record.Anon.Internal.Core.Canonical (-    Canonical(..)+    Canonical -- opaque     -- * Indexed access   , getAtIndex   , setAtIndex     -- * Conversion-  , toList-  , fromList-  , toVector-  , fromVector+  , fromRowOrderList+  , toRowOrderList+  , fromRowOrderArray+  , toRowOrderArray+  , arrayIndicesInRowOrder     -- * Basic API   , insert   , lens@@ -46,7 +47,8 @@ #endif   ) where -import Prelude hiding (map, mapM, zip, zipWith, sequenceA, pure)+import Prelude hiding (map, mapM, zipWith, sequenceA, pure)+import qualified Prelude  import Data.Coerce (coerce) import Data.Kind@@ -63,6 +65,7 @@ import Data.Record.Anon.Internal.Util.StrictArray (StrictArray)  import qualified Data.Record.Anon.Internal.Util.StrictArray as Strict+import Data.Primitive (SmallArray)  {-------------------------------------------------------------------------------   Definition@@ -71,12 +74,21 @@ -- | Canonical record representation -- -- Canonicity here refers to the fact that we have no @Diff@ to apply (see--- "Data.Record.Anonymous.Internal.Diff"). In this case, the record is--- represented as a strict vector in row order (@large-anon@ is strict by--- default; lazy records can be achieved using boxing). This order is important:--- it makes it possible to define functions such as @mapM@ (for which ordering--- must be well-defined).+-- "Data.Record.Anonymous.Internal.Diff"). --+-- == Order+--+-- The record is represented as a strict vector in row order (@large-anon@ is+-- strict by default; lazy records can be achieved using boxing). This order is+-- important: it makes it possible to define functions such as @mapM@ (for which+-- ordering must be well-defined).+--+-- /Indices/ into the array however are interpreted from the /end/ of the array.+-- This ensures that when we insert new elements into the record, the indices of+-- the already existing fields do not change; see 'Diff' for further discussion.+--+-- == Shadowing+-- -- Type level shadowing is reflected at the term level: if a record has -- duplicate fields in its type, it will have multiple entries for that field -- in the vector.@@ -85,12 +97,17 @@ -- adding an API for that is future work. The work by Daan Leijen on scoped -- labels might offer some inspiration there. ----- NOTE: When we cite the algorithmic complexity of operations on 'Canonical',--- we assume that 'HashMap' inserts and lookups are @O(1)@, which they are in+-- == Note on complexity+--+-- When we cite the algorithmic complexity of operations on 'Canonical', we+-- assume that 'HashMap' inserts and lookups are @O(1)@, which they are in -- practice (especially given the relatively small size of typical records), -- even if theoretically they are @O(log n)@. See also the documentation of -- "Data.HashMap.Strict".-newtype Canonical (f :: k -> Type) = Canonical (StrictArray (f Any))+newtype Canonical (f :: k -> Type) = Canonical {+      -- | To strict vector+      toVector :: StrictArray Strict.ReverseIndex (f Any)+    }   deriving newtype (Semigroup, Monoid)  type role Canonical representational@@ -105,7 +122,7 @@ -- -- @O(1)@. getAtIndex :: Canonical f -> Int -> f Any-getAtIndex (Canonical c) ix = c Strict.! ix+getAtIndex (Canonical c) ix = c Strict.! Strict.ReverseIndex ix  -- | Set fields at the specified indices --@@ -113,32 +130,41 @@ -- @O(1)@ if the list of updates is empty. setAtIndex :: [(Int, f Any)] -> Canonical f -> Canonical f setAtIndex [] c             = c-setAtIndex fs (Canonical v) = Canonical (v Strict.// fs)+setAtIndex fs (Canonical v) = Canonical (v Strict.// co fs)+  where+    co :: [(Int, f Any)] -> [(Strict.ReverseIndex, f Any)]+    co = coerce  {-------------------------------------------------------------------------------   Conversion -------------------------------------------------------------------------------} --- | To strict vector-toVector :: Canonical f -> StrictArray (f Any)-toVector (Canonical v) = v---- | From strict vector-fromVector :: StrictArray (f Any) -> Canonical f-fromVector = Canonical+-- | From list of fields in row order+--+-- @O(n)@.+fromRowOrderList :: [f Any] -> Canonical f+fromRowOrderList = Canonical . Strict.fromList  -- | All fields in row order -- -- @O(n)@-toList :: Canonical f -> [f Any]-toList = Foldable.toList . toVector+toRowOrderList :: Canonical f -> [f Any]+toRowOrderList = Foldable.toList . toVector --- | From list of fields in row order------ @O(n)@.-fromList :: [f Any] -> Canonical f-fromList = fromVector . Strict.fromList+toRowOrderArray :: Canonical f -> SmallArray (f Any)+toRowOrderArray = Strict.toLazy . toVector +fromRowOrderArray :: SmallArray (f Any) -> Canonical f+fromRowOrderArray = Canonical . Strict.fromLazy++-- | Given the length of the array, all indices in row order+arrayIndicesInRowOrder :: Int -> [Int]+arrayIndicesInRowOrder 0 = []+arrayIndicesInRowOrder n = Prelude.map (Strict.arrayIndex n) [+                               Strict.ReverseIndex i+                             | i <- [0 .. pred n]+                             ]+ {-------------------------------------------------------------------------------   Basic API -------------------------------------------------------------------------------}@@ -164,13 +190,16 @@ -- order of the new record. -- -- @O(n)@ (in both directions)-lens :: StrictArray Int -> Canonical f -> (Canonical f, Canonical f -> Canonical f)+lens :: [Int] -> Canonical f -> (Canonical f, Canonical f -> Canonical f) lens is (Canonical v) = (       Canonical $-        Strict.backpermute v is+        Strict.backpermute v (co is)     , \(Canonical v') -> Canonical $-         Strict.update v (Strict.zipWith (,) is v')+         Strict.update v (zip (co is) $ Foldable.toList v')     )+  where+    co :: [Int] -> [Strict.ReverseIndex]+    co = coerce  {-------------------------------------------------------------------------------   Simple (non-constrained) combinators
src/Data/Record/Anon/Internal/Core/Diff.hs view
@@ -42,7 +42,7 @@  import qualified Data.List.NonEmpty as NE -import Data.Record.Anon.Internal.Core.Canonical (Canonical(..))+import Data.Record.Anon.Internal.Core.Canonical (Canonical) import Data.Record.Anon.Internal.Core.FieldName (FieldName) import Data.Record.Anon.Internal.Util.SmallHashMap (SmallHashMap) @@ -75,7 +75,10 @@ data Diff (f :: k -> Type) = Diff {       -- | New values of existing fields       ---      -- Indices refer to the original record.+      -- Indices refer to the /canonical/ record. Since new fields are inserted+      -- /after/ old fields, field indices do not change as we insert new+      -- fields. This is key to the soundness of having a 'Canonical' and 'Diff'+      -- pair.       diffUpd :: !(IntMap (f Any))        -- | List of new fields, most recently inserted first@@ -98,7 +101,8 @@ {-------------------------------------------------------------------------------   Incremental construction -  TODO: We should property check these postconditions.+  The post-conditions are verified (albeit somewhat implicitly) in+  "Test.Prop.Record.Diff". -------------------------------------------------------------------------------}  -- | Empty difference
src/Data/Record/Anon/Internal/Plugin/TC/Constraints/AllFields.hs view
@@ -11,7 +11,6 @@   ) where  import Data.Bifunctor-import Data.Foldable (toList) import Data.Void  import Data.Record.Anon.Internal.Plugin.TC.Row.KnownField (KnownField(..))@@ -93,7 +92,7 @@   -> KnownRow (Type, EvVar)   -> TcPluginM 'Solve EvTerm evidenceAllFields ResolvedNames{..} CAllFields{..} fields = do-    fields' <- mapM dictForField (KnownRow.toList fields)+    fields' <- mapM dictForField (KnownRow.inRowOrder fields)     return $       evDataConApp         (classDataCon clsAllFields)@@ -149,13 +148,14 @@         return (Nothing, [])       Just fields -> do         fields' :: KnownRow (Type, CtEvidence)-           <- KnownRow.traverse fields $ \_nm typ -> fmap (typ,) $+           <- KnownRow.traverse fields $ \_nm _ix typ -> fmap (typ,) $                 newWanted loc $                   mkAppTy allFieldsTypeConstraint typ         ev <- evidenceAllFields rn cr $ second getEvVar <$> fields'         return (             Just (ev, orig)-          , map (mkNonCanonical . snd) (toList fields')+          , map (mkNonCanonical . snd . knownFieldInfo) $+              KnownRow.inRowOrder fields'           )   where     getEvVar :: CtEvidence -> EvVar
src/Data/Record/Anon/Internal/Plugin/TC/Constraints/KnownFields.hs view
@@ -11,11 +11,11 @@  import Data.Void -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.GhcTcPluginAPI import Data.Record.Anon.Internal.Plugin.TC.NameResolution 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@@ -85,7 +85,7 @@   -> KnownRow a   -> TcPluginM 'Solve EvTerm evidenceKnownFields ResolvedNames{..} CKnownFields{..} r = do-    fields <- mapM KnownField.toExpr (KnownRow.toList r)+    fields <- mapM KnownField.toExpr (KnownRow.inRowOrder r)     return $       evDataConApp         (classDataCon clsKnownFields)
src/Data/Record/Anon/Internal/Plugin/TC/Constraints/RowHasField.hs view
@@ -11,12 +11,14 @@ import Data.Void import GHC.Stack -import Data.Record.Anon.Internal.Plugin.TC.Row.ParsedRow (Fields, FieldLabel(..)) 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.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  {-------------------------------------------------------------------------------@@ -132,15 +134,20 @@ solveRowHasField _ _ (L _ CRowHasField{hasFieldLabel = FieldVar _}) =     return (Nothing, []) solveRowHasField rn orig (L loc hf@CRowHasField{hasFieldLabel = FieldKnown name, ..}) =-    case ParsedRow.lookup name hasFieldRecord of+    case ParsedRow.allKnown hasFieldRecord of       Nothing ->-        -- TODO: If the record is fully known, we should issue a custom type-        -- error here rather than leaving the constraint unsolved+        -- Not all fields are known; leave the constraint unsolved         return (Nothing, [])-      Just (i, typ) -> do-        eq <- newWanted loc $-                mkPrimEqPredRole Nominal-                  hasFieldTypeField-                  typ-        ev <- evidenceHasField rn hf i-        return (Just (ev, orig), [mkNonCanonical eq])+      Just allKnown ->+        case KnownRow.lookup name allKnown of+          Nothing ->+            -- TODO: We should issue an error here rather than leaving the+            -- constraint unsolved: we /know/ the field does not exist+            return (Nothing, [])+          Just info -> do+            eq <- newWanted loc $+                    mkPrimEqPredRole Nominal+                      hasFieldTypeField+                      (knownRowFieldInfo info)+            ev <- evidenceHasField rn hf (knownRowFieldIndex info)+            return (Just (ev, orig), [mkNonCanonical eq])
src/Data/Record/Anon/Internal/Plugin/TC/Constraints/SubRow.hs view
@@ -10,10 +10,12 @@ import Control.Monad (forM) import Data.Void -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.Parsing+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@@ -89,7 +91,7 @@ evidenceSubRow ::      ResolvedNames   -> CSubRow-  -> [Int]+  -> [(Target (KnownField Type), Source (KnownRowField Type))]   -> TcPluginM 'Solve EvTerm evidenceSubRow ResolvedNames{..} CSubRow{..} fields = do     return $@@ -99,7 +101,7 @@         [ mkCoreApps (Var idEvidenceSubRow) $ concat [               map Type typeArgsEvidence             , [ mkListExpr intTy $-                  map (mkUncheckedIntExpr . fromIntegral) fields ]+                  map (mkUncheckedIntExpr . fromIntegral) indices ]             ]         ]   where@@ -110,6 +112,10 @@         , subrowTypeRHS         ] +    -- Indices into the source array, in the order of the target array+    indices :: [Int]+    indices = map (knownRowFieldIndex . getSource . snd) fields+ {-------------------------------------------------------------------------------   Solver -------------------------------------------------------------------------------}@@ -124,11 +130,14 @@          , ParsedRow.allKnown subrowParsedRHS          ) of       (Just lhs, Just rhs) ->-        case KnownRow.isSubRow lhs rhs of+        case rhs `KnownRow.isSubRowOf` lhs of           Right inBoth -> do-            eqs <- forM inBoth $ \(_i, (l, r)) ->-                     newWanted loc $ mkPrimEqPredRole Nominal l r-            ev  <- evidenceSubRow rn proj (map fst inBoth)+            eqs <- forM inBoth $ \(Target r, Source l) -> newWanted loc $+                     mkPrimEqPredRole+                       Nominal+                       (knownRowFieldInfo l)+                       (knownFieldInfo r)+            ev  <- evidenceSubRow rn proj inBoth             return (Just (ev, orig), map mkNonCanonical eqs)           Left _err ->             -- TODO: Return a custom error message
src/Data/Record/Anon/Internal/Plugin/TC/Rewriter.hs view
@@ -100,4 +100,4 @@ computeMetadataOf mf r =     mkPromotedListTy       (mkTupleTy Boxed [mkTyConTy typeSymbolKindCon, liftedTypeKind])-      (map (KnownField.toType mf) $ KnownRow.toList r)+      (map (KnownField.toType mf) $ KnownRow.inRowOrder r)
src/Data/Record/Anon/Internal/Plugin/TC/Row/KnownRow.hs view
@@ -14,23 +14,33 @@ module Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (     -- * Definition     KnownRow(..)-    -- * Construction+    -- * Fields+  , KnownRowField(..)+  , FieldIndex+  , toKnownRowField+  , fromKnownRowField+    -- * Conversion   , fromList-  , toList+  , inRowOrder+  , inFieldOrder   , visibleMap+    -- * Query+  , lookup     -- * Combinators   , traverse-  , indexed     -- * Check for subrows   , NotSubRow(..)-  , isSubRow+  , Source(..)+  , Target(..)+  , isSubRowOf   ) where -import Prelude hiding (traverse)+import Prelude hiding (traverse, lookup) import qualified Prelude -import Control.Monad.State (State, evalState, state) import Data.Either (partitionEithers)+import Data.List (sortBy)+import Data.Ord (comparing)  import Data.Record.Anon.Internal.Core.FieldName (FieldName) import Data.Record.Anon.Internal.Util.SmallHashMap (SmallHashMap)@@ -52,7 +62,7 @@       -- order are not considered equal by the library (merely isomorphic).       --       -- May contain duplicates (if fields are shadowed).-      knownRecordVector :: [KnownField a]+      knownRecordVector :: [KnownRowField a]        -- | "Most recent" position of each field in the record       --@@ -69,16 +79,57 @@       -- 'False' if some fields are shadowed.     , knownRecordAllVisible :: Bool     }-  deriving (Functor, Foldable)+  deriving (Functor)  {-------------------------------------------------------------------------------+  Individual fields+-------------------------------------------------------------------------------}++-- | Field in a known row+data KnownRowField a = KnownRowField {+      knownRowFieldName  :: FieldName+    , knownRowFieldIndex :: FieldIndex+    , knownRowFieldInfo  :: a+    }+  deriving (Functor)++type FieldIndex = Int++-- | Drop index information+fromKnownRowField :: KnownRowField a -> KnownField a+fromKnownRowField field = KnownField {+      knownFieldName = knownRowFieldName field+    , knownFieldInfo = knownRowFieldInfo field+    }++-- | Add index information+toKnownRowField :: KnownField a -> FieldIndex -> KnownRowField a+toKnownRowField field ix = KnownRowField {+      knownRowFieldName  = knownFieldName field+    , knownRowFieldInfo  = knownFieldInfo field+    , knownRowFieldIndex = ix+    }++{-------------------------------------------------------------------------------   Conversion -------------------------------------------------------------------------------} -toList :: KnownRow a -> [KnownField a]-toList = knownRecordVector+-- | List of all fields, in row order+--+-- This may /NOT/ be the order in which the fields are stored.+inRowOrder :: KnownRow a -> [KnownField a]+inRowOrder =+      map fromKnownRowField+    . knownRecordVector -visibleMap :: KnownRow a -> SmallHashMap FieldName (KnownField a)+-- | List of all fields, ordered by fieldIndex+inFieldOrder :: KnownRow a -> [KnownField a]+inFieldOrder =+      map fromKnownRowField+    . sortBy (comparing knownRowFieldIndex)+    . knownRecordVector++visibleMap :: KnownRow a -> SmallHashMap FieldName (KnownRowField a) visibleMap KnownRow{..} = (knownRecordVector !!) <$> knownRecordVisible  {-------------------------------------------------------------------------------@@ -86,18 +137,18 @@ -------------------------------------------------------------------------------}  fromList :: forall a.-     [KnownField a]+     [KnownRowField a]      -- ^ Fields of the record in the order they appear in the row types      --      -- In other words, fields earlier in the list shadow later fields.   -> KnownRow a fromList = go [] 0 HashMap.empty True   where-    go :: [KnownField a]  -- Acc fields, reverse order (includes shadowed)-       -> Int             -- Next index-       -> SmallHashMap FieldName Int -- Acc indices of visible fields-       -> Bool            -- Are all already processed fields visible?-       -> [KnownField a]  -- To process+    go :: [KnownRowField a]           -- Acc fields, rev order (incl shadowed)+       -> Int                         -- Next index+       -> SmallHashMap FieldName Int  -- Acc indices of visible fields+       -> Bool                        -- All already processed fields visible?+       -> [KnownRowField a]           -- To process        -> KnownRow a     go accFields !nextIndex !accVisible !accAllVisible = \case         [] -> KnownRow {@@ -120,37 +171,38 @@                  accAllVisible                  fs           where-            name = knownFieldName f+            name = knownRowFieldName f  {-------------------------------------------------------------------------------+  Query+-------------------------------------------------------------------------------}++lookup :: FieldName -> KnownRow a -> Maybe (KnownRowField a)+lookup field KnownRow{..} =+    (knownRecordVector !!) <$>+      HashMap.lookup field knownRecordVisible++{-------------------------------------------------------------------------------   Combinators -------------------------------------------------------------------------------}  traverse :: forall m a b.      Applicative m   => KnownRow a-  -> (FieldName -> a -> m b)+  -> (FieldName -> FieldIndex -> a -> m b)   -> m (KnownRow b) traverse KnownRow{..} f =     mkRow <$> Prelude.traverse f' knownRecordVector   where-    mkRow :: [KnownField b] -> KnownRow b+    mkRow :: [KnownRowField b] -> KnownRow b     mkRow updated = KnownRow {           knownRecordVector     = updated         , knownRecordVisible    = knownRecordVisible         , knownRecordAllVisible = knownRecordAllVisible         } -    f' :: KnownField a -> m (KnownField b)-    f' (KnownField nm info) = KnownField nm <$> f nm info--indexed :: KnownRow a -> KnownRow (Int, a)-indexed r =-    flip evalState 0 $-      traverse r (const aux)-  where-    aux :: a -> State Int (Int, a)-    aux a = state $ \i -> ((i, a), succ i)+    f' :: KnownRowField a -> m (KnownRowField b)+    f' (KnownRowField nm ix info) = KnownRowField nm ix <$> f nm ix info  {-------------------------------------------------------------------------------   Check for projections@@ -158,7 +210,7 @@  -- | Reason why we cannot failed to prove 'SubRow' data NotSubRow =-    -- | We do not support precords with shadowed fields+    -- | We do not support records with shadowed fields     --     -- Since these fields can only come from the source record, and shadowed     -- fields in the source record are invisible, shadowed fields in the target@@ -172,40 +224,46 @@   | SourceMissesFields [FieldName]   deriving (Show, Eq) +newtype Source a = Source { getSource :: a } deriving (Show, Functor)+newtype Target a = Target { getTarget :: a } deriving (Show, Functor)+ -- | Check if one row is a subrow of another ----- If it is, returns the paired information from both records in the order of--- the /target/ record along with the index into the /source/ record.+-- If it is, returns the paired information from both records. If @a@ is a+-- subrow of @b@, then we can project from @b@ to @a@; for improved clarity,+-- we therefore mark @a@ as the /target/ and @b@ as the source. --+-- Results are returned in row order of the target.+-- -- See 'NotSubRow' for some discussion of shadowing.-isSubRow :: forall a b.-     KnownRow a-  -> KnownRow b-  -> Either NotSubRow [(Int, (a, b))]-isSubRow recordA recordB =-    if not (knownRecordAllVisible recordB) then+isSubRowOf :: forall a b.+     KnownRow a  -- ^ Target+  -> KnownRow b  -- ^ Source+  -> Either NotSubRow [(Target (KnownField a), Source (KnownRowField b))]+target `isSubRowOf` source =+    if not (knownRecordAllVisible target) then       Left TargetContainsShadowedFields     else         uncurry checkMissing       . partitionEithers-      $ map findInA (toList recordB)+        -- It doesn't matter which order we process 'target' in:+      $ map findInSrc (inRowOrder target)   where-    findInA :: KnownField b -> Either FieldName (Int, (a, b))-    findInA b =-        case HashMap.lookup (knownFieldName b) (visibleMap (indexed recordA)) of-          Nothing -> Left  $ knownFieldName b-          Just a  -> Right $ distrib (knownFieldInfo a, knownFieldInfo b)+    findInSrc ::+         KnownField a+      -> Either FieldName (Target (KnownField a), Source (KnownRowField b))+    findInSrc a =+        case HashMap.lookup (knownFieldName a) (visibleMap source) of+          Nothing -> Left  $ knownFieldName a+          Just b  -> Right $ (Target a, Source b)      checkMissing :: [FieldName] -> x -> Either NotSubRow x     checkMissing []      x = Right x     checkMissing missing _ = Left $ SourceMissesFields missing -    distrib :: ((i, a), b) -> (i, (a, b))-    distrib ((i, a), b) = (i, (a, b))- {-------------------------------------------------------------------------------   Outputable -------------------------------------------------------------------------------}  instance Outputable a => Outputable (KnownRow a) where-  ppr = ppr . toList+  ppr = ppr . inRowOrder
src/Data/Record/Anon/Internal/Plugin/TC/Row/ParsedRow.hs view
@@ -10,8 +10,7 @@     -- * Definition     Fields     -- opaque   , FieldLabel(..)-    -- * Query-  , lookup+    -- * Check if all fields are known   , allKnown     -- * Parsing   , parseFields@@ -21,6 +20,7 @@ import Prelude hiding (lookup)  import Control.Monad (mzero)+import Control.Monad.State (State, evalState, state) import Data.Foldable (asum)  import Data.Record.Anon.Internal.Core.FieldName (FieldName)@@ -28,7 +28,7 @@ import qualified Data.Record.Anon.Internal.Core.FieldName as FieldName  import Data.Record.Anon.Internal.Plugin.TC.Row.KnownField (KnownField(..))-import Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (KnownRow(..))+import Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (KnownRow(..), KnownRowField(..)) 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@@ -54,56 +54,18 @@   deriving (Eq)  {--------------------------------------------------------------------------------  Query+  Check if all fields are known -------------------------------------------------------------------------------} --- | Find field type by name------ Since records are left-biased, we report the /first/ match, independent of--- what is in the record tail. If however we encounter an unknown (variable)--- field, we stop the search: even if a later field matches the one we're--- looking for, the unknown field might too and, crucially, might not have the--- same type.------ Put another way: unlike in 'checkAllFieldsKnown', we do not insist that /all/--- fields are known here, but only the fields up to (including) the one we're--- looking for.------ Returns the index and the type of the field, if found.-lookup :: FieldName -> Fields -> Maybe (Int, Type)-lookup nm = go 0 . (:[])-  where-    go :: Int -> [Fields] -> Maybe (Int, Type)-    go _ []       = Nothing-    go i (fs:fss) =-        case fs of-          FieldsNil ->-            go i fss-          FieldsVar _ ->-            -- The moment we encounter a variable (unknown part of the record),-            -- we must say that the field is unknown (see discussion above)-            Nothing-          FieldsCons (Field (FieldKnown nm') typ) fs' ->-            if nm == nm' then-              Just (i, typ)-            else-              go (succ i) (fs':fss)-          FieldsCons (Field (FieldVar _) _) _ ->-            -- We must also stop when we see a field with an unknown name-            Nothing-          FieldsMerge l r ->-            go i (l:r:fss)-- -- | Return map from field name to type, /if/ all fields are statically known allKnown :: Fields -> Maybe (KnownRow Type)-allKnown- = go [] . (:[])+allKnown =+    go [] . (:[])   where     go :: [KnownField Type]        -> [Fields]        -> Maybe (KnownRow Type)-    go acc []       = Just $ KnownRow.fromList (reverse acc)+    go acc []       = Just $ postprocess (reverse acc)     go acc (fs:fss) =         case fs of           FieldsNil ->@@ -122,6 +84,20 @@           knownFieldName = nm         , knownFieldInfo = typ         }++    -- Assign field indices+    postprocess :: [KnownField Type] -> KnownRow Type+    postprocess fields =+          KnownRow.fromList+        . flip evalState (length fields)+        . mapM assignIndex+        $ fields+      where+        assignIndex :: KnownField Type -> State Int (KnownRowField Type)+        assignIndex field = state $ \ix -> (+              KnownRow.toKnownRowField field (ix - 1)+            , pred ix+            )  {-------------------------------------------------------------------------------   Parsing
src/Data/Record/Anon/Internal/Util/StrictArray.hs view
@@ -1,10 +1,15 @@ {-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables        #-}  module Data.Record.Anon.Internal.Util.StrictArray (     StrictArray -- opaque+    -- * Array index+  , ArrayIndex(..)+  , ZeroBasedIndex(..)+  , ReverseIndex(..)     -- * Reads   , (!)     -- * Conversion@@ -25,11 +30,17 @@ import Prelude hiding (mapM, zipWith)  import Control.Monad (forM_)-import Data.Primitive.SmallArray+import Control.Monad.ST+import Data.Primitive.SmallArray hiding (writeSmallArray, indexSmallArray) -import qualified Control.Monad as Monad-import qualified Data.Foldable as Foldable+import qualified Control.Monad             as Monad+import qualified Data.Foldable             as Foldable+import qualified Data.Primitive.SmallArray as SmallArray +#ifdef DEBUG+import GHC.Stack+#endif+ {-------------------------------------------------------------------------------   Definition -------------------------------------------------------------------------------}@@ -38,7 +49,8 @@ -- -- Implemented as a wrapper around a 'SmallArray'. ----- NOTE: None of the operations on 'Vector' do any bounds checking.+-- NOTE: The operations on 'Vector' do bounds checking only if the @debug@ flag+-- is enabled. -- -- NOTE: 'Vector' is implemented as a newtype around 'SmallArray', which in turn -- is defined as@@ -55,49 +67,71 @@ -- -- This means that 'Record' will have /direct/ access (no pointers) to the -- 'SmallArray#'.-newtype StrictArray a = WrapLazy { unwrapLazy :: SmallArray a }+newtype StrictArray i a = WrapLazy { unwrapLazy :: SmallArray a }   deriving newtype (Show, Eq, Foldable, Semigroup, Monoid)  {-------------------------------------------------------------------------------+  Array index+-------------------------------------------------------------------------------}++class ArrayIndex i where+  -- | Compute 0-based index from @i@, given the size of the array+  arrayIndex :: Int -> i -> Int++newtype ZeroBasedIndex = ZeroBasedIndex { getZeroBasedIndex :: Int }++instance ArrayIndex ZeroBasedIndex where+  arrayIndex _size = getZeroBasedIndex++-- | Index from the /end/ of the array+--+-- @ReverseIndex 0@ points to the final element.+newtype ReverseIndex = ReverseIndex { getReverseIndex :: Int }++instance ArrayIndex ReverseIndex where+  arrayIndex size i = size - 1 - getReverseIndex i++{-------------------------------------------------------------------------------   Reads -------------------------------------------------------------------------------} -(!) :: StrictArray a -> Int -> a+(!) :: ArrayIndex i => StrictArray i a -> i -> a (!) = indexSmallArray . unwrapLazy  {-------------------------------------------------------------------------------   Conversion -------------------------------------------------------------------------------} -fromList :: [a] -> StrictArray a+fromList :: [a] -> StrictArray i a fromList as = fromListN (length as) as -fromListN :: Int -> [a] -> StrictArray a+fromListN :: Int -> [a] -> StrictArray i a fromListN n as = WrapLazy $ runSmallArray $ do     r <- newSmallArray n undefined     forM_ (zip [0..] as) $ \(i, !a) ->-      writeSmallArray r i a+      writeSmallArray r (ZeroBasedIndex i) a     return r -fromLazy :: forall a. SmallArray a -> StrictArray a+fromLazy :: forall i a. SmallArray a -> StrictArray i a fromLazy v = go 0   where-    go :: Int -> StrictArray a+    go :: Int -> StrictArray i a     go i       | i < sizeofSmallArray v-      = let !_a = indexSmallArray v i in go (succ i)+      = let !_a = indexSmallArray v (ZeroBasedIndex i)+        in go (succ i)        | otherwise       = WrapLazy v -toLazy :: StrictArray a -> SmallArray a+toLazy :: StrictArray i a -> SmallArray a toLazy = unwrapLazy  {-------------------------------------------------------------------------------   Non-monadic combinators -------------------------------------------------------------------------------} -instance Functor StrictArray where+instance Functor (StrictArray i) where   fmap f (WrapLazy as) = WrapLazy $ runSmallArray $ do       r <- newSmallArray newSize undefined       forArrayM_ as $ \i a -> writeSmallArray r i $! f a@@ -106,7 +140,7 @@       newSize :: Int       newSize = sizeofSmallArray as -(//) :: StrictArray a -> [(Int, a)] -> StrictArray a+(//) :: ArrayIndex i => StrictArray i a -> [(i, a)] -> StrictArray i a (//) (WrapLazy as) as' = WrapLazy $ runSmallArray $ do     r <- thawSmallArray as 0 newSize     forM_ as' $ \(i, !a) -> writeSmallArray r i a@@ -115,30 +149,44 @@     newSize :: Int     newSize = sizeofSmallArray as -update :: StrictArray a -> StrictArray (Int, a) -> StrictArray a-update (WrapLazy as) (WrapLazy as') = WrapLazy $ runSmallArray $ do+update ::+     ArrayIndex i+  => StrictArray i a  -- ^ Array to update+  -> [(i, a)]         -- ^ Indices into the original array and their new value+                      --   (the order of this list is irrelevant)+  -> StrictArray i a+update (WrapLazy as) as' = WrapLazy $ runSmallArray $ do     r <- thawSmallArray as 0 newSize-    forArrayM_ as' $ \_i (j, !a) -> writeSmallArray r j a+    forM_ as' $ \(j, !a) -> writeSmallArray r j a     return r   where     newSize :: Int     newSize = sizeofSmallArray as -backpermute :: StrictArray a -> StrictArray Int -> StrictArray a-backpermute (WrapLazy as) (WrapLazy is) = WrapLazy $ runSmallArray $ do+backpermute ::+     ArrayIndex i+  => StrictArray i a   -- ^ Array to take values from+  -> [i]               -- ^ List of indices into the source array,+                       --   in the order they must appear in the result array+  -> StrictArray i a+backpermute (WrapLazy as) is = WrapLazy $ runSmallArray $ do     r <- newSmallArray newSize undefined-    forArrayM_ is $ \i j -> writeSmallArray r i $! indexSmallArray as j+    forM_ (zip [0..] is) $ \(i, j) ->+      writeSmallArray r (ZeroBasedIndex i) $! indexSmallArray as j     return r   where     newSize :: Int     newSize = length is -zipWith :: (a -> b -> c) -> StrictArray a -> StrictArray b -> StrictArray c+zipWith ::+     (a -> b -> c)+  -> StrictArray i a -> StrictArray i b -> StrictArray i c zipWith f (WrapLazy as) (WrapLazy bs) = WrapLazy $ runSmallArray $ do     r <- newSmallArray newSize undefined     forM_ [0 .. newSize - 1] $ \i -> do-      let !c = f (indexSmallArray as i) (indexSmallArray bs i)-      writeSmallArray r i c+      let !c = f (indexSmallArray as (ZeroBasedIndex i))+                 (indexSmallArray bs (ZeroBasedIndex i))+      writeSmallArray r (ZeroBasedIndex i) c     return r   where     newSize :: Int@@ -154,9 +202,9 @@   (through the monadic combinators on 'Record'), we prefer to avoid it. -------------------------------------------------------------------------------} -mapM :: forall m a b.+mapM :: forall m i a b.      Applicative m-  => (a -> m b) -> StrictArray a -> m (StrictArray b)+  => (a -> m b) -> StrictArray i a -> m (StrictArray i b) mapM f (WrapLazy as) =     fromListN newSize <$>       traverse f (Foldable.toList as)@@ -166,7 +214,8 @@  zipWithM ::      Applicative m-  => (a -> b -> m c) -> StrictArray a -> StrictArray b -> m (StrictArray c)+  => (a -> b -> m c)+  -> StrictArray i a -> StrictArray i b -> m (StrictArray i c) zipWithM f (WrapLazy as) (WrapLazy bs) = do     fromListN newSize <$>       Monad.zipWithM f (Foldable.toList as) (Foldable.toList bs)@@ -178,14 +227,64 @@   Internal auxiliary -------------------------------------------------------------------------------} -forArrayM_ :: forall m a. Monad m => SmallArray a -> (Int -> a -> m ()) -> m ()+forArrayM_ :: forall m a.+     Monad m+  => SmallArray a -> (ZeroBasedIndex -> a -> m ()) -> m () forArrayM_ arr f = go 0   where     go :: Int -> m ()     go i-      | i < sizeofSmallArray arr-      = f i (indexSmallArray arr i) >> go (succ i)+      | i < sizeofSmallArray arr = do+          f (ZeroBasedIndex i) (indexSmallArray arr (ZeroBasedIndex i))+          go (succ i)+      | otherwise =+          return () -      | otherwise-      = return ()+{-------------------------------------------------------------------------------+  Interpreting 'ArrayIndex'++  Bounds checking is only enabled when built with the @debug@ flag set.+-------------------------------------------------------------------------------}++indexSmallArray :: ArrayIndex i => SmallArray r -> i -> r+indexSmallArray arr i = boundsCheck arr i' $+    SmallArray.indexSmallArray arr i'+  where+    i' :: Int+    i' = arrayIndex (sizeofSmallArray arr) i++writeSmallArray :: ArrayIndex i => SmallMutableArray s a -> i -> a -> ST s ()+writeSmallArray arr i a = boundsCheckM arr i' $+    SmallArray.writeSmallArray arr i' a+  where+    i' :: Int+    i' = arrayIndex (sizeofSmallMutableArray arr) i++#ifdef DEBUG+boundsCheck :: HasCallStack => SmallArray a -> Int -> r -> r+boundsCheck arr i k =+    if 0 <= i && i < sizeofSmallArray arr+      then k+      else error $ concat [+               "StrictArray: index " ++ show i ++ " out of bounds"+             , " (array size: " ++ show (sizeofSmallArray arr) ++ ")"+             ]+#else+boundsCheck :: SmallArray a -> Int -> r -> r+boundsCheck _arr _i k = k+#endif++#ifdef DEBUG+boundsCheckM :: HasCallStack => SmallMutableArray s a -> Int -> r -> r+boundsCheckM arr i k =+    if 0 <= i && i < sizeofSmallMutableArray arr+      then k+      else error $ concat [+               "StrictArray: index " ++ show i ++ " out of bounds"+             , " (array size: " ++ show (sizeofSmallMutableArray arr) ++ ")"+             ]+#else+boundsCheckM :: SmallMutableArray s a -> Int -> r -> r+boundsCheckM _arr _i k = k+#endif
src/Data/Record/Anon/Plugin/Internal/Runtime.hs view
@@ -58,10 +58,6 @@ import GHC.TypeLits import Unsafe.Coerce (unsafeCoerce) -import Data.Record.Anon.Internal.Util.StrictArray (StrictArray)--import qualified Data.Record.Anon.Internal.Util.StrictArray as Strict- {-------------------------------------------------------------------------------   IMPLEMENTATION NOTE @@ -262,10 +258,10 @@  -- | In order of the fields in the /target/ record, the index in the /source/ type DictSubRow k (r :: Row k) (r' :: Row k) =-       Tagged '(r, r') (StrictArray Int)+       Tagged '(r, r') [Int]  evidenceSubRow :: forall k r r'. [Int] -> DictSubRow k r r'-evidenceSubRow = Tagged . Strict.fromList+evidenceSubRow = Tagged  {-------------------------------------------------------------------------------   Utility
+ test/Test/Prop/Record/Diff.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE EmptyCase           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE OverloadedLabels    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Anon.Plugin #-}++module Test.Prop.Record.Diff (tests) where++import Data.Kind+import Data.Map (Map)+import Data.SOP+import Data.Type.Equality+import GHC.TypeLits+import Test.QuickCheck+import Test.Tasty hiding (after)+import Test.Tasty.QuickCheck++import qualified Data.Map as Map++import Data.Record.Anon+import Data.Record.Anon.Advanced (Record)+import qualified Data.Record.Anon.Advanced as Anon++{-------------------------------------------------------------------------------+  Abstraction over the 'Diff' operations+-------------------------------------------------------------------------------}++data Op :: Row Type -> Row Type -> Type where+  -- | Insert new field into the record+  Insert :: KnownSymbol n => Field n -> Int -> Op r (n := Int : r)++  -- | Get field from the record and check that it has the correct value+  --+  -- (The test itself will have to keep track of what the correct value /is/)+  Get :: (KnownSymbol n, RowHasField n r Int) => Field n -> Op r r++  -- | Update value of a field in the record+  Set :: (KnownSymbol n, RowHasField n r Int) => Field n -> Int -> Op r r++  -- | Apply all pending changes+  Apply  :: Op r r++deriving instance Show (Op r r')++data Ops :: Row Type -> Row Type -> Type where+  Done :: Ops r r+  Op   :: IsKnownRow r' => Op r r' -> Ops r' r'' -> Ops r r''+++data TestResult = TestOk | TestFailed String+  deriving (Show, Eq)++-- | Model to test the actual record against+type RecordModel = Map String Int++execute :: Ops '[] r -> TestResult+execute = go Anon.empty Map.empty+  where+    go :: Record I r -> RecordModel -> Ops r r' -> TestResult+    go _ _ Done      = TestOk+    go r m (Op o os) =+        case o of+          Insert f v ->+            go (Anon.insert f (I v) r) (Map.insert (symbolVal f) v m) os+          Get f ->+            case Map.lookup (symbolVal f) m of+              Nothing ->+                TestFailed "Unknown field (this indicates a bug in the tests"+              Just expected ->+                let actual = unI (Anon.get f r) in+                if actual == expected+                  then go r m os+                  else TestFailed $ concat [+                      "Expected " ++ show expected+                    , ", got " ++ show actual+                    ]+          Set f v ->+            go (Anon.set f (I v) r) (Map.insert (symbolVal f) v m) os+          Apply ->+            go (Anon.applyPending r) m os++{-------------------------------------------------------------------------------+  Existential wrappers+-------------------------------------------------------------------------------}++data SomeField r where+  SomeField :: (KnownSymbol n, RowHasField n r Int) => Field n -> SomeField r++data SomeOp r where+  SomeOp :: forall r r'. IsKnownRow r' => Op r r' -> SomeOp r++data SomeOps r where+  SomeOps :: forall r r'. IsKnownRow r' => Ops r r' -> SomeOps r++{-------------------------------------------------------------------------------+  Show instances++  These are not lawful (they are not valid Haskell), but try to present+  readable counter-examples.+-------------------------------------------------------------------------------}++-- | Used only for 'Show'+data UnknownOp where+  UnknownOp :: Op r r' -> UnknownOp++opsToList :: Ops r r' -> [UnknownOp]+opsToList Done        = []+opsToList (Op op ops) = UnknownOp op : opsToList ops++instance Show UnknownOp     where show (UnknownOp x) = show x+instance Show (SomeField r) where show (SomeField x) = show x+instance Show (SomeOp    r) where show (SomeOp    x) = show x+instance Show (SomeOps   r) where show (SomeOps   x) = show (opsToList x)++{-------------------------------------------------------------------------------+  Generation+-------------------------------------------------------------------------------}++-- | Known row+--+-- @large-anon@ is not designed for inductive reasoning, which makes+-- constructing a random record iteratively rather difficult. We could use the+-- (unsafe) low level API, but part of what we want to test here is the high+-- level translation the library does in the plugin. We therefore restrict our+-- attention to specific valid rows.+--+-- TODO: If we add allow for permutations, we can also test 'Anon.project'.+data KnownRow :: Row Type -> Type where+  Valid0 :: KnownRow '[]+  Valid1 :: KnownRow '[ "f1" := Int ]+  Valid2 :: KnownRow '[ "f2" := Int, "f1" := Int ]+  Valid3 :: KnownRow '[ "f3" := Int, "f2" := Int, "f1" := Int ]++class IsKnownRow (row :: Row Type) where+  isKnownRow :: proxy row -> KnownRow row++instance IsKnownRow '[]                                        where isKnownRow _ = Valid0+instance IsKnownRow '[ "f1" := Int ]                           where isKnownRow _ = Valid1+instance IsKnownRow '[ "f2" := Int, "f1" := Int ]              where isKnownRow _ = Valid2+instance IsKnownRow '[ "f3" := Int, "f2" := Int, "f1" := Int ] where isKnownRow _ = Valid3++++tryPickExisting :: KnownRow r -> Maybe (Gen (SomeField r))+tryPickExisting Valid0 = Nothing+tryPickExisting Valid1 = Just $ elements [ SomeField #f1 ]+tryPickExisting Valid2 = Just $ elements [ SomeField #f1+                                         , SomeField #f2+                                         ]+tryPickExisting Valid3 = Just $ elements [ SomeField #f1+                                         , SomeField #f2+                                         , SomeField #f3+                                         ]++tryGenInsert :: KnownRow r -> Maybe (Int -> Gen (SomeOp r))+tryGenInsert Valid0 = Just $ \v -> return $ SomeOp (Insert #f1 v)+tryGenInsert Valid1 = Just $ \v -> return $ SomeOp (Insert #f2 v)+tryGenInsert Valid2 = Just $ \v -> return $ SomeOp (Insert #f3 v)+tryGenInsert Valid3 = Nothing++genOp :: forall proxy r. IsKnownRow r => proxy r -> Gen (SomeOp r)+genOp r = oneof . concat $ [+      [ do SomeField field <- genField+           return $ SomeOp (Get field)+      | Just genField <- [tryPickExisting $ isKnownRow r]+      ]+    , [ do SomeField field <- genField+           newValue <- choose (0, 100)+           return $ SomeOp (Set field newValue)+      | Just genField <- [tryPickExisting $ isKnownRow r]+      ]+    , [ do v <- choose (0, 100)+           genInsert v+      | Just genInsert <- [tryGenInsert (isKnownRow r)]+      ]+    , [ return $ SomeOp Apply ]+    ]++genOpsFrom :: IsKnownRow r => proxy r -> Int -> Gen (SomeOps r)+genOpsFrom _ 0 = return $ SomeOps Done+genOpsFrom r n = do SomeOp  op  <- genOp      r+                    SomeOps ops <- genOpsFrom op (pred n)+                    return $ SomeOps (Op op ops)++genOps :: Gen (SomeOps '[])+genOps = do+    n <- choose (0, 10)+    genOpsFrom Anon.empty n++{-------------------------------------------------------------------------------+  Shrinking++  We could be much more sophisticated in how we shrink, but now for we just pick+  the low hanging fruit only. Specifically, we do not try to omit/change any+  instructions that affect types (specifically, inserts).+-------------------------------------------------------------------------------}++sameResultRow :: Op r r' -> Maybe (r :~: r')+sameResultRow (Insert _ _) = Nothing+sameResultRow (Get _)      = Just Refl+sameResultRow (Set _ _)    = Just Refl+sameResultRow Apply        = Just Refl++isDone :: Ops r r' -> Bool+isDone Done     = True+isDone (Op _ _) = False++shrinkOp :: Op r r' -> [Op r r']+shrinkOp (Insert f n) = Insert f <$> shrink n+shrinkOp (Get _)      = []+shrinkOp (Set f n)    = Set f <$> shrink n+shrinkOp Apply        = []++shrinkOps :: IsKnownRow r' => Ops r r' -> [SomeOps r]+shrinkOps Done        = []+shrinkOps (Op op ops) = concat [+      -- Shrink the operation+      [ SomeOps $ Op op' ops+      | op' <- shrinkOp op+      ]++      -- Shrink the tail+    , [ SomeOps $ Op op ops'+      | SomeOps ops' <- shrinkOps ops+      ]++      -- Drop the operation+    , [ SomeOps $ ops+      | Just Refl <- [sameResultRow op]+      ]++      -- Drop the tail+    , [ SomeOps $ Op op Done+      | not $ isDone ops+      ]+    ]++{-------------------------------------------------------------------------------+  Arbitrary instance+-------------------------------------------------------------------------------}++instance Arbitrary (SomeOps '[]) where+  arbitrary            = genOps+  shrink (SomeOps ops) = shrinkOps ops++{-------------------------------------------------------------------------------+  Top-level++  These tests test the various ways to construct a record bit by bit, thereby+  constructing a 'Diff' (and occassionally applying that 'Diff').+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Prop.Record.Diff" [+      testProperty "diff" test_diff+    ]++test_diff :: SomeOps '[] -> Property+test_diff (SomeOps ops) = execute ops === TestOk
test/Test/Sanity/Fourmolu/OverloadedRecordDot.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ < 902+#ifdef NO_FOURMOLU  module Test.Sanity.Fourmolu.OverloadedRecordDot (tests) where @@ -10,7 +10,7 @@ tests :: TestTree tests =     testCaseInfo "Test.Sanity.Fourmolu.OverloadedRecordDot" $-      return "Skipped for ghc < 9.2"+      return "Fourmolu tests disabled"  #else
test/Test/Sanity/Fourmolu/OverloadedRecordUpdate.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ < 902+#ifdef NO_FOURMOLU  module Test.Sanity.Fourmolu.OverloadedRecordUpdate (tests) where @@ -10,7 +10,7 @@ tests :: TestTree tests =     testCaseInfo "Test.Sanity.Fourmolu.OverloadedRecordUpdate" $-      return "Skipped for ghc < 9.2"+      return "Fourmolu tests disabled"  #else
test/Test/Sanity/Merging.hs view
@@ -20,7 +20,6 @@ tests :: TestTree tests = testGroup "Test.Sanity.Merging" [       testCase "concrete"     test_concrete-    , testCase "polymorphic"  test_polymorphic     , testCase "eqConstraint" test_eqConstraint     ] @@ -57,19 +56,6 @@ test_concrete = do     assertEqual "get" (I True) $ Anon.get #a ab     assertEqual "set" ab'      $ Anon.set #a (I False) ab--test_polymorphic :: Assertion-test_polymorphic = do-    assertEqual "get" (I 1) $ getPoly ab-    assertEqual "set" ab'   $ setPoly ab-  where-    getPoly :: Record I (Merge [ "a" := Bool, "b" := Int ] r) -> I Int-    getPoly = Anon.get #b--    setPoly ::-         Record I (Merge [ "a" := Bool, "b" := Int ] r)-      -> Record I (Merge [ "a" := Bool, "b" := Int ] r)-    setPoly = Anon.set #a (I False)  -- | Test that type equalities are handled correctly test_eqConstraint :: Assertion
+ test/Test/Sanity/Regression.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedLabels #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Anon.Plugin #-}++module Test.Sanity.Regression (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Anon.Simple++{-------------------------------------------------------------------------------+  Top-level+-------------------------------------------------------------------------------}++-- | Sets for specific bugs+tests :: TestTree+tests = testGroup "Test.Sanity.Regression" [+      testGroup "issue146" [+          testCase "get_insert_anon"                      test_get_insert_anon+        , testCase "get_insert_applyPending_insert_empty" test_get_insert_applyPending_insert_empty+        , testCase "get_insert_insert_empty"              test_get_insert_insert_empty+        , testCase "get_applyPending_insert_empty"        test_get_applyPending_insert_empty+        , testCase "get_insert_empty"                     test_get_insert_empty+        ]+    ]++{-------------------------------------------------------------------------------+  Issue #146+-------------------------------------------------------------------------------}++-- | The issue as reported+--+-- The bug caused this test to segfault.+test_get_insert_anon :: Assertion+test_get_insert_anon =+    assertEqual "" "field1" $+        get #field1+      $ insert #field2 "field2"+      $ ANON { field1 = "field1" }++-- | Manual expansion of ANON+--+-- The bug caused this test to segfault.+test_get_insert_applyPending_insert_empty :: Assertion+test_get_insert_applyPending_insert_empty =+    assertEqual "" "field1" $+        get #field1+      $ insert #field2 "field2"+      $ applyPending+      $ insert #field1 "field1"+      $ empty++-- | Omit call to 'applyPending'+--+-- This test was not affected by the bug.+test_get_insert_insert_empty :: Assertion+test_get_insert_insert_empty =+    assertEqual "" "field1" $+        get #field1+      $ insert #field2 "field2"+      $ insert #field1 "field1"+      $ empty++-- | Only single insert, but still call applyPending+--+-- This test was not affected by the bug.+test_get_applyPending_insert_empty :: Assertion+test_get_applyPending_insert_empty =+    assertEqual "" "field1" $+        get #field1+      $ applyPending+      $ insert #field1 "field1"+      $ empty++-- | Simplest form: just a get after an insert+--+-- This test was not affected by the bug.+test_get_insert_empty :: Assertion+test_get_insert_empty =+    assertEqual "" "field1" $+        get #field1+      $ insert #field1 "field1"+      $ empty
test/TestLargeAnon.hs view
@@ -4,6 +4,7 @@  import qualified Test.Prop.Record.Combinators.Constrained import qualified Test.Prop.Record.Combinators.Simple+import qualified Test.Prop.Record.Diff import qualified Test.Sanity.AllFields import qualified Test.Sanity.Applicative import qualified Test.Sanity.BlogPost@@ -22,6 +23,7 @@ import qualified Test.Sanity.RebindableSyntax.Disabled import qualified Test.Sanity.RebindableSyntax.Enabled import qualified Test.Sanity.RecordLens+import qualified Test.Sanity.Regression import qualified Test.Sanity.Simple import qualified Test.Sanity.SrcPlugin.WithoutTypelet import qualified Test.Sanity.SrcPlugin.WithTypelet@@ -52,9 +54,11 @@         , Test.Sanity.RebindableSyntax.Enabled.tests         , Test.Sanity.Fourmolu.OverloadedRecordDot.tests         , Test.Sanity.Fourmolu.OverloadedRecordUpdate.tests+        , Test.Sanity.Regression.tests         ]     , testGroup "Prop" [-          Test.Prop.Record.Combinators.Simple.tests+          Test.Prop.Record.Diff.tests+        , Test.Prop.Record.Combinators.Simple.tests         , Test.Prop.Record.Combinators.Constrained.tests         ]     ]