Merge pull request #5259 from unisonweb/24-08-01-merge-api

codebase2/core/Unison/NameSegment.hs

@@ -1,5 +1,6 @@
 module Unison.NameSegment
   ( NameSegment,
+    toUnescapedText,
 
     -- * Sentinel name segments
     defaultPatchSegment,
@@ -23,7 +24,7 @@ module Unison.NameSegment
   )
 where
 
-import Unison.NameSegment.Internal (NameSegment (NameSegment))
+import Unison.NameSegment.Internal (NameSegment (NameSegment, toUnescapedText))
 
 ------------------------------------------------------------------------------------------------------------------------
 -- special segment names

lib/unison-util-relation/src/Unison/Util/BiMultimap.hs

@@ -170,6 +170,7 @@ withoutRan ys m =
 domain :: BiMultimap a b -> Map a (NESet b)
 domain = toMultimap
 
+-- | /O(1)/.
 range :: BiMultimap a b -> Map b a
 range = toMapR
 

parser-typechecker/src/Unison/Codebase/Type.hs

@@ -9,14 +9,13 @@ module Unison.Codebase.Type
 where
 
 import U.Codebase.HashTags (CausalHash)
-import U.Codebase.Reference qualified as V2
 import Unison.Codebase.Branch (Branch)
 import Unison.CodebasePath (CodebasePath)
 import Unison.ConstructorType qualified as CT
 import Unison.DataDeclaration (Decl)
 import Unison.Hash (Hash)
 import Unison.Prelude
-import Unison.Reference (Reference, TypeReference)
+import Unison.Reference (Reference, TypeReference, TermReferenceId, TypeReferenceId)
 import Unison.Reference qualified as Reference
 import Unison.Referent qualified as Referent
 import Unison.ShortHash (ShortHash)
@@ -31,27 +30,27 @@ data Codebase m v a = Codebase
     --
     -- Note that it is possible to call 'putTerm', then 'getTerm', and receive @Nothing@, per the semantics of
     -- 'putTerm'.
-    getTerm :: Reference.Id -> Sqlite.Transaction (Maybe (Term v a)),
+    getTerm :: TermReferenceId -> Sqlite.Transaction (Maybe (Term v a)),
     -- | Get the type of a user-defined term.
     --
     -- Note that it is possible to call 'putTerm', then 'getTypeOfTermImpl', and receive @Nothing@, per the semantics of
     -- 'putTerm'.
-    getTypeOfTermImpl :: Reference.Id -> Sqlite.Transaction (Maybe (Type v a)),
+    getTypeOfTermImpl :: TermReferenceId -> Sqlite.Transaction (Maybe (Type v a)),
     -- | Get a type declaration.
     --
     -- Note that it is possible to call 'putTypeDeclaration', then 'getTypeDeclaration', and receive @Nothing@, per the
     -- semantics of 'putTypeDeclaration'.
-    getTypeDeclaration :: Reference.Id -> Sqlite.Transaction (Maybe (Decl v a)),
+    getTypeDeclaration :: TypeReferenceId -> Sqlite.Transaction (Maybe (Decl v a)),
     -- | Get the type of a given decl.
-    getDeclType :: V2.Reference -> Sqlite.Transaction CT.ConstructorType,
+    getDeclType :: TypeReference -> Sqlite.Transaction CT.ConstructorType,
     -- | Enqueue the put of a user-defined term (with its type) into the codebase, if it doesn't already exist. The
     -- implementation may choose to delay the put until all of the term's (and its type's) references are stored as
     -- well.
-    putTerm :: Reference.Id -> Term v a -> Type v a -> Sqlite.Transaction (),
+    putTerm :: TermReferenceId -> Term v a -> Type v a -> Sqlite.Transaction (),
     putTermComponent :: Hash -> [(Term v a, Type v a)] -> Sqlite.Transaction (),
     -- | Enqueue the put of a type declaration into the codebase, if it doesn't already exist. The implementation may
     -- choose to delay the put until all of the type declaration's references are stored as well.
-    putTypeDeclaration :: Reference.Id -> Decl v a -> Sqlite.Transaction (),
+    putTypeDeclaration :: TypeReferenceId -> Decl v a -> Sqlite.Transaction (),
     putTypeDeclarationComponent :: Hash -> [Decl v a] -> Sqlite.Transaction (),
     -- getTermComponent :: Hash -> m (Maybe [Term v a]),
     getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term v a, Type v a)]),
@@ -66,7 +65,7 @@ data Codebase m v a = Codebase
     -- | Copy a branch and all of its dependencies from this codebase into the given codebase.
     syncToDirectory :: CodebasePath -> Branch m -> m (),
     -- | @getWatch k r@ returns watch result @t@ that was previously put by @putWatch k r t@.
-    getWatch :: WK.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term v a)),
+    getWatch :: WK.WatchKind -> TermReferenceId -> Sqlite.Transaction (Maybe (Term v a)),
     -- | Get the set of user-defined terms-or-constructors that have the given type.
     termsOfTypeImpl :: Reference -> Sqlite.Transaction (Set Referent.Id),
     -- | Get the set of user-defined terms-or-constructors mention the given type anywhere in their signature.

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

