Backticky symbol parsing

codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Decl/Hashing.hs

@@ -34,7 +34,7 @@ verifyDeclFormatHash (ComponentHash hash) (DeclFormat.Decl (DeclFormat.LocallyIn
     & Map.toList
     & fmap (\(_refId, (v, decl, ())) -> (v, either H2.toDataDecl id $ H2.v2ToH2Decl decl))
     & Map.fromList
-    & H2.hashDecls Name.unsafeFromVar
+    & H2.hashDecls Name.unsafeParseVar
     & \case
       Left _err -> Just HH.DeclHashResolutionFailure
       Right m ->

codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs

@@ -200,8 +200,7 @@ import U.Util.Base32Hex qualified as Base32Hex
 import U.Util.Serialization qualified as S
 import Unison.Hash qualified as H
 import Unison.Hash32 qualified as Hash32
-import Unison.NameSegment (NameSegment (NameSegment))
-import Unison.NameSegment qualified as NameSegment
+import Unison.NameSegment (NameSegment)
 import Unison.Prelude
 import Unison.ShortHash (ShortCausalHash (..), ShortNamespaceHash (..))
 import Unison.Sqlite
@@ -577,7 +576,7 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
       Transaction (Map NameSegment (Map C.Referent (Transaction C.Branch.MdValues)))
     doTerms =
       Map.bitraverse
-        (fmap NameSegment . Q.expectText)
+        Q.expectNameSegment
         ( Map.bitraverse s2cReferent \case
             S.MetadataSet.Inline rs ->
               pure $ C.Branch.MdValues <$> loadTypesForMetadata rs
@@ -587,22 +586,22 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
       Transaction (Map NameSegment (Map C.Reference (Transaction C.Branch.MdValues)))
     doTypes =
       Map.bitraverse
-        (fmap NameSegment . Q.expectText)
+        Q.expectNameSegment
         ( Map.bitraverse s2cReference \case
             S.MetadataSet.Inline rs ->
               pure $ C.Branch.MdValues <$> loadTypesForMetadata rs
         )
     doPatches ::
       Map Db.TextId Db.PatchObjectId ->
       Transaction (Map NameSegment (PatchHash, Transaction C.Branch.Patch))
-    doPatches = Map.bitraverse (fmap NameSegment . Q.expectText) \patchId -> do
+    doPatches = Map.bitraverse Q.expectNameSegment \patchId -> do
       h <- PatchHash <$> (Q.expectPrimaryHashByObjectId . Db.unPatchObjectId) patchId
       pure (h, expectPatch patchId)
 
     doChildren ::
       Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) ->
       Transaction (Map NameSegment (C.Branch.CausalBranch Transaction))
-    doChildren = Map.bitraverse (fmap NameSegment . Q.expectText) \(boId, chId) ->
+    doChildren = Map.bitraverse Q.expectNameSegment \(boId, chId) ->
       C.Causal
         <$> Q.expectCausalHash chId
         <*> expectValueHashByCausalHashId chId
@@ -718,15 +717,15 @@ saveNamespace hh bhId me = do
     c2sBranch :: BranchV Transaction -> Transaction DbBranchV
     c2sBranch = \case
       BranchV2 branch -> do
-        terms <- Map.bitraverse saveNameSegment (Map.bitraverse c2sReferent c2sMetadata) (branch ^. #terms)
-        types <- Map.bitraverse saveNameSegment (Map.bitraverse c2sReference c2sMetadata) (branch ^. #types)
-        patches <- Map.bitraverse saveNameSegment savePatchObjectId (branch ^. #patches)
-        children <- Map.bitraverse saveNameSegment (saveBranch hh) (branch ^. #children)
+        terms <- Map.bitraverse Q.saveNameSegment (Map.bitraverse c2sReferent c2sMetadata) (branch ^. #terms)
+        types <- Map.bitraverse Q.saveNameSegment (Map.bitraverse c2sReference c2sMetadata) (branch ^. #types)
+        patches <- Map.bitraverse Q.saveNameSegment savePatchObjectId (branch ^. #patches)
+        children <- Map.bitraverse Q.saveNameSegment (saveBranch hh) (branch ^. #children)
         pure (DbBranchV2 S.Branch {terms, types, patches, children})
       BranchV3 branch -> do
-        children <- Map.bitraverse saveNameSegment (saveBranchV3 hh) (branch ^. #children)
-        terms <- Map.bitraverse saveNameSegment c2sReferent (branch ^. #terms)
-        types <- Map.bitraverse saveNameSegment c2sReference (branch ^. #types)
+        children <- Map.bitraverse Q.saveNameSegment (saveBranchV3 hh) (branch ^. #children)
+        terms <- Map.bitraverse Q.saveNameSegment c2sReferent (branch ^. #terms)
+        types <- Map.bitraverse Q.saveNameSegment c2sReference (branch ^. #types)
         pure (DbBranchV3 S.BranchV3 {children, terms, types})
 
     c2sMetadata :: Transaction C.Branch.MdValues -> Transaction S.Branch.Full.DbMetadataSet
@@ -740,9 +739,6 @@ saveNamespace hh bhId me = do
         patch <- mp
         savePatch hh h patch
 
-    saveNameSegment :: NameSegment -> Transaction Db.TextId
-    saveNameSegment = Q.saveText . NameSegment.toText
-
 -- Save just the causal object (i.e. the `causal` row and its associated `causal_parents`). Internal helper shared by
 -- `saveBranch` and `saveBranchV3`.
 saveCausalObject ::

codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs

@@ -16,6 +16,10 @@ module U.Codebase.Sqlite.Queries
     expectText,
     expectTextCheck,
 
+    -- ** name segments
+    saveNameSegment,
+    expectNameSegment,
+
     -- * hash table
     saveHash,
     saveHashes,
@@ -389,6 +393,8 @@ import Unison.Hash qualified as Hash
 import Unison.Hash32 (Hash32)
 import Unison.Hash32 qualified as Hash32
 import Unison.Hash32.Orphans.Sqlite ()
+import Unison.NameSegment (NameSegment (NameSegment))
+import Unison.NameSegment qualified as NameSegment
 import Unison.Prelude
 import Unison.Sqlite
 import Unison.Util.Alternative qualified as Alternative
@@ -646,6 +652,14 @@ loadTextSql h =
     WHERE id = :h
   |]
 
+saveNameSegment :: NameSegment -> Transaction TextId
+saveNameSegment =
+ saveText . NameSegment.toUnescapedText
+
+expectNameSegment :: TextId -> Transaction NameSegment
+expectNameSegment =
+  fmap NameSegment . expectText
+
 saveHashObject :: HashId -> ObjectId -> HashVersion -> Transaction ()
 saveHashObject hId oId version =
   execute
@@ -4229,7 +4243,7 @@ data JsonParseFailure = JsonParseFailure
   deriving anyclass (SqliteExceptionReason)
 
 -- | Get the most recent namespace the user has visited.
-expectMostRecentNamespace :: Transaction [Text]
+expectMostRecentNamespace :: Transaction [NameSegment]
 expectMostRecentNamespace =
   queryOneColCheck
     [sql|
@@ -4238,11 +4252,11 @@ expectMostRecentNamespace =
     |]
     check
   where
-    check :: Text -> Either JsonParseFailure [Text]
+    check :: Text -> Either JsonParseFailure [NameSegment]
     check bytes =
       case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of
         Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure}
-        Right namespace -> Right namespace
+        Right namespace -> Right (map NameSegment namespace)
 
 -- | Set the most recent namespace the user has visited.
 setMostRecentNamespace :: [Text] -> Transaction ()

codebase2/core/Unison/NameSegment.hs

@@ -1,63 +1,57 @@
-module Unison.NameSegment where
+module Unison.NameSegment
+  ( NameSegment (..),
+    toUnescapedText,
+    isPrefixOf,
+
+    -- * Sentinel name segments
+    defaultPatchSegment,
+    docSegment,
+    libSegment,
+  )
+where
 
 import Data.Text qualified as Text
-import Data.Text.Lazy.Builder qualified as Text (Builder)
-import Data.Text.Lazy.Builder qualified as Text.Builder
 import Unison.Prelude
-import Unison.Util.Alphabetical (Alphabetical, compareAlphabetical)
+import Unison.Util.Alphabetical (Alphabetical)
 
 -- Represents the parts of a name between the `.`s
-newtype NameSegment = NameSegment {toText :: Text}
+newtype NameSegment
+  = NameSegment Text
   deriving stock (Eq, Ord, Generic)
+  deriving newtype (Alphabetical)
 
-instance Alphabetical NameSegment where
-  compareAlphabetical n1 n2 = compareAlphabetical (toText n1) (toText n2)
-
--- Split text into segments. A smarter version of `Text.splitOn` that handles
--- the name `.` properly.
-segments' :: Text -> [Text]
-segments' n = go split
-  where
-    split = Text.splitOn "." n
-    go [] = []
-    go ("" : "" : z) = "." : go z
-    go ("" : z) = go z
-    go (x : y) = x : go y
-
--- Same as reverse . segments', but produces the output as a
--- lazy list, suitable for suffix-based ordering purposes or
--- building suffix tries. Examples:
+instance IsString NameSegment where
+  fromString =
+    NameSegment . Text.pack
+
+instance Show NameSegment where
+  show =
+    Text.unpack . toUnescapedText
+
+-- | Convert a name segment to unescaped text.
 --
---   reverseSegments' "foo.bar.baz"  => ["baz","bar","foo"]
---   reverseSegments' ".foo.bar.baz" => ["baz","bar","foo"]
---   reverseSegments' ".."           => ["."]
---   reverseSegments' "Nat.++"       => ["++","Nat"]
---   reverseSegments' "Nat.++.zoo"   => ["zoo","++","Nat"]
-reverseSegments' :: Text -> [Text]
-reverseSegments' = go
-  where
-    go "" = []
-    go t =
-      let seg0 = Text.takeWhileEnd (/= '.') t
-          seg = if Text.null seg0 then Text.takeEnd 1 t else seg0
-          rem = Text.dropEnd (Text.length seg + 1) t
-       in seg : go rem
-
-isEmpty :: NameSegment -> Bool
-isEmpty ns = toText ns == mempty
+-- You might use this when storing a name segment as text in a database, where the literal name segment bytes are all
+-- that matter. However, you wouldn't use this to display the name segment to a user - that depends on concrete syntax.
+-- See Unison.Syntax.NameSegment (or indeed, some actual yet-built interface that abstracts concrete syntax) for that
+-- kind of function.
+--
+-- > toUnescapedText (unsafeFromText ".~") = ".~"
+toUnescapedText :: NameSegment -> Text
+toUnescapedText =
+  coerce
 
 isPrefixOf :: NameSegment -> NameSegment -> Bool
-isPrefixOf n1 n2 = Text.isPrefixOf (toText n1) (toText n2)
-
-toString :: NameSegment -> String
-toString = Text.unpack . toText
+isPrefixOf =
+  coerce Text.isPrefixOf
 
-toTextBuilder :: NameSegment -> Text.Builder
-toTextBuilder =
-  coerce Text.Builder.fromText
+defaultPatchSegment :: NameSegment
+defaultPatchSegment =
+  "patch"
 
-instance IsString NameSegment where
-  fromString = NameSegment . Text.pack
+docSegment :: NameSegment
+docSegment =
+  "doc"
 
-instance Show NameSegment where
-  show = show . toText
+libSegment :: NameSegment
+libSegment =
+  "lib"

codebase2/core/Unison/ShortHash.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
 module Unison.ShortHash

parser-typechecker/src/U/Codebase/Projects.hs

@@ -11,7 +11,7 @@ import U.Codebase.Causal qualified as Causal
 import U.Codebase.HashTags (BranchHash (..))
 import Unison.Codebase.Path
 import Unison.Codebase.Path qualified as Path
-import Unison.Name (libSegment)
+import Unison.NameSegment (libSegment)
 import Unison.Prelude
 import Unison.Sqlite qualified as Sqlite
 import Unison.Util.Monoid (ifoldMapM)

parser-typechecker/src/Unison/Builtin.hs

@@ -38,7 +38,7 @@ import Unison.Prelude
 import Unison.Reference qualified as R
 import Unison.Referent qualified as Referent
 import Unison.Symbol (Symbol)
-import Unison.Syntax.Name qualified as Name (unsafeFromText, unsafeFromVar)
+import Unison.Syntax.Name qualified as Name (unsafeParseText, unsafeParseVar)
 import Unison.Type qualified as Type
 import Unison.Typechecker.TypeLookup qualified as TL
 import Unison.Util.Relation qualified as Rel
@@ -56,24 +56,24 @@ names = Names terms types
     terms =
       Rel.mapRan Referent.Ref (Rel.fromMap termNameRefs)
         <> Rel.fromList
-          [ (Name.unsafeFromVar vc, Referent.Con (ConstructorReference (R.DerivedId r) cid) ct)
+          [ (Name.unsafeParseVar vc, Referent.Con (ConstructorReference (R.DerivedId r) cid) ct)
             | (ct, (_, (r, decl))) <-
                 ((CT.Data,) <$> builtinDataDecls)
                   <> ((CT.Effect,) . (second . second) DD.toDataDecl <$> builtinEffectDecls),
               ((_, vc, _), cid) <- DD.constructors' decl `zip` [0 ..]
           ]
         <> Rel.fromList
-          [ (Name.unsafeFromVar v, Referent.Ref (R.DerivedId i))
+          [ (Name.unsafeParseVar v, Referent.Ref (R.DerivedId i))
             | (v, i) <- Map.toList TD.builtinTermsRef
           ]
     types =
       Rel.fromList builtinTypes
         <> Rel.fromList
-          [ (Name.unsafeFromVar v, R.DerivedId r)
+          [ (Name.unsafeParseVar v, R.DerivedId r)
             | (v, (r, _)) <- builtinDataDecls
           ]
         <> Rel.fromList
-          [ (Name.unsafeFromVar v, R.DerivedId r)
+          [ (Name.unsafeParseVar v, R.DerivedId r)
             | (v, (r, _)) <- builtinEffectDecls
           ]
 
@@ -147,7 +147,7 @@ builtinTypeDependentsOfComponent h0 = Rel.searchRan ord builtinDependencies
 -- if we decide to change their names.
 builtinTypes :: [(Name, R.Reference)]
 builtinTypes =
-  Map.toList . Map.mapKeys Name.unsafeFromText $
+  Map.toList . Map.mapKeys Name.unsafeParseText $
     foldl' go mempty builtinTypesSrc
   where
     go m = \case
@@ -286,7 +286,7 @@ instance Show BuiltinDSL where
   show _ = ""
 
 termNameRefs :: Map Name R.Reference
-termNameRefs = Map.mapKeys Name.unsafeFromText $ foldl' go mempty (stripVersion builtinsSrc)
+termNameRefs = Map.mapKeys Name.unsafeParseText $ foldl' go mempty (stripVersion builtinsSrc)
   where
     go m = \case
       B r _tp -> Map.insert r (R.Builtin r) m

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

@@ -120,6 +120,7 @@ import Unison.Hashing.V2.Convert qualified as H
 import Unison.Name (Name)
 import Unison.Name qualified as Name
 import Unison.NameSegment (NameSegment)
+import Unison.NameSegment qualified as NameSegment
 import Unison.Prelude hiding (empty)
 import Unison.Reference (TermReference, TypeReference)
 import Unison.Referent (Referent)
@@ -151,7 +152,7 @@ withoutLib Branch0 {..} =
         _children
           & imapMaybe
             ( \nameSegment child ->
-                if nameSegment == Name.libSegment
+                if nameSegment == NameSegment.libSegment
                   then Nothing
                   else Just (child & head_ %~ withoutLib)
             )
@@ -165,7 +166,7 @@ withoutTransitiveLibs Branch0 {..} =
         _children
           & imapMaybe
             ( \nameSegment child ->
-                if nameSegment == Name.libSegment
+                if nameSegment == NameSegment.libSegment
                   then Just (child & head_ %~ withoutLib)
                   else Just (child & head_ %~ withoutTransitiveLibs)
             )
@@ -348,7 +349,7 @@ deepChildrenHelper (reversePrefix, libDepth, b0) = do
           pure
             if isShallowDependency || isUnseenNamespace
               then
-                let libDepth' = if ns == "lib" then libDepth + 1 else libDepth
+                let libDepth' = if ns == NameSegment.libSegment then libDepth + 1 else libDepth
                  in Seq.singleton (ns : reversePrefix, libDepth', head b)
               else Seq.empty
         State.modify' (Set.insert h)

parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs

@@ -12,6 +12,7 @@ import Unison.Prelude
 import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
 import Unison.Share.Types
 import Unison.Util.Monoid qualified as Monoid
+import qualified Unison.NameSegment as NameSegment
 
 data ReadRepo
   = ReadRepoGit ReadGitRepo
@@ -131,7 +132,7 @@ data ReadShareLooseCode = ReadShareLooseCode
 isPublic :: ReadShareLooseCode -> Bool
 isPublic ReadShareLooseCode {path} =
   case path of
-    ("public" Path.:< _) -> True
+    ((NameSegment.toUnescapedText -> "public") Path.:< _) -> True
     _ -> False
 
 data WriteRemoteNamespace a