diff --git a/.github/workflows/proofs/formatting.txt b/.github/workflows/proofs/formatting.txt index 1074aeb523e..cfaba2a6b53 100644 --- a/.github/workflows/proofs/formatting.txt +++ b/.github/workflows/proofs/formatting.txt @@ -1 +1 @@ -e22453ae22870523f79984c00371b3514967b63f230dfee2297964f1b6c1b251 ab5370655049c955d122d644eb26598258e7998bf91ebc7433f068470a966a9e pass +6fa984cffdeb66869d9e53ccf73166a0d3cbaa2c1e07ded9780652f9c0002d1b ab5370655049c955d122d644eb26598258e7998bf91ebc7433f068470a966a9e pass diff --git a/.github/workflows/proofs/tests.txt b/.github/workflows/proofs/tests.txt index b25f348b587..8bd0baf8336 100644 --- a/.github/workflows/proofs/tests.txt +++ b/.github/workflows/proofs/tests.txt @@ -1 +1 @@ -8309e64b8a084106fe325f756e8e5e7abd81cea1f33b20f335cfb06a83d80eb9 36894b8d3d19e10c74bdc233d752feca155998462033d20e6770eba9f82a10a0 pass +4338a8b7d94500696756f67931282126fc0dd23b8c838efa0599781226d03ce9 36894b8d3d19e10c74bdc233d752feca155998462033d20e6770eba9f82a10a0 pass diff --git a/.github/workflows/proofs/transcripts.txt b/.github/workflows/proofs/transcripts.txt index d44ab7c1ce6..7a435aa4123 100644 --- a/.github/workflows/proofs/transcripts.txt +++ b/.github/workflows/proofs/transcripts.txt @@ -1 +1 @@ -8667add51840b308bc23bf95a9c9c0032ff5486ec285e3d3de38970385912c67 beb4a304f24dcbdf3db627887d7c02e22209258fc25b84ad944267279c7278aa pass +4497d4885947f64a10a617e786b65a989442e48af7e92cdbf2f1ef4eee8daf76 beb4a304f24dcbdf3db627887d7c02e22209258fc25b84ad944267279c7278aa pass diff --git a/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs b/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs index 6ecd10b7f6f..de70ff7c7a8 100644 --- a/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs +++ b/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs @@ -84,6 +84,10 @@ v2ToH2Type' mkReference = ABT.transform convertF V2.Type.Effects a -> H2.TypeEffects a V2.Type.Forall a -> H2.TypeForall a V2.Type.IntroOuter a -> H2.TypeIntroOuter a + V2.Type.Record fb fields -> H2.TypeRecord (convertFB fb) fields + convertFB = \case + V2.Type.AllowExtraFields -> H2.AllowExtraFields + V2.Type.RequireExactFields -> H2.RequireExactFields convertKind :: V2.Kind -> H2.Kind convertKind = \case @@ -179,6 +183,7 @@ v2ToH2Term = ABT.transform convertF V2.Term.Char c -> H2.TermChar c V2.Term.Ref r -> H2.TermRef (v2ToH2Reference r) V2.Term.Constructor r cid -> H2.TermConstructor (v2ToH2Reference r) cid + V2.Term.Record fields -> H2.TermRecord fields V2.Term.Request r cid -> H2.TermRequest (v2ToH2Reference r) cid V2.Term.Handle a b -> H2.TermHandle a b V2.Term.App a b -> H2.TermApp a b @@ -210,6 +215,7 @@ v2ToH2Term = ABT.transform convertF V2.Term.PChar c -> H2.PatternChar () c V2.Term.PBytes b -> H2.PatternBytes () b V2.Term.PConstructor r cid ps -> H2.PatternConstructor () (v2ToH2Reference r) cid (convertPattern <$> ps) + V2.Term.PRecord fieldPats -> H2.PatternRecord () (convertPattern <$> fieldPats) V2.Term.PAs pat -> H2.PatternAs () (convertPattern pat) V2.Term.PEffectPure pat -> H2.PatternEffectPure () (convertPattern pat) V2.Term.PEffectBind r conId pats pat -> H2.PatternEffectBind () (v2ToH2Reference r) conId (convertPattern <$> pats) (convertPattern pat) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 5d564617135..60927176fd3 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -465,7 +465,7 @@ type TextPathSegments = [Text] -- * main squeeze currentSchemaVersion :: SchemaVersion -currentSchemaVersion = 26 +currentSchemaVersion = 27 runCreateSql :: Transaction () runCreateSql = @@ -2738,6 +2738,7 @@ c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do C.Type.Effects es -> pure $ C.Type.Effects es C.Type.Forall a -> pure $ C.Type.Forall a C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a + C.Type.Record fb fields -> pure $ C.Type.Record fb fields done :: (S.Decl.Decl Symbol, (Seq Text, Seq Hash)) -> m (LocalIds' t d, S.Decl.Decl Symbol) done (decl, (localTextValues, localDefnValues)) = do textIds <- traverse saveText localTextValues @@ -2771,6 +2772,7 @@ c2xTerm saveText saveDefn tm tp = C.Term.Constructor <$> bitraverse lookupText lookupDefn typeRef <*> pure cid + C.Term.Record fields -> pure $ C.Term.Record fields C.Term.Request typeRef cid -> C.Term.Request <$> bitraverse lookupText lookupDefn typeRef <*> pure cid C.Term.Handle a a2 -> pure $ C.Term.Handle a a2 @@ -2806,6 +2808,7 @@ c2xTerm saveText saveDefn tm tp = C.Type.Effects es -> pure $ C.Type.Effects es C.Type.Forall a -> pure $ C.Type.Forall a C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a + C.Type.Record fb fields -> pure $ C.Type.Record fb fields goCase :: forall m w s a. ( MonadState s m, @@ -2842,6 +2845,7 @@ c2xTerm saveText saveDefn tm tp = C.Term.PChar c -> pure $ C.Term.PChar c C.Term.PBytes b -> pure $ C.Term.PBytes b C.Term.PConstructor r i ps -> C.Term.PConstructor <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat ps + C.Term.PRecord fields -> C.Term.PRecord <$> traverse goPat fields C.Term.PAs p -> C.Term.PAs <$> goPat p C.Term.PEffectPure p -> C.Term.PEffectPure <$> goPat p C.Term.PEffectBind r i bindings k -> C.Term.PEffectBind <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat bindings <*> goPat k diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index d0083e76634..74c9acfd421 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -58,6 +58,7 @@ import Data.Bytes.Put (MonadPut, putByteString, putWord8) import Data.Bytes.Serial (SerialEndian (serializeBE), deserialize, deserializeBE, serialize) import Data.Bytes.VarInt (VarInt (VarInt), unVarInt) import Data.List (elemIndex) +import Data.Map qualified as Map import Data.Set qualified as Set import Data.Vector (Vector) import U.Codebase.Decl (Modifier) @@ -281,6 +282,8 @@ putSingleTerm t = putABT putSymbol putUnit putF t putWord8 20 *> putReferent' putRecursiveReference putReference r Term.TypeLink r -> putWord8 21 *> putReference r + Term.Record fields -> + putWord8 22 *> putFoldable (\(name, val) -> putText name *> putChild val) (Map.toList fields) putMatchCase :: (MonadPut m) => (a -> m ()) -> Term.MatchCase LocalTextId TermFormat.TypeRef a -> m () putMatchCase putChild (Term.MatchCase pat guard body) = putPattern pat *> putMaybe putChild guard *> putChild body @@ -317,6 +320,10 @@ putSingleTerm t = putABT putSymbol putUnit putF t Term.PBytes b -> let bs = Bytes.toByteString b in putWord8 14 *> putVarInt (BS.length bs) *> putByteString bs + Term.PRecord fields -> + putWord8 15 + *> putFoldable (\(name, pat) -> putText name *> putPattern pat) (Map.toList fields) + putSeqOp :: (MonadPut m) => Term.SeqOp -> m () putSeqOp Term.PCons = putWord8 0 putSeqOp Term.PSnoc = putWord8 1 @@ -368,6 +375,10 @@ getSingleTerm = getABT getSymbol getUnit getF 19 -> Term.Char <$> getChar 20 -> Term.TermLink <$> getReferent 21 -> Term.TypeLink <$> getReference + 22 -> + getList + ((,) <$> getText <*> getChild) + <&> Term.Record . Map.fromList tag -> unknownTag "getSingleTerm" tag where getReferent :: (MonadGet m) => m (Referent' TermFormat.TermRef TermFormat.TypeRef) @@ -406,6 +417,7 @@ getSingleTerm = getABT getSymbol getUnit getF n <- getVarInt bs <- getByteString n pure $ Term.PBytes (Bytes.fromByteString bs) + 15 -> Term.PRecord . Map.fromList <$> (getList ((,) <$> getText <*> getPattern)) x -> unknownTag "Pattern" x where getSeqOp :: (MonadGet m) => m Term.SeqOp @@ -452,6 +464,7 @@ getType getReference = getABT getSymbol getUnit go 5 -> Type.Effects <$> getList getChild 6 -> Type.Forall <$> getChild 7 -> Type.IntroOuter <$> getChild + 8 -> Type.Record <$> getEnum @Type.FieldBehavior <*> (Map.fromList <$> getList (getPair getText getChild)) tag -> unknownTag "getType" tag getKind :: (MonadGet m) => m Kind getKind = @@ -1128,6 +1141,7 @@ putType putReference putVar = putABT putVar putUnit go Type.Effects es -> putWord8 5 *> putFoldable putChild es Type.Forall body -> putWord8 6 *> putChild body Type.IntroOuter body -> putWord8 7 *> putChild body + Type.Record fb fields -> putWord8 8 *> putEnum @Type.FieldBehavior fb *> putFoldable (\(l, t) -> putText l *> putChild t) (Map.toAscList fields) putKind :: (MonadPut m) => Kind -> m () putKind k = case k of Kind.Star -> putWord8 0 @@ -1154,3 +1168,9 @@ getMaybe getA = unknownTag :: (MonadGet m, Show a) => String -> a -> m x unknownTag msg tag = fail $ "unknown tag " ++ show tag ++ " while deserializing: " ++ msg + +putEnum :: forall e m. (MonadPut m, Enum e) => e -> m () +putEnum e = putVarInt (fromEnum e) + +getEnum :: forall e m. (MonadGet m, Enum e) => m e +getEnum = toEnum <$> getVarInt diff --git a/codebase2/codebase/U/Codebase/Decl.hs b/codebase2/codebase/U/Codebase/Decl.hs index cf6ae66902c..6cfdc33c639 100644 --- a/codebase2/codebase/U/Codebase/Decl.hs +++ b/codebase2/codebase/U/Codebase/Decl.hs @@ -145,3 +145,4 @@ unhashComponent componentHash refToVar m = Type.Effects as -> ABT.tm () $ Type.Effects as Type.Forall a -> ABT.tm () $ Type.Forall a Type.IntroOuter a -> ABT.tm () $ Type.IntroOuter a + Type.Record fb fields -> ABT.tm () $ Type.Record fb fields diff --git a/codebase2/codebase/U/Codebase/Term.hs b/codebase2/codebase/U/Codebase/Term.hs index ab2c2f24f5a..c2b7521c9be 100644 --- a/codebase2/codebase/U/Codebase/Term.hs +++ b/codebase2/codebase/U/Codebase/Term.hs @@ -65,6 +65,7 @@ data F' text termRef typeRef termLink typeLink vt a | -- First argument identifies the data type, -- second argument identifies the constructor Constructor typeRef ConstructorId + | Record (Map Text {- field name -} a {- field value -}) | Request typeRef ConstructorId | Handle a a | App a a @@ -109,6 +110,7 @@ data Pattern t r | PChar !Char | PBytes !Bytes | PConstructor !r !ConstructorId [Pattern t r] + | PRecord (Map Text (Pattern t r)) | PAs (Pattern t r) | PEffectPure (Pattern t r) | PEffectBind !r !ConstructorId [Pattern t r] (Pattern t r) @@ -189,6 +191,7 @@ extraMapM ftext ftermRef ftypeRef ftermLink ftypeLink fvt = go' Char c -> pure $ Char c Ref r -> Ref <$> ftermRef r Constructor r cid -> Constructor <$> (ftypeRef r) <*> pure cid + Record fields -> pure $ Record fields Request r cid -> Request <$> ftypeRef r <*> pure cid Handle e h -> pure $ Handle e h App f a -> pure $ App f a @@ -224,6 +227,7 @@ rmapPatternM ft fr = go PChar c -> pure $ PChar c PBytes b -> pure $ PBytes b PConstructor r i ps -> PConstructor <$> fr r <*> pure i <*> (traverse go ps) + PRecord fields -> PRecord <$> (traverse go fields) PAs p -> PAs <$> go p PEffectPure p -> PEffectPure <$> go p PEffectBind r i ps p -> PEffectBind <$> fr r <*> pure i <*> traverse go ps <*> go p @@ -332,6 +336,7 @@ unhashComponent componentHash refToVar m = Text t -> ABT.tm () $ Text t Char c -> ABT.tm () $ Char c Constructor typeRef conId -> ABT.tm () $ Constructor typeRef conId + Record fields -> ABT.tm () $ Record fields Request typeRef conId -> ABT.tm () $ Request typeRef conId Handle e h -> ABT.tm () $ Handle e h App f a -> ABT.tm () $ App f a diff --git a/codebase2/codebase/U/Codebase/Type.hs b/codebase2/codebase/U/Codebase/Type.hs index d24179b89a1..628c1710d6c 100644 --- a/codebase2/codebase/U/Codebase/Type.hs +++ b/codebase2/codebase/U/Codebase/Type.hs @@ -16,6 +16,17 @@ type FT = F' Reference -- | For potentially recursive types, like those in DataDeclaration type FD = F' (Reference' Text (Maybe Hash)) +-- | Whether the record type unifies with types that have _extra_ fields. +-- E.g. subtype (Record _ {a: Int, b: Nat}) (Record AllowExtraFields {a: Int}) +-- will succeed, since the former has all the required fields, and extra fields are allowed, +-- but: +-- subtype (Record _ {a: Int, b: Nat}) (Record RequireExactFields {a: Int}) +-- fails. +data FieldBehavior + = AllowExtraFields + | RequireExactFields + deriving (Eq, Ord, Show, Enum, Bounded) + data F' r a = Ref r | Arrow a a @@ -27,6 +38,7 @@ data F' r a | IntroOuter a -- binder like ∀, used to introduce variables that are -- bound by outer type signatures, to support scoped type -- variables + | Record FieldBehavior (Map Text a) deriving (Foldable, Functor, Eq, Ord, Show, Traversable) -- | Non-recursive type diff --git a/lib/unison-pretty-printer/src/Unison/Util/ColorText.hs b/lib/unison-pretty-printer/src/Unison/Util/ColorText.hs index 5833a0aff3f..584a5f03bc7 100644 --- a/lib/unison-pretty-printer/src/Unison/Util/ColorText.hs +++ b/lib/unison-pretty-printer/src/Unison/Util/ColorText.hs @@ -201,3 +201,6 @@ defaultColors = \case ST.Parenthesis -> Nothing ST.DocDelimiter -> Just Green ST.DocKeyword -> Just HiCyan + ST.RecordFieldName {} -> Just HiCyan + ST.RecordFieldValueColon -> Just HiPurple + ST.RecordExtraFields -> Just HiPurple diff --git a/lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs b/lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs index e086e4849bd..37fc75a0a71 100644 --- a/lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs +++ b/lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs @@ -51,6 +51,9 @@ data Element r | DocDelimiter | -- the 'source' in @source{…}, etc DocKeyword + | RecordFieldName Text + | RecordFieldValueColon + | RecordExtraFields deriving (Eq, Ord, Show, Functor) syntax :: Element r -> SyntaxText' r -> SyntaxText' r diff --git a/lib/unison-util-relation/src/Unison/Util/BiMap.hs b/lib/unison-util-relation/src/Unison/Util/BiMap.hs new file mode 100644 index 00000000000..43f944bcd2b --- /dev/null +++ b/lib/unison-util-relation/src/Unison/Util/BiMap.hs @@ -0,0 +1,105 @@ +module Unison.Util.BiMap + ( BiMap (..), + empty, + singleton, + fromList, + fromMap, + toList, + toMapL, + toMapR, + lookupL, + lookupR, + union, + difference, + insert, + deleteL, + deleteR, + keysSetL, + keysSetR, + ) +where + +import Data.Map qualified as Map +import Data.Set (Set) +import Data.Tuple (swap) + +-- | A bidirectional map between keys of type k and values of type v. +data BiMap k v = BiMap + { forward :: Map.Map k v, + backward :: Map.Map v k + } + deriving (Eq, Ord, Show) + +-- | Combine two BiMaps. In case of key or value collisions, the entries from +-- the second BiMap take precedence. +instance (Ord k, Ord v) => Semigroup (BiMap k v) where + BiMap f1 b1 <> BiMap f2 b2 = + BiMap (Map.union f2 f1) (Map.union b2 b1) + +instance (Ord k, Ord v) => Monoid (BiMap k v) where + mempty = BiMap Map.empty Map.empty + +empty :: (Ord k, Ord v) => BiMap k v +empty = mempty + +singleton :: k -> v -> BiMap k v +singleton k v = BiMap (Map.singleton k v) (Map.singleton v k) + +fromList :: (Ord k, Ord v) => [(k, v)] -> BiMap k v +fromList kvs = + let forward = Map.fromList kvs + backward = Map.fromList (swap <$> Map.toList forward) + in BiMap {forward, backward} + +fromMap :: (Ord k, Ord v) => Map.Map k v -> BiMap k v +fromMap f = + let b = Map.fromList (swap <$> Map.toList f) + in BiMap f b + +toList :: BiMap k v -> [(k, v)] +toList (BiMap f _) = Map.toList f + +toMapL :: BiMap k v -> Map.Map k v +toMapL (BiMap f _) = f + +toMapR :: BiMap k v -> Map.Map v k +toMapR (BiMap _ b) = b + +lookupL :: (Ord k) => k -> BiMap k v -> Maybe v +lookupL k (BiMap f _) = Map.lookup k f + +lookupR :: (Ord v) => v -> BiMap k v -> Maybe k +lookupR v (BiMap _ b) = Map.lookup v b + +union :: (Ord k, Ord v) => BiMap k v -> BiMap k v -> BiMap k v +union = (<>) + +difference :: (Ord k, Ord v) => BiMap k v -> BiMap k v -> BiMap k v +difference (BiMap f1 b1) (BiMap f2 b2) = + let f' = Map.difference f1 f2 + b' = Map.difference b1 b2 + in BiMap f' b' + +insert :: (Ord k, Ord v) => k -> v -> BiMap k v -> BiMap k v +insert k v (BiMap f b) = + BiMap (Map.insert k v f) (Map.insert v k b) + +deleteL :: (Ord k, Ord v) => k -> BiMap k v -> BiMap k v +deleteL k bm = case lookupL k bm of + Nothing -> bm + Just v -> + BiMap + (Map.delete k (forward bm)) + (Map.delete v (backward bm)) + +deleteR :: (Ord v, Ord k) => v -> BiMap k v -> BiMap k v +deleteR v bm = flipped $ deleteL v (flipped bm) + +keysSetL :: BiMap k v -> Set k +keysSetL (BiMap f _) = Map.keysSet f + +keysSetR :: BiMap k v -> Set v +keysSetR (BiMap _ b) = Map.keysSet b + +flipped :: BiMap k v -> BiMap v k +flipped (BiMap f b) = BiMap b f diff --git a/lib/unison-util-relation/unison-util-relation.cabal b/lib/unison-util-relation/unison-util-relation.cabal index 94deba5e773..e864de7b152 100644 --- a/lib/unison-util-relation/unison-util-relation.cabal +++ b/lib/unison-util-relation/unison-util-relation.cabal @@ -17,6 +17,7 @@ source-repository head library exposed-modules: + Unison.Util.BiMap Unison.Util.BiMultimap Unison.Util.Relation Unison.Util.Relation3 diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index b5c3f2b023c..49c93f58da8 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -102,6 +102,7 @@ term1to2 h = V1.Term.Char c -> V2.Term.Char c V1.Term.Ref r -> V2.Term.Ref (rreference1to2 h r) V1.Term.Constructor (V1.ConstructorReference r i) -> V2.Term.Constructor (reference1to2 r) (fromIntegral i) + V1.Term.Record fields -> V2.Term.Record fields V1.Term.Request (V1.ConstructorReference r i) -> V2.Term.Request (reference1to2 r) (fromIntegral i) V1.Term.Handle b h -> V2.Term.Handle b h V1.Term.App f a -> V2.Term.App f a @@ -134,6 +135,8 @@ term1to2 h = V1.Pattern.Bytes _ b -> V2.Term.PBytes b V1.Pattern.Constructor _ (V1.ConstructorReference r i) ps -> V2.Term.PConstructor (reference1to2 r) i (goPat <$> ps) + V1.Pattern.RecordLiteral _loc fields -> + V2.Term.PRecord (goPat <$> fields) V1.Pattern.As _ p -> V2.Term.PAs (goPat p) V1.Pattern.EffectPure _ p -> V2.Term.PEffectPure (goPat p) V1.Pattern.EffectBind _ (V1.ConstructorReference r i) ps k -> @@ -166,6 +169,7 @@ term2to1 h lookupCT = V2.Term.Ref r -> pure $ V1.Term.Ref (rreference2to1 h r) V2.Term.Constructor r i -> pure (V1.Term.Constructor (V1.ConstructorReference (reference2to1 r) (fromIntegral i))) + V2.Term.Record fields -> pure $ V1.Term.Record fields V2.Term.Request r i -> pure (V1.Term.Request (V1.ConstructorReference (reference2to1 r) (fromIntegral i))) V2.Term.Handle a a4 -> pure $ V1.Term.Handle a a4 @@ -196,6 +200,8 @@ term2to1 h lookupCT = V2.Term.PBytes b -> pure $ V1.Pattern.Bytes a b V2.Term.PConstructor r i ps -> V1.Pattern.Constructor a (V1.ConstructorReference (reference2to1 r) i) <$> traverse goPat ps + V2.Term.PRecord fields -> + V1.Pattern.RecordLiteral a <$> traverse goPat fields V2.Term.PAs p -> V1.Pattern.As a <$> goPat p V2.Term.PEffectPure p -> V1.Pattern.EffectPure a <$> goPat p V2.Term.PEffectBind r i ps p -> @@ -359,7 +365,11 @@ type2to1' convertRef = V2.Type.Effects as -> V1.Type.Effects as V2.Type.Forall a -> V1.Type.Forall a V2.Type.IntroOuter a -> V1.Type.IntroOuter a + V2.Type.Record fb fields -> V1.Type.Record (convertFB fb) fields where + convertFB = \case + V2.Type.AllowExtraFields -> V1.Type.AllowExtraFields + V2.Type.RequireExactFields -> V1.Type.RequireExactFields convertKind = \case V2.Kind.Star -> V1.Kind.Star V2.Kind.Arrow i o -> V1.Kind.Arrow (convertKind i) (convertKind o) @@ -386,7 +396,11 @@ type1to2' convertRef = V1.Type.Effects as -> V2.Type.Effects as V1.Type.Forall a -> V2.Type.Forall a V1.Type.IntroOuter a -> V2.Type.IntroOuter a + V1.Type.Record fb fields -> V2.Type.Record (convertFB fb) fields where + convertFB = \case + V1.Type.AllowExtraFields -> V2.Type.AllowExtraFields + V1.Type.RequireExactFields -> V2.Type.RequireExactFields convertKind = \case V1.Kind.Star -> V2.Kind.Star V1.Kind.Arrow i o -> V2.Kind.Arrow (convertKind i) (convertKind o) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index e6b1b4faabe..3c97457f73f 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -777,6 +777,7 @@ patternReferences_ f = \case (\newRef newPatterns -> Pattern.Constructor loc newRef newPatterns) <$> (ref & someRefCon_ %%~ f) <*> (patterns & traversed . patternReferences_ %%~ f) + Pattern.RecordLiteral {} -> error "Impossible: encountered unexpected record patterns in old code" (Pattern.As loc pat) -> Pattern.As loc <$> patternReferences_ f pat (Pattern.EffectPure loc pat) -> Pattern.EffectPure loc <$> patternReferences_ f pat (Pattern.EffectBind loc ref patterns pat) -> diff --git a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs index 66d0ec375c0..9f119c33a91 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs @@ -119,6 +119,7 @@ m2hTerm = ABT.transformM \case Memory.Term.Blank b -> pure (Hashing.TermBlank b) Memory.Term.Ref r -> pure (Hashing.TermRef (m2hReference r)) Memory.Term.Constructor (Memory.ConstructorReference.ConstructorReference r i) -> pure (Hashing.TermConstructor (m2hReference r) i) + Memory.Term.Record fields -> pure (Hashing.TermRecord fields) Memory.Term.Request (Memory.ConstructorReference.ConstructorReference r i) -> pure (Hashing.TermRequest (m2hReference r) i) Memory.Term.Handle x y -> pure (Hashing.TermHandle x y) Memory.Term.App f x -> pure (Hashing.TermApp f x) @@ -150,6 +151,7 @@ m2hPattern = \case Memory.Pattern.Bytes loc b -> Hashing.PatternBytes loc b Memory.Pattern.Constructor loc (Memory.ConstructorReference.ConstructorReference r i) ps -> Hashing.PatternConstructor loc (m2hReference r) i (fmap m2hPattern ps) + Memory.Pattern.RecordLiteral loc fields -> Hashing.PatternRecord loc (m2hPattern <$> fields) Memory.Pattern.As loc p -> Hashing.PatternAs loc (m2hPattern p) Memory.Pattern.EffectPure loc p -> Hashing.PatternEffectPure loc (m2hPattern p) Memory.Pattern.EffectBind loc (Memory.ConstructorReference.ConstructorReference r i) ps k -> @@ -182,6 +184,7 @@ h2mTerm getCT = ABT.transform \case Hashing.TermRef r -> Memory.Term.Ref (h2mReference r) Hashing.TermConstructor r i -> Memory.Term.Constructor (Memory.ConstructorReference.ConstructorReference (h2mReference r) i) Hashing.TermRequest r i -> Memory.Term.Request (Memory.ConstructorReference.ConstructorReference (h2mReference r) i) + Hashing.TermRecord fields -> Memory.Term.Record fields Hashing.TermHandle x y -> Memory.Term.Handle x y Hashing.TermApp f x -> Memory.Term.App f x Hashing.TermAnn e t -> Memory.Term.Ann e (h2mType t) @@ -212,6 +215,7 @@ h2mPattern = \case Hashing.PatternBytes loc b -> Memory.Pattern.Bytes loc b Hashing.PatternConstructor loc r i ps -> Memory.Pattern.Constructor loc (Memory.ConstructorReference.ConstructorReference (h2mReference r) i) (h2mPattern <$> ps) + Hashing.PatternRecord loc fields -> Memory.Pattern.RecordLiteral loc (h2mPattern <$> fields) Hashing.PatternAs loc p -> Memory.Pattern.As loc (h2mPattern p) Hashing.PatternEffectPure loc p -> Memory.Pattern.EffectPure loc (h2mPattern p) Hashing.PatternEffectBind loc r i ps k -> @@ -280,6 +284,12 @@ m2hType = ABT.transform \case Memory.Type.Effects a1s -> Hashing.TypeEffects a1s Memory.Type.Forall a1 -> Hashing.TypeForall a1 Memory.Type.IntroOuter a1 -> Hashing.TypeIntroOuter a1 + Memory.Type.Record fb a1 -> Hashing.TypeRecord (m2hFieldBehavior fb) a1 + +m2hFieldBehavior :: Memory.Type.FieldBehavior -> Hashing.FieldBehavior +m2hFieldBehavior = \case + Memory.Type.RequireExactFields -> Hashing.RequireExactFields + Memory.Type.AllowExtraFields -> Hashing.AllowExtraFields m2hKind :: Memory.Kind.Kind -> Hashing.Kind m2hKind = \case @@ -318,6 +328,12 @@ h2mType = ABT.transform \case Hashing.TypeEffects a1s -> Memory.Type.Effects a1s Hashing.TypeForall a1 -> Memory.Type.Forall a1 Hashing.TypeIntroOuter a1 -> Memory.Type.IntroOuter a1 + Hashing.TypeRecord fb a1 -> Memory.Type.Record (h2mFieldBehavior fb) a1 + +h2mFieldBehavior :: Hashing.FieldBehavior -> Memory.Type.FieldBehavior +h2mFieldBehavior = \case + Hashing.RequireExactFields -> Memory.Type.RequireExactFields + Hashing.AllowExtraFields -> Memory.Type.AllowExtraFields h2mKind :: Hashing.Kind -> Memory.Kind.Kind h2mKind = \case diff --git a/parser-typechecker/src/Unison/KindInference/Constraint/Context.hs b/parser-typechecker/src/Unison/KindInference/Constraint/Context.hs index 5739cdebeff..72bc6bfff87 100644 --- a/parser-typechecker/src/Unison/KindInference/Constraint/Context.hs +++ b/parser-typechecker/src/Unison/KindInference/Constraint/Context.hs @@ -3,6 +3,7 @@ module Unison.KindInference.Constraint.Context ) where +import Data.Text (Text) import Unison.KindInference.UVar (UVar) import Unison.Type (Type) @@ -19,4 +20,6 @@ data ConstraintContext v loc | DeclDefinition | Builtin | ContextLookup + | Record + | RecordField Text deriving stock (Show, Eq, Ord) diff --git a/parser-typechecker/src/Unison/KindInference/Generate.hs b/parser-typechecker/src/Unison/KindInference/Generate.hs index dcb66d786b6..56531b9a0a8 100644 --- a/parser-typechecker/src/Unison/KindInference/Generate.hs +++ b/parser-typechecker/src/Unison/KindInference/Generate.hs @@ -10,6 +10,7 @@ where import Control.Monad.Except import Data.Foldable (foldlM) +import Data.Map qualified as Map import Data.Set qualified as Set import U.Core.ABT qualified as ABT import Unison.Builtin.Decls (rewriteTypeRef) @@ -112,6 +113,12 @@ typeConstraintTree resultVar ABT.Term {annotation, out} = do effKind <- freshVar eff effConstraints <- typeConstraintTree effKind eff pure $ ParentConstraint (IsAbility effKind (Provenance EffectsList $ ABT.annotation eff)) effConstraints + Type.Record _fb fields -> do + ParentConstraint (IsType resultVar (Provenance Record annotation)) . Node <$> for (Map.toList fields) \(fieldName, fieldType) -> do + fieldKind <- freshVar fieldType + fieldConstraints <- typeConstraintTree fieldKind fieldType + let fieldAnn = ABT.annotation fieldType + pure $ ParentConstraint (IsType fieldKind (Provenance (RecordField fieldName) fieldAnn)) fieldConstraints handleIntroOuter :: (Var v) => v -> loc -> (GeneratedConstraint v loc -> Gen v loc r) -> Gen v loc r handleIntroOuter v loc k = do diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Class.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Class.hs index f5a384aa0b5..21252c08068 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Class.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Class.hs @@ -10,6 +10,7 @@ where import Control.Monad.Fix (MonadFix) import Data.Map (Map) import Data.Map qualified as Map +import Data.Text (Text) import Unison.ConstructorReference (ConstructorReference) import Unison.PatternMatchCoverage.ListPat (ListPat) import Unison.PrettyPrintEnv (PrettyPrintEnv) @@ -42,6 +43,10 @@ data EnumeratedConstructors vt v loc = ConstructorType [(v, ConstructorReference, Type vt loc)] | AbilityType (Type vt loc) (Map ConstructorReference (v, Type vt loc)) | SequenceType [(ListPat, [Type vt loc])] + | -- | A record is a product with a single constructor, whose argument types + -- are the field types. Carrying the field names lets us name the variables + -- we introduce for them. + RecordType (Map Text (Type vt loc)) | BooleanType | OtherType deriving stock (Show) @@ -64,5 +69,6 @@ traverseConstructorTypes f = \case (pure mempty) m SequenceType x -> pure (SequenceType x) + RecordType x -> pure (RecordType x) BooleanType -> pure BooleanType OtherType -> pure OtherType diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Constraint.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Constraint.hs index 10e7ed42a16..65bf96b04c7 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Constraint.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Constraint.hs @@ -4,6 +4,9 @@ module Unison.PatternMatchCoverage.Constraint ) where +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Text (Text) import Unison.ConstructorReference (ConstructorReference) import Unison.PatternMatchCoverage.EffectHandler import Unison.PatternMatchCoverage.IntervalSet (IntervalSet) @@ -53,6 +56,11 @@ data Constraint vt v loc Int -- | element variable v + | PosRecordLiteral + -- | record root + v + -- | a variable and type per matched field + (Map Text (v, Type vt loc)) | -- | Negative constraint on length of the list (/i.e./ the list -- may not be an element of the interval set) NegListInterval v IntervalSet @@ -76,6 +84,9 @@ prettyConstraint ppe = \case NegLit var lit -> sep " " [prettyVar var, "≠", prettyPmLit lit] PosListHead root n el -> sep " " [prettyVar el, "<-", "head", pany n, prettyVar root] PosListTail root n el -> sep " " [prettyVar el, "<-", "tail", pany n, prettyVar root] + PosRecordLiteral root fields -> + let fieldStrs = fmap (\(k, (v, _t)) -> sep " " [pany k, ":", prettyVar v]) (Map.toAscList fields) + in sep " " ["{" <> sep ", " fieldStrs <> "}", "<-", "record", prettyVar root] NegListInterval var x -> sep " " [prettyVar var, "≠", string (show x)] Effectful var -> "!" <> prettyVar var Eq v0 v1 -> sep " " [prettyVar v0, "=", prettyVar v1] diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Desugar.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Desugar.hs index 1017d72a57e..70058b7cc5d 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Desugar.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Desugar.hs @@ -3,6 +3,9 @@ module Unison.PatternMatchCoverage.Desugar ) where +import Data.Align qualified as Align +import Data.Map qualified as Map +import Data.These (These (..)) import U.Core.ABT qualified as ABT import Unison.Pattern import Unison.Pattern qualified as Pattern @@ -10,6 +13,7 @@ import Unison.PatternMatchCoverage.Class import Unison.PatternMatchCoverage.GrdTree import Unison.PatternMatchCoverage.PmGrd import Unison.PatternMatchCoverage.PmLit qualified as PmLit +import Unison.Prelude import Unison.Term (MatchCase (..), Term', app, var) import Unison.Type (Type) import Unison.Type qualified as Type @@ -70,6 +74,13 @@ desugarPattern typ v0 pat k vs = case pat of tpatvars = zipWith (\(v, p) t -> (v, p, t)) patvars contyps rest <- foldr (\(v, pat, t) b -> desugarPattern t v pat b) k tpatvars vs pure (Grd c rest) + RecordLiteral _loc fields + | Type.Record' _fb typeFields <- Type.stripIntroOuters typ -> handleRecord typ typeFields v0 k fields vs + -- The typechecker rejects a record pattern whose scrutinee isn't a record, + -- so reaching this means the two disagree. + | otherwise -> + error $ + "impossible: desugarPattern: record pattern against a non-record type: " <> show typ As _ rest -> desugarPattern typ v0 rest k (v0 : vs) EffectPure _ resume -> do v <- fresh @@ -89,6 +100,42 @@ desugarPattern typ v0 pat k vs = case pat of SequenceLiteral {} -> handleSequence typ v0 pat k vs SequenceOp {} -> handleSequence typ v0 pat k vs +handleRecord :: + forall v vt loc m. + (Pmc vt v loc m) => + Type vt loc -> + (Map Text (Type vt loc)) -> + v -> + ([v] -> m (GrdTree (PmGrd vt v loc) loc)) -> + Map Text (Pattern loc) -> + [v] -> + m (GrdTree (PmGrd vt v loc) loc) +handleRecord typ typeFields recordVar k fieldPats vs = do + -- Each field the pattern mentions gets a fresh variable standing for that + -- field of the scrutinee, then its subpattern is desugared against it. + let go :: + (Text, ((v, Type vt loc), Pattern loc)) -> + ([v] -> m (GrdTree (PmGrd vt v loc) loc)) -> + [v] -> + m (GrdTree (PmGrd vt v loc) loc) + go (_fieldName, ((fieldVar, fieldType), fieldPat)) k vs = + desugarPattern fieldType fieldVar fieldPat k vs + -- Fields present in only one of the two maps are dropped: a field the type + -- has but the pattern doesn't is simply unmatched, and a field the pattern + -- has but the type doesn't was already rejected by the typechecker. + let matched = + Align.align typeFields fieldPats + & Map.mapMaybe \case + This _ -> Nothing + That _ -> Nothing + These t p -> Just (t, p) + withVars <- for matched \(fieldType, fieldPat) -> do + v <- fresh + pure ((v, fieldType), fieldPat) + let fieldVars = fst <$> withVars + subtree <- foldr go k (Map.toAscList withVars) vs + pure $ Grd (PmRecordLiteral fieldVars recordVar typ) subtree + handleSequence :: forall v vt loc m. (Pmc vt v loc m) => diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs index 7a353817a69..087c3ebd0ae 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs @@ -4,6 +4,9 @@ module Unison.PatternMatchCoverage.Literal ) where +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Text (Text) import Unison.ConstructorReference (ConstructorReference) import Unison.PatternMatchCoverage.EffectHandler import Unison.PatternMatchCoverage.IntervalSet (IntervalSet) @@ -66,6 +69,11 @@ data Literal vt v loc Effectful v | -- | Introduce a binding for a term Let v (Term' vt v loc) (Type vt loc) + | PosRecordLiteral + -- | record root + v + -- | a variable and type per matched field + (Map Text (v, Type vt loc)) deriving stock (Show) prettyLiteral :: (Var v) => Literal (TypeVar b v) v loc -> Pretty ColorText @@ -87,6 +95,9 @@ prettyLiteral = \case NegListInterval var x -> sep " " [pv var, "≠", string (show x)] Effectful var -> "!" <> pv var Let var expr typ -> sep " " ["let", pv var, "=", TermPrinter.pretty PPE.empty (lowerTerm expr), ":", TypePrinter.pretty PPE.empty typ] + PosRecordLiteral root fields -> + let fieldStrs = fmap (\(k, (v, _t)) -> sep " " [pc k, ":", pv v]) (Map.toAscList fields) + in sep " " ["{" <> sep ", " fieldStrs <> "}", "<-", "record", pv root] where pv = string . show pc :: forall a. (Show a) => a -> Pretty ColorText diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/NormalizedConstraints.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/NormalizedConstraints.hs index 9edc1b21ce1..80cf46eda98 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/NormalizedConstraints.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/NormalizedConstraints.hs @@ -30,7 +30,7 @@ import Unison.PatternMatchCoverage.UFMap qualified as UFMap import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.Syntax.TypePrinter qualified as TypePrinter -import Unison.Type (Type, booleanRef, bytesRef, charRef, effectRef, floatRef, intRef, listRef, natRef, textRef, pattern App', pattern Apps', pattern Ref') +import Unison.Type (Type, booleanRef, bytesRef, charRef, effectRef, floatRef, intRef, listRef, natRef, textRef, pattern App', pattern Apps', pattern Record', pattern Ref') import Unison.Util.Bytes (Bytes) import Unison.Util.Pretty import Unison.Var (Var) @@ -185,6 +185,10 @@ mkVarInfo v t = vi_typ = t, vi_con = case t of Apps' (Ref' r) _ | r == effectRef -> Vc'Effect Nothing mempty + -- A record is a product with exactly one constructor, so there is no + -- negative information to track: the only thing we can learn is which + -- variables stand for its fields. + Record' _fb _fields -> Vc'Record Nothing App' (Ref' r) t | r == listRef -> Vc'ListRoot t Empty Empty (IntervalSet.singleton (0, maxBound)) Ref' r @@ -220,6 +224,11 @@ data VarConstraints vt v loc | Vc'Effect (Maybe (EffectHandler, [(v, Type vt loc)])) (Set EffectHandler) + | -- | Records have a single constructor, so the only constraint we can + -- carry is the positive one naming a variable per matched field. Fields + -- the match hasn't mentioned are simply absent from the map. + Vc'Record + (Maybe (Map Text (v, Type vt loc))) | Vc'Boolean (Maybe Bool) (Set Bool) | Vc'Int (Maybe Int64) (Set Int64) | Vc'Nat (Maybe Word64) (Set Word64) @@ -269,6 +278,8 @@ prettyNormalizedConstraints ppe (NormalizedConstraints {constraintMap}) = sep " (\x -> [PosLit kcanon (PmLit.Char x)]) <$> pos Vc'Bytes pos _neg -> (\x -> [PosLit kcanon (PmLit.Bytes x)]) <$> pos + Vc'Record pos -> + (\fields -> [PosRecordLiteral kcanon fields]) <$> pos Vc'ListRoot _typ posCons posSnoc _iset -> let consConstraints = fmap (\(i, x) -> PosListHead kcanon i x) (zip [0 ..] (toList posCons)) snocConstraints = fmap (\(i, x) -> PosListTail kcanon i x) (zip [0 ..] (toList posSnoc)) @@ -285,6 +296,8 @@ prettyNormalizedConstraints ppe (NormalizedConstraints {constraintMap}) = sep " Vc'Text _pos neg -> negConK neg (\v a -> NegLit v (PmLit.Text a)) Vc'Char _pos neg -> negConK neg (\v a -> NegLit v (PmLit.Char a)) Vc'Bytes _pos neg -> negConK neg (\v a -> NegLit v (PmLit.Bytes a)) + -- Records have no negative constraints. + Vc'Record _pos -> [] Vc'ListRoot _typ _posCons _posSnoc iset -> [NegListInterval kcanon (IntervalSet.complement iset)] botCon = case vi_eff vi of IsNotEffectful -> [] diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/PmGrd.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/PmGrd.hs index 41bf27573a3..4533c055f28 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/PmGrd.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/PmGrd.hs @@ -1,5 +1,9 @@ module Unison.PatternMatchCoverage.PmGrd where +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text import Unison.ConstructorReference (ConstructorReference) import Unison.PatternMatchCoverage.PmLit (PmLit, prettyPmLit) import Unison.PatternMatchCoverage.Pretty @@ -57,6 +61,17 @@ data | -- | @PmLet x expr@ corresponds to a @let x = expr@ guard. This actually -- /binds/ @x@. PmLet v (Term' vt v loc) (Type vt loc) + | -- | @PmRecordLiteral fields x typ@ corresponds to matching the record in + -- @x@, binding a variable for each named field. A record has a single + -- constructor, so this match is irrefutable; fields the pattern doesn't + -- mention are absent from the map. + PmRecordLiteral + -- | a variable and type per matched field + (Map Text (v, Type vt loc)) + -- | record value + v + -- | record type + (Type vt loc) deriving stock (Show) prettyPmGrd :: (Var vt, Var v) => PPE.PrettyPrintEnv -> PmGrd vt v loc -> Pretty ColorText @@ -74,5 +89,8 @@ prettyPmGrd ppe = \case PmLit var lit -> sep " " [prettyPmLit lit, "<-", prettyVar var] PmBang v -> "!" <> prettyVar v PmLet v _expr _ -> sep " " ["let", prettyVar v, "=", ""] + PmRecordLiteral fields v _ -> + let fieldStrs = fmap (\(k, (fv, _t)) -> sep " " [string (Text.unpack k), ":", prettyVar fv]) (Map.toAscList fields) + in sep " " ["{" <> sep ", " fieldStrs <> "}", "<-", prettyVar v] where pc = prettyConstructorReference ppe diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs index 3d450c23c1a..f4d44d32e63 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs @@ -103,6 +103,12 @@ uncoverAnnotate z grdtree0 = cata phi grdtree0 z PmLet var expr typ -> do nc <- addLiteral' nc0 (Let var expr typ) k nc + PmRecordLiteral fields recordVar _recordType -> do + -- A record match is irrefutable, so unlike a constructor match there + -- is no negative branch to take: we only learn which variables stand + -- for the scrutinee's fields. + nc <- addLiteral' nc0 (PosRecordLiteral recordVar fields) + k nc -- Constructors and literals are handled uniformly except that -- they pass different positive and negative literals. @@ -201,6 +207,12 @@ generateInhabitants x nc = [(v, _)] -> generateInhabitants v nc' _ -> error "NoEffect has the incorrect number of convars" Effect cr -> Pattern.EffectBind () cr (map (\(v, _) -> generateInhabitants v nc') convars) (Pattern.Unbound ()) + Vc'Record pos -> case pos of + Nothing -> Pattern.Unbound () + -- Note this emits `Unbound` for unconstrained fields rather than + -- `Var`: these patterns are rendered with no variable supply. + Just fields -> + Pattern.RecordLiteral () (fields <&> \(v, _) -> generateInhabitants v nc') Vc'Boolean pos _neg -> case pos of Nothing -> Pattern.Unbound () Just b -> Pattern.Boolean () b @@ -325,6 +337,10 @@ expandSolution x nc = Vc'Effect pos neg | Just _ <- pos -> go newFuel v nc' | not (Set.null neg) -> go (newFuel - 1) v nc' + -- Always expand records: they're irrefutable, so + -- suggesting `{a: {b: _}}` costs nothing and reads + -- better than `{a: _}`. + Vc'Record _pos -> go newFuel v nc' Vc'Boolean _pos neg | not (Set.null neg) -> go (newFuel - 1) v nc' Vc'ListRoot _typ _posCons _posSnoc neg @@ -386,6 +402,20 @@ withConstructors nil vinfo k = do mkNeg _v (_pos, neg) = neg in k constraints mkPos mkNeg + RecordType fields -> + -- A record is a product with exactly one constructor, so there is a + -- single instantiation to try and its argument types are the field + -- types. Walking into them is what lets us notice that a record with an + -- uninhabited field is itself uninhabited. + let names = Map.keys fields + fieldTypes = Map.elems fields + mkPos recVar ns args = [C.PosRecordLiteral recVar (Map.fromList (zip ns args))] + -- There is no negative record constraint: with one constructor + -- there's nothing to rule out and nothing to retry. Adding an empty + -- positive constraint is a no-op, and `inhabited` skips this + -- entirely for records (see `shouldAddNegative`). + mkNeg recVar _ns = C.PosRecordLiteral recVar mempty + in k [(names, fieldTypes)] mkPos mkNeg BooleanType -> do k [(True, []), (False, [])] (\v b _ -> [C.PosLit v (PmLit.Boolean b)]) (\v b -> C.NegLit v (PmLit.Boolean b)) OtherType -> nil @@ -413,6 +443,9 @@ inhabited fuel x nc0 = shouldAddNegative :: Bool shouldAddNegative = case vi_con xvi of Vc'Effect {} -> False + -- Records have a single constructor, so there is no other + -- instantiation to rule out. + Vc'Record {} -> False _ -> True in withConstructors (pure (Just nc')) xvi \cs posConstraint negConstraint -> -- one of the constructors must be inhabited, Return the @@ -488,6 +521,13 @@ addLiteral lit0 nabla0 = runMaybeT do let nabla1 = declVar listElem listElemType id nabla0 c = C.PosListTail listRoot n listElem addConstraint c nabla1 + PosRecordLiteral recordVar fields -> + -- The record variable is the scrutinee and is already declared; it's the + -- field variables that are new. Compare `PosCon`, which declares its + -- `convars` the same way. + let ctx = foldr (\(trm, typ) b -> declVar trm typ id b) nabla0 (Map.elems fields) + c = C.PosRecordLiteral recordVar fields + in addConstraint c ctx NegListInterval listVar iset -> addConstraint (C.NegListInterval listVar iset) nabla0 Effectful var -> addConstraint (C.Effectful var) nabla0 Let var _expr typ -> pure (Just (declVar var typ id nabla0)) @@ -592,6 +632,19 @@ addConstraint con0 nc = do iset' = IntervalSet.delete (0, length posSnoc' - 1) iset in (populateCons r posCons iset', Update (posCons, posSnoc', iset')) in modifyListC r updateList nc + C.PosRecordLiteral var fields -> + let updateRecord pos + | Just fields1 <- pos = + -- We already know variables for some of this record's fields. + -- Fields we've seen before must be equated with the existing + -- variable; fields new to this match are added. + let varsToEquate = + Map.elems $ + Map.intersectionWith (\(y, _) (z, _) -> (y, z)) fields fields1 + in (equate varsToEquate, Update (Just (Map.union fields1 fields))) + -- A record match can never contradict, so there is no negative case. + | otherwise = (pure (), Update (Just fields)) + in modifyRecordC var updateRecord nc C.PosCon var datacon convars -> let updateConstructor pos neg | Just (datacon1, convars1) <- pos = case datacon == datacon1 of @@ -744,6 +797,11 @@ union v0 v1 nc@NormalizedConstraints {constraintMap} = Just (datacon, convars) -> [C.PosEffect chosenCanon datacon convars] negC = foldr (\a b -> C.NegEffect chosenCanon a : b) [] neg in (posC, negC) + Vc'Record pos -> + let posC = case pos of + Nothing -> [] + Just fields -> [C.PosRecordLiteral chosenCanon fields] + in (posC, []) Vc'ListRoot _typ posCons posSnoc iset -> let consConstraints = map (\(i, x) -> C.PosListHead chosenCanon i x) (zip [0 ..] (toList posCons)) snocConstraints = map (\(i, x) -> C.PosListTail chosenCanon i x) (zip [0 ..] (toList posSnoc)) @@ -823,6 +881,32 @@ modifyConstructorF v f nc = let g vc = getCompose (posAndNegConstructor (\pos neg -> Compose (f pos neg)) vc) in modifyVarConstraints v g nc +modifyRecordC :: + forall vt v loc m. + (Pmc vt v loc m) => + v -> + ( Maybe (Map Text (v, Type vt loc)) -> + (C vt v loc m (), ConstraintUpdate (Maybe (Map Text (v, Type vt loc)))) + ) -> + NormalizedConstraints vt v loc -> + m (Maybe (NormalizedConstraints vt v loc)) +modifyRecordC v f nc0 = + let (ccomp, nc1) = modifyRecordF v f nc0 + in fmap snd <$> runC nc1 ccomp + +modifyRecordF :: + forall vt v loc f. + (Var v, Functor f) => + v -> + ( Maybe (Map Text (v, Type vt loc)) -> + f (ConstraintUpdate (Maybe (Map Text (v, Type vt loc)))) + ) -> + NormalizedConstraints vt v loc -> + f (NormalizedConstraints vt v loc) +modifyRecordF v f nc = + let g vc = getCompose (posRecord (Compose . f) vc) + in modifyVarConstraints v g nc + modifyEffectC :: forall vt v loc m. (Pmc vt v loc m) => @@ -924,6 +1008,21 @@ posAndNegConstructor f = \case _ -> error "impossible: posAndNegConstructor called on something other than Vc'Constructor" {-# INLINE posAndNegConstructor #-} +-- | Modify the positive constraint of a record. Records have a single +-- constructor, so there is no negative constraint to modify. +posRecord :: + forall f vt v loc. + (Functor f) => + ( Maybe (Map Text (v, Type vt loc)) -> + f (Maybe (Map Text (v, Type vt loc))) + ) -> + VarConstraints vt v loc -> + f (VarConstraints vt v loc) +posRecord f = \case + Vc'Record pos -> Vc'Record <$> f pos + _ -> error "impossible: posRecord called on something other than Vc'Record" +{-# INLINE posRecord #-} + -- | Modify the positive and negative constraints of an effect. posAndNegEffect :: forall f vt v loc. diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 8269eed08a7..eacd3ea12ee 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -46,6 +46,7 @@ import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names import Unison.Parser.Ann (Ann (..)) import Unison.Pattern (Pattern) +import Unison.Pattern qualified as Pattern import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnv.Names qualified as PPE @@ -1023,6 +1024,83 @@ renderTypeError e env src = case e of case defns of _ Nel.:| [] -> "name" _ -> "names" + MissingRecordField {missingFieldName, fieldType, recordWithField, recordWithoutField} -> + Pr.lines + [ Pr.wrap "I expected this record: ", + "", + annotatedAsErrorSite src recordWithoutField, + "", + "to have the field", + Pr.indentN 2 $ + ( style Type2 $ + (Text.unpack missingFieldName) + <> ": " + <> (renderType' env fieldType) + ), + "", + "so that it would match the type:", + Pr.indentN 2 $ + ( Pr.lines + [ "", + style Type2 (renderType' env recordWithField), + "" + ] + ), + "", + Pr.wrap "from here: ", + "", + annotatedAsStyle Type1 src fieldType + ] + UnexpectedRecordField {unexpectedFieldName, fieldType, recordWithoutField, recordWithField} -> + Pr.lines + [ Pr.wrap "I didn't expect this record: ", + "", + annotatedAsErrorSite src recordWithField, + "", + "to have the field", + Pr.indentN 2 $ + ( style Type1 $ + (Text.unpack unexpectedFieldName) + <> ": " + <> (renderType' env fieldType) + ), + "", + "because it should have the type:", + Pr.indentN 2 $ + ( Pr.lines + [ "", + style Type1 (renderType' env recordWithoutField), + "" + ] + ), + "", + Pr.wrap "derived from here: ", + "", + annotatedAsStyle Type2 src recordWithoutField + ] + PatternMatchedMissingField {matchedFieldName, recordPatternLoc, scrutineeRecordType} -> + Pr.lines + [ Pr.wrap $ + "This record has no field called " + <> style ErrorSite (Text.unpack matchedFieldName) + <> " here:", + "", + annotatedAsErrorSite src recordPatternLoc, + "", + "It has type:", + Pr.indentN 2 (style Type1 (renderType' env scrutineeRecordType)), + "" + ] + RecordPatternMatchOnNonRecordType {recordPatternLoc, scrutineeNonRecordType} -> + Pr.lines + [ Pr.wrap "This isn't a record, so there are no fields to read from it:", + "", + annotatedAsErrorSite src recordPatternLoc, + "", + "It has type:", + Pr.indentN 2 (style Type1 (renderType' env scrutineeNonRecordType)), + "" + ] Other (C.cause -> C.HandlerOfUnexpectedType loc typ) -> Pr.lines [ Pr.wrap "The handler used here", @@ -1321,6 +1399,61 @@ renderTypeError e env src = case e of " reference=", showTypeRef env rf ] + C.MissingRecordField fieldName expectedFieldType recordMissingTheField expectedRecordType -> + mconcat + [ "Expected this record: ", + renderType' + env + recordMissingTheField, + "\n", + "to have the field: \n", + Pr.indent " " $ + fromString (Text.unpack fieldName) + <> " : " + <> renderType' env expectedFieldType, + "\n", + "so it would match this record: \n", + Pr.indent " " $ + renderType' env expectedRecordType, + "but it was missing." + ] + C.UnexpectedRecordField fieldName unexpectedFieldType actualRecordType expectedRecordType -> + mconcat + [ "Did not expect this record to have the field: \n", + Pr.indent " " $ + fromString (Text.unpack fieldName) + <> " : " + <> renderType' env unexpectedFieldType, + "\n", + "because it would not match the type of this record: \n", + Pr.indent " " $ + renderType' env expectedRecordType, + "\n", + "but it was present in this record: \n", + Pr.indent " " $ + renderType' env actualRecordType + ] + C.PatternMatchedMissingField fieldName fieldPat missingFieldTyp -> + mconcat + [ "PatternMatchedMissingField:\n", + " field=", + Pr.text fieldName, + "\n", + " loc=", + annotatedToEnglish (Pattern.loc fieldPat), + "\n", + " typ=", + renderType' env missingFieldTyp + ] + C.RecordPatternMatchOnNonRecordType recordPat nonRecordTyp -> + mconcat + [ "RecordPatternMatchOnNonRecordType:\n", + " loc=", + annotatedToEnglish (Pattern.loc recordPat), + "\n", + " typ=", + renderType' env nonRecordTyp + ] renderCompilerBug :: (Var v, Annotated loc, Ord loc, Show loc) => @@ -1431,7 +1564,14 @@ renderPattern env = Pr.render 0 . Pr.syntaxToColor . fst - . TermPrinter.prettyPattern env TermPrinter.emptyAc Precedence.Annotation ([] :: [Symbol]) + . TermPrinter.prettyPattern env TermPrinter.emptyAc Precedence.Annotation placeholders + where + -- `prettyPattern` draws a name from this list for every `Pattern.Var` it + -- meets and errors if it runs dry. Callers here render patterns that came + -- from the coverage checker, which uses `Unbound` rather than `Var`, but + -- an empty list would turn any future var-bearing pattern into a crash. + placeholders :: [Symbol] + placeholders = Var.named . ("_p" <>) . tShow <$> [(0 :: Int) ..] -- | renders a type with no special styling renderType' :: (IsString s, Var v) => Env -> Type v loc -> s @@ -1473,6 +1613,20 @@ renderType env f t = renderType0 env f (0 :: Int) (cleanup t) then go 0 body else "forall " <> spaces renderVar vs <> " . " <> go 1 body Type.Var' v -> renderVar v + Type.Record' fb fields -> + let fbs = case fb of + Type.AllowExtraFields -> " | ..." + Type.RequireExactFields -> "" + in curly + (p >= 3) + "{" + <> commas + ( \(label, fieldType) -> + fromString (Text.unpack label) <> ": " <> go 0 fieldType + ) + (Map.toList fields) + <> fbs + <> "}" _ -> error $ "pattern match failure in PrintError.renderType " ++ show t where go = renderType0 env f @@ -2200,6 +2354,19 @@ renderParseErrors s = \case tokenAsErrorSite s $ HQ.toText <$> tok ] in (msg, [rangeForToken tok]) + go (Parser.DuplicateRecordField ann1 ann2 name) = + let msg = + Pr.lines + [ Pr.wrap $ + "I found the field " + <> style ErrorSite (Text.unpack name) + <> " twice in the same record:", + "", + annotatedsAsErrorSite s [ann1, ann2], + "", + Pr.wrap "Each field can only be named once." + ] + in (msg, mapMaybe rangeForAnnotated [ann1, ann2]) go (Parser.DuplicateBinders ann1 ann2 var) = let msg = Pr.lines diff --git a/parser-typechecker/src/Unison/Syntax/TermParser.hs b/parser-typechecker/src/Unison/Syntax/TermParser.hs index 944a6466663..2bca74b75a5 100644 --- a/parser-typechecker/src/Unison/Syntax/TermParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TermParser.hs @@ -55,7 +55,7 @@ import Unison.Syntax.Lexer.Unison qualified as L import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar) import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Syntax.Parser hiding (seq) -import Unison.Syntax.Parser qualified as Parser (seq, uniqueName) +import Unison.Syntax.Parser qualified as Parser import Unison.Syntax.Parser.Doc.Data qualified as Doc import Unison.Syntax.Pattern qualified as Syntax.Pattern import Unison.Syntax.Precedence (operatorPrecedence) @@ -304,6 +304,8 @@ parsePattern = Parser.seq Syntax.Pattern.SequenceLiteral pRoot, -- () or (pat, pat) or (pat, pat, pat) [which is actually parsed as (pat, (pat, pat)] pParenOrTuple, + -- { a : b, c : d } + P.try pRecord, -- { pat -> pat } or { pat } pEffect ] @@ -397,6 +399,19 @@ parsePattern = pEffectPure = parsePattern <&> \pat -> Syntax.Pattern.EffectPure (ann pat) pat + pRecord :: P v m (Syntax.Pattern.Pattern v) + pRecord = do + start <- openBlockWith "{" + let field = do + fieldName <- Parser.recordFieldName + _ <- reserved ":" + fieldPattern <- parsePattern + pure (fieldName, fieldPattern) + fields <- sepBy (reserved ",") field + end <- closeBlock + checkForDuplicateRecordFields (fst <$> fields) + pure (Syntax.Pattern.RecordLiteral (ann start <> ann end) (Map.fromList (first L.payload <$> fields))) + -- Parse an "HQ-namey", which could either definitely be a nullary constructor (because it's either hash-only or -- hash-qualified or symboly), or either a variable or nullary constructor (because it's a wordy name-only). And if -- it's the latter, we might see that it's actually not a nullary constructor but actually a variable in an @@ -451,6 +466,8 @@ bindConstructorsInPattern = ) <$> bindConstructorsInPattern1 lpat1 <*> bindConstructorsInPattern1 lpat2 + Syntax.Pattern.RecordLiteral pos fields -> + traverse bindConstructorsInPattern1 fields <&> Pattern.RecordLiteral pos Syntax.Pattern.SequenceLiteral pos pats -> Pattern.SequenceLiteral pos <$> traverse bindConstructorsInPattern1 pats Syntax.Pattern.SequenceOp pos lpat1 op lpat2 -> Pattern.SequenceOp pos @@ -664,7 +681,58 @@ resolveHashQualified tok = do | otherwise -> pure $ Term.fromReferent (ann tok) (Set.findMin s) termLeaf :: forall m v. (Monad m, Var v) => TermP v m -termLeaf = +termLeaf = termLeafNoProjection >>= recordProjections + +-- | Parse a chain of record field projections onto an already-parsed term, so +-- that @r\@x@ reads the @x@ field of the record @r@. +-- +-- The @\@@ must be adjacent to both sides -- @r\@x@, never @r \@ x@. That keeps +-- it from reading as an ordinary infix operator, and keeps it clear of the +-- @\@@ that introduces doc special forms. +-- +-- Because this wraps a leaf, projection binds tighter than application: +-- @f r\@x@ is @f (r\@x)@. +recordProjections :: forall m v. (Monad m, Var v) => Term v Ann -> P v m (Term v Ann) +recordProjections base = do + mfield <- optional . P.try $ do + at <- reserved "@" + guard (adjacentAnns (ann base) (ann at)) + field <- recordFieldName + guard (adjacentAnns (ann at) (ann field)) + pure field + case mfield of + Nothing -> pure base + Just field -> recordProjections (recordProjection base field) + +-- | Whether the second annotation begins exactly where the first ends, meaning +-- there was no whitespace between the two tokens. +adjacentAnns :: Ann -> Ann -> Bool +adjacentAnns (Ann _ e) (Ann s _) = e == s +adjacentAnns _ _ = False + +-- | @base\@field@ desugars to a single-field record match. +-- +-- That needs no new term form: it typechecks to @{field: t | ...} -> t@ through +-- the existing record pattern machinery, and compiles to the existing +-- @RecUnpack@ instruction. The bound variable scopes over nothing but itself, +-- so it cannot capture and needs no freshening. +recordProjection :: (Var v) => Term v Ann -> L.Token Text -> Term v Ann +recordProjection base fieldTok = + let fieldAnn = ann fieldTok + -- Not `_field`: a leading underscore makes it a wildcard when the + -- printed form is re-parsed, which would drop the binding. + v = Var.named "field" + in Term.match + (ann base <> fieldAnn) + base + [ Term.MatchCase + (Pattern.RecordLiteral fieldAnn (Map.singleton (L.payload fieldTok) (Pattern.Var fieldAnn))) + Nothing + (ABT.abs' fieldAnn v (Term.var fieldAnn v)) + ] + +termLeafNoProjection :: forall m v. (Monad m, Var v) => TermP v m +termLeafNoProjection = asum [ force, hashQualifiedPrefixTerm, @@ -674,6 +742,7 @@ termLeaf = bytes, boolean, link, + recordLiteral, tupleOrParenthesizedTerm, keywordBlock, list term, @@ -1343,6 +1412,23 @@ number' i u f = fmap go numeric | take 1 p == "-" = i (read <$> num) | otherwise = u (read <$> num) +-- E.g. { name = "Steve", age = 30 } +recordLiteral :: + forall v m. + (Var v, Ord v, Monad m) => + TermP v m +recordLiteral = do + (spanAnn, kvs) <- seq' "{" (,) keyValueP + checkForDuplicateRecordFields (fst <$> kvs) + pure $ Term.record spanAnn (Map.fromList (first L.payload <$> kvs)) + where + keyValueP :: P v m (L.Token Text, Term v Ann) + keyValueP = do + key <- recordFieldName + _ <- reserved ":" + value <- term + pure (key, value) + tupleOrParenthesizedTerm :: (Monad m, Var v) => TermP v m tupleOrParenthesizedTerm = label "tuple" $ do (spanAnn, tm) <- tupleOrParenthesized term DD.unitTerm pair diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index c7cab78b046..746621c0c6b 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -64,6 +64,7 @@ import Unison.Term import Unison.Type (Type, pattern ForallsNamed') import Unison.Type qualified as Type import Unison.Util.Bytes qualified as Bytes +import Unison.Util.List qualified as List import Unison.Util.Monoid (foldMapM, intercalateMap, intercalateMapM) import Unison.Util.Pretty (ColorText, Pretty, Width) import Unison.Util.Pretty qualified as PP @@ -351,6 +352,13 @@ pretty0 let open = listLink "[" `PP.orElse` listLink "[ " let close = listLink "]" `PP.orElse` ("\n" <> listLink "]") pure $ PP.group (open <> PP.sep comma pelems <> close) + Record' fields -> do + renderedFields <- for (Map.toList fields) \(fieldName, v) -> + do + pretty0 (ac Annotation Normal im doc) v + <&> (\v -> fmt (S.RecordFieldName fieldName) (PP.text fieldName) <> fmt S.RecordFieldValueColon ": " <> v) + <&> PP.indentNAfterNewline 2 + pure $ PP.group $ PP.surroundCommas "{" "}" renderedFields If' cond t f -> do pcond <- pretty0 (ac Control Block im doc) cond @@ -379,6 +387,16 @@ pretty0 LetBlock bs e -> let (im', uses) = calcImports im term in printLet a {imports = im'} bc bs e uses + -- A single-field record match is what `base@field` desugars to, so + -- print it back that way rather than as the underlying match. + (asRecordProjection -> Just (base, field)) -> do + -- `Top` so anything that parenthesizes at all gets parens; a + -- projection binds tighter than application and than `!`/`'`. + pbase <- goNormal Top base + pure $ + pbase + <> fmt S.DelimiterChar "@" + <> fmt (S.RecordFieldName field) (PP.text field) -- Some matches are rendered as a destructuring bind, like -- match foo with (a,b) -> blah -- becomes @@ -423,7 +441,7 @@ pretty0 ] else (fmt S.ControlKeyword "match " <> ps <> fmt S.ControlKeyword " with") `PP.hang` pbs Apps' f args -> paren (p >= Application) <$> (PP.hang <$> goNormal (InfixOp Highest) f <*> PP.spacedTraverse (goNormal Application) args) - t -> pure $ l "error: " <> l (show t) + t -> pure $ l "TermPrinter:pretty0: Unhandled term: " <> l (show t) where goNormal prec tm = pretty0 (ac prec Normal im doc) tm specialCases term go = do @@ -659,6 +677,7 @@ pretty0 isDelay (Delay' _) = True isDelay _ = False + varList = intercalateMap PP.softbreak prettyBinder nonForcePred :: Term3 v PrintAnnotation -> Bool @@ -768,6 +787,30 @@ prettyPattern n c@AmbientContext {imports = im} p vs patt = case patt of `PP.hang` pats_printed, tail_vs ) + Pattern.RecordLiteral _loc fields -> do + let (renderedFields, vs') = + fields + & Map.toList + & flip + foldl' + ([], vs) + ( \(acc, currentVS) (fieldName, p) -> + let (renderedPat, tailVS) = do + prettyPattern n c Bottom currentVS p + renderedField = + fmt (S.RecordFieldName fieldName) (PP.text fieldName) + <> fmt S.RecordFieldValueColon ": " + <> renderedPat + in (acc <> [renderedField], tailVS) + ) + in ( PP.group + ( PP.surroundCommas + (fmt S.DelimiterChar "{") + (fmt S.DelimiterChar "}") + (map (PP.indentNAfterNewline 2) renderedFields) + ), + vs' + ) Pattern.As _ pat -> case vs of (v : tail_vs) -> @@ -835,14 +878,14 @@ groupCases :: (Ord v) => [MatchCase' () (Term3 v ann)] -> [([Pattern ()], [v], [(Maybe (Term3 v ann), ([v], Term3 v ann))])] -groupCases = \cases - [] -> [] - ms@((p1, _, AbsN' vs1 _) : _) -> go (p1, vs1) [] ms - where - go (p0, vs0) acc [] = [(p0, vs0, reverse acc)] - go (p0, vs0) acc ms@((p1, g1, AbsN' vs body) : tl) - | p0 == p1 && vs == vs0 = go (p0, vs0) ((g1, (vs, body)) : acc) tl - | otherwise = (p0, vs0, reverse acc) : groupCases ms +groupCases ms = + ms + & List.groupMap + ( \case + (p, g, AbsN' vs body) -> ((p, vs), (g, body)) + ) + & foldMap \((p, vs), guardRows) -> + [(p, vs, second (vs,) <$> toList guardRows)] printCase :: forall m v. @@ -1416,6 +1459,8 @@ countPatternUsages n usedTm = Pattern.foldMap' f if noImportRefs (r ^. ConstructorReference.reference_) then mempty else countHQ usedTm $ PrettyPrintEnv.patternName n r + Pattern.RecordLiteral _loc fields -> + foldMap (countPatternUsages n usedTm) fields countHQ :: (HasCallStack) => Set Name -> HQ.HashQualified Name -> PrintAnnotation countHQ used (HQ.NameOnly n) @@ -1687,6 +1732,20 @@ isLet _ = False -- Has shadowing, is rendered as a regular `match`. -- match blah with 42 -> body -- Pattern has (is) a literal, rendered as a regular match (rather than `42 = blah; body`) + +-- | Recognize the term that `base@field` desugars to: a match with one +-- irrefutable single-field record pattern whose body is just the bound +-- variable. Printing it back as a projection keeps `view` showing the syntax +-- that was written. +asRecordProjection :: + (Var v) => Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation, Text) +asRecordProjection = \case + Match' scrutinee [MatchCase (Pattern.RecordLiteral _ fields) Nothing (AbsN' [v] (Var' v'))] + | v == v', + [(field, Pattern.Var _)] <- Map.toList fields -> + Just (scrutinee, field) + _ -> Nothing + isDestructuringBind :: (Ord v) => ABT.Term f v a -> [MatchCase loc (ABT.Term f v a)] -> Bool isDestructuringBind scrutinee [MatchCase pat _ (ABT.AbsN' vs _)] = all (`Set.notMember` ABT.freeVars scrutinee) vs && not (hasLiteral pat) @@ -1700,6 +1759,8 @@ isDestructuringBind scrutinee [MatchCase pat _ (ABT.AbsN' vs _)] = Pattern.Char _ _ -> True Pattern.Bytes _ _ -> True Pattern.Constructor _ _ ps -> any hasLiteral ps + Pattern.RecordLiteral _loc fields -> + any hasLiteral fields Pattern.As _ p -> hasLiteral p Pattern.EffectPure _ p -> hasLiteral p Pattern.EffectBind _ _ ps pk -> any hasLiteral (pk : ps) diff --git a/parser-typechecker/src/Unison/Syntax/TypeParser.hs b/parser-typechecker/src/Unison/Syntax/TypeParser.hs index e270ef25eb0..ef216af3de0 100644 --- a/parser-typechecker/src/Unison/Syntax/TypeParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TypeParser.hs @@ -8,6 +8,7 @@ module Unison.Syntax.TypeParser where import Control.Monad.Reader (asks) +import Data.Map qualified as Map import Data.Set qualified as Set import Text.Megaparsec qualified as P import Unison.ABT qualified as ABT @@ -36,11 +37,11 @@ valueType = forAll type1 <|> type1 -- Computation -- computationType ::= [{effect*}] valueType computationType :: (Monad m, Var v) => TypeP v m -computationType = effect <|> valueType +computationType = P.try effect <|> valueType valueTypeLeaf :: (Monad m, Var v) => TypeP v m valueTypeLeaf = - tupleOrParenthesizedType valueType <|> typeAtom <|> sequenceTyp + tupleOrParenthesizedType valueType <|> typeAtom <|> sequenceTyp <|> recordType -- Examples: Optional, Optional#abc, woot, #abc typeAtom :: (Monad m, Var v) => TypeP v m @@ -63,7 +64,7 @@ type2a = delayed <|> type2 delayed :: (Monad m, Var v) => TypeP v m delayed = do q <- reserved "'" - t <- effect <|> (pt <$> type2a) + t <- P.try effect <|> (pt <$> type2a) pure $ Type.arrow (Ann (L.start q) (end $ ann t)) @@ -76,7 +77,7 @@ delayed = do type2 :: (Monad m, Var v) => TypeP v m type2 = do hd <- valueTypeLeaf - tl <- many (effectList <|> valueTypeLeaf) + tl <- many (P.try effectList <|> valueTypeLeaf) pure $ foldl' (\a b -> Type.app (ann a <> ann b) a b) hd tl -- ex : {State Text, IO} (List Int) @@ -110,13 +111,32 @@ tupleOrParenthesizedType rec = do let a = ann t1 <> ann t2 in Type.app a (Type.app (ann t1) (DD.pairType a) t1) t2 +recordType :: (Monad m, Var v) => TypeP v m +recordType = do + open <- openBlockWith "{" + fields <- sepBy (reserved ",") recordField + fb <- + optional (reserved "|" *> reserved "...") >>= \case + Just _ -> pure Type.AllowExtraFields + Nothing -> pure Type.RequireExactFields + close <- closeBlock + checkForDuplicateRecordFields (fst <$> fields) + let a = ann open <> ann close + pure $ Type.record a fb (Map.fromList (first L.payload <$> fields)) + where + recordField = do + nameTok <- recordFieldName + _ <- reserved ":" + t <- valueType + pure (nameTok, t) + -- valueType ::= ... | Arrow valueType computationType arrow :: (Monad m, Var v) => TypeP v m -> TypeP v m arrow rec = - let eff = mkArr <$> optional effectList + let eff = mkArr <$> optional (P.try effectList) mkArr Nothing a b = Type.arrow (ann a <> ann b) a b mkArr (Just es) a b = Type.arrow (ann a <> ann b) a (Type.effect1 (ann es <> ann b) es b) - in chainr1 (effect <|> rec) (reserved "->" *> eff) + in chainr1 (P.try effect <|> rec) (reserved "->" *> eff) -- "forall a b . List a -> List b -> Maybe Text" forAll :: (Var v) => TypeP v m -> TypeP v m diff --git a/parser-typechecker/src/Unison/Syntax/TypePrinter.hs b/parser-typechecker/src/Unison/Syntax/TypePrinter.hs index 0100a46a087..957a2c4b3ce 100644 --- a/parser-typechecker/src/Unison/Syntax/TypePrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TypePrinter.hs @@ -139,6 +139,19 @@ prettyRaw im p tp = go im p tp in parenthesizeArrows <$> ((<>) <$> go im 0 fst <*> arrows False False rest) _ -> pure . fromString $ "bug: unexpected Arrow form in prettyRaw: " <> show t + Record' fb fields -> do + renderedValues <- traverse (go im (-1)) fields + let renderedFields = + Map.toList renderedValues + <&> (\(k, v) -> fmt (S.RecordFieldName k) (PP.text k) <> fmt S.RecordFieldValueColon ": " <> v) + let renderedFB = case fb of + AllowExtraFields -> fmt S.RecordExtraFields " | ..." + RequireExactFields -> mempty + pure $ + PP.surroundCommas + (fmt S.DelimiterChar "{") + (renderedFB <> fmt S.DelimiterChar "}") + renderedFields _ -> pure . fromString $ "bug: unexpected form in prettyRaw: " <> show tp -- Sort effects in effect lists by how they're printed rather than hash, -- this helps with both readability and diff alignment. diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 70896971c83..e0ad8cf8bc6 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -4,6 +4,11 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} +-- Typechecker is derived from the paper: "Complete and Easy Bidirectional Typechecking for Higher-Rank Polymorphism" by +-- Jana Dunfield and Neelakantan Krishnaswami +-- +-- https://arxiv.org/abs/1306.6032 + module Unison.Typechecker.Context ( synthesizeClosed, ErrorNote (..), @@ -65,12 +70,14 @@ import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as Nel import Data.Map qualified as Map import Data.Monoid (Ap (..)) +import Data.Semialign qualified as Align import Data.Sequence qualified as Seq import Data.Sequence.NonEmpty (NESeq) import Data.Sequence.NonEmpty qualified as NESeq import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Text qualified as Text +import Data.These (These (..)) import Unison.ABT qualified as ABT import Unison.Blank qualified as B import Unison.Builtin.Decls qualified as DDB @@ -347,6 +354,8 @@ data PathElement v loc | InMatchGuard | InMatchBody | InActionRestriction + | InRecordLiteral loc -- location of record + | InRecordField (loc {- location of field being checked -}) (Text {- name of field -}) deriving (Show) type ExpectedArgCount = Int @@ -497,6 +506,23 @@ data Cause v loc | -- A `run>` watch whose type isn't a valid `'{IO, Exception} a`. Carries the -- watch's location and its (offending) inferred type. RunWatchTypeMismatch loc (Type.Type v loc) + | MissingRecordField + (Text {- the missing field name -}) + (Type v loc {- the type we expected the field to have -}) + (Type v loc {- the record which is missing the field -}) + (Type v loc {- the record which requires the field -}) + | UnexpectedRecordField + (Text {- the extra/unexpected field name -}) + (Type v loc {- the type we inferred for the field -}) + (Type v loc {- the record which does not want the field -}) + (Type v loc {- the record which has the extra field -}) + | PatternMatchedMissingField + (Text {- the field name we tried to match, but wasn't in the type -}) + (Pattern loc {- the place we matched on the missing field -}) + (Type v loc {- The type of the record which is missing the field -}) + | RecordPatternMatchOnNonRecordType + (Pattern loc {- the place we matched on the non-record -}) + (Type v loc {- The type which is not a record -}) deriving (Show) errorTerms :: ErrorNote v loc -> [Term v loc] @@ -766,6 +792,8 @@ wellformedType c t = case t of Type.Forall' t' -> let (v, ctx2) = extendUniversal c in wellformedType ctx2 (ABT.bind t' (universal' (ABT.annotation t) v)) + Type.Record' _fb fields -> + all (wellformedType c) fields _ -> error $ "Match failure in wellformedType: " ++ show t where -- Extend this `Context` with a single variable, guaranteed fresh @@ -948,6 +976,7 @@ getDataConstructors typ (ListPat.Nil, []) ] in pure (SequenceType xs) + | Type.Record' _fb fields <- typ = pure (RecordType fields) | Just r <- theRef typ = ConstructorType . crFromDecl r <$> getDataDeclaration r | otherwise = pure OtherType where @@ -1087,8 +1116,6 @@ synthesizeApp fun (Type.stripIntroOuters -> Type.Effect'' es ft) argp@(arg, argN replaceContext (existential a) ctxMid synthesizeApp fun (Type.getPolytype soln) argp go _ = getContext >>= \ctx -> failWith $ TypeMismatch ctx -synthesizeApp _ _ _ = - error "unpossible - Type.Effect'' pattern always succeeds" -- For arity 3, creates the type `∀ a . a -> a -> a -> Sequence a` -- For arity 2, creates the type `∀ a . a -> a -> Sequence a` @@ -1359,6 +1386,21 @@ synthesizeWanted e v <- freshenVar freshType appendContext [Var (TypeVar.Existential blank v)] pure (existential' l blank v, []) + | Term.Record' fields <- e = scope (InRecordLiteral (ABT.annotation e)) $ do + -- Record literals have an exact field set. + let fb = Type.RequireExactFields + (fieldTypes, wantedSets) <- + fields + & Map.traverseWithKey + ( \fieldName v -> do + scope (InRecordField (ABT.annotation v) fieldName) $ do + (t, w) <- synthesize v + pure (t, [w]) + ) + <&> Align.unzip + -- Unify ability wants for the whole record + wanteds <- foldM coalesceWanted [] (fold wantedSets) + pure (Type.record l fb fieldTypes, wanteds) | Term.List' v <- e = do ft <- vectorConstructorOfArity l (Foldable.length v) case Foldable.toList v of @@ -1644,6 +1686,9 @@ instance (Ord loc, Var v) => Pmc (TypeVar v loc) v loc (StateT (PmcState (TypeVa BooleanType -> pure [] OtherType -> pure [] SequenceType {} -> pure [] + -- Records have no `ConstructorReference`, so this is never reached for + -- them; `withConstructors` gets the field types from `RecordType`. + RecordType {} -> pure [] where extractArgs (Type.Arrows' xs) = init xs extractArgs _ = [] @@ -1747,7 +1792,6 @@ getEffect ref = do Type.Effect'' [et] _ -> pure et t@(Type.Effect'' _ _) -> compilerCrash $ EffectConstructorHadMultipleEffects t - _ -> compilerCrash PatternMatchFailure requestType :: (Var v) => (Ord loc) => [Pattern loc] -> M v loc (Maybe [Type v loc]) @@ -1804,6 +1848,20 @@ checkCase scrutineeType outputType (Term.MatchCase pat guard rhs) = do -- The output (assuming no type errors) is [(x,x'), (y,y'), (z,z')] -- where x', y', z' are freshened versions of x, y, z. These will be substituted -- into `blah x y z` to produce `blah x' y' z'` before typechecking it. + +-- | Whether a type could still turn out to be a record: either it already is +-- one, or it isn't yet determined. Used to decide whether a record pattern is +-- definitely being matched against something that isn't a record, which +-- deserves a better error than a generic type mismatch. +couldBeRecord :: (Var v) => Type v loc -> Bool +couldBeRecord = \case + Type.Record' {} -> True + Type.Var' _ -> True + Type.Forall' _ -> True + Type.Ann' t _ -> couldBeRecord t + Type.Effect1' _ t -> couldBeRecord t + _ -> False + checkPattern :: (Var v, Ord loc) => Type v loc -> @@ -1812,6 +1870,42 @@ checkPattern :: checkPattern tx ty | (debugEnabled || debugPatternsEnabled) && traceShow ("checkPattern" :: String, tx, ty) False = undefined checkPattern scrutineeType p = case p of + Pattern.RecordLiteral recordLoc fieldPatterns -> do + -- The scrutinee may already be solved to a concrete type by an + -- enclosing pattern or an annotation, so look through solutions before + -- inspecting it. + scrutineeType <- lift $ Type.stripIntroOuters <$> applyM scrutineeType + -- If we already know what we're matching, we can produce a much better + -- error than the `subtype` check below would. + case scrutineeType of + Type.Record' _fb typeFields -> + -- Matching a field the record doesn't have. + for_ (Map.toList (Map.difference fieldPatterns typeFields)) \(fieldName, fieldPat) -> + lift . failWith $ PatternMatchedMissingField fieldName fieldPat scrutineeType + _ + | couldBeRecord scrutineeType -> pure () + | otherwise -> lift . failWith $ RecordPatternMatchOnNonRecordType p scrutineeType + -- Create unification variables for each field in the pattern + inferredFieldTypes <- lift $ for fieldPatterns \pat -> do + fieldTypeV <- freshenVar Var.inferOther + let vt = existentialp (Pattern.loc pat) fieldTypeV + appendContext [existential fieldTypeV] + pure vt + -- Record patterns allow extra unmatched fields + let fb = Type.AllowExtraFields + -- Build the type of the pattern, filled with those unification variables + let patternRecordType = Type.record recordLoc fb inferredFieldTypes + lift $ subtype scrutineeType patternRecordType + -- Solving the subtype constraint above may have solved some of the field + -- variables; the recursive calls need the solutions, since `subtype` + -- doesn't apply the context to its arguments itself. + inferredFieldTypes <- lift $ traverse applyM inferredFieldTypes + -- Check each field pattern against the variable for that field. The two + -- maps have the same key set by construction, so this is a zip. + vs <- + Map.intersectionWith (,) inferredFieldTypes fieldPatterns + & traverse (\(fieldTyp, fieldPat) -> checkPattern fieldTyp fieldPat) + pure $ fold vs Pattern.Unbound _ -> pure [] Pattern.Var loc -> do v <- getAdvance p @@ -2513,6 +2607,7 @@ ungeneralize' t = pure ([], t) -- de-generalized, and replaces simple freshening of the -- polymorphic variable. tweakEffects :: + forall v loc. (Var v) => (Ord loc) => TypeVar v loc -> @@ -2536,6 +2631,10 @@ tweakEffects v0 t0 appendContext (existential <$> vs) pure (vs, ABT.substInheritAnnotation v0 (typ vs) ty) + rewrite :: + Maybe Bool -> + ABT.Term Type.F (TypeVar v loc) a -> + MT v loc (Result v loc) ([v], Type.Type (TypeVar v loc) a) rewrite p ty | Type.ForallNamed' v t <- ty, v0 /= v = @@ -2560,6 +2659,9 @@ tweakEffects v0 t0 (vfs, f) <- rewrite p f (vxs, x) <- rewrite Nothing x pure (vfs ++ vxs, Type.app (loc ty) f x) + | Type.Record' fb fields <- ty = do + (vs, fields') <- getCompose $ for fields (Compose . rewrite p) + pure (vs, Type.record (loc ty) fb fields') | otherwise = pure ([], ty) where a = loc ty @@ -2588,6 +2690,7 @@ isVariant u = walk True walk var i && walk var o && all (walk var) es walk var (Type.App' f x) = walk var f && walk False x walk var (Type.Var' v) = u /= v || var + walk var (Type.Record' _fb fields) = all (walk var) fields walk _ _ = True skolemize :: @@ -2887,6 +2990,10 @@ discardCovariant vars gens ty = | Just vs <- checkVarianceWith vars f, length vs == length xs = keepVarsT pos f <> foldMap (keepVarsV pos) (zip vs xs) + -- Records place no field in a negative position, so every field is + -- treated the same way as the covariant part of an application. + keepVarsT pos (Type.Record' _fb fields) = + foldMap (keepVarsT pos) fields keepVarsT _ t = foldMap exi $ Type.freeVars t exi (TypeVar.Existential _ v) = Set.singleton v @@ -2995,6 +3102,9 @@ relax' vars nonArrow fv = rebuild True Just (Pos : _) -> rebuild False x _ -> pure x pure $ Type.app loc f x + | Type.Record' fb fields <- t = do + fields <- traverse (rebuild False) fields + pure $ Type.record loc fb fields | top, nonArrow = ftv loc <&> \tv -> Type.effect loc [tv] t | otherwise = pure t where @@ -3021,7 +3131,7 @@ checkWantedScoped exact want m ty = -- updated set. -- -- The Maybe argument determines whether an exact ability match is --- required for function maches. This is to check for suspicious +-- required for function matches. This is to check for suspicious -- ability handler situations like: -- -- foo : '{X, Y} r -> r @@ -3134,6 +3244,9 @@ checkWanted exact want (Term.List' es) lty Foldable.foldlM f want es where bexact = isJust exact +-- Note: no case is needed for `Term.Record'`. The fallthrough synthesizes, +-- and `synthesizeWanted`'s record case already coalesces every field's wanted +-- abilities. checkWanted _ want e t = do (u, wnew) <- synthesize e ctx <- getContext @@ -3199,7 +3312,8 @@ check m0 t0 = scope (InCheck m0 t0) $ do checkWanted Nothing [] m (Type.stripIntroOuters t0) -- | `subtype ctx t1 t2` returns successfully if `t1` is a subtype of `t2`. --- This may have the effect of altering the context. +-- This may have the effect of altering the context, since unsolved existentials +-- will be instantiated as needed. subtype :: forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> M v loc () subtype tx ty | debugTypes "subtype" tx ty = undefined subtype tx ty = scope (InSubtype tx ty) $ do @@ -3265,6 +3379,21 @@ subtype tx ty = scope (InSubtype tx ty) $ do vars <- getVariances t <- relax' vars False (extendExistential Var.inferAbility) t instantiateR t b v + go _ r1@(Type.Record' _fb1 fields1) r2@(Type.Record' fb2 fields2) = do + Align.align fields1 fields2 + & Map.traverseWithKey + ( \fieldName -> \case + -- r1 has a field r2 doesn't: an extra field, which is only an + -- error if r2 won't tolerate extras. + This t1 -> case fb2 of + Type.RequireExactFields -> failWith $ UnexpectedRecordField fieldName t1 r2 r1 + Type.AllowExtraFields -> pure () + -- r1 is missing a field r2 requires, so it can't be a subtype + -- regardless of the field behavior. + That t2 -> failWith $ MissingRecordField fieldName t2 r1 r2 + These t1 t2 -> subtype t1 t2 + ) + & void go _ (Type.Effects' es1) (Type.Effects' es2) = void $ subAbilities ((,) Nothing <$> es1) es2 go _ t t2@(Type.Effects' _) | expand t = subtype (Type.effects (loc t) [t]) t2 @@ -3347,6 +3476,23 @@ equate0 t (Type.Var' (TypeVar.Existential b v)) instantiateL b v t equate0 (Type.Effects' es1) (Type.Effects' es2) = equateAbilities es1 es2 +equate0 r1@(Type.Record' fb1 fields1) r2@(Type.Record' fb2 fields2) = + do + -- Equality is invariant, so unlike `subtype` an open record is not + -- interchangeable with a closed one even when the fields line up. + when (fb1 /= fb2) do + ctx <- getContext + failWith $ TypeMismatch ctx + Align.align fields1 fields2 + & Map.traverseWithKey + ( \fieldName -> \case + -- r1 has a field r2 doesn't, so r1 carries the extra one. + This fieldType -> failWith $ UnexpectedRecordField fieldName fieldType r2 r1 + -- r1 lacks a field r2 has. + That fieldType -> failWith $ MissingRecordField fieldName fieldType r1 r2 + These t1 t2 -> equate t1 t2 + ) + & void equate0 y1 y2 = do subtype y1 y2 y1 <- applyM y1 @@ -3412,6 +3558,30 @@ instantiateL blank v (Type.stripIntroOuters -> t) = [existential y', existential x', s] applyM x >>= instantiateL B.Blank x' applyM y >>= instantiateL B.Blank y' + Type.Record' fb fields -> do + -- For now, treat record instantiation similarly to a Constructor Application, + -- we require that record types match exactly, no record field subsets are allowed yet. + -- First generate a new var and existential for each field's type + (fieldVars, fieldExistentials) <- + for + fields + ( \tp -> do + v' <- freshenVar (nameFrom Var.inferRecordFieldType tp) + pure $ (v', existentialp (loc tp) v') + ) + <&> Align.unzip + let recordLoc = ABT.annotation t + -- We can assert that the result type is equal to the record filled with the existentials + let solved = Solved blank v (Type.Monotype (Type.record recordLoc fb fieldExistentials)) + -- Now, update the context, replacing the existential of the current var to + -- include the new field existentials and the solved type, which depends on them. + replaceContext + (existential v) + ((existential <$> Map.elems fieldVars) <> [solved]) + -- Finally, instantiate each field type to the corresponding existential + -- Any missing fields are simply not instantiated + for_ (Align.zip fields fieldVars) \(fieldTyp, fieldVar) -> + applyM fieldTyp >>= instantiateL B.Blank fieldVar Type.Effect1' es vt -> do es' <- freshenVar Var.inferAbility vt' <- freshenVar Var.inferOther @@ -3525,6 +3695,34 @@ instantiateR (Type.stripIntroOuters -> t) blank v = replaceContext (existential v) [existential y', existential x', s] applyM x >>= \x -> instantiateR x B.Blank x' applyM y >>= \y -> instantiateR y B.Blank y' + Type.Record' fb fields -> do + -- For now, treat record instantiation similarly to a Constructor Application + -- + -- { name : n } <: v' will + -- 1. create result', n', add these to the context + -- 2. add result' = { name : n' } to the context + -- 3. recurse to refine the type of n' + (fieldVars, fieldExistentials) <- + for + fields + ( \tp -> do + v' <- freshenVar (nameFrom Var.inferRecordFieldType tp) + pure $ (v', existentialp (loc tp) v') + ) + <&> Align.unzip + let recordLoc = ABT.annotation t + -- We can assert that the result type is equal to the record filled with the existentials + let solved = Solved blank v (Type.Monotype (Type.record recordLoc fb fieldExistentials)) + -- Now, update the context, replacing the existential of the current var to + -- include the new field existentials and the solved type, which depends on them. + replaceContext + (existential v) + ((existential <$> Map.elems fieldVars) <> [solved]) + -- Finally, instantiate each field type to the corresponding existential. + -- Note this is the R direction, matching the surrounding function; the + -- two agree for monotype fields but not for arrow- or forall-typed ones. + for_ (Align.zip fields fieldVars) \(fieldTyp, fieldVar) -> + applyM fieldTyp >>= \fieldTyp -> instantiateR fieldTyp B.Blank fieldVar Type.Effect1' es vt -> do es' <- freshenVar (nameFrom Var.inferAbility es) vt' <- freshenVar (nameFrom Var.inferTypeConstructorArg vt) diff --git a/parser-typechecker/src/Unison/Typechecker/Context/Structure.hs b/parser-typechecker/src/Unison/Typechecker/Context/Structure.hs index e8626015009..8054eda0b78 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context/Structure.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context/Structure.hs @@ -380,6 +380,7 @@ apply' solved refined t = go t Type.Effects' es -> Type.effects a (fmap go es) Type.ForallNamed' v t' -> Type.forAll a v (go t') Type.IntroOuterNamed' v t' -> Type.introOuter a v (go t') + Type.Record' fb fields -> Type.record a fb (go <$> fields) _ -> error $ "Match error in Context.apply': " ++ show t where a = ABT.annotation t diff --git a/parser-typechecker/src/Unison/Typechecker/Extractor.hs b/parser-typechecker/src/Unison/Typechecker/Extractor.hs index 3522ea12710..e509bd0ef2b 100644 --- a/parser-typechecker/src/Unison/Typechecker/Extractor.hs +++ b/parser-typechecker/src/Unison/Typechecker/Extractor.hs @@ -9,6 +9,7 @@ import Unison.Blank qualified as B import Unison.ConstructorReference (ConstructorReference) import Unison.KindInference (KindError) import Unison.Pattern (Pattern) +import Unison.Pattern qualified as Pattern import Unison.Prelude hiding (whenM) import Unison.Term qualified as Term import Unison.Type (Type) @@ -206,6 +207,18 @@ inFunctionCall = asPathExtractor $ \case f -> Just (vs, f, ft, e) _ -> Nothing +inRecordLiteral :: + SubseqExtractor v loc loc +inRecordLiteral = asPathExtractor $ \case + C.InRecordLiteral loc -> Just loc + _ -> Nothing + +inRecordField :: + SubseqExtractor v loc (loc, Text) +inRecordField = asPathExtractor $ \case + C.InRecordField loc t -> Just (loc, t) + _ -> Nothing + inAndApp, inOrApp, inIfCond, @@ -279,6 +292,34 @@ typeMismatch = C.TypeMismatch c -> pure c _ -> mzero +missingRecordField :: ErrorExtractor v loc (Text, C.Type v loc, C.Type v loc, C.Type v loc) +missingRecordField = + cause >>= \case + C.MissingRecordField fieldName expectedFieldType actualRecordType expectedRecordType -> + pure (fieldName, expectedFieldType, actualRecordType, expectedRecordType) + _ -> mzero + +unexpectedRecordField :: ErrorExtractor v loc (Text, C.Type v loc, C.Type v loc, C.Type v loc) +unexpectedRecordField = + cause >>= \case + C.UnexpectedRecordField fieldName actualFieldType recordWithoutField recordWithField -> + pure (fieldName, actualFieldType, recordWithoutField, recordWithField) + _ -> mzero + +patternMatchedMissingField :: ErrorExtractor v loc (Text, loc, C.Type v loc) +patternMatchedMissingField = + cause >>= \case + C.PatternMatchedMissingField fieldName fieldPat recordType -> + pure (fieldName, Pattern.loc fieldPat, recordType) + _ -> mzero + +recordPatternMatchOnNonRecordType :: ErrorExtractor v loc (loc, C.Type v loc) +recordPatternMatchOnNonRecordType = + cause >>= \case + C.RecordPatternMatchOnNonRecordType recordPat nonRecordType -> + pure (Pattern.loc recordPat, nonRecordType) + _ -> mzero + illFormedType :: ErrorExtractor v loc (C.Context v loc) illFormedType = cause >>= \case diff --git a/parser-typechecker/src/Unison/Typechecker/TypeError.hs b/parser-typechecker/src/Unison/Typechecker/TypeError.hs index 0603496f983..75d1c013b3e 100644 --- a/parser-typechecker/src/Unison/Typechecker/TypeError.hs +++ b/parser-typechecker/src/Unison/Typechecker/TypeError.hs @@ -146,6 +146,27 @@ data TypeError v loc | RedundantPattern loc | KindInferenceFailure (KindError v loc) | RunWatchTypeMismatch (Type v loc) loc (C.ErrorNote v loc) + | MissingRecordField + { missingFieldName :: Text, + fieldType :: C.Type v loc, + recordWithField :: C.Type v loc, + recordWithoutField :: C.Type v loc + } + | UnexpectedRecordField + { unexpectedFieldName :: Text, + fieldType :: C.Type v loc, + recordWithoutField :: C.Type v loc, + recordWithField :: C.Type v loc + } + | PatternMatchedMissingField + { matchedFieldName :: Text, + recordPatternLoc :: loc, + scrutineeRecordType :: C.Type v loc + } + | RecordPatternMatchOnNonRecordType + { recordPatternLoc :: loc, + scrutineeNonRecordType :: C.Type v loc + } | Other (C.ErrorNote v loc) deriving (Show) @@ -181,6 +202,10 @@ allErrors = ifBody, listBody, matchBody, + missingRecordField, + unexpectedReccordField, + patternMatchedMissingField, + recordPatternMatchOnNonRecordType, applyingFunction, applyingNonFunction, generalMismatch, @@ -422,6 +447,55 @@ existentialMismatch0 em getExpectedLoc = do -- todo : save type leaves too n +missingRecordField :: + (Var v, Ord loc) => + Ex.ErrorExtractor v loc (TypeError v loc) +missingRecordField = do + (missingFieldName, fieldType, recordWithoutField, recordWithField) <- Ex.missingRecordField + pure $ + MissingRecordField + { missingFieldName, + fieldType, + recordWithoutField, + recordWithField + } + +unexpectedReccordField :: + (Var v, Ord loc) => + Ex.ErrorExtractor v loc (TypeError v loc) +unexpectedReccordField = do + (unexpectedFieldName, fieldType, recordWithoutField, recordWithField) <- Ex.unexpectedRecordField + pure $ + UnexpectedRecordField + { unexpectedFieldName, + fieldType, + recordWithoutField, + recordWithField + } + +patternMatchedMissingField :: + (Var v, Ord loc) => + Ex.ErrorExtractor v loc (TypeError v loc) +patternMatchedMissingField = do + (matchedFieldName, recordPatternLoc, scrutineeRecordType) <- Ex.patternMatchedMissingField + pure $ + PatternMatchedMissingField + { matchedFieldName, + recordPatternLoc, + scrutineeRecordType + } + +recordPatternMatchOnNonRecordType :: + (Var v, Ord loc) => + Ex.ErrorExtractor v loc (TypeError v loc) +recordPatternMatchOnNonRecordType = do + (recordPatternLoc, scrutineeNonRecordType) <- Ex.recordPatternMatchOnNonRecordType + pure $ + RecordPatternMatchOnNonRecordType + { recordPatternLoc, + scrutineeNonRecordType + } + actionRestriction :: (Var v, Ord loc) => Ex.ErrorExtractor v loc (TypeError v loc) diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 1f3480101ff..cf120d3f581 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -331,6 +331,36 @@ analyseNotes codebase fileUri ppe src notes = do TypeError.UncoveredPatterns loc _pats -> singleRange loc TypeError.KindInferenceFailure ke -> singleRange (KindInference.lspLoc ke) TypeError.RunWatchTypeMismatch _ watchSite _ -> singleRange watchSite + TypeError.MissingRecordField {fieldType, recordWithoutField, recordWithField} -> + do + r1 <- aToR (ABT.annotation recordWithoutField) + r2 <- aToR (ABT.annotation fieldType) + r3 <- aToR (ABT.annotation recordWithField) + pure + ( r1, + [ ("expected field type", r2), + ("expected record type", r3) + ] + ) + TypeError.UnexpectedRecordField {recordWithoutField, recordWithField} -> + do + r1 <- aToR (ABT.annotation recordWithField) + r2 <- aToR (ABT.annotation recordWithoutField) + pure + ( r1, + [ ("expected record type", r2) + ] + ) + TypeError.PatternMatchedMissingField {recordPatternLoc, scrutineeRecordType} -> + do + r1 <- aToR recordPatternLoc + r2 <- aToR (ABT.annotation scrutineeRecordType) + pure (r1, [("record type", r2)]) + TypeError.RecordPatternMatchOnNonRecordType {recordPatternLoc, scrutineeNonRecordType} -> + do + r1 <- aToR recordPatternLoc + r2 <- aToR (ABT.annotation scrutineeNonRecordType) + pure (r1, [("not a record type", r2)]) -- These type errors don't have custom type error conversions, but some -- still have valid diagnostics. TypeError.Other e@(Context.ErrorNote {cause}) -> case cause of @@ -353,6 +383,29 @@ analyseNotes codebase fileUri ppe src notes = do Context.InaccessiblePattern loc -> singleRange loc Context.KindInferenceFailure {} -> shouldHaveBeenHandled e Context.RunWatchTypeMismatch loc _typ -> singleRange loc + Context.MissingRecordField _fieldName fieldType recordWithoutField recordWithField -> do + r1 <- aToR (ABT.annotation recordWithoutField) + r2 <- aToR (ABT.annotation fieldType) + r3 <- aToR (ABT.annotation recordWithField) + pure + ( r1, + [ ("expected field type", r2), + ("expected record type", r3) + ] + ) + Context.UnexpectedRecordField _fieldName fieldType actualRecordType expectedRecordType -> do + r1 <- aToR (ABT.annotation actualRecordType) + r2 <- aToR (ABT.annotation fieldType) + r3 <- aToR (ABT.annotation expectedRecordType) + pure + ( r1, + [ ("expected field type", r2), + ("expected record type", r3) + ] + ) + Context.PatternMatchedMissingField {} -> shouldHaveBeenHandled e + Context.RecordPatternMatchOnNonRecordType {} -> shouldHaveBeenHandled e + shouldHaveBeenHandled e = do Debug.debugM Debug.LSP "This diagnostic should have been handled by a previous case but was not" e empty @@ -651,3 +704,4 @@ expressionLeafNodes abt = Term.Match _a cases -> cases & foldMap \(Term.MatchCase {matchBody}) -> expressionLeafNodes matchBody Term.TermLink {} -> [abt] Term.TypeLink {} -> [abt] + Term.Record fields -> fields & foldMap expressionLeafNodes diff --git a/unison-cli/src/Unison/LSP/Hover.hs b/unison-cli/src/Unison/LSP/Hover.hs index 65bce7c4578..f91caee9028 100644 --- a/unison-cli/src/Unison/LSP/Hover.hs +++ b/unison-cli/src/Unison/LSP/Hover.hs @@ -170,6 +170,7 @@ builtinTypeForTermLiterals term = Term.Match {} -> Nothing Term.TermLink {} -> Nothing Term.TypeLink {} -> Nothing + Term.Record {} -> Nothing ABT.Var {} -> Nothing ABT.Cycle {} -> Nothing ABT.Abs {} -> Nothing @@ -191,3 +192,4 @@ builtinTypeForPatternLiterals = \case Pattern.EffectBind _ _ _ _ -> Nothing Pattern.SequenceLiteral _ _ -> Nothing Pattern.SequenceOp _ _ _ _ -> Nothing + Pattern.RecordLiteral {} -> Nothing diff --git a/unison-cli/src/Unison/LSP/Queries.hs b/unison-cli/src/Unison/LSP/Queries.hs index 71d3b040e63..3071a1399fa 100644 --- a/unison-cli/src/Unison/LSP/Queries.hs +++ b/unison-cli/src/Unison/LSP/Queries.hs @@ -150,6 +150,7 @@ refInTerm term = Term.Match _a _cases -> Nothing Term.TermLink ref -> Just (LD.TermReferent ref) Term.TypeLink ref -> Just (LD.TypeReference ref) + Term.Record {} -> Nothing ABT.Var _v -> Nothing ABT.Cycle _r -> Nothing ABT.Abs _v _r -> Nothing @@ -166,6 +167,7 @@ refInType typ = case ABT.out typ of Type.Ann _a _kind -> Nothing Type.Effects _es -> Nothing Type.IntroOuter _a -> Nothing + Type.Record _fb _fields -> Nothing ABT.Var _v -> Nothing ABT.Cycle _r -> Nothing ABT.Abs _v _r -> Nothing @@ -188,6 +190,7 @@ refInPattern = \case Pattern.EffectBind _loc conRef _ _ -> Just (LD.ConReference conRef CT.Effect) Pattern.SequenceLiteral {} -> Nothing Pattern.SequenceOp {} -> Nothing + Pattern.RecordLiteral {} -> Nothing data SourceNode a = TermNode (Term Symbol a) @@ -262,6 +265,8 @@ findSmallestEnclosingNodeMatching pos pred term <|> altSum (cases <&> \(MatchCase pat grd body) -> ((findSmallestEnclosingPatternMatching pos patPred pat) <|> (altMaybe grd >>= findSmallestEnclosingNodeMatching pos pred) <|> findSmallestEnclosingNodeMatching pos pred body)) Term.TermLink {} -> guardInFile *> termPred term Term.TypeLink {} -> guardInFile *> termPred term + Term.Record fields -> + altSum (findSmallestEnclosingNodeMatching pos pred <$> fields) ABT.Var _v -> guardInFile *> termPred term ABT.Cycle r -> findSmallestEnclosingNodeMatching pos pred r ABT.Abs _v r -> findSmallestEnclosingNodeMatching pos pred r @@ -325,6 +330,7 @@ findSmallestEnclosingPatternMatching pos pred pat Pattern.EffectBind _loc _conRef pats p -> altSum (findSmallestEnclosingPatternMatching pos pred <$> pats) <|> findSmallestEnclosingPatternMatching pos pred p Pattern.SequenceLiteral _loc pats -> altSum (findSmallestEnclosingPatternMatching pos pred <$> pats) Pattern.SequenceOp _loc p1 _op p2 -> findSmallestEnclosingPatternMatching pos pred p1 <|> findSmallestEnclosingPatternMatching pos pred p2 + Pattern.RecordLiteral _loc fields -> altSum (findSmallestEnclosingPatternMatching pos pred <$> fields) let fallback = if annIsFilePosition (ann pat) then pred pat else empty bestChild <|> fallback where @@ -375,6 +381,7 @@ findSmallestEnclosingTypeMatching pos pred typ Type.Ann a _kind -> findSmallestEnclosingTypeMatching pos pred a Type.Effects es -> altSum (findSmallestEnclosingTypeMatching pos pred <$> es) Type.IntroOuter a -> findSmallestEnclosingTypeMatching pos pred a + Type.Record _fb fields -> altSum (findSmallestEnclosingTypeMatching pos pred <$> fields) ABT.Var _v -> guardInFile *> pred typ ABT.Cycle r -> findSmallestEnclosingTypeMatching pos pred r ABT.Abs _v r -> findSmallestEnclosingTypeMatching pos pred r diff --git a/unison-core/src/Unison/Pattern.hs b/unison-core/src/Unison/Pattern.hs index 22716fab839..c1dbc0dd6c3 100644 --- a/unison-core/src/Unison/Pattern.hs +++ b/unison-core/src/Unison/Pattern.hs @@ -31,6 +31,7 @@ data Pattern loc | EffectBind loc !ConstructorReference [Pattern loc] (Pattern loc) | SequenceLiteral loc [Pattern loc] | SequenceOp loc (Pattern loc) !SeqOp (Pattern loc) + | RecordLiteral loc (Map Text (Pattern loc)) deriving (Ord, Generic, Functor, Foldable, Traversable) data SeqOp @@ -53,6 +54,8 @@ updateDependencies tms p = case p of Constructor loc r ps -> case Map.lookup (Referent.Con r CT.Data) tms of Just (Referent.Con r CT.Data) -> Constructor loc r (updateDependencies tms <$> ps) _ -> Constructor loc r (updateDependencies tms <$> ps) + RecordLiteral loc ps -> + RecordLiteral loc (updateDependencies tms <$> ps) As loc p -> As loc (updateDependencies tms p) EffectPure loc p -> EffectPure loc (updateDependencies tms p) EffectBind loc r pats k -> case Map.lookup (Referent.Con r CT.Effect) tms of @@ -79,6 +82,7 @@ hasSubpattern needle haystack = needle == haystack || go haystack go Char {} = False go Bytes {} = False go (Constructor _ _ ps) = any (hasSubpattern needle) ps + go (RecordLiteral _ ps) = any (hasSubpattern needle) (Map.elems ps) go (As _ p) = hasSubpattern needle p go (EffectPure _ p) = hasSubpattern needle p go (EffectBind _ _ ps p) = any (hasSubpattern needle) ps || hasSubpattern needle p @@ -97,6 +101,8 @@ instance Show (Pattern loc) where show (Bytes _ b) = "Bytes " <> show b show (Constructor _ (ConstructorReference r i) ps) = "Constructor " <> unwords [show r, show i, show ps] + show (RecordLiteral _ ps) = + "RecordLiteral {" <> intercalate ", " (fmap (\(k, v) -> show k <> ": " <> show v) $ Map.toList ps) <> "}" show (As _ p) = "As " <> show p show (EffectPure _ k) = "EffectPure " <> show k show (EffectBind _ (ConstructorReference r i) ps k) = @@ -120,6 +126,7 @@ loc = \case Char loc _ -> loc Bytes loc _ -> loc Constructor loc _ _ -> loc + RecordLiteral loc _ -> loc As loc _ -> loc EffectPure loc _ -> loc EffectBind loc _ _ _ -> loc @@ -145,6 +152,7 @@ instance Eq (Pattern loc) where Nat _ n == Nat _ m = n == m Float _ f == Float _ g = f == g Constructor _ r args == Constructor _ s brgs = r == s && args == brgs + RecordLiteral _ ps == RecordLiteral _ ps2 = ps == ps2 EffectPure _ p == EffectPure _ q = p == q EffectBind _ r ps k == EffectBind _ r2 ps2 k2 = r == r2 && ps == ps2 && k == k2 As _ p == As _ q = p == q @@ -166,6 +174,7 @@ foldMap' f p = case p of Char _ _ -> f p Bytes _ _ -> f p Constructor _ _ ps -> f p <> foldMap (foldMap' f) ps + RecordLiteral _ ps -> f p <> foldMap (foldMap' f) (Map.elems ps) As _ p' -> f p <> foldMap' f p' EffectPure _ p' -> f p <> foldMap' f p' EffectBind _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p' @@ -189,6 +198,7 @@ generalizedDependencies literalType dataConstructor dataType effectConstructor e Var _ -> mempty As _ _ -> mempty Constructor _ (ConstructorReference r cid) _ -> [dataType r, dataConstructor r cid] + RecordLiteral _ _ -> mempty EffectPure _ _ -> [effectType Type.effectRef] EffectBind _ (ConstructorReference r cid) _ _ -> [effectType Type.effectRef, effectType r, effectConstructor r cid] diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index e4100f1507a..886c12ed6c6 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -101,6 +101,9 @@ data F typeVar typeAnn patternAnn a Match a [MatchCase patternAnn a] | TermLink Referent | TypeLink Reference + | -- | Field names carry no annotation of their own, so errors about a field + -- are reported at the field value's location. + Record (Map Text a) deriving (Ord, Foldable, Functor, Generic, Generic1, Traversable) _Ref :: Prism' (F tv ta pa a) Reference @@ -285,6 +288,7 @@ extraMap vtf atf apf = \case Blank x -> Blank (fmap atf x) Ref x -> Ref x Constructor x -> Constructor x + Record fields -> Record fields Request x -> Request x Handle x y -> Handle x y App x y -> App x y @@ -525,6 +529,9 @@ pattern Match' scrutinee branches <- (ABT.out -> ABT.Tm (Match scrutinee branche pattern Constructor' :: ConstructorReference -> ABT.Term (F typeVar typeAnn patternAnn) v a pattern Constructor' ref <- (ABT.out -> ABT.Tm (Constructor ref)) +pattern Record' :: Map Text (ABT.Term (F typeVar typeAnn patternAnn) v a) -> ABT.Term (F typeVar typeAnn patternAnn) v a +pattern Record' fields <- (ABT.out -> ABT.Tm (Record fields)) + pattern Request' :: ConstructorReference -> ABT.Term (F typeVar typeAnn patternAnn) v a pattern Request' ref <- (ABT.out -> ABT.Tm (Request ref)) @@ -768,6 +775,7 @@ unReferent :: Term2 vt at ap v a -> Maybe Referent unReferent (Ref' r) = Just $ Referent.Ref r unReferent (Constructor' r) = Just $ Referent.Con r CT.Data unReferent (Request' r) = Just $ Referent.Con r CT.Effect +unReferent (Record' _fields) = Nothing unReferent _ = Nothing refId :: (Ord v) => a -> Reference.Id -> Term2 vt at ap v a @@ -826,6 +834,9 @@ constructor a ref = ABT.tm' a (Constructor ref) request :: (Ord v) => a -> ConstructorReference -> Term2 vt at ap v a request a ref = ABT.tm' a (Request ref) +record :: (Ord v) => a -> Map Text (Term2 vt at ap v a) -> Term2 vt at ap v a +record a fields = ABT.tm' a (Record fields) + -- todo: delete and rename app' to app app_ :: (Ord v) => Term0' vt v -> Term0' vt v -> Term0' vt v app_ f arg = ABT.tm (App f arg) @@ -1534,6 +1545,13 @@ toPattern tm = case tm of Apps' (Request' r) args -> Pattern.EffectBind loc r <$> traverse toPattern args <*> pure (Pattern.Unbound loc) Apps' (Constructor' r) args -> Pattern.Constructor loc r <$> traverse toPattern args Constructor' r -> pure $ Pattern.Constructor loc r [] + -- A record literal is never applied to arguments, so unlike a constructor there's + -- no `Apps'` case here; `{x = ...} y` isn't a term that could have been a pattern. + -- + -- `traverse` over a `Map Text` visits fields in ascending key order, which is the + -- order `intop` assigns pattern variables in and the order `ABT.allVars` recovers + -- them in, so the variables of the rebuilt pattern line up with the abs chain. + Record' fields -> Pattern.RecordLiteral loc <$> traverse toPattern fields Request' r -> pure $ Pattern.EffectBind loc r [] (Pattern.Unbound loc) Int' i -> pure $ Pattern.Int loc i Nat' n -> pure $ Pattern.Nat loc n @@ -1596,6 +1614,7 @@ matchCaseToTerm (MatchCase pat guard (ABT.unabsA -> (avs, body))) = pure $ app loc (builtin loc "Bytes.fromList") (list loc (nat loc . fromIntegral <$> Bytes.toWord8s b)) Pattern.Constructor loc r ps -> apps' (constructor loc r) <$> traverse intop ps + Pattern.RecordLiteral loc ps -> record loc <$> traverse intop ps Pattern.As loc p -> do avs <- State.get case avs of @@ -1634,6 +1653,7 @@ instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where TypeLink x == TypeLink y = x == y Constructor r == Constructor r2 = r == r2 Request r == Request r2 = r == r2 + Record fields == Record fields2 = fields == fields2 Handle h b == Handle h2 b2 = h == h2 && b == b2 App f a == App f2 a2 = f == f2 && a == a2 Ann e t == Ann e2 t2 = e == e2 && t == t2 @@ -1680,6 +1700,10 @@ instance (Show v, Show a) => Show (F v a0 p a) where True (s "handle " <> shows b <> s " in " <> shows body) go _ (Constructor (ConstructorReference r n)) = s "Con" <> shows r <> s "#" <> shows n + go _ (Record fields) = + showParen + True + (s "{" <> shows fields <> s " }") go _ (Match scrutinee cases) = showParen True diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index 3d11855b0d4..e8c3bbe22d1 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -5,11 +5,13 @@ module Unison.Type where import Control.Lens (Prism') import Control.Monad.Writer.Strict qualified as Writer import Data.Generics.Sum (_Ctor) +import Data.List qualified as List import Data.List.Extra (nubOrd) import Data.Map qualified as Map import Data.Monoid (Any (..)) import Data.Sequence qualified as Seq import Data.Set qualified as Set +import Data.Text qualified as Text import Unison.ABT qualified as ABT import Unison.HashQualified qualified as HQ import Unison.Kind qualified as K @@ -36,6 +38,17 @@ import Unison.Util.List qualified as List import Unison.Var (Var) import Unison.Var qualified as Var +-- | Whether the record type unifies with types that have _extra_ fields. +-- E.g. subtype (Record _ {a: Int, b: Nat}) (Record AllowExtraFields {a: Int}) +-- will succeed, since the former has all the required fields, and extra fields are allowed, +-- but: +-- subtype (Record _ {a: Int, b: Nat}) (Record RequireExactFields {a: Int}) +-- fails. +data FieldBehavior + = AllowExtraFields + | RequireExactFields + deriving (Eq, Ord, Show) + -- | Base functor for types in the Unison language data F a = Ref TypeReference @@ -48,6 +61,8 @@ data F a | IntroOuter a -- binder like ∀, used to introduce variables that are -- bound by outer type signatures, to support scoped type -- variables + | -- Record type, mapping field names to types + Record FieldBehavior (Map Text a) deriving (Foldable, Functor, Generic, Generic1, Eq, Ord, Traversable) _Ref :: Prism' (F a) TypeReference @@ -145,6 +160,9 @@ pattern Pure' t <- (unPure -> Just t) pattern Request' :: [Type v a] -> Type v a -> Type v a pattern Request' ets res <- Apps' (Ref' ((== effectRef) -> True)) [(flattenEffects -> ets), res] +pattern Record' :: FieldBehavior -> Map Text (ABT.Term F v a) -> ABT.Term F v a +pattern Record' fb fields <- ABT.Tm' (Record fb fields) + pattern Effects' :: [ABT.Term F v a] -> ABT.Term F v a pattern Effects' es <- ABT.Tm' (Effects es) @@ -193,10 +211,15 @@ pattern Cycle' xs t <- ABT.Cycle' xs t pattern Abs' :: (Foldable f, Functor f, ABT.Var v) => ABT.Subst f v a -> ABT.Term f v a pattern Abs' subst <- ABT.Abs' _ subst +-- Pattern match combinations for Type terms +-- Effect'' matches ANY type and extracts the underlying type and its effects (if any) +{-# COMPLETE Effect'' #-} + +{-# COMPLETE Ref', Arrow', Ann', App', Effect', Effects', Forall', IntroOuter', Record' #-} + unPure :: (Ord v) => Type v a -> Maybe (Type v a) unPure (Effect'' [] t) = Just t unPure (Effect'' _ _) = Nothing -unPure t = Just t unArrows :: Type v a -> Maybe [Type v a] unArrows t = @@ -433,6 +456,9 @@ char a = ref a charRef integer :: (Ord v) => a -> Type v a integer a = ref a integerRef +record :: (Ord v) => a -> FieldBehavior -> Map Text (Type v a) -> Type v a +record a fb fields = ABT.tm' a (Record fb fields) + natural :: (Ord v) => a -> Type v a natural a = ref a naturalRef @@ -923,5 +949,12 @@ instance (Show a) => Show (F a) where go p (IntroOuter body) = case p of 0 -> showsPrec p body _ -> showParen True $ s "outer " <> shows body + go p (Record fb fields) = + let fbs = case fb of + RequireExactFields -> s "" + AllowExtraFields -> s "| ..." + in showParen (p > 0) $ foldl' (<>) (s "{") (List.intersperse (s ", ") (showField <$> Map.toList fields)) <> fbs <> s "}" + where + showField (l, t) = s (Text.unpack l) <> s ": " <> shows t (<>) = (.) s = showString diff --git a/unison-core/src/Unison/Var.hs b/unison-core/src/Unison/Var.hs index 291d183aadc..ebb0d31af9a 100644 --- a/unison-core/src/Unison/Var.hs +++ b/unison-core/src/Unison/Var.hs @@ -15,6 +15,7 @@ module Unison.Var inferPatternPureV, inferTypeConstructor, inferTypeConstructorArg, + inferRecordFieldType, isAction, missingResult, name, @@ -74,6 +75,7 @@ rawName typ = case typ of Inference PatternBindV -> "𝕧" Inference TypeConstructor -> "𝕗" Inference TypeConstructorArg -> "𝕦" + Inference RecordFieldType -> "𝕤" -- "s" for "struct" MissingResult -> "_" Blank -> "_" Eta -> "_eta" @@ -122,6 +124,7 @@ missingResult, inferPatternBindV, inferTypeConstructor, inferTypeConstructorArg, + inferRecordFieldType, inferOther :: (Var v) => v missingResult = typed MissingResult @@ -135,6 +138,7 @@ inferPatternBindE = typed (Inference PatternBindE) inferPatternBindV = typed (Inference PatternBindV) inferTypeConstructor = typed (Inference TypeConstructor) inferTypeConstructorArg = typed (Inference TypeConstructorArg) +inferRecordFieldType = typed (Inference RecordFieldType) inferOther = typed (Inference Other) unnamedRef :: (Var v) => Reference.Id -> v @@ -188,6 +192,7 @@ data InferenceType | PatternBindV | TypeConstructor | TypeConstructorArg + | RecordFieldType | Other deriving (Eq, Ord, Show) diff --git a/unison-hashing-v2/src/Unison/Hashing/V2.hs b/unison-hashing-v2/src/Unison/Hashing/V2.hs index d472af004b6..4e729a94643 100644 --- a/unison-hashing-v2/src/Unison/Hashing/V2.hs +++ b/unison-hashing-v2/src/Unison/Hashing/V2.hs @@ -27,6 +27,7 @@ module Unison.Hashing.V2 Type, TypeEdit (..), TypeF (..), + FieldBehavior (..), HashingWarning (..), crashOnHashingWarning, hashClosedTerm, @@ -57,5 +58,5 @@ import Unison.Hashing.V2.Reference (Reference (..), ReferenceId (..), pattern Re import Unison.Hashing.V2.Referent (Referent (..)) import Unison.Hashing.V2.Term (MatchCase (..), Term, TermF (..), hashClosedTerm, hashTermComponents, hashTermComponentsWithoutTypes) import Unison.Hashing.V2.TermEdit (TermEdit (..)) -import Unison.Hashing.V2.Type (Type, TypeF (..), typeToReference, typeToReferenceMentions) +import Unison.Hashing.V2.Type (FieldBehavior (..), Type, TypeF (..), typeToReference, typeToReferenceMentions) import Unison.Hashing.V2.TypeEdit (TypeEdit (..)) diff --git a/unison-hashing-v2/src/Unison/Hashing/V2/Pattern.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Pattern.hs index a414d43d9b0..57696872d49 100644 --- a/unison-hashing-v2/src/Unison/Hashing/V2/Pattern.hs +++ b/unison-hashing-v2/src/Unison/Hashing/V2/Pattern.hs @@ -4,6 +4,7 @@ module Unison.Hashing.V2.Pattern ) where +import Data.Map qualified as Map import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.Hashing.V2.Reference (Reference) import Unison.Hashing.V2.Tokenizable qualified as H @@ -22,6 +23,7 @@ data Pattern loc | PatternChar loc !Char | PatternBytes loc !Bytes | PatternConstructor loc !Reference !ConstructorId [Pattern loc] + | PatternRecord loc (Map Text (Pattern loc)) | PatternAs loc (Pattern loc) | PatternEffectPure loc (Pattern loc) | PatternEffectBind loc !Reference !ConstructorId [Pattern loc] (Pattern loc) @@ -58,6 +60,13 @@ instance H.Tokenizable (Pattern p) where tokens (PatternSequenceOp _ l op r) = H.Tag 12 : H.tokens op ++ H.tokens l ++ H.tokens r tokens (PatternChar _ c) = H.Tag 13 : H.tokens c tokens (PatternBytes _ b) = [H.Tag 14, H.Bytes (Bytes.toByteString b)] + -- The field count is hashed so that the flat name/pattern run is explicitly + -- delimited, rather than relying on every element happening to be + -- self-delimiting. + tokens (PatternRecord _ fields) = + H.Tag 15 + : (H.Nat . fromIntegral $ Map.size fields) + : foldMap (\(fieldName, p) -> H.tokens fieldName ++ H.tokens p) (Map.toAscList fields) instance Eq (Pattern loc) where PatternUnbound _ == PatternUnbound _ = True @@ -71,6 +80,7 @@ instance Eq (Pattern loc) where PatternEffectBind _ r ctor ps k == PatternEffectBind _ r2 ctor2 ps2 k2 = r == r2 && ctor == ctor2 && ps == ps2 && k == k2 PatternAs _ p == PatternAs _ q = p == q PatternText _ t == PatternText _ t2 = t == t2 + PatternRecord _ fs == PatternRecord _ fs2 = fs == fs2 PatternBytes _ b == PatternBytes _ b2 = b == b2 PatternSequenceLiteral _ ps == PatternSequenceLiteral _ ps2 = ps == ps2 PatternSequenceOp _ ph op pt == PatternSequenceOp _ ph2 op2 pt2 = ph == ph2 && op == op2 && pt == pt2 diff --git a/unison-hashing-v2/src/Unison/Hashing/V2/Term.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Term.hs index 3e4e3851e1b..3ab92216e12 100644 --- a/unison-hashing-v2/src/Unison/Hashing/V2/Term.hs +++ b/unison-hashing-v2/src/Unison/Hashing/V2/Term.hs @@ -8,6 +8,7 @@ module Unison.Hashing.V2.Term ) where +import Data.Map qualified as Map import Data.Sequence qualified as Sequence import Data.Text qualified as Text import Data.Zip qualified as Zip @@ -45,6 +46,7 @@ data TermF typeVar typeAnn patternAnn a | -- First argument identifies the data type, -- second argument identifies the constructor TermConstructor Reference ConstructorId + | TermRecord (Map Text a) | TermRequest Reference ConstructorId | TermHandle a a | TermApp a a @@ -200,3 +202,15 @@ instance (Var v) => Hashable1 (TermF v a p) where TermOr x y -> [tag 17, hashed $ hash x, hashed $ hash y] TermTermLink r -> [tag 18, accumulateToken r] TermTypeLink r -> [tag 19, accumulateToken r] + -- The field count is significant: without it the flat + -- name/value run has no terminator distinguishing it from + -- tokens that follow. + TermRecord fields -> tag 20 : varint (Map.size fields) : fieldTokens fields + where + fieldTokens :: Map Text x -> [Hashable.Token] + fieldTokens fs = + foldMap + ( \(name, val) -> + [accumulateToken name, hashed (hash val)] + ) + (Map.toAscList fs) diff --git a/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs index b1397d0e81c..0c52f54b9ab 100644 --- a/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs +++ b/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs @@ -1,6 +1,7 @@ module Unison.Hashing.V2.Type ( Type, TypeF (..), + FieldBehavior (..), bindExternal, bindReferences, @@ -35,6 +36,17 @@ import Unison.Prelude import Unison.Util.List qualified as List import Unison.Var (Var) +-- | Whether the record type unifies with types that have _extra_ fields. +-- E.g. subtype (Record _ {a: Int, b: Nat}) (Record AllowExtraFields {a: Int}) +-- will succeed, since the former has all the required fields, and extra fields are allowed, +-- but: +-- subtype (Record _ {a: Int, b: Nat}) (Record RequireExactFields {a: Int}) +-- fails. +data FieldBehavior + = AllowExtraFields + | RequireExactFields + deriving (Eq, Ord, Show) + -- | Base functor for types in the Unison language data TypeF a = TypeRef Reference @@ -47,6 +59,7 @@ data TypeF a | TypeIntroOuter a -- binder like ∀, used to introduce variables that are -- bound by outer type signatures, to support scoped type -- variables + | TypeRecord FieldBehavior (Map Text a) deriving (Foldable, Functor, Traversable) -- | Types are represented as ABTs over the base functor F, with variables in `v` @@ -151,3 +164,12 @@ instance Hashable1 TypeF where TypeEffect e t -> [tag 5, hashed (hash e), hashed (hash t)] TypeForall a -> [tag 6, hashed (hash a)] TypeIntroOuter a -> [tag 7, hashed (hash a)] + TypeRecord fb fields -> + let fbh = case fb of + AllowExtraFields -> 0 + RequireExactFields -> 1 + sortedFields = Map.toAscList fields + fieldHashes = + sortedFields & foldMap \(fieldName, fieldType) -> + [Hashable.accumulateToken fieldName, hashed (hash fieldType)] + in tag 8 : tag fbh : fieldHashes diff --git a/unison-merge/src/Unison/Merge/Synhash.hs b/unison-merge/src/Unison/Merge/Synhash.hs index 1a57a5b9405..7601f1396fc 100644 --- a/unison-merge/src/Unison/Merge/Synhash.hs +++ b/unison-merge/src/Unison/Merge/Synhash.hs @@ -323,6 +323,10 @@ hashPatternTokens ppe = \case Pattern.Snoc -> H.Tag 1 Pattern.Cons -> H.Tag 2 Pattern.Bytes _ b -> [H.Tag 17, H.Bytes (Bytes.toByteString b)] + Pattern.RecordLiteral _ ps -> + H.Tag 18 + : hashLengthToken ps + : (Map.toAscList ps >>= \(txt, p) -> H.Text txt : hashPatternTokens ppe p) hashReferentToken :: PrettyPrintEnv -> Referent -> Token hashReferentToken ppe = @@ -355,6 +359,7 @@ hashTermFTokens ppe = \case H.Tag 18 : hashLengthToken cases : (cases >>= hashCaseTokens ppe) Term.TermLink rf -> [H.Tag 19, hashReferentToken ppe rf] Term.TypeLink r -> [H.Tag 20, hashTypeReferenceToken ppe r] + Term.Record fields -> H.Tag 21 : hashLengthToken fields : fieldNameTokens (Map.keys fields) hashTypeTokens :: forall v a. (Var v) => PrettyPrintEnv -> [v] -> Type v a -> [Token] hashTypeTokens ppe = go @@ -378,6 +383,17 @@ hashTypeFTokens ppe = \case Type.Effects es -> [H.Tag 5, hashLengthToken es] Type.Forall {} -> [H.Tag 6] Type.IntroOuter {} -> [H.Tag 7] + Type.Record fb fields -> + [H.Tag 8, hashLengthToken fields] <> fieldBehaviorTokens fb <> fieldNameTokens (Map.keys fields) + +fieldBehaviorTokens :: Type.FieldBehavior -> [Token] +fieldBehaviorTokens = \case + Type.AllowExtraFields -> [H.Tag 0] + Type.RequireExactFields -> [H.Tag 1] + +fieldNameTokens :: [Text] -> [Token] +fieldNameTokens names = + fmap H.Text names hashTypeReferenceToken :: PrettyPrintEnv -> TypeReference -> Token hashTypeReferenceToken ppe = diff --git a/unison-runtime/package.yaml b/unison-runtime/package.yaml index 8d35823d7db..045c4141285 100644 --- a/unison-runtime/package.yaml +++ b/unison-runtime/package.yaml @@ -94,6 +94,7 @@ library: - temporary - text - template-haskell + - transformers - inspection-testing - time - tls @@ -108,6 +109,7 @@ library: - unison-syntax - unison-util-bytes - unison-util-recursion + - unison-util-relation - unliftio - unordered-containers - vector @@ -149,6 +151,7 @@ tests: - unison-core1 - unison-hash - unison-util-bytes + - unison-util-relation - unison-parser-typechecker - unison-prelude - unison-pretty-printer diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs index bfedb021992..19392d00055 100644 --- a/unison-runtime/src/Unison/Runtime/ANF.hs +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -61,6 +61,9 @@ module Unison.Runtime.ANF CTag, PackedTag (..), Tag (..), + RecordRef (..), + RecordSchema (..), + FieldName, GroupRef (..), Code (..), ValList, @@ -86,6 +89,7 @@ module Unison.Runtime.ANF replaceFunctions, foldGroup, foldGroupLinks, + groupRecordSchemas, overGroup, overGroupLinks, traverseGroup, @@ -131,7 +135,7 @@ import Unison.Runtime.TypeTags (CTag (..), PackedTag (..), RTag (..), Tag (..), import Unison.ShortHash (shortenTo) import Unison.Symbol (Symbol) import Unison.Syntax.NamePrinter (prettyHashQualified, prettyShortHash) -import Unison.Term hiding (Char, Float, List, Ref, Text, arity, float, fresh, resolve) +import Unison.Term hiding (Char, Float, List, Record, Ref, Text, arity, float, fresh, record, resolve) import Unison.Type qualified as Ty import Unison.Typechecker.Components (minimize') import Unison.Util.Bytes (Bytes) @@ -994,6 +998,8 @@ alignFunc _ (FReq rl tl) (FReq rr tr) | rl == rr, tl == tr = Just . pure $ FReq rl tl alignFunc _ (FPrim ol) (FPrim or) | ol == or = Just . pure $ FPrim ol +alignFunc _ (FRec rl) (FRec rr) + | rl == rr = Just . pure $ FRec rl alignFunc _ _ _ = Nothing alignBranch :: @@ -1041,6 +1047,8 @@ alignBranch f (MatchData rfl bl dl) (MatchData rfr br dr) all (\t -> fst (bl ! t) == fst (br ! t)) (keys bl), Just ds <- alignMaybe f dl dr = Just $ MatchData rfl <$> interverse (alignCCs f) bl br <*> ds +alignBranch f (MatchRec rsl bdl) (MatchRec rsr bdr) + | rsl == rsr = Just $ MatchRec rsl <$> f bdl bdr alignBranch f (MatchSum bl) (MatchSum br) | keysSet bl == keysSet br, all (\w -> fst (bl ! w) == fst (br ! w)) (keys bl) = @@ -1186,6 +1194,13 @@ pattern TCon :: ANormal ref v pattern TCon r t args = TApp (FCon r t) args +pattern TRec :: + (ABT.Var v) => + RecordSchema -> + [v] -> + ANormal ref v +pattern TRec rs args = TApp (FRec rs) args + pattern AKon :: v -> [v] -> ANormalF ref v e pattern AKon v args = AApp (FCont v) args @@ -1358,6 +1373,7 @@ data Branched ref e | MatchRequest [(ref, (EnumMap CTag ([Mem], e)))] e | MatchEmpty | MatchData ref (EnumMap CTag ([Mem], e)) (Maybe e) + | MatchRec RecordSchema e | MatchSum (EnumMap Word64 ([Mem], e)) | MatchNumeric ref (EnumMap Word64 e) (Maybe e) deriving (Show, Eq, Functor, Foldable, Traversable) @@ -1388,6 +1404,7 @@ data BranchAccum v Reference (Maybe (ANormal Reference v)) (EnumMap CTag ([Mem], ANormal Reference v)) + | AccumRec RecordSchema (ANormal Reference v) | AccumSeqEmpty (ANormal Reference v) | AccumSeqView SeqEnd @@ -1463,6 +1480,14 @@ instance Semigroup (BranchAccum v) where instance Monoid (BranchAccum e) where mempty = AccumEmpty +newtype RecordRef = RecordRef Word64 + deriving (Show, Eq, Ord) + +newtype RecordSchema = RecordSchema (Set FieldName) + deriving (Show, Eq, Ord) + +type FieldName = Text + data Func ref v = -- variable FVar v @@ -1476,6 +1501,8 @@ data Func ref v FReq !ref !CTag | -- prim op FPrim (Either POp ForeignFunc) + | -- record constructor + FRec RecordSchema deriving (Show, Eq, Functor, Foldable, Traversable) data Lit ref @@ -1602,6 +1629,7 @@ type ValList ref = [Value ref] data Value ref = Partial (GroupRef ref) (ValList ref) | Data ref Word64 (ValList ref) + | Record RecordSchema (ValList ref) | Cont (ValList ref) (Cont ref) | BLit (BLit ref) deriving (Show, Eq) @@ -1992,6 +2020,8 @@ anfBlock (Match' scrut cas) = do pure (sctx <> cx, pure $ TMatch v $ MatchNumeric r cs df) AccumData r df cs -> pure (sctx <> cx, pure . TMatch v $ MatchData r cs df) + AccumRec rs bd -> do + pure (sctx <> cx, pure $ TMatch v $ MatchRec rs bd) AccumSeqEmpty _ -> internalBug [] "anfBlock: non-exhaustive AccumSeqEmpty" AccumSeqView en (Just em) bd -> do @@ -2105,6 +2135,10 @@ anfBlock (TypeLink' r) = pure (mempty, pure . TLit $ LY r) anfBlock (List' as) = fmap (pure . TPrm BLDS) <$> anfArgs tms where tms = toList as +anfBlock (Record' fields) = fmap (pure . TRec recSchema) <$> anfArgs tms + where + recSchema = RecordSchema (Map.keysSet fields) + tms = toList fields anfBlock t = internalBug [] $ "anf: unhandled term: " ++ show t type ReqBranches ref v = @@ -2164,6 +2198,11 @@ anfInitCase u (MatchCase p guard (ABT.AbsN' vs bd)) <*> anfBody bd <&> \(us, bd) -> AccumData r Nothing . EC.mapSingleton (fromIntegral t) . (BX <$ us,) $ ABTN.TAbss us bd + | P.RecordLiteral _ fields <- p = do + (,) + <$> expandBindings (Map.elems fields) vs + <*> anfBody bd + <&> \(us, bd) -> AccumRec (RecordSchema $ Map.keysSet fields) $ ABTN.TAbss us bd | P.EffectPure _ q <- p = (,) <$> expandBindings [q] vs @@ -2229,6 +2268,7 @@ valueLinks f = go go (Data dr _ vs) = f True dr <> foldMap go vs go (Cont vs k) = foldMap go vs <> contLinks f k go (BLit l) = blitLinks f l + go (Record _rs vs) = foldMap go vs {-# INLINE valueLinks #-} -- Traversals of _all_ references in a `Value`, for e.g. @@ -2242,12 +2282,14 @@ instance Referential Value where Cont vs k -> Cont (fmap (overRefs h) vs) (overRefs h k) BLit l -> BLit (overRefs h l) + Record rs vs -> Record rs (fmap (overRefs h) vs) foldMapRefs h = \case Partial (GR r _) vs -> h False r <> foldMap (foldMapRefs h) vs Data r _ vs -> h True r <> foldMap (foldMapRefs h) vs Cont vs k -> foldMap (foldMapRefs h) vs <> foldMapRefs h k BLit l -> foldMapRefs h l + Record _rs vs -> foldMap (foldMapRefs h) vs traverseRefs h = \case Partial gr vs -> @@ -2263,6 +2305,7 @@ instance Referential Value where <$> traverse (traverseRefs h) vs <*> traverseRefs h k BLit l -> BLit <$> traverseRefs h l + Record rs vs -> Record rs <$> traverse (traverseRefs h) vs contLinks :: (Monoid a) => (Bool -> ref -> a) -> Cont ref -> a contLinks f = go @@ -2400,6 +2443,33 @@ foldGroupLinks :: r foldGroupLinks f = getConst . traverseGroupLinks (\b -> Const . f b) +-- | Every record schema constructed or matched on anywhere in a group. +-- +-- Record schemas are interned by the runtime like type and term references +-- are, so this is the analogue of 'foldGroupLinks' for them: it tells the code +-- cache which schemas a group needs before its code is emitted. +groupRecordSchemas :: SuperGroup ref v -> Set RecordSchema +groupRecordSchemas (Rec bs e) = + foldMap (normalRecordSchemas . snd) bs <> normalRecordSchemas e + +normalRecordSchemas :: SuperNormal ref v -> Set RecordSchema +normalRecordSchemas (Lambda _ e) = anfRecordSchemas e + +anfRecordSchemas :: ANormal ref v -> Set RecordSchema +anfRecordSchemas = \case + ABTN.Term _ (ABTN.Abs _ e) -> anfRecordSchemas e + ABTN.Term _ (ABTN.Tm e) -> case e of + AApp (FRec rs) _ -> Set.singleton rs + AMatch _ bs -> branchRecordSchemas bs + -- Everything else just recurses; `ANormalF` is Foldable in its + -- subexpressions, and no other constructor mentions a schema. + _ -> foldMap anfRecordSchemas e + +branchRecordSchemas :: Branched ref (ANormal ref v) -> Set RecordSchema +branchRecordSchemas = \case + MatchRec rs e -> Set.insert rs (anfRecordSchemas e) + bs -> foldMap anfRecordSchemas bs + normalLinks :: (Applicative f, Var v) => (Bool -> ref0 -> f ref1) -> @@ -2478,6 +2548,8 @@ branchLinks f g (MatchNumeric r m e) = MatchNumeric <$> f r <*> traverse g m <*> traverse g e branchLinks _ g (MatchSum m) = MatchSum <$> (traverse . traverse) g m +branchLinks _ g (MatchRec rs e) = + MatchRec rs <$> g e branchLinks _ _ MatchEmpty = pure MatchEmpty funcLinks :: @@ -2491,6 +2563,7 @@ funcLinks f (FReq r t) = flip FReq t <$> f True r funcLinks _ (FVar v) = pure $ FVar v funcLinks _ (FCont v) = pure $ FCont v funcLinks _ (FPrim e) = pure $ FPrim e +funcLinks _ (FRec rr) = pure $ FRec rr expandBindings' :: (Var v) => @@ -2687,6 +2760,8 @@ prettyFunc (FReq r t) = . shows t . showString ")" prettyFunc (FPrim op) = either shows shows op . showString " " +prettyFunc (FRec r) = + showString "REC(" . shows r . showString ") " showsShort :: Reference -> ShowS showsShort = @@ -2711,6 +2786,12 @@ prettyBranches ind bs = case bs of (uncurry $ prettyCase ind . prettyTag r) id (mapToList $ snd <$> bs) + MatchRec (RecordSchema rs) bd -> + let fields = + Set.toList rs + & Text.intercalate ", " + & Text.unpack + in prettyCase ind (showString "REC{" . showString fields . showString "}") bd id MatchRequest bs df -> foldr ( \(r, m) s -> diff --git a/unison-runtime/src/Unison/Runtime/ANF/MurmurHash/Untyped.hs b/unison-runtime/src/Unison/Runtime/ANF/MurmurHash/Untyped.hs index e804dc73a35..012fd666a2b 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/MurmurHash/Untyped.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/MurmurHash/Untyped.hs @@ -30,7 +30,7 @@ import Unison.Runtime.TypeTags (mapBinTag, mapTipTag) import Unison.Util.Bytes (Bytes) import Unison.Util.Bytes qualified as B import Unison.Util.EnumContainers qualified as EC -import Unison.Util.Text as UT hiding (reverse, pattern Text) +import Unison.Util.Text qualified as UT hiding (reverse, pattern Text) import Unison.Var (Var) hash64ValueUntyped :: Referenced Value -> Hash64 @@ -53,6 +53,9 @@ data HRefs r = HRefs hash64AddShort :: SBS.ShortByteString -> Hash64 -> Hash64 hash64AddShort = flip $ SBS.foldl (flip $ hash64AddInt . fromIntegral) +hash64AddText :: DT.Text -> Hash64 -> Hash64 +hash64AddText t h = DT.foldl' (flip hash64Add) h t + hash64AddRef :: Reference -> Hash64 -> Hash64 hash64AddRef (ReferenceBuiltin tx) h = DT.foldl' (flip hash64Add) (hash64AddInt 1 h) tx @@ -97,6 +100,10 @@ hash64AddValue rs = \case hash64AddUMap rs (M.fromDistinctAscList assocs) BLit lit -> hash64AddInt 4 `combine` hash64AddBLit rs lit + Record (RecordSchema recSchema) vs -> + hash64AddInt 5 + `combine` hash64AddFoldable (hash64AddText) recSchema + `combine` hash64AddValues rs vs hash64AddGroupRef :: HRefs r -> GroupRef r -> Hash64 -> Hash64 hash64AddGroupRef rs (GR i k) = @@ -308,6 +315,9 @@ hash64AddFunc rf ctx = \case FPrim ins -> hash64AddInt 6 `combine` hash64AddEither hash64AddPOp hash64AddForeign ins + FRec (RecordSchema rs) -> + hash64AddInt 7 + `combine` hash64AddFoldable (hash64AddText) rs hash64AddLit :: HRefs r -> Lit r -> Hash64 -> Hash64 hash64AddLit rs = \case @@ -356,6 +366,10 @@ hash64AddBranches rs ctx = \case hash64AddInt 8 `combine` hash64AddMap (hash64AddYAssoc rs ctx) bs `combine` hash64AddMaybe (hash64AddNormal rs ctx) df + MatchRec (RecordSchema recSchema) bd -> + hash64AddInt 9 + `combine` hash64AddFoldable (hash64AddText) recSchema + `combine` hash64AddNormal rs ctx bd hash64AddNAssoc :: (Show r) => @@ -465,6 +479,14 @@ hash64AddMap :: (k -> v -> Hash64 -> Hash64) -> M.Map k v -> Hash64 -> Hash64 hash64AddMap f = flip $ M.foldlWithKey' (rot f) +hash64AddFoldable :: + (Foldable f) => + (a -> Hash64 -> Hash64) -> + f a -> + Hash64 -> + Hash64 +hash64AddFoldable f = flip $ foldl' (flip f) + -- Serializes a map as if it were a unison data type hash64AddUMap :: (Show r) => HRefs r -> M.Map (Value r) (Value r) -> Hash64 -> Hash64 diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index e4f9569659b..b778dd0c358 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -378,6 +378,7 @@ putFunc refrep allowFop ctx f = case f of | allowFop -> putTag FForeignT <> putFOp f | otherwise -> exn [] $ "putFunc: could not serialize foreign operation: " ++ show f + FRec schema -> putTag FRecT <> putRecordSchema schema getFunc :: (PrimBase m, Var v) => [v] -> GDeserial m (Func Reference v) @@ -392,6 +393,7 @@ getFunc ctx (_, allowFOp) = FForeignT | allowFOp -> FPrim . Right <$> getFOp | otherwise -> exn [] "getFunc: can't deserialize a foreign func" + FRecT -> FRec <$> getRecordSchema -- Note: this numbering is derived, and so not particularly stable. -- However, foreign functions are not serialized for interchange. This @@ -551,6 +553,11 @@ putBranches refrep fops ctx bs = case bs of <> putReference r <> putEnumMap putCTag (putCase refrep fops ctx) m <> putMaybe df (putNormal refrep fops ctx) + MatchRec rs (TAbss us e) -> + putTag MRecT + <> putRecordSchema rs + <> putVarInt (length us) + <> putNormal refrep fops (pushCtx us ctx) e MatchSum m -> putTag MSumT <> putEnumMap BU.word64BE (putCase refrep fops ctx) m @@ -599,6 +606,12 @@ getBranches ctx frsh0 s = <$> getReference <*> getEnumMap getWord64be (getNormal ctx frsh0 s) <*> getMaybe (getNormal ctx frsh0 s) + MRecT -> do + rs <- getRecordSchema + uSize <- getVarInt + let frsh = frsh0 + fromIntegral uSize + let us = getFresh <$> take uSize [frsh0 ..] + MatchRec rs . TAbss us <$> getNormal (pushCtx us ctx) frsh s putCase :: (Var v) => @@ -667,6 +680,10 @@ putValue v (Data r t vs) = <> putReference r <> BU.word64BE t <> putFoldable (putValue v) vs +putValue v (Record rs vs) = + putTag RecordT + <> putRecordSchema rs + <> putFoldable (putValue v) vs putValue v (Cont bs k) = putTag ContT <> putFoldable (putValue v) bs @@ -702,6 +719,16 @@ getValue s@(v, _) = w <- getWord64be vs <- getList (getValue s) pure $ Data r w vs + RecordT + -- Record types didn't exist before version 4, so a payload claiming to + -- be older can't contain one. + | Transfer vn <- v, + vn < 4 -> + exn [] $ "getValue: record value in a version " ++ show vn ++ " payload" + | otherwise -> do + rs <- getRecordSchema + vs <- getList (getValue s) + pure $ Record rs vs ContT | Transfer vn <- v, vn < 4 -> do diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize/CodeV4.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize/CodeV4.hs index 4e8aea7e2d5..3a79a8a0ce9 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize/CodeV4.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize/CodeV4.hs @@ -230,7 +230,7 @@ putNormal fops ctx tm = case tm of <> putCCs ccs <> putNormal fops ctx l <> putNormal fops (pushCtx us ctx) e - v -> exn [] $ "putNormal: malformed term\n" ++ show v + v -> exn [] $ "CodeV4: putNormal: malformed term\n" ++ show v getNormal :: (PrimBase m) => @@ -304,6 +304,7 @@ putFunc ctx f = case f of FReq r c -> putTag FReqT <> putRefNum r <> putCTag c FPrim (Left p) -> putTag FPrimT <> putPOp p FPrim (Right f) -> putTag FForeignT <> putFOp f + FRec recSchema -> putTag FRecT <> putRecordSchema recSchema getFunc :: (PrimBase m, Var v) => [v] -> Get m (Func RefNum v) getFunc ctx = @@ -315,6 +316,7 @@ getFunc ctx = FReqT -> FReq <$> getRefNum <*> getCTag FPrimT -> FPrim . Left <$> getPOp FForeignT -> FPrim . Right <$> getFOp + FRecT -> FRec <$> getRecordSchema {-# INLINEABLE getFunc #-} -- Note: this numbering is derived, and so not particularly stable. @@ -400,6 +402,8 @@ putBranches fops ctx bs = case bs of <> putMaybe df (putNormal fops ctx) MatchBytes _ _ -> exn [] "putBranches: Bytes pattern matching not supported in V4 codec" + MatchRec _ _ -> + exn [] "putBranches: record pattern matching not supported in V4 codec" _ -> exn [] "putBranches: malformed intermediate term" getBranches :: @@ -439,6 +443,7 @@ getBranches ctx frsh0 = <*> getEnumMap getWord64be (getNormal ctx frsh0) <*> getMaybe (getNormal ctx frsh0) MBytesT -> exn [] "getBranches: Bytes pattern matching not supported in V4 codec" + MRecT -> exn [] "getBranches: record pattern matching not supported in V4 codec" {-# INLINEABLE getBranches #-} putCase :: diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize/Tags.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize/Tags.hs index 5bceeaf51ac..9eb06d1dd5e 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize/Tags.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize/Tags.hs @@ -24,6 +24,7 @@ data FnTag | FReqT | FPrimT | FForeignT + | FRecT data MtTag = MIntT @@ -34,6 +35,7 @@ data MtTag | MSumT | MNumT | MBytesT + | MRecT data LtTag = IT @@ -63,7 +65,7 @@ data BLTag | BigIntT | BigNatT -data VaTag = PartialT | DataT | ContT | BLitT +data VaTag = PartialT | DataT | ContT | BLitT | RecordT data CoTag = KET | MarkT | PushT @@ -105,6 +107,7 @@ instance Tag FnTag where FReqT -> 4 FPrimT -> 5 FForeignT -> 6 + FRecT -> 7 word2tag = \case 0 -> pure FVarT @@ -114,6 +117,7 @@ instance Tag FnTag where 4 -> pure FReqT 5 -> pure FPrimT 6 -> pure FForeignT + 7 -> pure FRecT n -> unknownTag "FnTag" n instance Tag MtTag where @@ -126,6 +130,7 @@ instance Tag MtTag where MSumT -> 5 MNumT -> 6 MBytesT -> 7 + MRecT -> 8 word2tag = \case 0 -> pure MIntT @@ -136,6 +141,7 @@ instance Tag MtTag where 5 -> pure MSumT 6 -> pure MNumT 7 -> pure MBytesT + 8 -> pure MRecT n -> unknownTag "MtTag" n instance Tag LtTag where @@ -206,6 +212,7 @@ instance Tag VaTag where DataT -> 1 ContT -> 2 BLitT -> 3 + RecordT -> 4 {-# INLINE tag2word #-} word2tag = \case @@ -213,6 +220,7 @@ instance Tag VaTag where 1 -> pure DataT 2 -> pure ContT 3 -> pure BLitT + 4 -> pure RecordT t -> unknownTag "VaTag" t {-# INLINE word2tag #-} diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize/ValueV5.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize/ValueV5.hs index 69e0b7eb747..cf458cc3ea0 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize/ValueV5.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize/ValueV5.hs @@ -93,6 +93,10 @@ putValue = \case <> putFoldable putValue bs <> putCont k BLit l -> putTag BLitT <> putBLit l + Record rs vs -> + putTag RecordT + <> putRecordSchema rs + <> putFoldable putValue vs getValue :: (PrimBase m) => Get m (Value RefNum) getValue = @@ -111,6 +115,10 @@ getValue = k <- getCont pure $ Cont bs k BLitT -> BLit <$> getBLit + RecordT -> do + rs <- getRecordSchema + vs <- getList getValue + pure $ Record rs vs {-# INLINEABLE getValue #-} putCont :: Cont RefNum -> Builder diff --git a/unison-runtime/src/Unison/Runtime/Decompile.hs b/unison-runtime/src/Unison/Runtime/Decompile.hs index 23c87db2cac..2c6b49f3e04 100644 --- a/unison-runtime/src/Unison/Runtime/Decompile.hs +++ b/unison-runtime/src/Unison/Runtime/Decompile.hs @@ -14,6 +14,7 @@ where import Data.Map qualified as Map import Data.Set (singleton) import Data.Text qualified as DT +import Data.Vector qualified as V import Numeric.Natural (Natural) import Unison.ABT (substs) import Unison.Builtin.Decls qualified as DD @@ -25,7 +26,7 @@ import Unison.Referent qualified as Referent import Unison.Runtime.ANF (maskTags) import Unison.Runtime.Array (byteArrayToList) import Unison.Runtime.IOSource (iarrayFromListRef, ibarrayFromBytesRef) -import Unison.Runtime.MCode (CombIx (..)) +import Unison.Runtime.MCode (CombIx (..), shapeFields) import Unison.Runtime.Stack ( Closure (..), Foreign (..), @@ -111,6 +112,12 @@ decompile backref topTerms = \case app () (builtin () "Any.Any") <$> decompile backref topTerms b (DataC rf (maskTags -> ct) vs) -> apps' (con rf ct) <$> traverse (decompile backref topTerms) vs + (RecordC shape vals) -> do + vs' <- traverse (decompile backref topTerms) vals + -- The field names are carried by the record's shape, in the same + -- ascending order as its slots. + pure . Term.record () . Map.fromList $ + zip (V.toList (shapeFields shape)) (V.toList vs') (PApV (CIx rf rt k) _ vs) | rf == Builtin "jumpCont" -> err Cont $ bug "" diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index c55d7d5728d..893b126bb09 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -37,7 +37,7 @@ where import Control.Concurrent.STM as STM import Control.Exception (fromException, tryJust) import Control.Monad -import Control.Monad.State +import Control.Monad.State.Strict import Data.Bitraversable (bitraverse) import Data.ByteString qualified as B import Data.ByteString.Builder (Builder) @@ -84,9 +84,11 @@ import Unison.Runtime.InternalError (CompileExn (CE)) import Unison.Runtime.MCode ( Args (..), CombIx (..), + FieldRef (..), GInstr (..), GSection (..), RCombs, + RecordFieldMappings (..), RefNums (..), absurdCombs, combTypes, @@ -126,6 +128,8 @@ import Unison.Syntax.NamePrinter (prettyHashQualified, prettyReference) import Unison.Syntax.TermPrinter import Unison.Term qualified as Tm import Unison.Type qualified as Type +import Unison.Util.BiMap qualified as BM +import Unison.Util.BiMap qualified as BiMap import Unison.Util.EnumContainers as EC import Unison.Util.Monoid (foldMapM) import Unison.Util.Pretty as P @@ -493,7 +497,8 @@ checkCacheability cl ctx (r, sg) = decompileCtx :: EnumMap Word64 Reference -> EvalCtx -> Val -> DecompResult Symbol -decompileCtx crs ctx = decompile ib $ backReferenceTm crs fr ir dt +decompileCtx crs ctx val = + decompile ib (backReferenceTm crs fr ir dt) val where ib = intermedToBase ctx fr = floatRemap ctx @@ -647,7 +652,7 @@ intermediateTerms ppe ctx rtms = where f ref = superNormalize - . splitPatterns (dspec ctx) + . splitPatterns ctx.dspec . addDefaultCases tmName where tmName = HQ.toText . termName ppe $ RF.Ref ref @@ -727,7 +732,7 @@ intermediateTerm ppe ctx tm = tmName = HQ.toText . termName ppe $ RF.Ref ref f = superNormalize - . splitPatterns (dspec ctx) + . splitPatterns ctx.dspec . addDefaultCases tmName prepareEvaluation :: @@ -917,14 +922,17 @@ data StoredCache (EnumMap Word64 Reference) Word64 Word64 + Word64 (Map Reference (SuperGroup Reference Symbol)) (Map Reference Word64) (Map Reference Word64) + (BM.BiMap ANF.RecordSchema ANF.RecordRef) (Map Reference (Set Reference)) + RecordFieldMappings deriving (Show, Eq) putStoredCache :: StoredCache -> Builder -putStoredCache (SCache cs crs cacheableCombs oinfo trs ftm fty int rtm rty sbs) = +putStoredCache (SCache cs crs cacheableCombs oinfo trs ftm fty frs int rtm rty rsLookup sbs rfm) = putEnumMap putNat (putEnumMap putNat (putComb absurd)) cs <> putEnumMap putNat putReference crs <> putEnumSet putNat cacheableCombs @@ -932,10 +940,26 @@ putStoredCache (SCache cs crs cacheableCombs oinfo trs ftm fty int rtm rty sbs) <> putEnumMap putNat putReference trs <> putNat ftm <> putNat fty + <> putNat frs <> putMap putReference (putGroup mempty False) int <> putMap putReference putNat rtm <> putMap putReference putNat rty + <> putMap putRecordSchema putRecordRef (BM.forward rsLookup) <> putMap putReference (putFoldable putReference) sbs + <> putRecordFieldMappings rfm + +putRecordFieldMappings :: RecordFieldMappings -> Builder +putRecordFieldMappings (RecordFieldMappings next rfm) = + putFieldRef next <> putMap putText putFieldRef (BiMap.toMapL rfm) + +getRecordFieldMappings :: (PrimBase m) => Get m RecordFieldMappings +getRecordFieldMappings = RecordFieldMappings <$> getFieldRef <*> (BiMap.fromMap <$> getMap getText getFieldRef) + +putFieldRef :: FieldRef -> Builder +putFieldRef (FieldRef w) = putVarInt w + +getFieldRef :: (PrimBase m) => Get m FieldRef +getFieldRef = FieldRef <$> getVarInt getStoredCache :: (PrimBase m) => Get m StoredCache getStoredCache = @@ -947,10 +971,13 @@ getStoredCache = <*> getEnumMap getNat getReference <*> getNat <*> getNat + <*> getNat <*> getMap getReference getGroupCurrent <*> getMap getReference getNat <*> getMap getReference getNat + <*> (BM.fromMap <$> getMap getRecordSchema getRecordRef) <*> getMap getReference (fromList <$> getList getReference) + <*> getRecordFieldMappings debugTextFormat :: Bool -> Pretty ColorText -> String debugTextFormat fancy = @@ -959,7 +986,7 @@ debugTextFormat fancy = render = if fancy then toANSI else toPlain restoreCache :: Bool -> StoredCache -> IO (CCache ()) -restoreCache sandboxed (SCache cs crs cacheableCombs opt trs ftm fty int rtm rty sbs) = do +restoreCache sandboxed (SCache cs crs cacheableCombs opt trs ftm fty frs int rtm rty recSchemas sbs rfm) = do cc <- CCache sandboxed debugText () <$> newTVarIO srcCombs @@ -970,10 +997,13 @@ restoreCache sandboxed (SCache cs crs cacheableCombs opt trs ftm fty int rtm rty <*> newTVarIO (trs <> builtinTypeBackref) <*> newTVarIO ftm <*> newTVarIO fty + <*> newTVarIO frs <*> newTVarIO int <*> newTVarIO (rtm <> builtinTermNumbering) <*> newTVarIO (rty <> builtinTypeNumbering) + <*> newTVarIO recSchemas <*> newTVarIO (sbs <> baseSandboxInfo) + <*> newTVarIO newRFM let (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = srcCombs & sanitizeCombsOfForeignFuncs sandboxed sandboxedForeignFuncs @@ -1003,10 +1033,20 @@ restoreCache sandboxed (SCache cs crs cacheableCombs opt trs ftm fty int rtm rty (debugTextFormat fancy $ pretty PPE.empty dv) rns = emptyRNs {dnum = refLookup "ty" builtinTypeNumbering} rf k = builtinTermBackref ! k + builtinCombs :: EnumMap Word64 Combs + newRFM :: RecordFieldMappings + (builtinCombs, newRFM) = + flip + runState + rfm + ( numberedTermLookup + & traverseWithKey + ( \k v -> do + emitComb @Symbol rns (rf k) k mempty (0, v) + ) + ) srcCombs :: EnumMap Word64 Combs - srcCombs = - let builtinCombs = mapWithKey (\k v -> emitComb @Symbol rns (rf k) k mempty (0, v)) numberedTermLookup - in builtinCombs <> cs + srcCombs = builtinCombs <> cs combs :: EnumMap Word64 (RCombs Val) combs = srcCombs @@ -1036,12 +1076,15 @@ buildSCache :: EnumMap Word64 Reference -> Word64 -> Word64 -> + Word64 -> Map Reference (SuperGroup Reference Symbol) -> Map Reference Word64 -> Map Reference Word64 -> + BM.BiMap ANF.RecordSchema ANF.RecordRef -> Map Reference (Set Reference) -> + RecordFieldMappings -> StoredCache -buildSCache crsrc cssrc cacheableCombs optsrc trsrc ftm fty int rtmsrc rtysrc sndbx = +buildSCache crsrc cssrc cacheableCombs optsrc trsrc ftm fty frs int rtmsrc rtysrc rsLookup sndbx rfm = SCache cs crs @@ -1050,10 +1093,13 @@ buildSCache crsrc cssrc cacheableCombs optsrc trsrc ftm fty int rtmsrc rtysrc sn trs ftm fty + frs int rtm (restrictTyR rtysrc) + rsLookup (restrictTmR sndbx) + rfm where termRefs = Map.keysSet int @@ -1096,10 +1142,13 @@ standalone cc init = <*> readTVarIO (tagRefs cc) <*> readTVarIO (freshTm cc) <*> readTVarIO (freshTy cc) + <*> readTVarIO (freshRecSchema cc) <*> (readTVarIO (intermed cc) >>= traceNeeded rinit) <*> readTVarIO (refTm cc) <*> readTVarIO (refTy cc) + <*> readTVarIO (recordRefs cc) <*> readTVarIO (sandbox cc) + <*> readTVarIO (recordFieldMappings cc) Nothing -> die [] $ "standalone: unknown combinator: " ++ show init diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 16a880d2c66..48d21d86f8f 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -9,6 +9,10 @@ module Unison.Runtime.MCode ( Args' (..), Args (..), + FieldRef (..), + RecordShape (..), + recordShape, + recordShapeFrom, RefNums (..), MLit (..), GInstr (..), @@ -33,6 +37,9 @@ module Unison.Runtime.MCode GBranch (..), Branch, RBranch, + RecordFieldMappings (..), + emptyRecordFieldMappings, + convertFieldNamesToRefs, emitCombs, emitComb, resolveCombs, @@ -40,6 +47,7 @@ module Unison.Runtime.MCode absurdCombs, emptyRNs, argsToLists, + argsToArgs', countArgs, combRef, combDeps, @@ -49,18 +57,27 @@ module Unison.Runtime.MCode ) where +import Control.Monad.RWS +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT) import Data.Bifoldable (Bifoldable (..)) import Data.Bifunctor (Bifunctor, bimap, first) import Data.Bitraversable (Bitraversable (..), bifoldMapDefault, bimapDefault) import Data.Bits (shiftL, shiftR, (.|.)) import Data.Coerce +import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Map.Strict qualified as M import Data.Primitive.PrimArray import Data.Primitive.PrimArray qualified as PA +import Data.Semigroup (Max (..)) import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as Text +import Data.Traversable (for) +import Data.Vector (Vector) +import Data.Vector qualified as V import Data.Void (Void, absurd) import Data.Word (Word16, Word64) import GHC.Stack (HasCallStack) @@ -97,8 +114,11 @@ import Unison.Runtime.ANF import Unison.Runtime.ANF qualified as ANF import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName) import Unison.Runtime.InternalError (internalBug) +import Unison.Util.BiMap (BiMap) +import Unison.Util.BiMap qualified as BiMap import Unison.Util.Bytes (Bytes) import Unison.Util.EnumContainers as EC +import Unison.Util.Monoid (foldMapM) import Unison.Util.Text (Text) import Unison.Var (Var) @@ -279,6 +299,85 @@ data Args | VArgV !Int deriving (Show, Eq, Ord) +argsToArgs' :: Args -> Args' +argsToArgs' = \case + ZArgs -> ArgN PA.emptyPrimArray + VArg1 i -> Arg1 i + VArg2 i j -> Arg2 i j + VArgR i l -> ArgR i l + VArgN us -> ArgN us + VArgV n -> ArgR 0 n +{-# INLINEABLE argsToArgs' #-} + +-- | Efficient mapping for record field names +newtype FieldRef = FieldRef Word64 + deriving newtype (Show, Eq, Ord, Enum, EnumKey) + +-- | The shape of a record: which fields it has, and where each one sits in a +-- record value's slots. +-- +-- One of these is built per record-construction site and is carried by every +-- value built there. Reaching it from the value is what lets `Eq` and +-- `compareClosure` -- which are pure, with no access to the code cache -- +-- order two records of *different* shapes by field name. That case is +-- reachable: two records with different fields can be compared once they are +-- wrapped in `Any`, which erases their types. +data RecordShape = RecordShape + { -- | Interned id for this field set. Not used for ordering: it is handed + -- out in allocation order, which is why ordering goes through + -- 'shapeFields' instead. + shapeRef :: !ANF.RecordRef, + -- | The record's field names, ascending. Slot @i@ of a record value holds + -- the value of @shapeFields ! i@. + shapeFields :: !(Vector ANF.FieldName), + -- | Slot index of each field, for 'RecUnpack'. + shapePositions :: !(EC.EnumMap FieldRef Int) + } + deriving stock (Show) + +-- | Records are equal and ordered by field name, never by 'shapeRef', so that +-- the result doesn't depend on the order field names happened to be interned. +instance Eq RecordShape where + s1 == s2 = shapeFields s1 == shapeFields s2 + +instance Ord RecordShape where + compare s1 s2 = compare (shapeFields s1) (shapeFields s2) + +-- | Build the shape for a record schema from already-interned field names. +-- Returns Nothing if any of them is unknown, which shouldn't happen for a +-- schema that is itself already interned. +recordShapeFrom :: + RecordFieldMappings -> + ANF.RecordRef -> + ANF.RecordSchema -> + Maybe RecordShape +recordShapeFrom (RecordFieldMappings _ m) ref (ANF.RecordSchema fields) = do + let names = V.fromList (Set.toAscList fields) + refs <- traverse (\n -> BiMap.lookupL n m) names + pure + RecordShape + { shapeRef = ref, + shapeFields = names, + shapePositions = EC.mapFromList (zip (V.toList refs) [0 ..]) + } + +-- | Build the shape for a record schema, assigning a 'FieldRef' to any field +-- name not yet seen. +recordShape :: + (MonadState RecordFieldMappings m) => + ANF.RecordRef -> + ANF.RecordSchema -> + m RecordShape +recordShape ref (ANF.RecordSchema fields) = do + let names = V.fromList (Set.toAscList fields) + refs <- convertFieldNamesToRefs names + pure + RecordShape + { shapeRef = ref, + shapeFields = names, + shapePositions = EC.mapFromList (zip (V.toList refs) [0 ..]) + } + argsToLists :: Args -> [Int] argsToLists = \case ZArgs -> [] @@ -538,6 +637,21 @@ data GInstr comb !Reference -- data type reference !PackedTag -- tag !Args -- arguments to pack + | -- Pack a record type into a closure and place it on the stack. + -- The args arrive in ascending field-name order, matching the shape's + -- slot order. + RecPack + !RecordShape + -- values to pack + !Args + | -- Unpack a set of fields from a record on the boxed stack. + -- It may be a subset of the record's fields, so the slot each one sits in + -- is read from the shape carried by the value rather than baked in here: + -- one pattern can match records of several different shapes, in which a + -- given field sits at a different slot. + RecUnpack + !(Vector FieldRef {- fields to unpack -}) + !Int {- index of record on boxed stack -} | -- Push a particular value onto the appropriate stack Lit !MLit -- value to push onto the stack | -- Print a value on the unboxed stack @@ -658,17 +772,20 @@ data CombIx combRef :: CombIx -> Reference combRef (CIx r _ _) = r --- dnum maps type references to their number in the runtime --- cnum maps combinator references to their number --- anum maps combinator references to their main arity +-- data RefNums = RN - { dnum :: Reference -> Word64, + { -- maps type references to their number in the runtime + dnum :: Reference -> Word64, + -- cnum maps combinator references to their number cnum :: Reference -> Word64, - anum :: Reference -> Maybe Int + -- anum maps combinator references to their main arity + anum :: Reference -> Maybe Int, + -- Map record schemas into their runtime reference + recNum :: ANF.RecordSchema -> ANF.RecordRef } emptyRNs :: RefNums -emptyRNs = RN mt mt (const Nothing) +emptyRNs = RN mt mt (const Nothing) mt where mt _ = internalBug [] "RefNums: empty" @@ -882,14 +999,16 @@ emitCombs :: Reference -> Word64 -> SuperGroup Reference v -> - EnumMap Word64 Comb -emitCombs rns grpr grpn (Rec grp ent) = - emitComb rns grpr grpn rec (0, ent) <> aux + State RecordFieldMappings (EnumMap Word64 Comb) +emitCombs rns grpr grpn (Rec grp ent) = do + es <- emitComb rns grpr grpn rec (0, ent) + auxEs <- aux + pure $ es <> auxEs where (rvs, cmbs) = unzip grp ixs = map (`shiftL` 16) [1 ..] rec = M.fromList $ zip rvs ixs - aux = foldMap (emitComb rns grpr grpn rec) (zip ixs cmbs) + aux = foldMapM (emitComb rns grpr grpn rec) (zip ixs cmbs) -- | lazily replace all references to combinators with the combinators themselves, -- tying the knot recursively when necessary. @@ -938,40 +1057,68 @@ instance Applicative Counted where pure = C 0 C s0 f <*> C s1 x = C (max s0 s1) (f x) -newtype Emit a - = EM (Word64 -> (EC.EnumMap Word64 Comb, Counted a)) - deriving (Functor) +instance Monad Counted where + C s0 x >>= f = + let C s1 y = f x + in C (max s0 s1) y + +data RecordFieldMappings + = RecordFieldMappings + (FieldRef {- next unassigned ref -}) + (BiMap ANF.FieldName FieldRef {- mapping from field name to field ref -}) + deriving stock (Show, Eq, Ord) + +-- | No field names assigned yet. The starting state for `emitCombs` and +-- friends, in the same spirit as `emptyRNs`. +emptyRecordFieldMappings :: RecordFieldMappings +emptyRecordFieldMappings = RecordFieldMappings (FieldRef 0) mempty + +-- | Note that the Ord instance for Field Refs is arbitrary and not tied to the field name Ord instance. +convertFieldNamesToRefs :: (MonadState RecordFieldMappings m, Traversable f) => f ANF.FieldName -> m (f FieldRef) +convertFieldNamesToRefs names = for names \name -> do + RecordFieldMappings next m <- get + case BiMap.lookupL name m of + Just fr -> pure fr + Nothing -> do + put $ RecordFieldMappings (succ next) (BiMap.insert name next m) + pure next -runEmit :: Word64 -> Emit a -> EC.EnumMap Word64 Comb -runEmit w (EM e) = fst $ e w +newtype Emit a + = EM ((ReaderT Word64 (WriterT (EC.EnumMap Word64 Comb, Max Int) (State RecordFieldMappings))) a) + deriving newtype (Functor, Applicative, Monad, MonadReader Word64, MonadWriter (EC.EnumMap Word64 Comb, Max Int), MonadState RecordFieldMappings) -instance Applicative Emit where - pure = EM . pure . pure . pure - EM ef <*> EM ex = EM $ (liftA2 . liftA2) (<*>) ef ex +runEmit :: Word64 -> Emit a -> State RecordFieldMappings (EC.EnumMap Word64 Comb) +runEmit w (EM e) = + e + & flip runReaderT w + & runWriterT + <&> \(_a, (ec, _)) -> ec counted :: Counted a -> Emit a -counted = EM . pure . pure - -onCount :: (Counted a -> Counted b) -> Emit a -> Emit b -onCount f (EM e) = EM $ fmap f <$> e +counted (C n a) = tell (mempty, Max n) *> pure a letIndex :: Word16 -> Word64 -> Word64 letIndex l c = c .|. fromIntegral l record :: Ctx v -> Word16 -> Emit Section -> Emit (Word64, Comb) -record ctx l (EM es) = EM $ \c -> - let (m, C sz s) = es c - na = countCtx0 0 ctx +record ctx l (EM es) = EM do + c <- ask + (s, (_m, Max sz)) <- listen es + let na = countCtx0 0 ctx n = letIndex l c comb = Lam na sz s - in (EC.mapInsert n comb m, C sz (n, comb)) + tell (EC.mapSingleton n comb, 0) + pure $ (n, comb) recordTop :: [v] -> Word16 -> Emit Section -> Emit () -recordTop vs l (EM e) = EM $ \c -> - let (m, C sz s) = e c - na = length vs +recordTop vs l (EM e) = EM do + c <- ask + (s, (_m, Max sz)) <- listen e + let na = length vs n = letIndex l c - in (EC.mapInsert n (Lam na sz s) m, C sz ()) + lam = Lam na sz s + tell (EC.mapSingleton n lam, 0) + pure () -- Counts the stack space used by a context and annotates a value -- with it. @@ -993,14 +1140,17 @@ emitComb :: Word64 -> RCtx v -> (Word64, SuperNormal Reference v) -> - EC.EnumMap Word64 Comb + State RecordFieldMappings (EC.EnumMap Word64 Comb) emitComb rns grpr grpn rec (n, Lambda ccs (TAbss vs bd)) = runEmit n . recordTop vs 0 $ emitSection rns grpr grpn rec (ctx vs ccs) bd addCount :: Int -> Emit a -> Emit a -addCount i = onCount $ \(C sz x) -> C (sz + i) x +addCount i (EM m) = EM $ do + (a, (_m, Max n)) <- listen m + tell (mempty, Max $ n + i) + pure a -- Emit a machine code section from an ANF term emitSection :: @@ -1056,8 +1206,13 @@ emitSection _ _ grpn _ ctx (TFOp p args) = . VArgV $ countBlock ctx emitSection rns grpr grpn rec ctx (TApp f args) = - emitClosures grpr grpn rec ctx args $ \ctx as -> - countCtx ctx $ emitFunction rns grpr grpn rec ctx f as + emitClosures grpr grpn rec ctx args $ \ctx as -> do + -- Record construction needs a shape, whose creation may intern new field + -- names, so it has to happen here rather than inside pure `emitFunction`. + mshape <- case f of + FRec rs -> Just <$> recordShape (recNum rns rs) rs + _ -> pure Nothing + countCtx ctx $ emitFunction rns mshape grpr grpn rec ctx f as emitSection rns grpr grpn rec ctx (TLocal v bo) | Just (i, BX) <- ctxResolve ctx v = Ins (InLocal i) @@ -1078,6 +1233,12 @@ emitSection rns grpr grpn rec ctx (TMatch v bs) MatchData r cs df <- bs = DMatch (Just r) i <$> emitDataMatching r rns grpr grpn rec ctx cs df + | Just (i, BX) <- ctxResolve ctx v, + MatchRec (ANF.RecordSchema fields) (TAbss vs bd) <- bs = do + fieldRefs <- convertFieldNamesToRefs (V.fromList $ Set.toList fields) + let instr = RecUnpack fieldRefs i + let newCtx = pushCtx (zip vs (repeat BX {- these are ignored -})) ctx + Ins instr <$> emitSection rns grpr grpn rec newCtx bd | Just (i, BX) <- ctxResolve ctx v, MatchRequest hs0 df <- bs, hs <- mapFromList $ first (dnum rns) <$> hs0 = @@ -1175,6 +1336,8 @@ emitSection _ _ _ _ _ tm = emitFunction :: (Var v) => RefNums -> + -- | the record shape, when emitting a record construction + Maybe RecordShape -> Reference -> Word64 -> -- self combinator number RCtx v -> -- recursive binding group @@ -1182,14 +1345,14 @@ emitFunction :: Func Reference v -> Args -> Section -emitFunction _ grpr grpn rec ctx (FVar v) as +emitFunction _ _mshape grpr grpn rec ctx (FVar v) as | Just (i, BX) <- ctxResolve ctx v = App False (Stk i) as | Just j <- rctxResolve rec v = let cix = CIx grpr grpn j in App False (Env cix cix) as | otherwise = emitSectionVErr v -emitFunction rns _grpr _ _ _ (FComb r) as +emitFunction rns _mshape _grpr _ _ _ (FComb r) as | Just k <- anum rns r, countArgs as == k -- exactly saturated call = @@ -1200,13 +1363,19 @@ emitFunction rns _grpr _ _ _ (FComb r) as where n = cnum rns r cix = CIx r n 0 -emitFunction rns _grpr _ _ _ (FCon r t) as = +emitFunction rns _mshape _grpr _ _ _ (FCon r t) as = Ins (Pack r (packTags rt t) as) . Yield $ VArg1 0 where rt = toEnum . fromIntegral $ dnum rns r -emitFunction rns _grpr _ _ _ (FReq r e) as = +emitFunction _ mshape _grpr _ _ _ (FRec _rs) as + | Just shape <- mshape = + Ins (RecPack shape as) + . Yield + $ VArg1 0 + | otherwise = internalBug [] "emitFunction: record construction without a shape" +emitFunction rns _mshape _grpr _ _ _ (FReq r e) as = -- Currently implementing packed calling convention for abilities -- TODO ct is 16 bits, but a is 48 bits. This will be a problem if we have -- more than 2^16 types. @@ -1216,11 +1385,11 @@ emitFunction rns _grpr _ _ _ (FReq r e) as = where a = dnum rns r rt = toEnum . fromIntegral $ a -emitFunction _ _grpr _ _ ctx (FCont k) as +emitFunction _ _mshape _grpr _ _ ctx (FCont k) as | Just (i, BX) <- ctxResolve ctx k = Jump i as | Nothing <- ctxResolve ctx k = emitFunctionVErr k | otherwise = internalBug [] $ "emitFunction: continuations are boxed" -emitFunction _ _grpr _ _ _ (FPrim _) _ = +emitFunction _ _mshape _grpr _ _ _ (FPrim _) _ = internalBug [] "emitFunction: impossible" countBlock :: Ctx v -> Int @@ -1242,6 +1411,7 @@ matchCallingError cc b = "(" ++ show cc ++ "," ++ brs ++ ")" | MatchSum _ <- b = "MatchSum" | MatchText _ _ <- b = "MatchText" | MatchBytes _ _ <- b = "MatchBytes" + | MatchRec _ _ <- b = "MatchRec" emitSectionVErr :: (Var v, HasCallStack) => v -> a emitSectionVErr v = @@ -1283,6 +1453,9 @@ emitLet rns _ grpn _ _ _ ctx (TApp (FCon r n) args) = fmap (Ins . Pack r (packTags rt n) $ emitArgs grpn ctx args) where rt = toEnum . fromIntegral $ dnum rns r +emitLet rns _ grpn _ _ _ ctx (TApp (FRec rs) args) = \es -> do + shape <- recordShape (recNum rns rs) rs + fmap (Ins . RecPack shape $ emitArgs grpn ctx args) es emitLet _ _ grpn _ _ _ ctx (TApp (FPrim p) args) = fmap (Ins . either emitPOp emitFOp p $ emitArgs grpn ctx args) emitLet _ _ _ _ _ _ ctx (TDiscard v) diff --git a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs index 1dc69d8d752..6b0d0529d7a 100644 --- a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs @@ -172,6 +172,8 @@ data InstrT | KeepAliveT | NewForeignPtrT | AddFinalizerT + | RecPackT + | RecUnpackT instance Tag InstrT where tag2word Prim1T = 0 @@ -196,6 +198,8 @@ instance Tag InstrT where tag2word KeepAliveT = 21 tag2word NewForeignPtrT = 22 tag2word AddFinalizerT = 23 + tag2word RecPackT = 24 + tag2word RecUnpackT = 25 word2tag 0 = pure Prim1T word2tag 1 = pure Prim2T @@ -219,6 +223,8 @@ instance Tag InstrT where word2tag 21 = pure KeepAliveT word2tag 22 = pure NewForeignPtrT word2tag 23 = pure AddFinalizerT + word2tag 24 = pure RecPackT + word2tag 25 = pure RecUnpackT word2tag n = unknownTag "InstrT" n putInstr :: GInstr cix -> Builder @@ -233,6 +239,8 @@ putInstr = \case (Name r a) -> putTag NameT <> putRef r <> putArgs a (Info s) -> putTag InfoT <> putString s (Pack r w a) -> putTag PackT <> putReference r <> putPackedTag w <> putArgs a + (RecPack shape args) -> putTag RecPackT <> putRecordShape shape <> putArgs args + (RecUnpack fields recIndex) -> putTag RecUnpackT <> putFoldable putFieldRef fields <> pInt recIndex (Lit l) -> putTag LitT <> putLit l (Print i) -> putTag PrintT <> pInt i (Reset s nh ah) -> @@ -255,6 +263,19 @@ putInstr = \case -- same for DLL calls; those happen exclusively at runtime error "putInstr: Unexpected serialized DLLCall" +putRecordShape :: RecordShape -> Builder +putRecordShape (RecordShape ref fields positions) = + putRecordRef ref + <> putFoldable putText fields + <> putEnumMap putFieldRef pInt positions + +getRecordShape :: (PrimBase m) => Get m RecordShape +getRecordShape = + RecordShape + <$> getRecordRef + <*> getVector getText + <*> getEnumMap getFieldRef gInt + getInstr :: (PrimBase m) => Get m Instr getInstr = getTag >>= \case @@ -280,6 +301,8 @@ getInstr = NewForeignPtrT -> NewForeignPtr <$> gInt <*> gInt AddFinalizerT -> AddFinalizer <$> gInt <*> gInt SandboxingFailureT -> error "getInstr: Unexpected serialized Sandboxing Failure" + RecPackT -> RecPack <$> getRecordShape <*> getArgs + RecUnpackT -> RecUnpack <$> getVector getFieldRef <*> gInt data ArgsT = ZArgsT @@ -323,6 +346,12 @@ getArgs = ArgNT -> VArgN <$> getIntArr ArgVT -> VArgV <$> gInt +putFieldRef :: FieldRef -> Builder +putFieldRef (FieldRef r) = putVarInt r + +getFieldRef :: (PrimBase m) => Get m FieldRef +getFieldRef = FieldRef <$> getVarInt + data RefT = StkT | EnvT | DynT instance Tag RefT where diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 2f2dcaebbb0..4e95f99fd97 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -79,6 +79,7 @@ import Unison.Runtime.ANF.Optimize qualified as ANF import Unison.Runtime.ANF.Serialize (serializeCode, deserializeCode) #endif import Data.Text qualified as Text +import Data.Vector qualified as V import Unison.Runtime.Array as PA import Unison.Runtime.Builtin hiding (unitValue) import Unison.Runtime.Exception (RuntimeExn (BU, PE), die, exn) @@ -101,6 +102,7 @@ import Unison.Runtime.Stack import Unison.Runtime.TypeTags qualified as TT import Unison.Symbol (Symbol) import Unison.Type qualified as Rf +import Unison.Util.BiMap qualified as BM import Unison.Util.Bytes qualified as Bytes import Unison.Util.EnumContainers as EC import Unison.Util.Pretty qualified as P @@ -426,6 +428,25 @@ exec _ henv !_activeThreads !stk !k _ (Pack r t args) = do stk <- bump stk bpoke stk clo pure (False, henv, stk, k) +exec _ henv !_activeThreads !stk !k _ (RecPack shape args) = do + clo <- buildRec stk shape args + stk <- bump stk + bpoke stk clo + pure (False, henv, stk, k) +exec _ henv !_activeThreads !stk !k _ (RecUnpack desiredFields recIndex) = do + bpeekOff stk recIndex >>= \case + RecordG shape vals -> do + -- The slot a field sits in depends on the *value's* shape, not the + -- pattern's: one pattern matches records of several shapes, in which a + -- given field may sit at a different slot. + let positions = shapePositions shape + let seg = + V.toList desiredFields + <&> (\f -> vals V.! (positions EC.! f)) + & segFromList + stk' <- dumpSeg stk seg S + pure (False, henv, stk', k) + _ -> die [] "RecUnpack called on non-record value" exec _ henv !_activeThreads !stk !k _ (Print i) = do t <- peekOffBi stk i Tx.putStrLn (Util.Text.toText t) @@ -1125,6 +1146,15 @@ buildData !stk !r !t (VArgV i) = do l = fsize stk - i {-# INLINE buildData #-} +-- | Pack some number of args into a record value of the given shape. The args +-- are emitted in ascending field-name order, which is the shape's slot order, +-- so this is a straight copy. +buildRec :: Stack -> RecordShape -> Args -> IO Closure +buildRec !stk shape args = do + seg <- augSeg I stk nullSeg (Just $ argsToArgs' args) + pure . RecordG shape . V.fromList $ segToList seg +{-# INLINE buildRec #-} + dumpDataValNoTag :: Stack -> Val -> @@ -1407,6 +1437,7 @@ dataBranchClosureError mrf clo = UnboxedTypeTag NatTag -> "a natural number" Foreign (foreignRef -> rf) -> "a builtin value of type `" <> prettyRef rf <> "`" + RecordC {} -> "a record" dataBranchBranchError :: MBranch -> IO a dataBranchBranchError br = @@ -1593,8 +1624,12 @@ cacheAdd0 :: IO () cacheAdd0 ntys0 (normalizeCodes -> termSuperGroups) sands cc = do let toAdd = M.fromList (termSuperGroups <&> second codeGroup) + -- Which record schemas this code needs is a property of the code, so read it + -- off the groups rather than making every caller work it out. + let recSchemas = foldMap (ANF.groupRecordSchemas . codeGroup . snd) termSuperGroups (unresolvedCacheableCombs, unresolvedNonCacheableCombs) <- atomically $ do have <- readTVar (intermed cc) + haveRecSchemas <- readTVar (recordRefs cc) let new = M.difference toAdd have let sz = fromIntegral $ M.size new let rs = M.keys new @@ -1608,12 +1643,20 @@ cacheAdd0 ntys0 (normalizeCodes -> termSuperGroups) sands cc = do stateTVar (optInfos cc) $ haff . ANF.optimize (fmap replace new) rty <- addRefs (freshTy cc) (refTy cc) (tagRefs cc) ntys0 ntm <- stateTVar (freshTm cc) $ \i -> (i, i + sz) + let newRecSchemas = recSchemas `Set.difference` (BM.keysSetL haveRecSchemas) + let numNewRecSchemas = fromIntegral $ Set.size newRecSchemas + nrs <- stateTVar (freshRecSchema cc) $ \i -> (i, i + numNewRecSchemas) + let newRecSchemaMap = BM.fromList $ zip (Set.toList newRecSchemas) (ANF.RecordRef <$> [nrs ..]) rtm <- updateMap (M.fromList $ zip rs [ntm ..]) (refTm cc) + rrLookup <- updateMap newRecSchemaMap (recordRefs cc) + -- Field names no longer need pre-registering here: building a record's + -- shape during emit interns any name it hasn't seen. + oldRfms <- readTVar (recordFieldMappings cc) -- check for missing references let arities = fmap (head . ANF.arities) int <> builtinArities - rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) (flip M.lookup arities) - combinate :: Word64 -> (Reference, SuperGroup Reference Symbol) -> (Word64, EnumMap Word64 Comb) - combinate n (r, g) = (n, emitCombs rns r n g) + rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) (flip M.lookup arities) (recordRefLookup rrLookup) + combinate :: Word64 -> (Reference, SuperGroup Reference Symbol) -> State RecordFieldMappings (Word64, EnumMap Word64 Comb) + combinate n (r, g) = (n,) <$> emitCombs rns r n g let combRefUpdates = (mapFromList $ zip [ntm ..] rs) let combIdFromRefMap = (M.fromList $ zip rs [ntm ..]) let newCacheableCombs = @@ -1626,13 +1669,17 @@ cacheAdd0 ntys0 (normalizeCodes -> termSuperGroups) sands cc = do ) & EC.setFromList newCombRefs <- updateMap combRefUpdates (combRefs cc) - (unresolvedNewCombs, unresolvedCacheableCombs, unresolvedNonCacheableCombs, updatedCombs) <- stateTVar (combs cc) \oldCombs -> - let unresolvedNewCombs :: EnumMap Word64 (GCombs any CombIx) + (newRFMs, unresolvedNewCombs, unresolvedCacheableCombs, unresolvedNonCacheableCombs, updatedCombs) <- stateTVar (combs cc) \oldCombs -> + let (emittedCombs, newRFMs) = + zipWith combinate [ntm ..] (M.toList opt) + & sequenceA + & flip runState oldRfms + unresolvedNewCombs :: EnumMap Word64 (GCombs any CombIx) unresolvedNewCombs = - absurdCombs - . sanitizeCombsOfForeignFuncs (sandboxed cc) sandboxedForeignFuncs - . mapFromList - $ zipWith combinate [ntm ..] (M.toList opt) + emittedCombs + & mapFromList + & sanitizeCombsOfForeignFuncs (sandboxed cc) sandboxedForeignFuncs + & absurdCombs (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = EC.mapToList unresolvedNewCombs & foldMap \(w, gcombs) -> if EC.member w newCacheableCombs @@ -1641,10 +1688,11 @@ cacheAdd0 ntys0 (normalizeCodes -> termSuperGroups) sands cc = do newCombs :: EnumMap Word64 MCombs newCombs = resolveCombs (Just oldCombs) $ unresolvedNewCombs updatedCombs = newCombs <> oldCombs - in ((unresolvedNewCombs, unresolvedCacheableCombs, unresolvedNonCacheableCombs, updatedCombs), updatedCombs) + in ((newRFMs, unresolvedNewCombs, unresolvedCacheableCombs, unresolvedNonCacheableCombs, updatedCombs), updatedCombs) nsc <- updateMap unresolvedNewCombs (srcCombs cc) nsn <- updateMap (M.fromList sands) (sandbox cc) ncc <- updateMap newCacheableCombs (cacheableCombs cc) + writeTVar (recordFieldMappings cc) newRFMs -- Now that the code cache is primed with everything we need, -- we can pre-evaluate the top-level constants. pure $ int `seq` rtm `seq` newCombRefs `seq` updatedCombs `seq` nsn `seq` ncc `seq` nsc `seq` (unresolvedCacheableCombs, unresolvedNonCacheableCombs) @@ -1885,6 +1933,11 @@ reflectValue0 rty rtm = goV0 DataG _ t seg -> do r <- resolveTy rty $ TT.typeTag t ANF.Data r (maskTags t) <$> goVs seg + RecordC shape vals -> + -- The shape carries the field names, in the same ascending order + -- as the slots, which is also the order `reifyValue` expects. + ANF.Record (ANF.RecordSchema (S.fromList (V.toList (shapeFields shape)))) + <$> traverse goV (V.toList vals) Captured k _ segs -> ANF.Cont <$> goVs segs <*> goK k Foreign f -> ANF.BLit <$> goF f @@ -1953,22 +2006,24 @@ reifyValue cc val = do atomically $ do combs <- readTVar (combs cc) rtm <- readTVar (refTm cc) + recRefLookup <- readTVar (recordRefs cc) + rfms <- readTVar (recordFieldMappings cc) case S.toList $ S.filter (`M.notMember` rtm) tmLinks of [] -> do newTy <- addRefs (freshTy cc) (refTy cc) (tagRefs cc) tyLinks - pure . Right $ (combs, newTy, rtm) + pure . Right $ (combs, newTy, rtm, recRefLookup, rfms) l -> pure (Left l) traverse (\rfs -> reifyValue1 rfs val) erc reifyValue1 :: - (EnumMap Word64 MCombs, M.Map Reference Word64, M.Map Reference Word64) -> + (EnumMap Word64 MCombs, M.Map Reference Word64, M.Map Reference Word64, BM.BiMap ANF.RecordSchema ANF.RecordRef, RecordFieldMappings) -> Referenced ANF.Value -> IO Val reifyValue1 tup (Plain v) = reifyValue0 tup v -reifyValue1 (combs, rty0, rtm0) (WithRefs tys tms v) = do +reifyValue1 (combs, rty0, rtm0, rrLookup, rfms) (WithRefs tys tms v) = do let rty = HM.fromList . mapMaybe procTypeRefs $ zip [0 ..] tys rtm = HM.fromList . mapMaybe procTermRefs $ zip [0 ..] tms - reifyValue0Canon combs tys tms rty rtm v + reifyValue0Canon combs tys tms rty rtm rrLookup rfms v where procTypeRefs (i, r) = (RefNum i,) <$> M.lookup r rty0 procTermRefs (i, r) = @@ -1981,9 +2036,11 @@ reifyValue0Canon :: [Reference] -> HM.HashMap RefNum Word64 -> HM.HashMap RefNum Word64 -> + BM.BiMap ANF.RecordSchema ANF.RecordRef -> + RecordFieldMappings -> ANF.Value RefNum -> IO Val -reifyValue0Canon combs tys tms rty rtm = goV +reifyValue0Canon combs tys tms rty rtm rrLookup rfms = goV where err s = "reifyValue: cannot restore value: " ++ s @@ -2040,6 +2097,17 @@ reifyValue0Canon combs tys tms rty rtm = goV t <- flip packTags (fromIntegral t0) . fromIntegral <$> refTy rn rf <- ixTy rn boxedVal . formDataReplaced rf t <$> goVs vs + goV (ANF.Record rs vals) = do + rref <- case BM.lookupL rs rrLookup of + Just r -> pure r + Nothing -> die [] . err $ "unknown record schema reference: " ++ show rs + shape <- case recordShapeFrom rfms rref rs of + Just shape -> pure shape + Nothing -> die [] . err $ "record schema with un-interned fields: " ++ show rs + -- `putValue` writes the values in ascending field-name order, which is + -- the shape's slot order, so no reordering is needed. + vals' <- goVs vals + pure . boxedVal . RecordG shape . V.fromList $ segToList vals' goV (ANF.Cont vs k) = do k' <- goK k vs' <- goVs vs @@ -2098,10 +2166,10 @@ reifyValue0Canon combs tys tms rty rtm = goV goL (ANF.BigNat n) = pure $ encodeVal n reifyValue0 :: - (EnumMap Word64 MCombs, M.Map Reference Word64, M.Map Reference Word64) -> + (EnumMap Word64 MCombs, M.Map Reference Word64, M.Map Reference Word64, BM.BiMap ANF.RecordSchema ANF.RecordRef, RecordFieldMappings) -> ANF.Value Reference -> IO Val -reifyValue0 (combs, rty, rtm) = goV +reifyValue0 (combs, rty, rtm, rrLookup, rfms) = goV where err s = "reifyValue: cannot restore value: " ++ s refTy r @@ -2137,6 +2205,17 @@ reifyValue0 (combs, rty, rtm) = goV goV (ANF.Data r t0 vs) = do t <- flip packTags (fromIntegral t0) . fromIntegral <$> refTy r boxedVal . formDataReplaced r t <$> goVs vs + goV (ANF.Record rs vals) = do + rref <- case BM.lookupL rs rrLookup of + Just r -> pure r + Nothing -> die [] . err $ "unknown record schema reference: " ++ show rs + shape <- case recordShapeFrom rfms rref rs of + Just shape -> pure shape + Nothing -> die [] . err $ "record schema with un-interned fields: " ++ show rs + -- `putValue` writes the values in ascending field-name order, which is + -- the shape's slot order, so no reordering is needed. + vals' <- goVs vals + pure . boxedVal . RecordG shape . V.fromList $ segToList vals' goV (ANF.Cont vs k) = do k' <- goK k vs' <- goVs vs diff --git a/unison-runtime/src/Unison/Runtime/Machine/Types.hs b/unison-runtime/src/Unison/Runtime/Machine/Types.hs index cae89391538..8070315f462 100644 --- a/unison-runtime/src/Unison/Runtime/Machine/Types.hs +++ b/unison-runtime/src/Unison/Runtime/Machine/Types.hs @@ -21,6 +21,7 @@ import GHC.Event (getSystemTimerManager, registerTimeout) #else import System.CPUTime #endif +import Control.Monad.State.Strict import Unison.Builtin.Decls (ioFailureRef) import Unison.Prelude import Unison.Reference (Reference, isBuiltin) @@ -33,15 +34,18 @@ import Unison.Runtime.ANF foldGroupLinks, valueLinks, ) +import Unison.Runtime.ANF qualified as ANF import Unison.Runtime.ANF.Optimize (OptInfos) import Unison.Runtime.Builtin import Unison.Runtime.Exception qualified as Exception -import Unison.Runtime.InternalError (CompileExn (CE)) +import Unison.Runtime.InternalError (CompileExn (CE), internalBug) import Unison.Runtime.MCode import Unison.Runtime.Profiling import Unison.Runtime.Referenced import Unison.Runtime.Stack import Unison.Symbol +import Unison.Util.BiMap (BiMap) +import Unison.Util.BiMap qualified as BM import Unison.Util.EnumContainers as EC import Unison.Util.Text as UText @@ -81,6 +85,12 @@ refLookup s m r | otherwise = error $ "refLookup:" ++ s ++ ": unknown reference: " ++ show r +recordRefLookup :: BM.BiMap ANF.RecordSchema ANF.RecordRef -> ANF.RecordSchema -> ANF.RecordRef +recordRefLookup m r + | Just rr <- BM.lookupL r m = rr + | otherwise = + internalBug [] $ "recordRefLookup: unknown record schema: " ++ show r + -- A class parameterizing profiling. The interpreter loop can be -- specialized to a class, which allows the same code to be used for both -- normal and profiling execution without sacrificing performance. If @@ -173,10 +183,13 @@ data CCache prof = CCache tagRefs :: TVar (EnumMap Word64 Reference), freshTm :: TVar Word64, freshTy :: TVar Word64, + freshRecSchema :: TVar Word64, intermed :: TVar (M.Map Reference (SuperGroup Reference Symbol)), refTm :: TVar (M.Map Reference Word64), refTy :: TVar (M.Map Reference Word64), - sandbox :: TVar (M.Map Reference (Set Reference)) + recordRefs :: TVar (BiMap ANF.RecordSchema ANF.RecordRef), + sandbox :: TVar (M.Map Reference (Set Reference)), + recordFieldMappings :: TVar RecordFieldMappings } refNumsTm :: CCache prof -> IO (M.Map Reference Word64) @@ -202,23 +215,35 @@ baseCCache sandboxed = do <*> newTVarIO builtinTypeBackref <*> newTVarIO ftm <*> newTVarIO fty + <*> newTVarIO frs <*> newTVarIO mempty <*> newTVarIO builtinTermNumbering <*> newTVarIO builtinTypeNumbering + <*> newTVarIO builtinFieldNumbering <*> newTVarIO baseSandboxInfo + <*> newTVarIO rfm where + builtinFieldNumbering = mempty cacheableCombs = mempty noTrace _ _ = NoTrace ftm = 1 + maximum builtinTermNumbering fty = 1 + maximum builtinTypeNumbering + -- No builtin record schemas yet + frs = 1 rns = emptyRNs {dnum = refLookup "ty" builtinTypeNumbering} srcCombs :: EnumMap Word64 Combs - srcCombs = - numberedTermLookup - & mapWithKey - (\k v -> let r = builtinTermBackref ! k in emitComb @Symbol rns r k mempty (0, v)) + rfm :: RecordFieldMappings + (srcCombs, rfm) = + flip runState emptyRecordFieldMappings $ + ( numberedTermLookup + & traverseWithKey + ( \k v -> do + let r = builtinTermBackref ! k + emitComb @Symbol rns r k mempty (0, v) + ) + ) combs :: EnumMap Word64 MCombs combs = srcCombs @@ -314,18 +339,27 @@ codeValidate :: codeValidate cc tml = do rty0 <- readTVarIO (refTy cc) fty <- readTVarIO (freshTy cc) + recRefs <- readTVarIO (recordRefs cc) + frs <- readTVarIO (freshRecSchema cc) + rfms <- readTVarIO (recordFieldMappings cc) let f b r | b, M.notMember r rty0 = S.singleton r | otherwise = mempty ntys0 = (foldMap . foldMap) (foldGroupLinks f) tml ntys = M.fromList $ zip (S.toList ntys0) [fty ..] rty = ntys <> rty0 + -- Validation must not mutate the cache, so any schema this code + -- introduces gets a provisional reference above the fresh counter, and + -- the field mappings it interns are discarded along with the result. + newSchemas = (foldMap . foldMap) ANF.groupRecordSchemas tml `S.difference` BM.keysSetL recRefs + recRefs' = + BM.fromList (zip (S.toList newSchemas) (ANF.RecordRef <$> [frs ..])) <> recRefs ftm <- readTVarIO (freshTm cc) rtm0 <- readTVarIO (refTm cc) let rs = fst <$> tml rtm = rtm0 `M.union` M.fromList (zip rs [ftm ..]) - rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) (const Nothing) - combinate (n, (r, g)) = evaluate $ emitCombs rns r n g + rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) (const Nothing) (recordRefLookup recRefs') + combinate (n, (r, g)) = evaluate . fst $ runState (emitCombs rns r n g) rfms (Nothing <$ traverse_ combinate (zip [ftm ..] tml)) `catch` \(CE cs _issues perr) -> let msg = UText.pack perr diff --git a/unison-runtime/src/Unison/Runtime/Pattern.hs b/unison-runtime/src/Unison/Runtime/Pattern.hs index bbcda4e1e3f..b7d849cbd3e 100644 --- a/unison-runtime/src/Unison/Runtime/Pattern.hs +++ b/unison-runtime/src/Unison/Runtime/Pattern.hs @@ -14,7 +14,7 @@ where import Control.Monad.State (State, evalState, modify, runState, state) import Data.Containers.ListUtils (nubOrd) -import Data.List (transpose) +import Data.List (mapAccumL, transpose) import Data.Map.Strict ( fromListWith, insertWith, @@ -36,6 +36,7 @@ import Unison.Pattern import Unison.Pattern qualified as P import Unison.Prelude hiding (guard) import Unison.Reference (Reference, Reference' (Builtin, DerivedId)) +import Unison.Runtime.ANF (RecordSchema (..)) import Unison.Runtime.InternalError (internalBug) import Unison.Term hiding (Term, matchPattern) import Unison.Term qualified as Tm @@ -48,13 +49,21 @@ type Term v = Tm.Term v () -- ability in order of constructors type Cons = [Int] +-- | A list of (constructor number, number of fields), e.g. `Cons` but with constructor numberings. type NCons = [(Int, Int)] -- Maps references to the constructor information for abilities (left) -- and data types (right) type DataSpec = Map Reference (Either Cons Cons) -data PType = PData Reference | PReq (Set Reference) | Unknown +data PType + = PData Reference + | PReq (Set Reference) + | -- | The union of the fields matched by every record pattern in this + -- column. Different cases may match different subsets of a record's + -- fields, so this accumulates all of them. + PRec RecordSchema + | Unknown instance Semigroup PType where Unknown <> r = r @@ -62,6 +71,7 @@ instance Semigroup PType where t@(PData l) <> PData r | l == r = t PReq l <> PReq r = PReq (l <> r) + PRec (RecordSchema l) <> PRec (RecordSchema r) = PRec (RecordSchema (l <> r)) _ <> _ = internalBug [] "inconsistent pattern matching types" instance Monoid PType where @@ -162,18 +172,18 @@ extractVars = catMaybes . fmap extractVar -- The outer list indicates success of the match. It could be Maybe, -- but elsewhere these results are added to a list, so it is more -- convenient to yield a list here. -decomposePattern :: +decomposeDataPattern :: (Var v) => Maybe Reference -> Int -> Int -> P.Pattern v -> [[P.Pattern v]] -decomposePattern (Just rf0) t _ (P.Boolean _ b) +decomposeDataPattern (Just rf0) t _ (P.Boolean _ b) | rf0 == Rf.booleanRef, t == if b then 1 else 0 = [[]] -decomposePattern (Just rf0) t nfields p@(P.Constructor _ (ConstructorReference rf u) ps) +decomposeDataPattern (Just rf0) t nfields p@(P.Constructor _ (ConstructorReference rf u) ps) | t == fromIntegral u, rf0 == rf = if length ps == nfields @@ -181,9 +191,9 @@ decomposePattern (Just rf0) t nfields p@(P.Constructor _ (ConstructorReference r else internalBug [] err where err = - "decomposePattern: wrong number of constructor fields: " + "decomposeDataPattern: wrong number of constructor fields: " ++ show (nfields, p) -decomposePattern (Just rf0) t nfields p@(P.EffectBind _ (ConstructorReference rf u) ps pk) +decomposeDataPattern (Just rf0) t nfields p@(P.EffectBind _ (ConstructorReference rf u) ps pk) | t == fromIntegral u, rf0 == rf = if length ps + 1 == nfields @@ -191,17 +201,63 @@ decomposePattern (Just rf0) t nfields p@(P.EffectBind _ (ConstructorReference rf else internalBug [] err where err = - "decomposePattern: wrong number of ability fields: " + "decomposeDataPattern: wrong number of ability fields: " ++ show (nfields, p) -decomposePattern _ t _ (P.EffectPure _ p) +decomposeDataPattern _ t _ (P.EffectPure _ p) | t == -1 = [[p]] -decomposePattern _ _ nfields (P.Var _) = +decomposeDataPattern _ _ nfields (P.Var _) = [replicate nfields (P.Unbound (typed Pattern))] -decomposePattern _ _ nfields (P.Unbound _) = +decomposeDataPattern _ _ nfields (P.Unbound _) = [replicate nfields (P.Unbound (typed Pattern))] -decomposePattern _ _ _ (P.SequenceLiteral _ _) = - internalBug [] "decomposePattern: sequence literal" -decomposePattern _ _ _ _ = [] +decomposeDataPattern _ _ _ (P.SequenceLiteral _ _) = + internalBug [] "decomposeDataPattern: sequence literal" +decomposeDataPattern _ _ _ _ = [] + +-- Splits a record pattern, yielding its subpatterns. +-- +-- Every row is decomposed against the same schema -- the union of the fields +-- matched anywhere in this column -- and yields exactly one subpattern per +-- field of it, in ascending field order. A row that doesn't mention a field +-- gets `Unbound` there. Without this, rows matching different field subsets +-- would have different lengths and would misalign when `buildMatrix` +-- transposes the columns. +-- +-- The outer list indicates success of the match. It could be Maybe, +-- but elsewhere these results are added to a list, so it is more +-- convenient to yield a list here. +decomposeRecPattern :: + (Var v) => + Set v -> + RecordSchema -> + P.Pattern v -> + [[P.Pattern v]] +decomposeRecPattern avoid (RecordSchema fields) = \case + P.RecordLiteral _loc fieldPats -> + pure . snd $ + mapAccumL + ( \used fieldName -> case Map.lookup fieldName fieldPats of + Just p -> (used, p) + -- This row doesn't match this field, but it still needs a slot so + -- that rows matching different subsets stay aligned. It has to be + -- a variable rather than `Unbound`: by this point `prepareAs` has + -- turned every user-written `_` into a `Var`, so an `Unbound` head + -- is the marker `chooseVars` uses to skip rows that came from + -- decomposing a wildcard. + Nothing -> + let u = freshIn used (typed Pattern) + in (Set.insert u used, P.Var u) + ) + avoid + (Set.toAscList fields) + -- These are the genuine wildcard decompositions, where the whole record is + -- matched by one variable and the made-up subpatterns share a name. + P.Var _ -> pure allUnbound + P.Unbound _ -> pure allUnbound + P.SequenceLiteral _ _ -> + internalBug [] "decomposeRecPattern: sequence literal" + _ -> empty + where + allUnbound = replicate (Set.size fields) (P.Unbound (typed Pattern)) matchBuiltin :: P.Pattern a -> Maybe (P.Pattern ()) matchBuiltin (P.Var _) = Just $ P.Unbound () @@ -321,7 +377,7 @@ decomposeSeqP _ _ _ = Overlap -- constructor, the subpatterns and resulting row are yielded. A list -- is used as the result value to indicate success or failure to match, -- because these results are accumulated into a larger list elsewhere. -splitRow :: +splitDataRow :: (Var v) => v -> Maybe Reference -> @@ -329,10 +385,29 @@ splitRow :: Int -> PatternRow v -> [([P.Pattern v], PatternRow v)] -splitRow v rf t nfields (PR (break ((== v) . loc) -> (pl, sp : pr)) g b) = - decomposePattern rf t nfields sp +splitDataRow v rf t nfields (PR (break ((== v) . loc) -> (pl, sp : pr)) g b) = + decomposeDataPattern rf t nfields sp <&> \subs -> (subs, PR (pl ++ filter refutable subs ++ pr) g b) -splitRow _ _ _ _ row = [([], row)] +splitDataRow _ _ _ _ row = [([], row)] + +-- Splits a pattern row with respect to matching a variable against a +-- record type. If the row would match the record +-- the subpatterns and resulting row are yielded. A list +-- is used as the result value to indicate success or failure to match, +-- because these results are accumulated into a larger list elsewhere. +splitRecRow :: + (Var v) => + Set v -> + v -> + RecordSchema -> + PatternRow v -> + [([P.Pattern v], PatternRow v)] +splitRecRow avoid0 v schema (PR (break ((== v) . loc) -> (pl, sp : pr)) g b) = + decomposeRecPattern avoid schema sp + <&> \subs -> (subs, PR (pl ++ filter refutable subs ++ pr) g b) + where + avoid = avoid0 <> maybe mempty freeVars g <> freeVars b +splitRecRow _ _ _ row = [([], row)] -- Splits a row with respect to a variable, expecting that the -- variable will be matched against a builtin pattern (non-data type, @@ -479,17 +554,31 @@ splitMatrixSeq avoid v (PM rs) = -- Splits a matrix at a given variable with respect to a data type or -- ability match. Yields a new matrix for each constructor, with -- variables introduced and their types for each case. -splitMatrix :: +splitMatrixOnData :: (Var v) => v -> Maybe Reference -> NCons -> PatternMatrix v -> [(Int, [(v, PType)], PatternMatrix v)] -splitMatrix v rf cons (PM rs) = +splitMatrixOnData v rf cons (PM rs) = fmap (\(a, (b, c)) -> (a, b, c)) . (fmap . fmap) buildMatrix $ mmap where - mmap = fmap (\(t, fs) -> (t, splitRow v rf t fs =<< rs)) cons + mmap = fmap (\(t, fs) -> (t, splitDataRow v rf t fs =<< rs)) cons + +-- Splits a matrix at a given variable with respect to a record match. A +-- record has a single constructor, so this always yields exactly one case. +splitMatrixOnRec :: + (Var v) => + Set v -> + v -> + RecordSchema -> + PatternMatrix v -> + [(Int, [(v, PType)], PatternMatrix v)] +splitMatrixOnRec avoid v schema (PM rows) = + fmap (\(a, (b, c)) -> (a, b, c)) . (fmap . fmap) buildMatrix $ mmap + where + mmap = [(0, splitRecRow avoid v schema =<< rows)] -- Eliminates a variable from a matrix, keeping the rows that are -- _not_ specific matches on that variable (so, would potentially @@ -546,6 +635,8 @@ normalizeSeqP (P.SequenceOp a p0 op q0) = (Concat, p, P.SequenceLiteral _ qs) -> foldl (\r q -> P.SequenceOp a r Snoc q) p qs (op, p, q) -> P.SequenceOp a p op q +normalizeSeqP (P.RecordLiteral a fields) = + P.RecordLiteral a (normalizeSeqP <$> fields) normalizeSeqP p = p -- Prepares a pattern for compilation, like `preparePattern`. This @@ -558,6 +649,8 @@ prepareAs (P.As _ p) u = (useVar >>= renameTo u) *> prepareAs p u prepareAs (P.Var _) u = P.Var u <$ (renameTo u =<< useVar) prepareAs (P.Constructor _ r ps) u = do P.Constructor u r <$> traverse preparePattern ps +prepareAs (P.RecordLiteral _ fields) u = do + P.RecordLiteral u <$> traverse preparePattern fields prepareAs (P.EffectPure _ p) u = do P.EffectPure u <$> preparePattern p prepareAs (P.EffectBind _ r ps k) u = do @@ -580,8 +673,8 @@ prepareAs p u = pure $ u <$ p preparePattern :: (Var v) => P.Pattern a -> PPM v (P.Pattern v) preparePattern p = prepareAs p =<< freshVar -buildPattern :: Bool -> ConstructorReference -> [v] -> Int -> P.Pattern () -buildPattern effect r vs nfields +buildDataPattern :: Bool -> ConstructorReference -> [v] -> Int -> P.Pattern () +buildDataPattern effect r vs nfields | effect, [] <- vps = internalBug [] "too few patterns for effect bind" | effect = P.EffectBind () r (init vps) (last vps) | otherwise = P.Constructor () r vps @@ -592,6 +685,22 @@ buildPattern effect r vs nfields | otherwise = P.Var () <$ vs +-- Rebuilds a record pattern over the union schema, binding one variable per +-- field. `decomposeRecPattern` produced the variables in ascending field +-- order, so they zip directly against the schema's fields. +buildRecPattern :: RecordSchema -> [v] -> P.Pattern () +buildRecPattern (RecordSchema matchedFields) vs + | Set.size matchedFields /= length vps = + internalBug [] $ + "wrong number of patterns for record literal: expected " + ++ show (Set.size matchedFields) + ++ " but got " + ++ show (length vps) + | otherwise = + P.RecordLiteral () . Map.fromList $ zip (Set.toAscList matchedFields) vps + where + vps = P.Var () <$ vs + numberCons :: Cons -> NCons numberCons = zip [0 ..] @@ -613,42 +722,47 @@ compile :: (Var v) => DataSpec -> Ctx v -> PatternMatrix v -> Term v compile _ _ (PM []) = apps' bu [text () "pattern match failure"] where bu = ref () (Builtin "bug") -compile spec ctx m@(PM (r : rs)) +compile dataspec ctx m@(PM (r : rs)) | noMatches r = case guard r of Nothing -> body r - Just g -> iff mempty g (body r) $ compile spec ctx (PM rs) + Just g -> iff mempty g (body r) $ compile dataspec ctx (PM rs) | PData rf <- ty, rf == Rf.listRef = match () (var () v) $ - buildCaseBuiltin spec ctx + buildCaseBuiltin dataspec ctx <$> splitMatrixSeq (Map.keysSet ctx <> usedVars m) v m | PData rf <- ty, rf `member` builtinCase = match () (var () v) $ - buildCaseBuiltin spec ctx + buildCaseBuiltin dataspec ctx <$> splitMatrixBuiltin v m | PData rf <- ty = - case lookupData rf spec of + case lookupData rf dataspec of Right cons -> match () (var () v) $ - ( buildCase spec rf False cons ctx - <$> splitMatrix v (Just rf) ncons m + ( buildDataCase dataspec rf False cons ctx + <$> splitMatrixOnData v (Just rf) ncons m ) - ++ buildDefaultCase spec False needDefault ctx dm + ++ buildDefaultCase dataspec False needDefault ctx dm where needDefault = length ncons < length cons Left err -> internalBug [] err | PReq rfs <- ty = match () (var () v) $ - [ buildCasePure spec ctx tup - | tup <- splitMatrix v Nothing [(-1, 1)] m + [ buildCasePure dataspec ctx tup + | tup <- splitMatrixOnData v Nothing [(-1, 1)] m ] - ++ [ buildCase spec rf True cons ctx tup + ++ [ buildDataCase dataspec rf True cons ctx tup | rf <- Set.toList rfs, - Right cons <- [lookupAbil rf spec], - tup <- splitMatrix v (Just rf) (numberCons cons) m + Right cons <- [lookupAbil rf dataspec], + tup <- splitMatrixOnData v (Just rf) (numberCons cons) m ] + | PRec recSchema <- ty = + match () (var () v) $ + ( buildRecCase dataspec recSchema ctx + <$> splitMatrixOnRec (Map.keysSet ctx <> usedVars m) v recSchema m + ) | Unknown <- ty = internalBug [] "unknown pattern compilation type" where @@ -683,8 +797,8 @@ buildCaseBuiltin :: Ctx v -> (P.Pattern (), [(v, PType)], PatternMatrix v) -> MatchCase () (Term v) -buildCaseBuiltin spec ctx0 (p, vrs, m) = - MatchCase p Nothing . absChain' vs $ compile spec ctx m +buildCaseBuiltin dataspec ctx0 (p, vrs, m) = + MatchCase p Nothing . absChain' vs $ compile dataspec ctx m where vs = ((),) . fst <$> vrs ctx = Map.fromList vrs <> ctx0 @@ -695,8 +809,8 @@ buildCasePure :: Ctx v -> (Int, [(v, PType)], PatternMatrix v) -> MatchCase () (Term v) -buildCasePure spec ctx0 (_, vts, m) = - MatchCase pat Nothing . absChain' vs $ compile spec ctx m +buildCasePure dataspec ctx0 (_, vts, m) = + MatchCase pat Nothing . absChain' vs $ compile dataspec ctx m where vp | [] <- vts = P.Unbound () @@ -705,7 +819,7 @@ buildCasePure spec ctx0 (_, vts, m) = vs = ((),) . fst <$> vts ctx = Map.fromList vts <> ctx0 -buildCase :: +buildDataCase :: (Var v) => DataSpec -> Reference -> @@ -714,10 +828,24 @@ buildCase :: Ctx v -> (Int, [(v, PType)], PatternMatrix v) -> MatchCase () (Term v) -buildCase spec r eff cons ctx0 (t, vts, m) = - MatchCase pat Nothing . absChain' vs $ compile spec ctx m +buildDataCase dataspec r eff cons ctx0 (t, vts, m) = + MatchCase pat Nothing . absChain' vs $ compile dataspec ctx m where - pat = buildPattern eff (ConstructorReference r (fromIntegral t)) vs $ cons !! t + pat = buildDataPattern eff (ConstructorReference r (fromIntegral t)) vs $ cons !! t + vs = ((),) . fst <$> vts + ctx = Map.fromList vts <> ctx0 + +buildRecCase :: + (Var v) => + DataSpec -> + RecordSchema -> + Ctx v -> + (Int, [(v, PType)], PatternMatrix v) -> + MatchCase () (Term v) +buildRecCase dataspec rs ctx0 (_t, vts, m) = + MatchCase pat Nothing . absChain' vs $ compile dataspec ctx m + where + pat = buildRecPattern rs vs vs = ((),) . fst <$> vts ctx = Map.fromList vts <> ctx0 @@ -729,8 +857,8 @@ buildDefaultCase :: Ctx v -> PatternMatrix v -> [MatchCase () (Term v)] -buildDefaultCase spec _eff needed ctx pm - | needed = [MatchCase (Unbound ()) Nothing $ compile spec ctx pm] +buildDefaultCase dataspec _eff needed ctx pm + | needed = [MatchCase (Unbound ()) Nothing $ compile dataspec ctx pm] | otherwise = [] mkRow :: @@ -779,18 +907,22 @@ grabId :: State Word64 Word64 grabId = state $ \n -> (n, n + 1) splitPatterns :: (Var v) => DataSpec -> Term v -> Term v -splitPatterns spec0 tm = evalState (splitPatterns0 spec tm) 0 +splitPatterns dataspec0 tm = evalState (splitPatterns0 dataspec tm) 0 where - spec = Map.insert Rf.booleanRef (Right [0, 0]) spec0 + dataspec = Map.insert Rf.booleanRef (Right [0, 0]) dataspec0 -splitPatterns0 :: (Var v) => DataSpec -> Term v -> State Word64 (Term v) -splitPatterns0 spec = visit $ \case +splitPatterns0 :: + (Var v) => + DataSpec -> + Term v -> + State Word64 (Term v) +splitPatterns0 dataspec = visit $ \case Match' sc0 cs0 | ty <- determineType $ p <$> cs0 -> Just $ do - sc <- splitPatterns0 spec sc0 - cs <- (traverse . traverse) (splitPatterns0 spec) cs0 + sc <- splitPatterns0 dataspec sc0 + cs <- (traverse . traverse) (splitPatterns0 dataspec) cs0 (lv, scrut, pm) <- initialize ty sc cs - let body = compile spec (uncurry Map.singleton scrut) pm + let body = compile dataspec (uncurry Map.singleton scrut) pm pure $ case lv of Just v -> let1 False [(((), v), sc)] body _ -> body @@ -825,4 +957,5 @@ determineType = foldMap f f (P.Constructor _ r _) = PData (r ^. ConstructorReference.reference_) f (P.EffectBind _ r _ _) = PReq $ Set.singleton (r ^. ConstructorReference.reference_) f P.EffectPure {} = PReq mempty + f (P.RecordLiteral _ fields) = PRec (RecordSchema $ Map.keysSet fields) f _ = Unknown diff --git a/unison-runtime/src/Unison/Runtime/Serialize.hs b/unison-runtime/src/Unison/Runtime/Serialize.hs index fd2b8ff6a61..360dcb481c1 100644 --- a/unison-runtime/src/Unison/Runtime/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/Serialize.hs @@ -16,6 +16,7 @@ import Data.Primitive.Array indexArray, sizeofArray, ) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word64, Word8) @@ -27,6 +28,7 @@ import Unison.Hash qualified as Hash import Unison.Reference (Id' (..), Reference, Reference' (Builtin, DerivedId), pattern Derived) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.ReferentPrime (Referent' (..)) +import Unison.Runtime.ANF qualified as ANF import Unison.Runtime.Array qualified as PA import Unison.Runtime.Canonicalizer import Unison.Runtime.Exception (exn) @@ -205,6 +207,13 @@ putEnumSet pk s = getEnumSet :: (PrimBase m) => (EnumKey k) => Get m k -> Get m (EnumSet k) getEnumSet gk = setFromList <$> getList gk +getSet :: (Ord a, PrimBase m) => Get m a -> Get m (Set.Set a) +getSet getA = Set.fromList <$> getList getA +{-# INLINEABLE getSet #-} + +putSet :: (Ord a) => (a -> Builder) -> Set.Set a -> Builder +putSet putA s = putFoldable putA (Set.toAscList s) + putMaybe :: Maybe a -> (a -> Builder) -> Builder putMaybe Nothing _ = BU.word8 0 putMaybe (Just a) putA = BU.word8 1 <> putA a @@ -465,6 +474,22 @@ getConstructorReference :: (PrimBase m) => Get m ConstructorReference getConstructorReference = ConstructorReference <$> getReference <*> getLength +getRecordSchema :: (PrimBase m) => Get m ANF.RecordSchema +getRecordSchema = do + fields <- getList getText + pure $ ANF.RecordSchema (Set.fromList fields) + +putRecordSchema :: ANF.RecordSchema -> Builder +putRecordSchema (ANF.RecordSchema fields) = + putFoldable putText (Set.toAscList fields) + +getRecordRef :: (PrimBase m) => Get m ANF.RecordRef +getRecordRef = do + ANF.RecordRef <$> getWord64be + +putRecordRef :: ANF.RecordRef -> Builder +putRecordRef (ANF.RecordRef r) = BU.word64BE r + instance Tag Prim1 where tag2word DECI = 0 tag2word DECN = 1 diff --git a/unison-runtime/src/Unison/Runtime/Serialize/Get.hs b/unison-runtime/src/Unison/Runtime/Serialize/Get.hs index 80f53c1d1c9..9d06278d47f 100644 --- a/unison-runtime/src/Unison/Runtime/Serialize/Get.hs +++ b/unison-runtime/src/Unison/Runtime/Serialize/Get.hs @@ -19,6 +19,7 @@ module Unison.Runtime.Serialize.Get getAccumulatingRevList, getArray, getList, + getVector, getSeq, getPrimArray, remaining, @@ -43,6 +44,7 @@ import Data.Primitive.PrimArray import Data.Primitive.PrimVar import Data.Primitive.Types import Data.Sequence qualified as Seq +import Data.Vector qualified as V import Data.Word -- TODO: replace with GHC builtins after upgrading to GHC 9.10 @@ -271,6 +273,9 @@ getList :: (PrimBase m) => Get m a -> Get m [a] getList ga = getVarInt >>= (`replicateM` ga) {-# INLINE getList #-} +getVector :: (PrimBase m) => Get m a -> Get m (V.Vector a) +getVector ga = V.fromList <$> getList ga + -- Builds a result by repeated snoc in an efficient loop. Should only be -- used when the snoc is efficient. getAccumulating :: diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index d22460cd36a..ee8e28d3770 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -11,6 +11,7 @@ module Unison.Runtime.Stack Closure ( .., DataC, + RecordC, PApV, CapV, PAp, @@ -18,6 +19,7 @@ module Unison.Runtime.Stack Data1, Data2, DataG, + RecordG, Captured, Foreign, Affine, @@ -66,6 +68,8 @@ module Unison.Runtime.Stack USeg, BSeg, SegList, + RecordVals, + segToList, Val ( .., CharVal, @@ -193,6 +197,8 @@ import Data.Ord (comparing) import Data.Primitive (sizeOf) import Data.Primitive.ByteArray qualified as BA import Data.Tagged (Tagged (..)) +import Data.Vector (Vector) +import Data.Vector qualified as V import Data.Word import Data.X509 qualified as X509 import Foreign.ForeignPtr qualified as Ptr @@ -401,6 +407,10 @@ unboxedTypeTagFromInt = \case 3 -> NatTag _ -> error "intToUnboxedTypeTag: invalid tag" +-- | A record's field values, in ascending field-name order. Slot @i@ holds the +-- value of field @i@ of the accompanying 'RecordShape'. +type RecordVals = Vector Val + data GClosure comb = GPAp !CombIx @@ -418,6 +428,7 @@ data GClosure comb !Int -- | u/b data stacks {-# UNPACK #-} !Seg + | GRecord !RecordShape !RecordVals | GForeign !Foreign | -- | The type tag for the value in the corresponding unboxed stack slot. -- @@ -469,6 +480,9 @@ pattern Data2 r t i j = Closure (GData2 r t i j) pattern DataG r t seg = Closure (GDataG r t seg) +pattern RecordG :: RecordShape -> RecordVals -> Closure +pattern RecordG sh vs = Closure (GRecord sh vs) + pattern Captured k a seg = Closure (GCaptured k a seg) pattern Foreign x = Closure (GForeign x) @@ -487,13 +501,13 @@ pattern UnboxedTypeTag t <- Closure (GUnboxedTypeTag t) IntTag -> intTypeTag NatTag -> natTypeTag -{-# COMPLETE PAp, Enum, Data1, Data2, DataG, Captured, Foreign, UnboxedTypeTag, BlackHole, Affine #-} +{-# COMPLETE PAp, Enum, Data1, Data2, DataG, RecordC, Captured, Foreign, UnboxedTypeTag, BlackHole, Affine #-} -{-# COMPLETE DataC, PAp, Captured, Foreign, BlackHole, UnboxedTypeTag, Affine #-} +{-# COMPLETE DataC, RecordC, PAp, Captured, Foreign, BlackHole, UnboxedTypeTag, Affine #-} -{-# COMPLETE DataC, PApV, Captured, Foreign, BlackHole, UnboxedTypeTag, Affine #-} +{-# COMPLETE DataC, RecordC, PApV, Captured, Foreign, BlackHole, UnboxedTypeTag, Affine #-} -{-# COMPLETE DataC, PApV, CapV, Foreign, BlackHole, UnboxedTypeTag, Affine #-} +{-# COMPLETE DataC, RecordC, PApV, CapV, Foreign, BlackHole, UnboxedTypeTag, Affine #-} -- We can avoid allocating a closure for common type tags on each poke by having shared top-level closures for them. natTypeTag :: Closure @@ -621,6 +635,11 @@ pattern DataC rf ct segs <- where DataC rf ct segs = formData rf ct segs +pattern RecordC :: RecordShape -> RecordVals -> Closure +pattern RecordC sh v <- (RecordG sh v) + where + RecordC sh v = RecordG sh v + matchCharVal :: Val -> Maybe Char matchCharVal = \case (UnboxedVal u CharTag) -> Just (Char.chr u) @@ -1592,6 +1611,7 @@ closureNum Foreign {} = 3 closureNum UnboxedTypeTag {} = 4 closureNum BlackHole {} = 5 closureNum Affine {} = 6 +closureNum RecordC {} = 7 -- | The `Eq` instance for `Val` can’t be derived because you need to -- take into account the fact that if a `Val` is boxed, the unboxed side @@ -1607,6 +1627,9 @@ instance Eq Closure where matchTags ct1 ct2 && w1 == w2 DataC _ ct1 vs1 == DataC _ ct2 vs2 = ct1 == ct2 && eqValList vs1 vs2 + -- Shape equality is by field name, so this doesn't depend on intern order. + RecordC sh1 vs1 == RecordC sh2 vs2 = + sh1 == sh2 && eqValList (V.toList vs1) (V.toList vs2) PApV cix1 _ segs1 == PApV cix2 _ segs2 = cix1 == cix2 && eqValList segs1 segs2 CapV k1 a1 vs1 == CapV k2 a2 vs2 = @@ -1674,6 +1697,16 @@ compareClosure tyEq = \cases -- when comparing corresponding `Any` values, which have -- existentials inside check that type references match <> compareValList (tyEq || rf1 == Ty.anyRef) vs1 vs2 + -- Two records of different shapes can reach this once wrapped in `Any`, + -- which erases their types. Order those by field name -- via the `Ord + -- RecordShape` instance -- rather than by interned shape id, so the result + -- doesn't depend on the order field names were first compiled. + -- + -- Without `tyEq` the static types are known equal, so the shapes match and + -- the slots line up positionally. + (RecordC sh1 vs1) (RecordC sh2 vs2) + | tyEq, sh1 /= sh2 -> compare sh1 sh2 + | otherwise -> compareValList tyEq (V.toList vs1) (V.toList vs2) (PApV cix1 _ segs1) (PApV cix2 _ segs2) -> compare cix1 cix2 <> compareValList tyEq segs1 segs2 diff --git a/unison-runtime/tests/Unison/Test/Runtime/ANF.hs b/unison-runtime/tests/Unison/Test/Runtime/ANF.hs index f97a3402c43..49caba5e760 100644 --- a/unison-runtime/tests/Unison/Test/Runtime/ANF.hs +++ b/unison-runtime/tests/Unison/Test/Runtime/ANF.hs @@ -5,6 +5,7 @@ module Unison.Test.Runtime.ANF where import Control.Monad.Reader (ReaderT (..)) import Control.Monad.State (evalState) +import Control.Monad.State.Strict qualified as State.Strict import Data.Map qualified as Map import Data.Set qualified as Set import Data.Word (Word64) @@ -15,7 +16,7 @@ import Unison.ConstructorReference (GConstructorReference (..)) import Unison.Pattern qualified as P import Unison.Reference (Reference, Reference' (Builtin)) import Unison.Runtime.ANF as ANF -import Unison.Runtime.MCode (RefNums (..), emitCombs) +import Unison.Runtime.MCode (RefNums (..), emitCombs, emptyRecordFieldMappings) import Unison.Term qualified as Term import Unison.Test.Common import Unison.Type as Ty @@ -53,7 +54,10 @@ testLift :: String -> Test () testLift s = case cs of !_ -> ok where cs = - emitCombs (RN (const 0) (const 0) (const Nothing)) (Builtin "Test") 0 + flip State.Strict.evalState emptyRecordFieldMappings + -- Not `emptyRNs`: every one of its lookups throws, and `emitCombs` + -- calls them. These stubs are total. + . emitCombs (RN (const 0) (const 0) (const Nothing) (const (RecordRef 0))) (Builtin "Test") 0 . superNormalize . (\(ll, _, _, _, _) -> ll) . lamLift mempty @@ -94,6 +98,10 @@ denormalize (TApp f args) r `elem` [Ty.natRef, Ty.intRef], [v] <- args = Term.var () v +denormalize (TApp (FRec (RecordSchema fields)) args) = + -- Unlike every other `Func`, a record isn't applied to its arguments: the + -- arguments are the field values, in ascending field-name order. + Term.record () . Map.fromList . zip (Set.toAscList fields) $ Term.var () <$> args denormalize (TApp f args) = Term.apps' df (Term.var () <$> args) where df = case f of @@ -105,6 +113,8 @@ denormalize (TApp f args) = Term.apps' df (Term.var () <$> args) Term.request () (ConstructorReference r (fromIntegral $ rawTag n)) FPrim _ -> error "FPrim" FCont _ -> error "denormalize FCont" + -- Handled by the equation above; the `case` can't see that. + FRec _ -> error "denormalize FRec" denormalize (TFrc _) = error "denormalize TFrc" denormalize (TDiscard _) = error "denormalize TDiscard" denormalize (TLocal _ _) = error "denormalize TLocal" @@ -147,6 +157,16 @@ denormalizeMatch b | MatchNumeric _ cs df <- b = (dcase (ipat @Word64 @Integer Ty.intRef) <$> mapToList cs) ++ dfcase df | MatchSum _ <- b = error "MatchSum not a compilation target" + | MatchRec (RecordSchema fields) br <- b = + -- A record match is a single irrefutable case binding one variable per + -- field, in ascending field-name order -- the order `AccumRec` pushes + -- them in. + let (_, dbr) = denormalizeBranch @Int br + in [ Term.MatchCase + (P.RecordLiteral () (Map.fromSet (const (P.Var ())) fields)) + Nothing + dbr + ] where dfcase (Just d) = [Term.MatchCase (P.Unbound ()) Nothing $ denormalize d] @@ -229,6 +249,11 @@ test = "1 + match x with\n\ \ +1 -> foo\n\ \ +2 -> bar", - testANF "(match x with +3 -> foo) + (match x with +2 -> foo)" + testANF "(match x with +3 -> foo) + (match x with +2 -> foo)", + testANF "{a: x}", + -- Fields are laid out in ascending name order, not source order. + testANF "{b: x, a: y}", + testANF "match x with {a: y} -> y", + testANF "match x with {b: y, a: z} -> y" ] ] diff --git a/unison-runtime/tests/Unison/Test/Runtime/Foreign/Dynamic.hs b/unison-runtime/tests/Unison/Test/Runtime/Foreign/Dynamic.hs index 454019efcc2..eb96b002717 100644 --- a/unison-runtime/tests/Unison/Test/Runtime/Foreign/Dynamic.hs +++ b/unison-runtime/tests/Unison/Test/Runtime/Foreign/Dynamic.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} module Unison.Test.Runtime.Foreign.Dynamic (test) where @@ -15,6 +16,24 @@ import Foreign.Storable import System.Mem (performGC) import Unison.Runtime.Foreign.Dynamic +-- | Whether an unpromoted /fixed/ prefix is accepted. Not checked on macOS: +-- Apple's system libffi applies the "variadic arguments must be promoted" check +-- to every argument past the first, ignoring @nfixedargs@, and so rejects a +-- legal unpromoted fixed prefix with @FFI_BAD_ARGTYPE@. It does this even when +-- @nfixedargs@ equals the total argument count and nothing is variadic at all. +-- Upstream libffi accepts these specs; @\/usr\/lib\/libffi.dylib@ is what GHC +-- links against here. +promotionTests :: [Test ()] +#if defined(darwin_HOST_OS) +promotionTests = [] +#else +promotionTests = + [ scope "fixed prefix is not promoted" do + actual <- io $ try $ void $ prepareSpec $ FFSpec [F32, I8, U16, D64, I32] Void (Just 3) + expectEqual (Right () :: Either PrepException ()) actual + ] +#endif + foreign import ccall unsafe "&snprintf" snprintfPtr :: FunPtr () foreign import ccall unsafe "&strlen" strlenPtr :: FunPtr () @@ -48,7 +67,7 @@ formatWith types values format = do test :: Test () test = scope "ffi.dynamic" $ - tests + tests $ [ scope "fixed calls" do actual <- io do spec <- prepareSpec $ FFSpec [Ptr] sizeType Nothing @@ -102,9 +121,6 @@ test = "%d %s %.1f %u %lld %llu %.1f %d %.1f %d %.1f %d %.1f %d %.1f" let expected = "-7 hello 2.5 99 -1234567890123 12345678901234 3.5 4 4.5 5 5.5 6 6.5 7 7.5" expectEqual (expected, fromIntegral $ length expected) actual, - scope "fixed prefix is not promoted" do - actual <- io $ try $ void $ prepareSpec $ FFSpec [F32, I8, U16, D64, I32] Void (Just 3) - expectEqual (Right () :: Either PrepException ()) actual, scope "void placeholder for fixed no-argument function" do actual <- io $ ffArgs . ffSpec <$> prepareSpec (FFSpec [Void] I32 Nothing) expectEqual [] actual, @@ -127,6 +143,7 @@ test = scope "reject array results" $ rejects BadResult (FFSpec [I32] MBArr (Just 1)) ] + <> promotionTests where rejects expected spec = do actual <- io $ try $ void $ prepareSpec spec diff --git a/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs b/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs index 43d0f57df1c..e50a32ea74b 100644 --- a/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs +++ b/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs @@ -12,13 +12,16 @@ import Hedgehog hiding (Rec, Test, test) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Unison.Prelude +import Unison.Runtime.ANF qualified as ANF import Unison.Runtime.Foreign.Function.Type (ForeignFunc) import Unison.Runtime.Interface -import Unison.Runtime.MCode (Args (..), Branch, Comb, CombIx (..), GBranch (..), GComb (..), GCombInfo (..), GInstr (..), GRef (..), GSection (..), Instr, MLit (..), Prim1, Prim2, Ref, Section) +import Unison.Runtime.MCode (Args (..), Branch, Comb, CombIx (..), FieldRef (..), GBranch (..), GComb (..), GCombInfo (..), GInstr (..), GRef (..), GSection (..), Instr, MLit (..), Prim1, Prim2, RecordFieldMappings (..), Ref, Section) import Unison.Runtime.Machine (Combs) import Unison.Runtime.Serialize.Get import Unison.Runtime.TypeTags (PackedTag (..)) import Unison.Test.Gen +import Unison.Util.BiMap (BiMap) +import Unison.Util.BiMap qualified as BiMap import Unison.Util.EnumContainers (EnumMap, EnumSet) import Unison.Util.EnumContainers qualified as EC @@ -169,6 +172,28 @@ genComb = -- CachedClosure ] +genFieldRef :: Gen FieldRef +genFieldRef = FieldRef <$> genSmallWord64 + +genRecordRef :: Gen ANF.RecordRef +genRecordRef = ANF.RecordRef <$> genSmallWord64 + +genRecordSchema :: Gen ANF.RecordSchema +genRecordSchema = ANF.RecordSchema <$> Gen.set (Range.linear 0 5) genSmallText + +-- | Generated through `fromMap`, because that's the shape the codec rebuilds: +-- it stores only the forward map and derives the backward one on the way in. A +-- BiMap assembled some other way can carry a backward map that doesn't follow +-- from its forward map, and then the round trip would be testing BiMap's +-- internal invariants rather than the codec. +genBiMap :: (Ord k, Ord v) => Gen k -> Gen v -> Gen (BiMap k v) +genBiMap genK genV = + BiMap.fromMap <$> Gen.map (Range.linear 0 10) ((,) <$> genK <*> genV) + +genRecordFieldMappings :: Gen RecordFieldMappings +genRecordFieldMappings = + RecordFieldMappings <$> genFieldRef <*> genBiMap genSmallText genFieldRef + genStoredCache :: Gen StoredCache genStoredCache = SCache @@ -180,12 +205,15 @@ genStoredCache = <*> (genEnumMap genSmallWord64 genReference) <*> genSmallWord64 <*> genSmallWord64 + <*> genSmallWord64 <*> -- We don't yet generate supergroups because generating valid ones is difficult. mempty <*> (Gen.map (Range.linear 0 10) ((,) <$> genReference <*> genSmallWord64)) <*> (Gen.map (Range.linear 0 10) ((,) <$> genReference <*> genSmallWord64)) + <*> genBiMap genRecordSchema genRecordRef <*> (Gen.map (Range.linear 0 10) ((,) <$> genReference <*> (Gen.set (Range.linear 0 10) genReference))) + <*> genRecordFieldMappings sCacheRoundtrip :: Property sCacheRoundtrip = diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index 595aa9fdebb..12320691792 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack @@ -161,6 +161,7 @@ library , text , time , tls + , transformers , unison-codebase-sqlite , unison-core , unison-core1 @@ -172,6 +173,7 @@ library , unison-syntax , unison-util-bytes , unison-util-recursion + , unison-util-relation , unliftio , unordered-containers , vector @@ -272,6 +274,7 @@ test-suite runtime-tests , unison-runtime , unison-syntax , unison-util-bytes + , unison-util-relation default-language: Haskell2010 if flag(arraychecks) cpp-options: -DARRAY_CHECK diff --git a/unison-share-api/src/Unison/Server/Syntax.hs b/unison-share-api/src/Unison/Server/Syntax.hs index 617554efc8f..0f98e0ba2e6 100644 --- a/unison-share-api/src/Unison/Server/Syntax.hs +++ b/unison-share-api/src/Unison/Server/Syntax.hs @@ -100,6 +100,9 @@ convertElement = \case SyntaxText.LinkKeyword -> LinkKeyword SyntaxText.DocDelimiter -> DocDelimiter SyntaxText.DocKeyword -> DocKeyword + SyntaxText.RecordFieldName name -> RecordFieldName name + SyntaxText.RecordFieldValueColon -> RecordFieldValueColon + SyntaxText.RecordExtraFields -> RecordExtraFields type UnisonHash = Text @@ -154,6 +157,9 @@ data Element | DocDelimiter | -- the 'include' in @[include], etc DocKeyword + | RecordFieldName Text + | RecordFieldValueColon + | RecordExtraFields deriving (Eq, Ord, Show, Generic) instance ToJSON Element where @@ -190,6 +196,9 @@ instance ToJSON Element where LinkKeyword -> object ["tag" .= String "LinkKeyword"] DocDelimiter -> object ["tag" .= String "DocDelimiter"] DocKeyword -> object ["tag" .= String "DocKeyword"] + RecordFieldName name -> object ["tag" .= String "RecordFieldName", "contents" .= name] + RecordFieldValueColon -> object ["tag" .= String "RecordFieldValueColon"] + RecordExtraFields -> object ["tag" .= String "RecordExtraFields"] instance FromJSON Element where parseJSON = withObject "Element" $ \obj -> do @@ -226,6 +235,9 @@ instance FromJSON Element where "LinkKeyword" -> pure LinkKeyword "DocDelimiter" -> pure DocDelimiter "DocKeyword" -> pure DocKeyword + "RecordFieldName" -> RecordFieldName <$> obj .: "contents" + "RecordFieldValueColon" -> pure RecordFieldValueColon + "RecordExtraFields" -> pure RecordExtraFields _ -> fail $ "Unknown tag: " <> tag deriving instance ToSchema Element @@ -392,3 +404,9 @@ elementToClassName el = "doc-delimeter" DocKeyword -> "doc-keyword" + RecordFieldName _name -> + "record-field-name" + RecordFieldValueColon -> + "record-field-value-colon" + RecordExtraFields -> + "record-extra-fields" diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index a91d26f1d65..0e76b25763e 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -37,7 +37,7 @@ scratch/a1> edit.new 1-1000 ☝️ - I added 111 definitions to the top of scratch.u + I added 122 definitions to the top of scratch.u You can edit them there, then run `update` to replace the definitions currently in this namespace. @@ -604,6 +604,41 @@ raw_d = """ +record_closed_type : {x: Nat, y: Text} -> Nat +record_closed_type = cases {x: x, y: _} -> x + +record_destructure : {x: Nat, y: Nat | ...} -> Nat +record_destructure = cases {x: x, y: y} -> x Nat.+ y + +record_empty : {} +record_empty = {} + +record_literal : {age: Nat, name: Text} +record_literal = {age: 30, name: "Alice"} + +record_nested : {a: {b: {c: Nat}}} +record_nested = {a: {b: {c: 42}}} + +record_open_type : {x: Nat, y: Text | ...} -> Nat +record_open_type = cases {x: x} -> x + +record_projection : {a: Nat | ...} -> Nat +record_projection = cases {a: field} -> field + +record_projection_applied : {a: Nat | ...} -> Nat +record_projection_applied r = Nat.increment r@a + +record_projection_chain : {a: {b: {c: Nat}} | ...} -> Nat +record_projection_chain r = r@a@b@c + +record_projection_of_expr : Nat -> Nat +record_projection_of_expr n = {v: n}@v + +record_refutable : {x: Nat | ...} -> Text +record_refutable = cases + {x: 0} -> "zero" + _ -> "other" + simplestPossibleExample : Nat simplestPossibleExample = use Nat + diff --git a/unison-src/transcripts-round-trip/reparses-with-same-hash.u b/unison-src/transcripts-round-trip/reparses-with-same-hash.u index 8d6863e5b90..22c5f804bb6 100644 --- a/unison-src/transcripts-round-trip/reparses-with-same-hash.u +++ b/unison-src/transcripts-round-trip/reparses-with-same-hash.u @@ -625,3 +625,39 @@ fixity = do zzzz = 1 * 2 + 3 * 3 < 4 + 5 * 6 && 7 + 8 * 9 > 10 + 11 * 12 === 1 + 3 * 3 < 4 + 5 * 6 && 7 + 8 * 9 > 10 + 11 * 12 () ) |> id + +-- Anonymous records: literals, types, patterns and field projections + +record_literal = { name : "Alice", age : 30 } + +record_nested = { a : { b : { c : 42 } } } + +record_empty = { } + +record_open_type : { x : Nat, y : Text | ... } -> Nat +record_open_type = cases { x : x } -> x + +record_closed_type : { x : Nat, y : Text } -> Nat +record_closed_type = cases { x : x, y : _ } -> x + +record_refutable : { x : Nat | ... } -> Text +record_refutable = cases + { x : 0 } -> "zero" + _ -> "other" + +record_destructure : { x : Nat, y : Nat | ... } -> Nat +record_destructure r = + { x : x, y : y } = r + x Nat.+ y + +record_projection : { a : Nat | ... } -> Nat +record_projection r = r@a + +record_projection_chain : { a : { b : { c : Nat } } | ... } -> Nat +record_projection_chain r = r@a@b@c + +record_projection_applied : { a : Nat | ... } -> Nat +record_projection_applied r = Nat.increment r@a + +record_projection_of_expr : Nat -> Nat +record_projection_of_expr n = ({ v : n })@v diff --git a/unison-src/transcripts/idempotent/generic-parse-errors.md b/unison-src/transcripts/idempotent/generic-parse-errors.md index 8b4cc71542a..a0f87f332fa 100644 --- a/unison-src/transcripts/idempotent/generic-parse-errors.md +++ b/unison-src/transcripts/idempotent/generic-parse-errors.md @@ -63,6 +63,7 @@ x = a.#abc I was surprised to find a '.' here. I was expecting one of these instead: + * @ * and * bang * do diff --git a/unison-src/transcripts/idempotent/new-records.md b/unison-src/transcripts/idempotent/new-records.md new file mode 100644 index 00000000000..854d1dfec0a --- /dev/null +++ b/unison-src/transcripts/idempotent/new-records.md @@ -0,0 +1,1443 @@ +# Structural records + +``` ucm +scratch/main> builtins.merge lib.builtins + + Done. +``` + +We should be able to write simple functions which construct record types, and can evaluate them. + +``` unison +mkRec : a -> b -> c -> { x: a, y: b, z: c } +mkRec a b c = { x: a, y: b, z: c } +> mkRec 1 2 3 + +addUpRec : { x: Nat, y: Nat, z: Nat | ... } -> Nat +addUpRec = cases + { x:x, y:y, z:z } -> x Nat.+ y Nat.+ z + +> addUpRec (mkRec 1 2 3) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + addUpRec : {x: Nat, y: Nat, z: Nat | ...} -> Nat + + mkRec : a -> b -> c -> {x: a, y: b, z: c} + + Run `update` to apply these changes to your codebase. + + 3 | > mkRec 1 2 3 + ⧩ + {x: 1, y: 2, z: 3} + + 9 | > addUpRec (mkRec 1 2 3) + ⧩ + 6 +``` + +And can add them to the codebase; + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> ls + + 1. addUpRec ({x: Nat, y: Nat, z: Nat | ...} -> Nat) + 2. lib. (775 terms, 120 types) + 3. mkRec (a -> b -> c -> {x: a, y: b, z: c}) +``` + +We should be able to create wrapper types which encapsulate records, and manipulate them. + +``` unison +type Point = Point { x: Nat, y: Nat } + +mkPoint : Nat -> Nat -> Point +mkPoint x y = Point { x: x, y: y } + +unpackPoint : Point -> (Nat, Nat) +unpackPoint = cases + Point { x:x, y:y } -> (x, y) + +-- We can do partial record projections and only bind the fields we care about. +getX : Point -> Nat +getX = cases + Point { x:x } -> x + +getY : Point -> Nat +getY = cases + Point { y:y } -> y + +p : Point +p = mkPoint 3 4 + +> unpackPoint p +> getX p +> getY p +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + type Point + + + getX : Point -> Nat + + getY : Point -> Nat + + mkPoint : Nat -> Nat -> Point + + p : Point + + unpackPoint : Point -> (Nat, Nat) + + Run `update` to apply these changes to your codebase. + + 22 | > unpackPoint p + ⧩ + (3, 4) + + 23 | > getX p + ⧩ + 3 + + 24 | > getY p + ⧩ + 4 +``` + +We should be able to add them to the codebase; + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> ls + + 1. Point (type) + 2. Point. (1 term) + 3. addUpRec ({x: Nat, y: Nat, z: Nat | ...} -> Nat) + 4. getX (Point -> Nat) + 5. getY (Point -> Nat) + 6. lib. (775 terms, 120 types) + 7. mkPoint (Nat -> Nat -> Point) + 8. mkRec (a -> b -> c -> {x: a, y: b, z: c}) + 9. p (Point) + 10. unpackPoint (Point -> (Nat, Nat)) + +scratch/main> view Point + + type Point = Point {x: Nat, y: Nat} +``` + +We should get a nice error if we are missing a field from an expected type. + +``` unison :error +getName = cases + { name:name, age:_ } -> name + +-- Missing the 'name' field +> getName { age: 30 } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I expected this record: + + 5 | > getName { age: 30 } + + + to have the field + name: 𝕩16 + + so that it would match the type: + + {age: 𝕩15, name: 𝕩16 | ...} + + + from here: + + 2 | { name:name, age:_ } -> name +``` + +We should get a nice error if we have additional unexpected fields. + +``` unison :error +type Person = Person { name: Text, age: Nat } + +-- 'address' is an unexpected field +createPerson = Person { name: "Alice", age: 30, address: "123 Main St" } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I didn't expect this record: + + 4 | createPerson = Person { name: "Alice", age: 30, address: "123 Main St" } + + + to have the field + address: Text + + because it should have the type: + + {age: Nat, name: Text} + + + derived from here: + + 1 | type Person = Person { name: Text, age: Nat } +``` + +Record field projections should infer the most general record type: + +``` unison +getAddress = cases + { address: address } -> address +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + getAddress : {address: t | ...} -> t + + Run `update` to apply these changes to your codebase. +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> ls + + 1. Point (type) + 2. Point. (1 term) + 3. addUpRec ({x: Nat, y: Nat, z: Nat | ...} -> Nat) + 4. getAddress ({address: t | ...} -> t) + 5. getX (Point -> Nat) + 6. getY (Point -> Nat) + 7. lib. (775 terms, 120 types) + 8. mkPoint (Nat -> Nat -> Point) + 9. mkRec (a -> b -> c -> {x: a, y: b, z: c}) + 10. p (Point) + 11. unpackPoint (Point -> (Nat, Nat)) +``` + +### Nested records + +Records nest, both as literals and as patterns, to arbitrary depth. + +``` unison +nested : { a: { b: Nat } } -> Nat +nested = cases + { a: { b: b } } -> b + +> nested { a: { b: 7 } } + +-- The same thing with no annotation, so every field type is inferred. +nestedInferred = cases + { a: { b: { c: c } } } -> c + +> nestedInferred { a: { b: { c: 11 } } } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + nested : {a: {b: Nat}} -> Nat + + nestedInferred : {a: {b: {c: t | ...} | ...} | ...} -> t + + Run `update` to apply these changes to your codebase. + + 5 | > nested { a: { b: 7 } } + ⧩ + 7 + + 11 | > nestedInferred { a: { b: { c: 11 } } } + ⧩ + 11 +``` + +Record types unify with each other inside other structures. + +``` unison +jons = + [ { name: "Jon Arbuckle", age: 35 } + , { name: "Jon Snow", age: 25 } + ] + +> jons +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + jons : [{age: Nat, name: Text}] + + Run `update` to apply these changes to your codebase. + + 6 | > jons + ⧩ + [ {age: 35, name: "Jon Arbuckle"} + , {age: 25, name: "Jon Snow"} + ] +``` + +### More type errors + +A field whose type doesn't match across two records that have to unify. + +``` unison :error +mismatchedFieldTypes = + [ { name: "Jon Arbuckle", age: 35 } + , { name: "Jon Snow", age: "25" } + ] +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + All the elements of a list need to have the same type. + + Here, one is: {age: Nat, name: Text} + and another is: {age: Text, name: Text} + + + 2 | [ { name: "Jon Arbuckle", age: 35 } + 3 | , { name: "Jon Snow", age: "25" } +``` + +A record pattern can only match a record. If we already know the scrutinee +isn't one, say so rather than reporting a generic mismatch. + +``` unison :error +notARecord : Nat -> Nat +notARecord = cases + { a: a } -> a +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This isn't a record, so there are no fields to read from it: + + 3 | { a: a } -> a + + + It has type: + Nat +``` + +Matching on a field the record doesn't have points at the pattern. + +``` unison :error +noSuchField : { age: Nat } -> Nat +noSuchField = cases + { name: n, age: _ } -> 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This record has no field called name here: + + 3 | { name: n, age: _ } -> 1 + + + It has type: + {age: Nat} +``` + +### Field names + +A field can only be named once. The field map would otherwise be built with +`Map.fromList`, which silently keeps the last binding. + +``` unison :error +dupLit = { a: 1, a: 2 } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found the field a twice in the same record: + + 1 | dupLit = { a: 1, a: 2 } + + + Each field can only be named once. +``` + +``` unison :error +dupType : { a: Nat, a: Text } -> Nat +dupType = cases _ -> 1 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found the field a twice in the same record: + + 1 | dupType : { a: Nat, a: Text } -> Nat + + + Each field can only be named once. +``` + +``` unison :error +dupPat = cases + { a: x, a: y } -> x +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found the field a twice in the same record: + + 2 | { a: x, a: y } -> x + + + Each field can only be named once. +``` + +The empty record is the record with no fields. It round-trips like any other. + +``` unison +empty : { } +empty = { } + +> empty +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + empty : {} + + Run `update` to apply these changes to your codebase. + + 4 | > empty + ⧩ + {} +``` + +### Pattern match coverage + +Pattern match coverage should warn on multiple record matches since they're irrefutable. + +``` unison :error +getAgeRedundant : { age: Nat, address: Text | ... } -> Nat +getAgeRedundant = cases + { age:age } -> age + { address:_ } -> 99 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This case would be ignored because it's already covered by the preceding case(s): + 4 | { address:_ } -> 99 + +``` + +Pattern match coverage should warn if there are NO cases, at least one is required. + +``` unison :error +missingRight : Either Nat { age: Nat } -> Nat +missingRight = cases + Left n -> n +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | missingRight = cases + 3 | Left n -> n + + + Patterns not matched: + * Right {age: _} +``` + +``` unison :error +missingAllCases : { age: Nat } -> Nat +missingAllCases = cases +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | missingAllCases = cases + + + Patterns not matched: + * {age: _} +``` + +A record with an uninhabited field is itself uninhabited, so it needs no case. + +``` unison +type Void = + +getVoid : Either { x: Void } Nat -> Nat +getVoid = cases + Right n -> n +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + type Void + + + getVoid : Either {x: Void} Nat -> Nat + + Run `update` to apply these changes to your codebase. +``` + +### Refutable patterns inside records + +A record match is irrefutable, but its field patterns need not be. A literal in +a field: + +``` unison +lit : { x: Nat | ... } -> Text +lit = cases + { x: 0 } -> "zero" + _ -> "other" + +> lit { x: 0 } +> lit { x: 5 } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + lit : {x: Nat | ...} -> Text + + Run `update` to apply these changes to your codebase. + + 6 | > lit { x: 0 } + ⧩ + "zero" + + 7 | > lit { x: 5 } + ⧩ + "other" +``` + +A constructor in a field, covering every case: + +``` unison +con : { x: Optional Nat | ... } -> Nat +con = cases + { x: Some n } -> n + { x: None } -> 0 + +> con { x: Some 5 } +> con { x: None } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + con : {x: Optional Nat | ...} -> Nat + + Run `update` to apply these changes to your codebase. + + 6 | > con { x: Some 5 } + ⧩ + 5 + + 7 | > con { x: None } + ⧩ + 0 +``` + +...and not covering every case: + +``` unison :error +partialField : { x: Optional Nat | ... } -> Nat +partialField = cases + { x: Some n } -> n +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | partialField = cases + 3 | { x: Some n } -> n + + + Patterns not matched: + * {x: None} +``` + +Suggestions reach into nested records too: + +``` unison :error +nestedSuggest : { a: { b: Optional Nat } } -> Nat +nestedSuggest = cases + { a: { b: Some n } } -> n +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + Pattern match doesn't cover all possible cases: + 2 | nestedSuggest = cases + 3 | { a: { b: Some n } } -> n + + + Patterns not matched: + * {a: {b: None}} +``` + +Two cases may match entirely different subsets of the record's fields. Each row +is compiled against the union of the fields matched anywhere in the match, so +the bindings stay aligned. + +``` unison +subsets : { x: Nat, y: Text | ... } -> Text +subsets = cases + { x: 0 } -> "zero" + { y: y } -> y + +> subsets { x: 0, y: "no" } +> subsets { x: 1, y: "one" } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + subsets : {x: Nat, y: Text | ...} -> Text + + Run `update` to apply these changes to your codebase. + + 6 | > subsets { x: 0, y: "no" } + ⧩ + "zero" + + 7 | > subsets { x: 1, y: "one" } + ⧩ + "one" +``` + +A refutable first case leaves a later one reachable, so this is *not* redundant +\-- compare the `getAgeRedundant` case above. + +``` unison +notRedundant : { age: Nat, address: Text | ... } -> Nat +notRedundant = cases + { age: 0 } -> 1 + { address: _ } -> 99 + +> notRedundant { age: 0, address: "x" } +> notRedundant { age: 7, address: "x" } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + notRedundant : {address: Text, age: Nat | ...} -> Nat + + Run `update` to apply these changes to your codebase. + + 6 | > notRedundant { age: 0, address: "x" } + ⧩ + 1 + + 7 | > notRedundant { age: 7, address: "x" } + ⧩ + 99 +``` + +### Values and code + +A record value can be reflected into a `Value`, serialized, deserialized and +reified back. Fields are written in ascending name order regardless of the +order they were given in, so this uses deliberately unsorted source order with +distinguishable values. + +``` unison +unpack : { a: Nat, z: Nat } -> (Nat, Nat) +unpack = cases { a: a, z: z } -> (a, z) + +valueRoundTrip : '{IO, Exception} (Nat, Nat) +valueRoundTrip = do + bytes = Value.serialize (Value.value {z: 7, a: 3}) + v = match Value.deserialize bytes with + Right x -> x + Left e -> bug e + r : { a: Nat, z: Nat } + r = match Value.load v with + Right x -> x + Left deps -> bug deps + unpack r +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + unpack : {a: Nat, z: Nat} -> (Nat, Nat) + + valueRoundTrip : '{IO, Exception} (Nat, Nat) + + Run `update` to apply these changes to your codebase. +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> run valueRoundTrip + + (3, 7) +``` + +Code that builds and matches on records survives `validateLinks`, +serialization, and the code cache. + +``` unison +mkRec : Nat -> { a: Nat, z: Text } +mkRec n = { a: n, z: "hi" } + +readA : { a: Nat | ... } -> Nat +readA = cases { a: a } -> a + +isRight : Either a b -> Boolean +isRight = cases + Right _ -> true + Left _ -> false +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + isRight : Either a b -> Boolean + + readA : {a: Nat | ...} -> Nat + ~ mkRec : Nat -> {a: Nat, z: Text} + + + (added), ~ (modified) + + Run `update` to apply these changes to your codebase. +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. +``` + +``` unison +codeRoundTrip : '{IO, Exception} (Boolean, Nat) +codeRoundTrip = do + tl = termLink mkRec + code = match Code.lookup tl with + Some c -> c + None -> bug "no code" + ok = Code.validateLinks [(tl, code)] + bytes = Code.serialize code + code2 = match Code.deserialize bytes with + Right c -> c + Left e -> bug e + _ = Code.cache_ [(tl, code2)] + (isRight ok, readA (mkRec 5)) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + codeRoundTrip : '{IO, Exception} (Boolean, Nat) + + Run `update` to apply these changes to your codebase. +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> run codeRoundTrip + + (true, 5) +``` + +A runtime error carrying a record shows real field names, since the names +travel with the value rather than being looked up by interned id. + +``` unison :error +boom = bug { name: "Alice", age: 30 } + +> boom +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + boom : b + + Run `update` to apply these changes to your codebase. + + 💔💥 + + I've encountered a call to builtin.bug with the following + value: + + {age: 30, name: "Alice"} + + Stack trace: + #135ikr7m3u + #s2jmnl2nc9 +``` + +### Reading fields + +A record pattern in a destructuring bind reads fields without a `match`, and +works partially and at depth. + +``` unison +sum3 : { x: Nat, y: Nat, z: Nat | ... } -> Nat +sum3 r = + { x: x, y: y, z: z } = r + x Nat.+ y Nat.+ z + +getInner : { a: { b: Nat } | ... } -> Nat +getInner r = + { a: { b: b } } = r + b + +> sum3 { x: 1, y: 2, z: 3, extra: "ignored" } +> getInner { a: { b: 42 }, c: 1 } +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + getInner : {a: {b: Nat} | ...} -> Nat + + sum3 : {x: Nat, y: Nat, z: Nat | ...} -> Nat + (also named addUpRec) + + Run `update` to apply these changes to your codebase. + + 11 | > sum3 { x: 1, y: 2, z: 3, extra: "ignored" } + ⧩ + 6 + + 12 | > getInner { a: { b: 42 }, c: 1 } + ⧩ + 42 +``` + +`r@x` reads the `x` field inline. It binds tighter than application, so +`f r@x` is `f (r@x)`, and it chains. + +``` unison +rec : { a: Nat, b: Text } +rec = { a: 7, b: "hi" } + +nested : { a: { b: { c: Nat } } } +nested = { a: { b: { c: 42 } } } + +> rec@a +> rec@b +> Nat.increment rec@a +> nested@a@b@c +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + nested : {a: {b: {c: Nat}}} + + rec : {a: Nat, b: Text} + + Run `update` to apply these changes to your codebase. + + 7 | > rec@a + ⧩ + 7 + + 8 | > rec@b + ⧩ + "hi" + + 9 | > Nat.increment rec@a + ⧩ + 8 + + 10 | > nested@a@b@c + ⧩ + 42 +``` + +Unlike a qualified name, the left side can be any expression, not just an +identifier. + +``` unison +mkRec2 : Nat -> { v: Nat } +mkRec2 n = { v: n } + +> (mkRec2 5)@v +> ({ v: 9 })@v +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + mkRec2 : Nat -> {v: Nat} + + Run `update` to apply these changes to your codebase. + + 4 | > (mkRec2 5)@v + ⧩ + 5 + + 5 | > ({ v: 9 })@v + ⧩ + 9 +``` + +The `@` has to be adjacent to both sides, which is what keeps it from being +confused with the `@` of an as-pattern. + +``` unison :error +spaced : { a: Nat } -> Nat +spaced r = r @ a +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 2 | spaced r = r @ a + + + I was surprised to find a '@' here. + I was expecting one of these instead: + + * and + * bang + * do + * false + * force + * handle + * if + * infixApp + * let + * newline or semicolon + * or + * quote + * termLink + * true + * tuple + * typeLink +``` + +``` unison +asPat : Optional Nat -> Nat +asPat = cases + x@(Some n) -> n + None -> 0 + +> asPat (Some 5) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + asPat : Optional Nat -> Nat + + Run `update` to apply these changes to your codebase. + + 6 | > asPat (Some 5) + ⧩ + 5 +``` + +Reading a field the record doesn't have, or reading from something that isn't a +record: + +``` unison :error +noSuchField2 : { a: Nat } -> Nat +noSuchField2 r = r@nope +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This record has no field called nope here: + + 2 | noSuchField2 r = r@nope + + + It has type: + {a: Nat} +``` + +``` unison :error +notARecord2 : Nat -> Nat +notARecord2 n = n@a +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + This isn't a record, so there are no fields to read from it: + + 2 | notARecord2 n = n@a + + + It has type: + Nat +``` + +A projection prints back as a projection. + +``` unison +projA : { a: Nat | ... } -> Nat +projA r = Nat.increment r@a + +projDeep : { a: { b: Nat } | ... } -> Nat +projDeep r = r@a@b +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + projA : {a: Nat | ...} -> Nat + + projDeep : {a: {b: Nat} | ...} -> Nat + + Run `update` to apply these changes to your codebase. +``` + +``` ucm +scratch/main> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +scratch/main> view projA projDeep + + projA : {a: Nat | ...} -> Nat + projA r = Nat.increment r@a + + projDeep : {a: {b: Nat} | ...} -> Nat + projDeep r = r@a@b +``` + +### Universals + +Records are ordered by field name, most significant field first -- not by the +order field names happened to be interned, which would make the result depend +on unrelated compilation history. Two records of *different* shapes can be +compared once wrapped in `Any`, which erases their types; those are ordered by +comparing the sorted field-name lists. + +``` unison +> Universal.compare {a: 2, b: 1} {a: 1, b: 2} +> Universal.compare (Any {a: 1}) (Any {b: 1}) +> Universal.compare (Any {b: 1}) (Any {a: 1}) +> Universal.compare (Any {a: 1}) (Any {a: 1, b: 2}) +> Universal.compare (Any {a: 1, b: 2}) (Any {a: 1}) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + No changes found. + + 1 | > Universal.compare {a: 2, b: 1} {a: 1, b: 2} + ⧩ + +1 + + 2 | > Universal.compare (Any {a: 1}) (Any {b: 1}) + ⧩ + -1 + + 3 | > Universal.compare (Any {b: 1}) (Any {a: 1}) + ⧩ + +1 + + 4 | > Universal.compare (Any {a: 1}) (Any {a: 1, b: 2}) + ⧩ + -1 + + 5 | > Universal.compare (Any {a: 1, b: 2}) (Any {a: 1}) + ⧩ + +1 +``` + +``` unison +> {a: 1} Universal.== {a: 1} +> {a: 1} Universal.== {a: 2} +> Any {a: 1} Universal.== Any {a: 1} +> Any {a: 1} Universal.== Any {a: 1, b: 2} +> Any {a: 1} Universal.== Any {a: 2} +> {a: 1} Universal.> {a: 1} +> {a: 2} Universal.> {a: 1} +> {a: 1} Universal.> {a: 2} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + No changes found. + + 1 | > {a: 1} Universal.== {a: 1} + ⧩ + true + + 2 | > {a: 1} Universal.== {a: 2} + ⧩ + false + + 3 | > Any {a: 1} Universal.== Any {a: 1} + ⧩ + true + + 4 | > Any {a: 1} Universal.== Any {a: 1, b: 2} + ⧩ + false + + 5 | > Any {a: 1} Universal.== Any {a: 2} + ⧩ + false + + 6 | > {a: 1} Universal.> {a: 1} + ⧩ + false + + 7 | > {a: 2} Universal.> {a: 1} + ⧩ + true + + 8 | > {a: 1} Universal.> {a: 2} + ⧩ + false +``` + +### Rewrite rules + +A `@rewrite case` rule can match on a record pattern. Here the field value is +a literal: + +``` unison +litRule = @rewrite + case {x: 0} ==> {x: 1} + +targetLit : {x: Nat} -> Nat +targetLit = cases + {x: 0} -> 100 + {x: n} -> n +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + litRule : Rewrites + (Tuple (RewriteCase {x: Nat} {x: Nat}) ()) + + targetLit : {x: Nat} -> Nat + + Run `update` to apply these changes to your codebase. +``` + +``` ucm +scratch/main> rewrite litRule + + ☝️ + + I found and replaced matches in these definitions: targetLit + + The rewritten file has been added to the top of scratch.u +``` + +``` unison :added-by-ucm scratch.u +-- | Rewrote using: +-- | Modified definition(s): targetLit + +litRule = @rewrite case {x: 0} ==> {x: 1} + +targetLit : {x: Nat} -> Nat +targetLit = cases + {x: 1} -> 100 + {x: n} -> n +``` + +``` ucm :hide +scratch/main> load + +scratch/main> add +``` + +A record pattern binds its variables in ascending field-name order, so a rule +that swaps two field subpatterns has to move the bindings along with them. The +rewritten body still refers to `p` and `q` by name, and they follow the fields +they were swapped onto: + +``` unison +swapRule a b = @rewrite + case {x: a, y: b} ==> {x: b, y: a} + +targetSwap : {x: Nat, y: Nat} -> Nat +targetSwap = cases + {x: p, y: q} -> p Nat.+ (q Nat.* 2) +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + swapRule : a + -> b + -> Rewrites + (Tuple + (RewriteCase {x: a, y: b} {x: b, y: a}) ()) + + targetSwap : {x: Nat, y: Nat} -> Nat + + Run `update` to apply these changes to your codebase. +``` + +``` ucm +scratch/main> rewrite swapRule + + ☝️ + + I found and replaced matches in these definitions: targetSwap + + The rewritten file has been added to the top of scratch.u +``` + +``` unison :added-by-ucm scratch.u +-- | Rewrote using: +-- | Modified definition(s): targetSwap + +swapRule a b = @rewrite case {x: a, y: b} ==> {x: b, y: a} + +targetSwap : {x: Nat, y: Nat} -> Nat +targetSwap = cases {x: q, y: p} -> p Nat.+ q Nat.* 2 +``` + +``` ucm :hide +scratch/main> load + +scratch/main> add +``` + +Record patterns nest: + +``` unison +nestRule = @rewrite + case {x: {y: 0}} ==> {x: {y: 1}} + +targetNest : {x: {y: Nat}} -> Nat +targetNest = cases + {x: {y: 0}} -> 100 + {x: {y: n}} -> n +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + nestRule : Rewrites + (Tuple + (RewriteCase {x: {y: Nat}} {x: {y: Nat}}) + ()) + + targetNest : {x: {y: Nat}} -> Nat + + Run `update` to apply these changes to your codebase. +``` + +``` ucm +scratch/main> rewrite nestRule + + ☝️ + + I found and replaced matches in these definitions: targetNest + + The rewritten file has been added to the top of scratch.u +``` + +``` unison :added-by-ucm scratch.u +-- | Rewrote using: +-- | Modified definition(s): targetNest + +nestRule = @rewrite case {x: {y: 0}} ==> {x: {y: 1}} + +targetNest : {x: {y: Nat}} -> Nat +targetNest = cases + {x: {y: 1}} -> 100 + {x: {y: n}} -> n +``` + +``` ucm :hide +scratch/main> load + +scratch/main> add +``` + +Finally, a rule that has nothing to do with records still has to pass over any +record patterns in the definitions it rewrites: + +``` unison +structural type Flag = On | Off + +flagRule = @rewrite + case On ==> Off + +targetFlag : {x: Flag} -> Nat +targetFlag = cases + {x: f} -> match f with + On -> 1 + _ -> 0 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + structural type Flag + + + flagRule : Rewrites (Tuple (RewriteCase Flag Flag) ()) + + targetFlag : {x: Flag} -> Nat + + Run `update` to apply these changes to your codebase. +``` + +``` ucm +scratch/main> rewrite flagRule + + ☝️ + + I found and replaced matches in these definitions: targetFlag + + The rewritten file has been added to the top of scratch.u +``` + +``` unison :added-by-ucm scratch.u +-- | Rewrote using: +-- | Modified definition(s): targetFlag + +structural type Flag = On | Off + +flagRule = @rewrite case Flag.On ==> Flag.Off + +targetFlag : {x: Flag} -> Nat +targetFlag = cases + {x: f} -> + match f with + Flag.Off -> 1 + _ -> 0 +``` + +``` ucm :hide +scratch/main> load +``` + +`sfind` reports the matches without rewriting them. Unlike `rewrite`, which +compares the pattern as a term, this compares record patterns to each other +directly: + +``` unison +findRule = @rewrite + case {q: 0} ==> {q: 1} + +targetFind : {q: Nat} -> Nat +targetFind = cases + {q: 0} -> 100 + {q: n} -> n +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + findRule : Rewrites + (Tuple (RewriteCase {q: Nat} {q: Nat}) ()) + + targetFind : {q: Nat} -> Nat + + Run `update` to apply these changes to your codebase. +``` + +``` ucm :hide +scratch/main> add +``` + +``` ucm +scratch/main> sfind findRule + + 🔎 + + These definitions from the current namespace (excluding `lib`) have matches: + + 1. targetFind + + Tip: Try `edit 1` to bring this into your scratch file. +``` + +A leading underscore makes the field's subpattern a wildcard, the same as +anywhere else in a rule: + +``` unison +wildRule _w = @rewrite + case {w: _w} ==> {w: 0} + +targetWild : {w: Nat} -> Nat +targetWild = cases + {w: _} -> 7 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + + targetWild : {w: Nat} -> Nat + + wildRule : ∀ _w. + _w + -> Rewrites + (Tuple (RewriteCase {w: _w} {w: Nat}) ()) + + Run `update` to apply these changes to your codebase. +``` + +``` ucm +scratch/main> rewrite wildRule + + ☝️ + + I found and replaced matches in these definitions: targetWild + + The rewritten file has been added to the top of scratch.u +``` + +``` unison :added-by-ucm scratch.u +-- | Rewrote using: +-- | Modified definition(s): targetWild + +wildRule _w = @rewrite case {w: _w} ==> {w: 0} + +targetWild : {w: Nat} -> Nat +targetWild = cases {w: 0} -> 7 +``` diff --git a/unison-syntax/src/Unison/Syntax/Lexer/Unison.hs b/unison-syntax/src/Unison/Syntax/Lexer/Unison.hs index c3c4a7fc035..9711995f09b 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer/Unison.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer/Unison.hs @@ -566,7 +566,8 @@ lexemes eof = -- yes "wordy" - just like a wordy keyword like "true", the literal "." (as in the dot in -- "forall a. a -> a") is considered the keyword "." so long as it is either followed by EOF, a space, or some -- non-wordy character (because ".foo" is a single identifier lexeme) - wordyKw "." + wordyKw "..." + <|> wordyKw "." <|> symbolyKw ":" <|> openKw "@rewrite" <|> symbolyKw "@" diff --git a/unison-syntax/src/Unison/Syntax/Parser.hs b/unison-syntax/src/Unison/Syntax/Parser.hs index 08d827db389..c412536fe61 100644 --- a/unison-syntax/src/Unison/Syntax/Parser.hs +++ b/unison-syntax/src/Unison/Syntax/Parser.hs @@ -60,6 +60,8 @@ module Unison.Syntax.Parser varOrNullaryConstructor, wordyDefinitionName, wordyPatternName, + recordFieldName, + checkForDuplicateRecordFields, ) where @@ -233,6 +235,9 @@ data Error v | -- | Pattern found in function declaration head (e.g. `f [] = ...`) -- Carries the function name and the location of the pattern token. PatternInFunctionDeclaration v Ann + | -- | The same field name appeared twice in one record type, literal, or + -- pattern. Args are the first occurrence, the second, and the name. + DuplicateRecordField Ann Ann Text deriving (Show, Eq, Ord) tokenToPair :: L.Token a -> (Ann, a) @@ -369,6 +374,26 @@ wordyDefinitionName = queryToken \case L.WordyId n -> Just $ Name.toVar (HQ'.toName n) _ -> Nothing +recordFieldName :: (Var v) => P v m (L.Token Text) +recordFieldName = queryToken \case + L.WordyId (HQ'.NameOnly (Name.segments -> (seg Nel.:| []))) -> Just (NameSegment.toUnescapedText seg) + _ -> Nothing + +-- | Reject a record type, literal, or pattern that names the same field twice. +-- Without this the field map is built with `Map.fromList`, which silently keeps +-- the last binding. +checkForDuplicateRecordFields :: (Ord v) => [L.Token Text] -> P v m () +checkForDuplicateRecordFields = go [] + where + go _ [] = pure () + go seen (t : ts) = + let name = L.payload t + in case lookup name seen of + Just ann0 -> P.customFailure (DuplicateRecordField ann0 (ann t) name) + -- Appending keeps `seen` in source order, so the error points at + -- the first occurrence rather than the nearest one. + Nothing -> go (seen <> [(name, ann t)]) ts + -- | Parse a wordyId as a Name, rejecting any hash importWordyId :: (Ord v) => P v m (L.Token Name) importWordyId = queryToken \case diff --git a/unison-syntax/src/Unison/Syntax/Pattern.hs b/unison-syntax/src/Unison/Syntax/Pattern.hs index 005c898500b..00c40ddea8c 100644 --- a/unison-syntax/src/Unison/Syntax/Pattern.hs +++ b/unison-syntax/src/Unison/Syntax/Pattern.hs @@ -33,6 +33,7 @@ data Pattern v | -- There's unfortunately no syntactic difference between nullary constructors and variables, -- so we can't commit to one or the other yet. VarOrNullaryConstructor Ann !(Token Name) + | RecordLiteral Ann (Map Text (Pattern v)) deriving stock (Show) instance Annotated (Pattern v) where @@ -54,6 +55,7 @@ instance Annotated (Pattern v) where Unbound pos -> pos Unit pos -> pos VarOrNullaryConstructor pos _ -> pos + RecordLiteral pos _ -> pos setPos :: Ann -> Pattern v -> Pattern v setPos pos = \case @@ -74,6 +76,7 @@ setPos pos = \case Unbound _ -> Unbound pos Unit _ -> Unit pos VarOrNullaryConstructor _ a -> VarOrNullaryConstructor pos a + RecordLiteral _ a -> RecordLiteral pos a data SeqOp = Concat diff --git a/unison-syntax/src/Unison/Syntax/ReservedWords.hs b/unison-syntax/src/Unison/Syntax/ReservedWords.hs index c9b9cce59fe..9467ca5e990 100644 --- a/unison-syntax/src/Unison/Syntax/ReservedWords.hs +++ b/unison-syntax/src/Unison/Syntax/ReservedWords.hs @@ -56,7 +56,8 @@ reservedOperators = "|", "!", "'", - "==>" + "==>", + "..." ] delimiters :: Set Char