@@ -0,0 +1,97 @@
+module Unison.Syntax.FilePrinter
+  ( renderDefnsForUnisonFile,
+  )
+where
+
+import Control.Lens (mapped, _1)
+import Control.Monad.Writer (Writer)
+import Control.Monad.Writer qualified as Writer
+import Data.List qualified as List
+import Data.Map.Strict qualified as Map
+import Data.Set qualified as Set
+import Unison.Builtin.Decls qualified as Builtin.Decls
+import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
+import Unison.DataDeclaration (Decl)
+import Unison.DeclNameLookup (DeclNameLookup, expectConstructorNames)
+import Unison.HashQualified qualified as HQ
+import Unison.HashQualifiedPrime qualified as HQ'
+import Unison.Name (Name)
+import Unison.Prelude
+import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
+import Unison.Reference (TypeReferenceId)
+import Unison.Reference qualified as Reference
+import Unison.Referent (Referent)
+import Unison.Referent qualified as Referent
+import Unison.Syntax.DeclPrinter (AccessorName)
+import Unison.Syntax.DeclPrinter qualified as DeclPrinter
+import Unison.Syntax.TermPrinter qualified as TermPrinter
+import Unison.Term (Term)
+import Unison.Type (Type)
+import Unison.Typechecker qualified as Typechecker
+import Unison.Util.Defns (Defns (..), DefnsF)
+import Unison.Util.Pretty (ColorText, Pretty)
+import Unison.Util.Pretty qualified as Pretty
+import Unison.Var (Var)
+
+-- | Render definitions destined for a Unison file.
+--
+-- This first renders the types (discovering which record accessors will be generated upon parsing), then renders the
+-- terms (being careful not to render any record accessors, since those would cause duplicate binding errors upon
+-- parsing).
+renderDefnsForUnisonFile ::
+  forall a v.
+  (Var v, Monoid a) =>
+  DeclNameLookup ->
+  PrettyPrintEnvDecl ->
+  DefnsF (Map Name) (Term v a, Type v a) (TypeReferenceId, Decl v a) ->
+  DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
+renderDefnsForUnisonFile declNameLookup ppe defns =
+  let (types, accessorNames) = Writer.runWriter (Map.traverseWithKey renderType defns.types)
+   in Defns
+        { terms = Map.mapMaybeWithKey (renderTerm accessorNames) defns.terms,
+          types
+        }
+  where
+    renderType :: Name -> (TypeReferenceId, Decl v a) -> Writer (Set AccessorName) (Pretty ColorText)
+    renderType name (ref, typ) =
+      fmap Pretty.syntaxToColor $
+        DeclPrinter.prettyDeclW
+          -- Sort of a hack; since the decl printer looks in the PPE for names of constructors,
+          -- we just delete all term names out and add back the constructors...
+          -- probably no need to wipe out the suffixified side but we do it anyway
+          (setPpedToConstructorNames declNameLookup name ref ppe)
+          (Reference.fromId ref)
+          (HQ.NameOnly name)
+          typ
+
+    renderTerm :: Set Name -> Name -> (Term v a, Type v a) -> Maybe (Pretty ColorText)
+    renderTerm accessorNames name (term, typ) = do
+      guard (not (Set.member name accessorNames))
+      let hqName = HQ.NameOnly name
+      let rendered
+            | Typechecker.isEqual (Builtin.Decls.testResultListType mempty) typ =
+                "test> " <> TermPrinter.prettyBindingWithoutTypeSignature ppe.suffixifiedPPE hqName term
+            | otherwise = TermPrinter.prettyBinding ppe.suffixifiedPPE hqName term
+      Just (Pretty.syntaxToColor rendered)
+
+setPpedToConstructorNames :: DeclNameLookup -> Name -> TypeReferenceId -> PrettyPrintEnvDecl -> PrettyPrintEnvDecl
+setPpedToConstructorNames declNameLookup name ref =
+  set (#unsuffixifiedPPE . #termNames) referentNames
+    . set (#suffixifiedPPE . #termNames) referentNames
+  where
+    constructorNameMap :: Map ConstructorReference Name
+    constructorNameMap =
+      Map.fromList
+        ( name
+            & expectConstructorNames declNameLookup
+            & List.zip [0 ..]
+            & over (mapped . _1) (ConstructorReference (Reference.fromId ref))
+        )
+
+    referentNames :: Referent -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
+    referentNames = \case
+      Referent.Con conRef _ ->
+        case Map.lookup conRef constructorNameMap of
+          Nothing -> []
+          Just conName -> let hqConName = HQ'.NameOnly conName in [(hqConName, hqConName)]
+      Referent.Ref _ -> []

parser-typechecker/unison-parser-typechecker.cabal

@@ -158,6 +158,7 @@ library
       Unison.Syntax.DeclParser
       Unison.Syntax.DeclPrinter
       Unison.Syntax.FileParser
+      Unison.Syntax.FilePrinter
       Unison.Syntax.NamePrinter
       Unison.Syntax.TermParser
       Unison.Syntax.TermPrinter

unison-cli/src/Unison/Cli/Monad.hs

@@ -47,6 +47,7 @@ module Unison.Cli.Monad
     -- * Running transactions
     runTransaction,
     runTransactionWithRollback,
+    runTransactionWithRollback2,
 
     -- * Internal
     setMostRecentProjectPath,
@@ -444,3 +445,10 @@ runTransactionWithRollback action = do
   Env {codebase} <- ask
   liftIO (Codebase.runTransactionWithRollback codebase \rollback -> Right <$> action (\output -> rollback (Left output)))
     & onLeftM returnEarly
+
+-- | Run a transaction that can abort early.
+-- todo: rename to runTransactionWithRollback
+runTransactionWithRollback2 :: ((forall void. a -> Sqlite.Transaction void) -> Sqlite.Transaction a) -> Cli a
+runTransactionWithRollback2 action = do
+  env <- ask
+  liftIO (Codebase.runTransactionWithRollback env.codebase action)