Merge pull request #5648 from unisonweb/fix/set-replacement-conventions

Fix calling conventions for Set function replacements

Author: aryairani

parser-typechecker/src/Unison/Builtin/Decls.hs

@@ -122,6 +122,9 @@ mapTip, mapBin :: ConstructorId
 mapTip = Maybe.fromJust $ constructorId mapRef "Map.Tip"
 mapBin = Maybe.fromJust $ constructorId mapRef "Map.Bin"
 
+setWrap :: ConstructorId
+setWrap = Maybe.fromJust $ constructorId setRef "Set.Set"
+
 isPropagatedConstructorId = Maybe.fromJust $ constructorId isPropagatedRef "IsPropagated.IsPropagated"
 
 isTestConstructorId = Maybe.fromJust $ constructorId isTestRef "IsTest.IsTest"
@@ -254,6 +257,9 @@ rewritesRef = lookupDeclRef "Rewrites"
 mapRef :: Reference
 mapRef = lookupDeclRef "Map"
 
+setRef :: Reference
+setRef = lookupDeclRef "Set"
+
 pattern Rewrites' :: [Term2 vt at ap v a] -> Term2 vt at ap v a
 pattern Rewrites' ts <- (unRewrites -> Just ts)
 
@@ -309,7 +315,8 @@ builtinDataDecls = rs1 ++ rs
           (v "RewriteSignature", rewriteType),
           (v "RewriteCase", rewriteCase),
           (v "Rewrites", rewrites),
-          (v "Map", map)
+          (v "Map", map),
+          (v "Set", set)
         ] of
       Right a -> a
       Left e -> error $ "builtinDataDecls: " <> show e
@@ -628,6 +635,18 @@ builtinDataDecls = rs1 ++ rs
           ),
           ((), v "Map.Tip", forke mapke)
         ]
+    set =
+      DataDeclaration
+        Structural
+        ()
+        [v "a"]
+        let va = var "a"
+            mapau = Type.apps' (var "Map") [va, var "Unit"]
+            seta = Type.apps' (var "Set") [va] in
+        [ ( (),
+            v "Set.Set",
+            Type.foralls () [v "a"] $ mapau `arr` seta)
+        ]
 
 builtinEffectDecls :: [(Symbol, Reference.Id, DD.EffectDeclaration Symbol ())]
 builtinEffectDecls =

unison-runtime/src/Unison/Runtime/Builtin.hs

@@ -1282,8 +1282,16 @@ declareForeigns = do
   declareForeign Untracked 2 Map_lookup
   declareForeign Untracked 1 Map_fromList
   declareForeign Untracked 2 Map_eq
+  declareForeign Untracked 2 Map_union
+  declareForeign Untracked 2 Map_intersect
+  declareForeign Untracked 1 Map_toList
   declareForeign Untracked 2 List_range
   declareForeign Untracked 1 List_sort
+  declareForeign Untracked 1 Multimap_fromList
+  declareForeign Untracked 1 Set_fromList
+  declareForeign Untracked 2 Set_union
+  declareForeign Untracked 2 Set_intersect
+  declareForeign Untracked 1 Set_toList
 
 foreignDeclResults :: (Map ForeignFunc (Sandbox, SuperNormal Symbol))
 foreignDeclResults =

unison-runtime/src/Unison/Runtime/Foreign/Function.hs

@@ -878,15 +878,46 @@ foreignCallHelper = \case
     evaluate $ Map.fromList l
   Map_eq -> mkForeign $ \(l :: Map Val Val, r :: Map Val Val) ->
     pure $ l == r
+  Map_union -> mkForeign $ \(l :: Map Val Val, r :: Map Val Val) ->
+    evaluate $ Map.union l r
+  Map_intersect -> mkForeign $ \(l :: Map Val Val, r :: Map Val Val) ->
+    evaluate $ Map.intersection l r
+  Map_toList -> mkForeign $ \(m :: Map Val Val) ->
+    evaluate . forceListSpine $ Map.toList m
   List_range -> mkForeign $ \(m :: Word64, n :: Word64) ->
     let sz
           | m < n = fromIntegral $ n - m
           | otherwise = 0
         mk i = NatVal $ m + fromIntegral i
-        force s = foldl (\u x -> x `seq` u) s s
-     in evaluate . force $ Sq.fromFunction sz mk
+     in evaluate . forceListSpine $ Sq.fromFunction sz mk
   List_sort -> mkForeign $ \(l :: Seq Val) -> pure $ Sq.unstableSort l
