⅄ trunk → 24-12-04-fix-5427

README.md

@@ -10,6 +10,8 @@ The Unison language
 * [Codebase Server](#codebase-server)
 * [Configuration](./docs/configuration.md)
 
+![Alt](https://repobeats.axiom.co/api/embed/92b662a65fd842d49cb8d7d813043f5f5b4b550d.svg "Repobeats analytics image")
+
 Overview
 --------
 

lib/unison-util-recursion/src/Unison/Util/Recursion.hs

@@ -8,12 +8,13 @@ module Unison.Util.Recursion
     cataM,
     para,
     Fix (..),
-    Cofree' (..),
   )
 where
 
 import Control.Arrow ((&&&))
 import Control.Comonad.Cofree (Cofree ((:<)))
+import Control.Comonad.Trans.Cofree (CofreeF)
+import Control.Comonad.Trans.Cofree qualified as CofreeF
 import Control.Monad ((<=<))
 
 type Algebra f a = f a -> a
@@ -46,12 +47,9 @@ instance (Functor f) => Recursive (Fix f) f where
   embed = Fix
   project (Fix f) = f
 
-data Cofree' f a x = a :<< f x
-  deriving (Foldable, Functor, Traversable)
-
 -- |
 --
 --  __NB__: `Cofree` from “free” is lazy, so this instance is technically partial.
-instance (Functor f) => Recursive (Cofree f a) (Cofree' f a) where
-  embed (a :<< fco) = a :< fco
-  project (a :< fco) = a :<< fco
+instance (Functor f) => Recursive (Cofree f a) (CofreeF f a) where
+  embed (a CofreeF.:< fco) = a :< fco
+  project (a :< fco) = a CofreeF.:< fco

parser-typechecker/src/Unison/Syntax/DeclParser.hs

@@ -75,38 +75,25 @@ declarations = do
 data UnresolvedModifier
   = UnresolvedModifier'Structural
   | UnresolvedModifier'UniqueWithGuid !Text
-  | -- The Text here is a random GUID that we *may not end up using*, as in the case when we instead have a GUID to
-    -- reuse (which we will discover soon, once we parse this unique type's name and pass it into the `uniqueTypeGuid`
-    -- function in the parser environment).
-    --
-    -- However, we generate this GUID anyway for backwards-compatibility with *transcripts*. Since the GUID we assign
-    -- is a function of the current source location in the parser state, if we generate it later (after moving a few
-    -- tokens ahead to the type's name), then we'll get a different value.
-    --
-    -- This is only done to make the transcript diff smaller and easier to review, as the PR that adds this GUID-reuse
-    -- feature ought not to change any hashes. However, at any point after it lands in trunk, this Text could be
-    -- removed from this constructor, the generation of these GUIDs could be delayed until we actually need them, and
-    -- the transcripts could all be re-generated.
-    UnresolvedModifier'UniqueWithoutGuid !Text
+  | UnresolvedModifier'UniqueWithoutGuid
 
 resolveUnresolvedModifier :: (Monad m, Var v) => L.Token UnresolvedModifier -> v -> P v m (L.Token DD.Modifier)
 resolveUnresolvedModifier unresolvedModifier var =
   case L.payload unresolvedModifier of
     UnresolvedModifier'Structural -> pure (DD.Structural <$ unresolvedModifier)
     UnresolvedModifier'UniqueWithGuid guid -> pure (DD.Unique guid <$ unresolvedModifier)
-    UnresolvedModifier'UniqueWithoutGuid guid0 -> do
-      unique <- resolveUniqueModifier var guid0
+    UnresolvedModifier'UniqueWithoutGuid -> do
+      unique <- resolveUniqueModifier var
       pure $ unique <$ unresolvedModifier
 
-resolveUniqueModifier :: (Monad m, Var v) => v -> Text -> P v m DD.Modifier
-resolveUniqueModifier var guid0 = do
-  ParsingEnv {uniqueTypeGuid} <- ask
-  guid <- fromMaybe guid0 <$> lift (lift (uniqueTypeGuid (Name.unsafeParseVar var)))
-  pure $ DD.Unique guid
-
-defaultUniqueModifier :: (Monad m, Var v) => v -> P v m DD.Modifier
-defaultUniqueModifier var =
-  uniqueName 32 >>= resolveUniqueModifier var
+resolveUniqueModifier :: (Monad m, Var v) => v -> P v m DD.Modifier
+resolveUniqueModifier var = do
+  env <- ask
+  guid <-
+    lift (lift (env.uniqueTypeGuid (Name.unsafeParseVar var))) >>= \case
+      Nothing -> uniqueName 32
+      Just guid -> pure guid
+  pure (DD.Unique guid)
 
 -- unique[someguid] type Blah = ...
 modifier :: (Monad m, Var v) => P v m (Maybe (L.Token UnresolvedModifier))
@@ -116,9 +103,7 @@ modifier = do
     unique = do
       tok <- openBlockWith "unique"
       optional (openBlockWith "[" *> importWordyId <* closeBlock) >>= \case
-        Nothing -> do
-          guid <- uniqueName 32
-          pure (UnresolvedModifier'UniqueWithoutGuid guid <$ tok)
+        Nothing -> pure (UnresolvedModifier'UniqueWithoutGuid <$ tok)
         Just guid -> pure (UnresolvedModifier'UniqueWithGuid (Name.toText (L.payload guid)) <$ tok)
     structural = do
       tok <- openBlockWith "structural"
@@ -196,7 +181,7 @@ dataDeclaration maybeUnresolvedModifier = do
   _ <- closeBlock
   case maybeUnresolvedModifier of
     Nothing -> do
-      modifier <- defaultUniqueModifier (L.payload name)
+      modifier <- resolveUniqueModifier (L.payload name)
       -- ann spanning the whole Decl.
       let declSpanAnn = ann typeToken <> closingAnn
       pure
@@ -234,7 +219,7 @@ effectDeclaration maybeUnresolvedModifier = do
 
   case maybeUnresolvedModifier of
     Nothing -> do
-      modifier <- defaultUniqueModifier (L.payload name)
+      modifier <- resolveUniqueModifier (L.payload name)
       -- ann spanning the whole ability declaration.
       let abilitySpanAnn = ann abilityToken <> closingAnn
       pure

parser-typechecker/src/Unison/Syntax/TermParser.hs

@@ -13,6 +13,7 @@ module Unison.Syntax.TermParser
   )
 where
 
+import Control.Comonad.Trans.Cofree (CofreeF ((:<)))
 import Control.Monad.Reader (asks, local)
 import Data.Bitraversable (bitraverse)
 import Data.Char qualified as Char
@@ -607,7 +608,7 @@ doc2Block = do
   let docAnn = Ann startDoc endDoc
   (docAnn,) . docUntitledSection (gann docAnn) <$> traverse foldTop docContents
   where
-    foldTop = cataM \(a :<< top) -> docTop a =<< bitraverse (cataM \(a :<< leaf) -> docLeaf a leaf) pure top
+    foldTop = cataM \(a :< top) -> docTop a =<< bitraverse (cataM \(a :< leaf) -> docLeaf a leaf) pure top
 
     gann :: (Annotated a) => a -> Ann
     gann = Ann.GeneratedFrom . ann

parser-typechecker/src/Unison/UnisonFile.hs

@@ -33,6 +33,7 @@ module Unison.UnisonFile
     nonEmpty,
     termSignatureExternalLabeledDependencies,
     topLevelComponents,
+    typecheckedToTypeLookup,
     typecheckedUnisonFile,
     Unison.UnisonFile.rewrite,
     prepareRewrite,
@@ -368,6 +369,15 @@ declsToTypeLookup uf =
   where
     wrangle = Map.fromList . Map.elems
 
+typecheckedToTypeLookup :: TypecheckedUnisonFile v a -> TL.TypeLookup v a
+typecheckedToTypeLookup tuf =
+  TL.TypeLookup
+    mempty
+    (wrangle (dataDeclarations' tuf))
+    (wrangle (effectDeclarations' tuf))
+  where
+    wrangle = Map.fromList . Map.elems
+
 -- Returns true if the file has any definitions or watches
 nonEmpty :: TypecheckedUnisonFile v a -> Bool
 nonEmpty uf =

parser-typechecker/src/Unison/Util/EnumContainers.hs

@@ -43,11 +43,15 @@ class EnumKey k where
   intToKey :: Int -> k
 
 instance EnumKey Word64 where
+  {-# INLINE keyToInt #-}
   keyToInt e = fromIntegral e
+  {-# INLINE intToKey #-}
   intToKey i = fromIntegral i
 
 instance EnumKey Word16 where
+  {-# INLINE keyToInt #-}
   keyToInt e = fromIntegral e
+  {-# INLINE intToKey #-}
   intToKey i = fromIntegral i
 
 newtype EnumMap k a = EM (IM.IntMap a)
@@ -77,24 +81,31 @@ newtype EnumSet k = ES IS.IntSet
       Semigroup
     )
 
+{-# INLINE mapFromList #-}
 mapFromList :: (EnumKey k) => [(k, a)] -> EnumMap k a
 mapFromList = EM . IM.fromList . fmap (first keyToInt)
 
+{-# INLINE setFromList #-}
 setFromList :: (EnumKey k) => [k] -> EnumSet k
 setFromList = ES . IS.fromList . fmap keyToInt
 
+{-# INLINE setToList #-}
 setToList :: (EnumKey k) => EnumSet k -> [k]
 setToList (ES s) = intToKey <$> IS.toList s
 
+{-# INLINE mapSingleton #-}
 mapSingleton :: (EnumKey k) => k -> a -> EnumMap k a
 mapSingleton e a = EM $ IM.singleton (keyToInt e) a
 
+{-# INLINE setSingleton #-}
 setSingleton :: (EnumKey k) => k -> EnumSet k
 setSingleton e = ES . IS.singleton $ keyToInt e
 
+{-# INLINE mapInsert #-}
 mapInsert :: (EnumKey k) => k -> a -> EnumMap k a -> EnumMap k a
 mapInsert e x (EM m) = EM $ IM.insert (keyToInt e) x m
 
+{-# INLINE unionWith #-}
 unionWith ::
   (EnumKey k) =>
   (a -> a -> a) ->
@@ -103,60 +114,77 @@ unionWith ::
   EnumMap k a
 unionWith f (EM l) (EM r) = EM $ IM.unionWith f l r
 
+{-# INLINE intersectionWith #-}
 intersectionWith ::
   (a -> b -> c) ->
   EnumMap k a ->
   EnumMap k b ->
   EnumMap k c
 intersectionWith f (EM l) (EM r) = EM $ IM.intersectionWith f l r
 
+{-# INLINE keys #-}
 keys :: (EnumKey k) => EnumMap k a -> [k]
 keys (EM m) = fmap intToKey . IM.keys $ m
 
+{-# INLINE keysSet #-}
 keysSet :: (EnumKey k) => EnumMap k a -> EnumSet k
 keysSet (EM m) = ES (IM.keysSet m)
 
+{-# INLINE restrictKeys #-}
 restrictKeys :: (EnumKey k) => EnumMap k a -> EnumSet k -> EnumMap k a
 restrictKeys (EM m) (ES s) = EM $ IM.restrictKeys m s
 
+{-# INLINE withoutKeys #-}
 withoutKeys :: (EnumKey k) => EnumMap k a -> EnumSet k -> EnumMap k a
 withoutKeys (EM m) (ES s) = EM $ IM.withoutKeys m s
 
+{-# INLINE mapDifference #-}
 mapDifference :: (EnumKey k) => EnumMap k a -> EnumMap k b -> EnumMap k a
 mapDifference (EM l) (EM r) = EM $ IM.difference l r
 
+{-# INLINE member #-}
 member :: (EnumKey k) => k -> EnumSet k -> Bool
 member e (ES s) = IS.member (keyToInt e) s
 
+{-# INLINE hasKey #-}
 hasKey :: (EnumKey k) => k -> EnumMap k a -> Bool
 hasKey k (EM m) = IM.member (keyToInt k) m
 
+{-# INLINE lookup #-}
 lookup :: (EnumKey k) => k -> EnumMap k a -> Maybe a
 lookup e (EM m) = IM.lookup (keyToInt e) m
 
+{-# INLINE lookupWithDefault #-}
 lookupWithDefault :: (EnumKey k) => a -> k -> EnumMap k a -> a
 lookupWithDefault d e (EM m) = IM.findWithDefault d (keyToInt e) m
 
+{-# INLINE mapWithKey #-}
 mapWithKey :: (EnumKey k) => (k -> a -> b) -> EnumMap k a -> EnumMap k b
 mapWithKey f (EM m) = EM $ IM.mapWithKey (f . intToKey) m
 
+{-# INLINE foldMapWithKey #-}
 foldMapWithKey :: (EnumKey k) => (Monoid m) => (k -> a -> m) -> EnumMap k a -> m
 foldMapWithKey f (EM m) = IM.foldMapWithKey (f . intToKey) m
 
+{-# INLINE mapToList #-}
 mapToList :: (EnumKey k) => EnumMap k a -> [(k, a)]
 mapToList (EM m) = first intToKey <$> IM.toList m
 
+{-# INLINE (!) #-}
 (!) :: (EnumKey k) => EnumMap k a -> k -> a
 (!) (EM m) e = m IM.! keyToInt e
 
+{-# INLINE findMin #-}
 findMin :: (EnumKey k) => EnumSet k -> k
 findMin (ES s) = intToKey $ IS.findMin s
 
+{-# INLINE traverseSet_ #-}
 traverseSet_ ::
   (Applicative f) => (EnumKey k) => (k -> f ()) -> EnumSet k -> f ()
 traverseSet_ f (ES s) =
   IS.foldr (\i r -> f (intToKey i) *> r) (pure ()) s
 
+{-# INLINE interverse #-}
 interverse ::
   (Applicative f) =>
   (a -> b -> f c) ->
@@ -166,6 +194,7 @@ interverse ::
 interverse f (EM l) (EM r) =
   fmap EM . traverse id $ IM.intersectionWith f l r
 
+{-# INLINE traverseWithKey #-}
 traverseWithKey ::
   (Applicative f) =>
   (EnumKey k) =>
@@ -174,5 +203,6 @@ traverseWithKey ::
   f (EnumMap k b)
 traverseWithKey f (EM m) = EM <$> IM.traverseWithKey (f . intToKey) m
 
+{-# INLINE setSize #-}
 setSize :: EnumSet k -> Int
 setSize (ES s) = IS.size s

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -1469,7 +1469,9 @@ displayI outputLoc hq = do
       let filePPED = PPED.makePPED (PPE.hqNamer 10 namesWithDefinitionsFromFile) (suffixify namesWithDefinitionsFromFile)
 
       let suffixifiedFilePPE = PPE.biasTo bias $ PPE.suffixifiedPPE filePPED
-      (_, watches) <- evalUnisonFile Sandboxed suffixifiedFilePPE unisonFile []
+      (_, watches) <-
+        evalUnisonFile Sandboxed suffixifiedFilePPE unisonFile [] & onLeftM \err ->
+          Cli.returnEarly (Output.EvaluationFailure err)
       (_, _, _, _, tm, _) <-
         Map.lookup toDisplay watches & onNothing (error $ "Evaluation dropped a watch expression: " <> Text.unpack (HQ.toText hq))
       let ns = UF.addNamesFromTypeCheckedUnisonFile unisonFile names

unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs

@@ -77,11 +77,13 @@ loadUnisonFile sourceName text = do
 
   when (not . null $ UF.watchComponents unisonFile) do
     Timing.time "evaluating watches" do
-      (bindings, e) <- evalUnisonFile Permissive ppe unisonFile []
-      let e' = Map.map go e
-          go (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit)
-      when (not (null e')) do
-        Cli.respond $ Output.Evaluated text ppe bindings e'
+      evalUnisonFile Permissive ppe unisonFile [] >>= \case
+        Right (bindings, e) -> do
+          when (not (null e)) do
+            let f (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit)
+            Cli.respond $ Output.Evaluated text ppe bindings (Map.map f e)
+        Left err -> Cli.respond (Output.EvaluationFailure err)
+
   #latestTypecheckedFile .= Just (Right unisonFile)
   where
     withFile ::
@@ -174,29 +176,34 @@ evalUnisonFile ::
   TypecheckedUnisonFile Symbol Ann ->
   [String] ->
   Cli
-    ( [(Symbol, Term Symbol ())],
-      Map Symbol (Ann, WK.WatchKind, Reference.Id, Term Symbol (), Term Symbol (), Bool)
+    ( Either
+        Runtime.Error
+        ( [(Symbol, Term Symbol ())],
+          Map Symbol (Ann, WK.WatchKind, Reference.Id, Term Symbol (), Term Symbol (), Bool)
+        )
     )
 evalUnisonFile mode ppe unisonFile args = do
-  Cli.Env {codebase, runtime, sandboxedRuntime, nativeRuntime} <- ask
+  env <- ask
+
   let theRuntime = case mode of
-        Sandboxed -> sandboxedRuntime
-        Permissive -> runtime
-        Native -> nativeRuntime
+        Sandboxed -> env.sandboxedRuntime
+        Permissive -> env.runtime
+        Native -> env.nativeRuntime
 
   let watchCache :: Reference.Id -> IO (Maybe (Term Symbol ()))
       watchCache ref = do
-        maybeTerm <- Codebase.runTransaction codebase (Codebase.lookupWatchCache codebase ref)
+        maybeTerm <- Codebase.runTransaction env.codebase (Codebase.lookupWatchCache env.codebase ref)
         pure (Term.amap (\(_ :: Ann) -> ()) <$> maybeTerm)
 
   Cli.with_ (withArgs args) do
-    (nts, errs, map) <-
-      Cli.ioE (Runtime.evaluateWatches (Codebase.codebaseToCodeLookup codebase) ppe watchCache theRuntime unisonFile) \err -> do
-        Cli.returnEarly (Output.EvaluationFailure err)
-    when (not $ null errs) (RuntimeUtils.displayDecompileErrors errs)
-    for_ (Map.elems map) \(_loc, kind, hash, _src, value, isHit) -> do
-      -- only update the watch cache when there are no errors
-      when (not isHit && null errs) do
-        let value' = Term.amap (\() -> Ann.External) value
-        Cli.runTransaction (Codebase.putWatch kind hash value')
-    pure (nts, map)
+    let codeLookup = Codebase.codebaseToCodeLookup env.codebase
+    liftIO (Runtime.evaluateWatches codeLookup ppe watchCache theRuntime unisonFile) >>= \case
+      Right (nts, errs, map) -> do
+        when (not $ null errs) (RuntimeUtils.displayDecompileErrors errs)
+        for_ (Map.elems map) \(_loc, kind, hash, _src, value, isHit) -> do
+          -- only update the watch cache when there are no errors
+          when (not isHit && null errs) do
+            let value' = Term.amap (\() -> Ann.External) value
+            Cli.runTransaction (Codebase.putWatch kind hash value')
+        pure (Right (nts, map))
+      Left err -> pure (Left err)