(untested) create suffixed pretty print environment directly from names

parser-typechecker/src/Unison/PrettyPrintEnv.hs

@@ -40,7 +40,10 @@ fromNames len names = PrettyPrintEnv terms' types' where
   shortestName ns = safeHead $ HQ.sortByLength (toList ns)
 
 fromSuffixNames :: Int -> Names -> PrettyPrintEnv
-fromSuffixNames len names = fromNames len (Names.suffixify names)
+fromSuffixNames len names = PrettyPrintEnv terms' types' where
+  terms' r = pickName . Set.map HQ'.toHQ $ Names.suffixedTermName len r names
+  types' r = pickName . Set.map HQ'.toHQ $ Names.suffixedTypeName len r names
+  pickName ns = safeHead . Name.sortNameds toList . HQ.sortByLength $ toList ns
 
 fromNamesDecl :: Int -> Names -> PrettyPrintEnvDecl
 fromNamesDecl len names =

unison-core/src/Unison/HashQualified.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -20,7 +22,7 @@ import qualified Unison.Var                    as Var
 
 data HashQualified n
   = NameOnly n | HashOnly ShortHash | HashQualified n ShortHash
-  deriving (Eq, Functor, Show, Generic)
+  deriving (Eq, Foldable, Traversable, Functor, Show, Generic)
 
 stripNamespace :: Text -> HashQualified Name -> HashQualified Name
 stripNamespace namespace hq = case hq of

unison-core/src/Unison/Name.hs

@@ -16,11 +16,13 @@ module Unison.Name
   , parent
   , sortNames
   , sortNamed
+  , sortNameds
   , sortByText
   , sortNamed'
   , stripNamePrefix
   , stripPrefixes
   , segments
+  , reverseSegments
   , countSegments
   , segments'
   , suffixes
@@ -60,6 +62,9 @@ sortNames = sortNamed id
 sortNamed :: (a -> Name) -> [a] -> [a]
 sortNamed by = sortByText (toText . by)
 
+sortNameds :: (a -> [Name]) -> [a] -> [a]
+sortNameds by = sortByText (Text.intercalate "." . map toText . by)
+
 sortByText :: (a -> Text) -> [a] -> [a]
 sortByText by as = let
   as' = [ (a, by a) | a <- as ]
@@ -178,6 +183,9 @@ fromSegment = unsafeFromText . NameSegment.toText
 segments :: Name -> [NameSegment]
 segments (Name n) = NameSegment <$> segments' n
 
+reverseSegments :: Name -> [NameSegment]
+reverseSegments (Name n) = NameSegment <$> NameSegment.reverseSegments' n
+
 countSegments :: Name -> Int
 countSegments n = length (segments n)
 
@@ -194,6 +202,8 @@ class Parse a b where
 instance Convert Name Text where convert = toText
 instance Convert Name [NameSegment] where convert = segments
 instance Convert NameSegment Name where convert = fromSegment
+instance Convert [NameSegment] Name where
+  convert sgs = unsafeFromText (Text.intercalate "." (map NameSegment.toText sgs))
 
 instance Parse Text NameSegment where
   parse txt = case NameSegment.segments' txt of

unison-core/src/Unison/Names3.hs

@@ -6,6 +6,7 @@ module Unison.Names3 where
 
 import Unison.Prelude
 
+import Data.List (tails,find)
 import Data.List.Extra (nubOrd)
 import Unison.HashQualified (HashQualified)
 import qualified Unison.HashQualified as HQ
@@ -192,6 +193,36 @@ termName length r Names{..} =
   where hq n = HQ'.take length (HQ'.fromNamedReferent n r)
         isConflicted n = R.manyDom n (Names.terms currentNames)
 
+suffixedTypeName :: Int -> Reference -> Names -> Set (HQ'.HashQualified Name)
+suffixedTermName :: Int -> Referent -> Names -> Set (HQ'.HashQualified Name)
+(suffixedTermName,suffixedTypeName) =
+  ( suffixedName termName (Names.terms . currentNames) HQ'.fromNamedReferent
+  , suffixedName typeName (Names.types . currentNames) HQ'.fromNamedReference )
+  where
+  suffixedName fallback getRel hq' length r ns@(getRel -> rel) =
+    if R.memberRan r rel
+    then go $ toList (R.lookupRan r rel)
+    else fallback length r ns
+    where
+      isConflicted n = R.manyDom n rel
+      hq n = HQ'.take length (hq' n r)
+      go ns = case sortOn (\n -> (Name.countSegments n, Name.toText n)) ns of
+        [] -> mempty
+        fqn : _ -> Set.singleton $
+          let n' = shortestUniqueSuffix fqn r rel
+          in if isConflicted fqn then hq n'
+             else HQ'.fromName n'
+
+shortestUniqueSuffix :: Ord r => Name -> r -> Relation Name r -> Name
+shortestUniqueSuffix fqn r rel =
+  maybe fqn (Name.convert . reverse) (find isOk suffixes)
+  where
+  suffixes = reverse $ init (tails (Name.reverseSegments fqn))
+  isOk suffix = Set.size rs <= 1 || Set.toList rs == [r]
+    where rs = R.searchDom compareEnd rel
+          compareEnd n = compare (take len (Name.reverseSegments n)) suffix
+          len = length suffix
+
 -- Set HashQualified -> Branch m -> Action' m v Names
 -- Set HashQualified -> Branch m -> Free (Command m i v) Names
 -- Set HashQualified -> Branch m -> Command m i v Names