+  Multimap_fromList -> mkForeign $ \(l :: [(Val, Val)]) -> do
+    let listVals = l <&> \(k, v) -> (k, Sq.singleton v)
+    evaluate $ Map.fromListWith (<>) listVals
+  Set_fromList -> mkForeign $ \(l :: [Val]) -> do
+    m <- evaluate $ Map.fromList $ zip l (repeat unitValue)
+    pure . Data1 Ty.setRef TT.setWrapTag $ encodeVal m
+  Set_union -> mkForeign $ \case
+    (Data1 _ _ vl, Data1 _ _ vr) -> do
+      (l :: Map Val Val) <- decodeVal vl
+      (r :: Map Val Val) <- decodeVal vr
+      m <- evaluate $ Map.union l r
+      pure . Data1 Ty.setRef TT.setWrapTag $ encodeVal m
+    _ -> die "Set.union: bad closure"
+  Set_intersect -> mkForeign $ \case
+    (Data1 _ _ vl, Data1 _ _ vr) -> do
+      (l :: Map Val Val) <- decodeVal vl
+      (r :: Map Val Val) <- decodeVal vr
+      m <- evaluate $ Map.intersection l r
+      pure . Data1 Ty.setRef TT.setWrapTag $ encodeVal m
+    _ -> die "Set.insersect: bad closure"
+  Set_toList -> mkForeign $ \case
+    (Data1 _ _ vs) -> do
+      (s :: Map Val Val) <- decodeVal vs
+      evaluate . forceListSpine $ Map.keys s
+    _ -> die "Set.toList: bad closure"
   where
+    forceListSpine xs = foldl (\u x -> x `seq` u) xs xs
     chop = reverse . dropWhile isPathSeparator . reverse
 
     hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference
@@ -2083,6 +2114,30 @@ functionReplacementList =
     ( "005mc1fq7ojq72c238qlm2rspjgqo2furjodf28icruv316odu6du",
       Map_fromList
     ),
+    ( "01qqpul0ttlgjhr5i2gtmdr2uarns2hbtnjpipmk1575ipkrlug42",
+      Map_union
+    ),
+    ( "00c363e340il8q0fai6peiv3586o931nojj98qfek09hg1tjkm9ma",
+      Map_intersect
+    ),
+    ( "03pjq0jijrr7ebf6s3tuqi4d5hi5mrv19nagp7ql2j9ltm55c32ek",
+      Map_toList
+    ),
+    ( "03putoun7i5n0lhf8iu990u9p08laklnp668i170dka2itckmadlq",
+      Multimap_fromList
+    ),
+    ( "03q6giac0qlva6u4mja29tr7mv0jqnsugk8paibatdrns8lhqqb92",
+      Set_fromList
+    ),
+    ( "03362vaalqq28lcrmmsjhha637is312j01jme3juj980ugd93up28",
+      Set_union
+    ),
+    ( "01lm6ejo31na1ti6u85bv0klliefll7q0c0da2qnefvcrq1l8rlqe",
+      Set_intersect
+    ),
+    ( "01p7ot36tg62na408mnk1psve6rc7fog30gv6n7thkrv6t3na2gdm",
+      Set_toList
+    ),
     ( "03c559iihi2vj0qps6cln48nv31ajup2srhas4pd05b9k46ds8jvk",
       Map_eq
     ),

unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs

@@ -260,8 +260,16 @@ data ForeignFunc
   | Map_lookup
   | Map_fromList
   | Map_eq
+  | Map_union
+  | Map_intersect
+  | Map_toList
   | List_range
   | List_sort
+  | Multimap_fromList
+  | Set_fromList
+  | Set_union
+  | Set_intersect
+  | Set_toList
   deriving (Show, Eq, Ord, Enum, Bounded)
 
 foreignFuncBuiltinName :: ForeignFunc -> Text
@@ -518,5 +526,13 @@ foreignFuncBuiltinName = \case
   Map_lookup -> "Map.lookup"
   Map_fromList -> "Map.fromList"
   Map_eq -> "Map.=="
+  Map_union -> "Map.union"
+  Map_intersect -> "Map.intersect"
+  Map_toList -> "Map.toList"
   List_range -> "List.range"
   List_sort -> "List.sort"
+  Multimap_fromList -> "Multimap.fromList"
+  Set_fromList -> "Set.fromList"
+  Set_union -> "Set.union"
+  Set_intersect -> "Set.intersect"
+  Set_toList -> "Set.toList"

unison-runtime/src/Unison/Runtime/TypeTags.hs

@@ -41,6 +41,7 @@ module Unison.Runtime.TypeTags
     seqViewEmptyTag,
     mapTipTag,
     mapBinTag,
+    setWrapTag,
   )
 where
 
@@ -251,6 +252,13 @@ mapTipTag, mapBinTag :: PackedTag
         ] = (mtt, mbt)
   | otherwise = error "internal error: map tags"
 
+setWrapTag :: PackedTag
+setWrapTag
+  | [swt] <-
+      mkTags "set tag" Ty.setRef
+        [ Ty.setWrap ] = swt
+  | otherwise = error "internal error: set tag"
+
 -- | A tag we use to represent the 'pure' effect case.
 pureEffectTag :: PackedTag
 pureEffectTag = PackedTag 0