module Unison.Name
  ( Name,

    -- * Basic construction
    cons,
    snoc,
    joinDot,
    fromSegment,
    fromSegments,
    fromReverseSegments,

    -- * Basic queries
    countSegments,
    isAbsolute,
    isRelative,
    isPrefixOf,
    beginsWithSegment,
    endsWith,
    endsWithReverseSegments,
    endsWithSegments,
    stripReversedPrefix,
    tryStripReversedPrefix,
    reverseSegments,
    segments,
    suffixes,
    lastSegment,

    -- * Basic manipulation
    makeAbsolute,
    makeRelative,
    setPosition,
    parent,
    stripNamePrefix,
    unqualified,
    isUnqualified,

    -- * To organize later
    commonPrefix,
    preferShallowLibDepth,
    searchByRankedSuffix,
    searchBySuffix,
    filterBySuffix,
    filterByRankedSuffix,
    suffixifyByName,
    suffixifyByHash,
    suffixifyByHashName,
    sortByText,
    sortNamed,
    sortNames,
    splits,
    suffixFrom,

    -- * Re-exports
    module Unison.Util.Alphabetical,

    -- * Exported for testing
    compareSuffix,
  )
where

import Control.Lens (mapped, _1, _2)
import Data.List qualified as List
import Data.List.Extra qualified as List
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.Map qualified as Map
import Data.Monoid (Sum (..))
import Data.RFC5051 qualified as RFC5051
import Data.Set qualified as Set
import Unison.Name.Internal
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment
import Unison.Position (Position (..))
import Unison.Prelude
import Unison.Util.Alphabetical (Alphabetical, compareAlphabetical)
import Unison.Util.List qualified as List
import Unison.Util.Relation qualified as R

-- | @compareSuffix x y@ compares the suffix of @y@ (in reverse segment order) that is as long as @x@ to @x@ (in reverse
-- segment order).
--
-- >>> compareSuffix "b.c" "a.b.c"
-- EQ -- because [c,b] == [c,b]
--
-- >>> compareSuffix "b.c" "a.b.b"
-- LT -- because [b,b] < [c,b]
--
-- >>> compareSuffix "a.b.c" "b.c"
-- LT -- because [c,b] < [c,b,a]
--
-- >>> compareSuffix "b.b" "a.b.c"
-- GT -- because [c,b] > [b,b]
--
-- Used for suffix-based lookup of a name. For instance, given a @r : Relation Name x@,
-- @Relation.searchDom (compareSuffix "foo.bar") r@ will find all @r@ whose name has @foo.bar@ as a suffix.
--
-- This is only exported for testing; use 'searchBySuffix' or 'shortestUniqueSuffix' instead.
--
-- /O(n)/, where /n/ is the number of name segments.
compareSuffix :: Name -> Name -> Ordering
compareSuffix :: Name -> Name -> Ordering
compareSuffix (Name Position
_ NonEmpty NameSegment
ss0) =
  (NameSegment
 -> ([NameSegment] -> Ordering) -> [NameSegment] -> Ordering)
-> ([NameSegment] -> Ordering)
-> NonEmpty NameSegment
-> [NameSegment]
-> Ordering
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NameSegment
-> ([NameSegment] -> Ordering) -> [NameSegment] -> Ordering
f (Ordering -> [NameSegment] -> Ordering
forall a b. a -> b -> a
const Ordering
EQ) NonEmpty NameSegment
ss0 ([NameSegment] -> Ordering)
-> (Name -> [NameSegment]) -> Name -> Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
List.NonEmpty.toList (NonEmpty NameSegment -> [NameSegment])
-> (Name -> NonEmpty NameSegment) -> Name -> [NameSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NonEmpty NameSegment
reverseSegments
  where
    f :: NameSegment -> ([NameSegment] -> Ordering) -> ([NameSegment] -> Ordering)
    f :: NameSegment
-> ([NameSegment] -> Ordering) -> [NameSegment] -> Ordering
f NameSegment
x [NameSegment] -> Ordering
acc = \case
      [] -> Ordering
LT
      NameSegment
y : [NameSegment]
ys -> NameSegment -> NameSegment -> Ordering
forall a. Ord a => a -> a -> Ordering
compare NameSegment
y NameSegment
x Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> [NameSegment] -> Ordering
acc [NameSegment]
ys

-- | Cons a name segment onto the head of a relative name. Not monotonic with respect to ordering! It is not safe to use
-- @cons s@ as the first argument to @Map.mapKeysMonotonic@!
--
-- /Precondition/: the name is relative
--
-- /O(n)/, where /n/ is the number of segments.
cons :: (HasCallStack) => NameSegment -> Name -> Name
cons :: HasCallStack => NameSegment -> Name -> Name
cons NameSegment
x Name
name =
  case Name
name of
    Name Position
Absolute NonEmpty NameSegment
_ ->
      [Char] -> Name
forall a. HasCallStack => [Char] -> a
error ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$
        [Char] -> [Char] -> [Char]
reportBug
          [Char]
"E495986"
          ([Char]
"cannot cons " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NameSegment -> [Char]
forall a. Show a => a -> [Char]
show NameSegment
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" onto absolute name" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name)
    Name Position
Relative (NameSegment
y :| [NameSegment]
ys) -> Position -> NonEmpty NameSegment -> Name
Name Position
Relative (NameSegment
y NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| [NameSegment]
ys [NameSegment] -> [NameSegment] -> [NameSegment]
forall a. [a] -> [a] -> [a]
++ [NameSegment
x])

-- | Snoc a name segment onto the end of a name.
--
-- /O(1)/.
snoc :: Name -> NameSegment -> Name
snoc :: Name -> NameSegment -> Name
snoc (Name Position
pos (NameSegment
s1 :| [NameSegment]
ss)) NameSegment
s0 =
  Position -> NonEmpty NameSegment -> Name
Name Position
pos (NameSegment
s0 NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| NameSegment
s1 NameSegment -> [NameSegment] -> [NameSegment]
forall a. a -> [a] -> [a]
: [NameSegment]
ss)

-- | Return the number of name segments in a name.
--
-- /O(n)/, where /n/ is the number of name segments.
countSegments :: Name -> Int
countSegments :: Name -> Int
countSegments (Name Position
_ NonEmpty NameSegment
ss) =
  NonEmpty NameSegment -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty NameSegment
ss

-- | Is this name relative?
--
-- /O(1)/.
isRelative :: Name -> Bool
isRelative :: Name -> Bool
isRelative = \case
  Name Position
Absolute NonEmpty NameSegment
_ -> Bool
False
  Name Position
Relative NonEmpty NameSegment
_ -> Bool
True

-- | @beginsWithSegment name segment@ returns whether @name@'s first name segment is @segment@.
--
-- >>> beginsWithSegment "abc.def" "abc"
-- True
--
-- >>> beginsWithSegment "abc.def" "ab"
-- False
--
-- /O(n)/, where /n/ is the number of name segments.
beginsWithSegment :: Name -> NameSegment -> Bool
beginsWithSegment :: Name -> NameSegment -> Bool
beginsWithSegment Name
name NameSegment
segment =
  NameSegment
segment NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NonEmpty NameSegment -> NameSegment
forall a. NonEmpty a -> a
List.NonEmpty.head (Name -> NonEmpty NameSegment
segments Name
name)

-- | @endsWithSegments x y@ returns whether @x@ ends with @y@.
--
-- >>> endsWithSegments "a.b.c" ["b", "c"]
-- True
--
-- >>> endsWithSegments "a.b.c" ["d"]
-- False
--
-- >>> endsWithSegments "a.b.c" []
-- True
--
-- /O(n)/, where /n/ is the number of name segments.
endsWithSegments :: Name -> [NameSegment] -> Bool
endsWithSegments :: Name -> [NameSegment] -> Bool
endsWithSegments Name
name [NameSegment]
ss =
  Name -> [NameSegment] -> Bool
endsWithReverseSegments Name
name ([NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse [NameSegment]
ss)

-- | Like 'endsWithSegments', but accepts a list of name segments in reverse order.
--
-- Slightly more efficient than 'endsWithSegments'.
--
-- >>> endsWithReverseSegments "a.b.c" ["c", "b"]
-- True
endsWithReverseSegments :: Name -> [NameSegment] -> Bool
endsWithReverseSegments :: Name -> [NameSegment] -> Bool
endsWithReverseSegments (Name Position
_ NonEmpty NameSegment
ss0) [NameSegment]
ss1 =
  [NameSegment] -> NonEmpty NameSegment -> Bool
forall a. Eq a => [a] -> NonEmpty a -> Bool
List.NonEmpty.isPrefixOf [NameSegment]
ss1 NonEmpty NameSegment
ss0

-- >>> endsWith "a.b.c" "b.c"
-- True
endsWith :: Name -> Name -> Bool
endsWith :: Name -> Name -> Bool
endsWith Name
overall Name
suffix = Name -> [NameSegment] -> Bool
endsWithReverseSegments Name
overall (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty NameSegment -> [NameSegment])
-> NonEmpty NameSegment -> [NameSegment]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty NameSegment
reverseSegments Name
suffix)

-- >>> stripReversedPrefix (fromReverseSegments ("c" :| ["b", "a"])) ["b", "a"]
-- Just (Name Relative (NameSegment {toText = "c"} :| []))
-- >>> stripReversedPrefix (fromReverseSegments ("y" :| ["x"])) ["b", "a"]
-- Nothing
--
-- >>> stripReversedPrefix (fromReverseSegments ("c" :| ["b", "a"])) ["b", "a"]
-- Just (Name Relative (NameSegment {toText = "c"} :| []))
stripReversedPrefix :: Name -> [NameSegment] -> Maybe Name
stripReversedPrefix :: Name -> [NameSegment] -> Maybe Name
stripReversedPrefix (Name Position
p NonEmpty NameSegment
segs) [NameSegment]
suffix = do
  [NameSegment]
stripped <- [NameSegment] -> [NameSegment] -> Maybe [NameSegment]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripSuffix [NameSegment]
suffix (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty NameSegment
segs)
  NonEmpty NameSegment
nonEmptyStripped <- [NameSegment] -> Maybe (NonEmpty NameSegment)
forall a. [a] -> Maybe (NonEmpty a)
List.NonEmpty.nonEmpty [NameSegment]
stripped
  Name -> Maybe Name
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Position -> NonEmpty NameSegment -> Name
Name Position
p NonEmpty NameSegment
nonEmptyStripped

-- | Like 'stripReversedPrefix' but if the prefix doesn't match, or if it would strip the
-- entire name away just return the original name.
--
-- >>> tryStripReversedPrefix (fromReverseSegments ("c" :| ["b", "a"])) ["b", "a"]
-- Name Relative (NameSegment {toText = "c"} :| [])
-- >>> tryStripReversedPrefix (fromReverseSegments ("y" :| ["x"])) ["b", "a"]
-- Name Relative (NameSegment {toText = "y"} :| [NameSegment {toText = "x"}])
--
-- >>> tryStripReversedPrefix (fromReverseSegments ("c" :| ["b", "a"])) ["b", "a"]
-- Name Relative (NameSegment {toText = "c"} :| [])
tryStripReversedPrefix :: Name -> [NameSegment] -> Name
tryStripReversedPrefix :: Name -> [NameSegment] -> Name
tryStripReversedPrefix Name
n [NameSegment]
s = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
n (Name -> [NameSegment] -> Maybe Name
stripReversedPrefix Name
n [NameSegment]
s)

-- | @isPrefixOf x y@ returns whether @x@ is a prefix of (or equivalent to) @y@, which is false if one name is relative
-- and the other is absolute.
--
-- >>> isPrefixOf "a.b" "a.b.c"
-- True
--
-- >>> isPrefixOf "a.b.c" "a.b.c"
-- True
--
-- >>> isPrefixOf ".a.b" "a.b.c"
-- False
--
-- /O(n)/, where /n/ is the number of name segments.
isPrefixOf :: Name -> Name -> Bool
isPrefixOf :: Name -> Name -> Bool
isPrefixOf (Name Position
p0 NonEmpty NameSegment
ss0) (Name Position
p1 NonEmpty NameSegment
ss1) =
  Position
p0 Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
p1 Bool -> Bool -> Bool
&& [NameSegment] -> [NameSegment] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf ([NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty NameSegment
ss0)) ([NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty NameSegment
ss1))

joinDot :: (HasCallStack) => Name -> Name -> Name
joinDot :: HasCallStack => Name -> Name -> Name
joinDot n1 :: Name
n1@(Name Position
p0 NonEmpty NameSegment
ss0) n2 :: Name
n2@(Name Position
p1 NonEmpty NameSegment
ss1) =
  case Position
p1 of
    Position
Relative -> Position -> NonEmpty NameSegment -> Name
Name Position
p0 (NonEmpty NameSegment
ss1 NonEmpty NameSegment
-> NonEmpty NameSegment -> NonEmpty NameSegment
forall a. Semigroup a => a -> a -> a
<> NonEmpty NameSegment
ss0)
    Position
Absolute ->
      [Char] -> Name
forall a. HasCallStack => [Char] -> a
error ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$
        [Char] -> [Char] -> [Char]
reportBug
          [Char]
"E261635"
          ( [Char]
"joinDot: second name cannot be absolute. (name 1 = "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
n1
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", name 2 = "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
n2
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
          )

-- | Make a name absolute. No-op if the name is already absolute.
--
-- /O(1)/.
makeAbsolute :: Name -> Name
makeAbsolute :: Name -> Name
makeAbsolute = Position -> Name -> Name
setPosition Position
Absolute

-- | Make a name relative. No-op if the name is already relative.
--
-- /O(1)/.
makeRelative :: Name -> Name
makeRelative :: Name -> Name
makeRelative = Position -> Name -> Name
setPosition Position
Relative

-- | Overwrite a name's position.
-- This only changes the name's tag, it performs no manipulations to
-- the segments of the name.
--
-- /O(1)/.
setPosition :: Position -> Name -> Name
setPosition :: Position -> Name -> Name
setPosition Position
pos (Name Position
_ NonEmpty NameSegment
ss) =
  Position -> NonEmpty NameSegment -> Name
Name Position
pos NonEmpty NameSegment
ss

-- | Compute the "parent" of a name, unless the name is only a single segment, in which case it has no parent.
--
-- >>> parent "a.b.c"
-- Just "a.b"
--
-- >>> parent ".a.b.c"
-- Just ".a.b"
--
-- >>> parent "a"
-- Nothing
parent :: Name -> Maybe Name
parent :: Name -> Maybe Name
parent (Name Position
p NonEmpty NameSegment
ss0) =
  Position -> NonEmpty NameSegment -> Name
Name Position
p (NonEmpty NameSegment -> Name)
-> Maybe (NonEmpty NameSegment) -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NameSegment] -> Maybe (NonEmpty NameSegment)
forall a. [a] -> Maybe (NonEmpty a)
List.NonEmpty.nonEmpty (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
List.NonEmpty.tail NonEmpty NameSegment
ss0)

-- | Construct a relative name from a name segment.
--
-- /O(1)/.
fromSegment :: NameSegment -> Name
fromSegment :: NameSegment -> Name
fromSegment NameSegment
s =
  Position -> NonEmpty NameSegment -> Name
Name Position
Relative (NameSegment
s NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| [])

-- | Construct a relative name from a list of name segments.
--
-- >>> fromSegments ("a" :| ["b", "c"])
-- "a.b.c"
--
-- /O(n)/, where /n/ is the number of name segments.
fromSegments :: NonEmpty NameSegment -> Name
fromSegments :: NonEmpty NameSegment -> Name
fromSegments NonEmpty NameSegment
ss =
  Position -> NonEmpty NameSegment -> Name
Name Position
Relative (NonEmpty NameSegment -> NonEmpty NameSegment
forall a. NonEmpty a -> NonEmpty a
List.NonEmpty.reverse NonEmpty NameSegment
ss)

-- | Construct a relative name from a list of name segments which are in reverse order
--
-- >>> fromReverseSegments ("c" :| ["b", "a"])
-- a.b.c
--
-- /O(1)/
fromReverseSegments :: NonEmpty NameSegment -> Name
fromReverseSegments :: NonEmpty NameSegment -> Name
fromReverseSegments NonEmpty NameSegment
rs =
  Position -> NonEmpty NameSegment -> Name
Name Position
Relative NonEmpty NameSegment
rs

-- | Return the name segments of a name, in reverse order.
--
-- >>> reverseSegments "a.b.c"
-- "c" :| ["b", "a"]
--
-- /O(1)/.
reverseSegments :: Name -> NonEmpty NameSegment
reverseSegments :: Name -> NonEmpty NameSegment
reverseSegments (Name Position
_ NonEmpty NameSegment
ss) =
  NonEmpty NameSegment
ss

-- | Return the final segment of a name.
--
-- >>> lastSegment (fromSegments ("base" :| ["List", "map"]))
-- NameSegment {toText = "map"}
lastSegment :: Name -> NameSegment
lastSegment :: Name -> NameSegment
lastSegment = NonEmpty NameSegment -> NameSegment
forall a. NonEmpty a -> a
List.NonEmpty.head (NonEmpty NameSegment -> NameSegment)
-> (Name -> NonEmpty NameSegment) -> Name -> NameSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NonEmpty NameSegment
reverseSegments

-- If there's no exact matches for `suffix` in `rel`, find all
-- `r` in `rel` whose corresponding name `suffix` as a suffix.
-- For example, `searchBySuffix List.map {(base.List.map, r1)}`
-- will return `{r1}`.
--
-- NB: Implementation uses logarithmic time lookups, not a linear scan.
searchBySuffix :: (Ord r) => Name -> R.Relation Name r -> Set r
searchBySuffix :: forall r. Ord r => Name -> Relation Name r -> Set r
searchBySuffix Name
suffix Relation Name r
rel =
  Name -> Relation Name r -> Set r
forall a b. Ord a => a -> Relation a b -> Set b
R.lookupDom Name
suffix Relation Name r
rel Set r -> Set r -> Set r
forall {a}. Set a -> Set a -> Set a
`orElse` (Name -> Ordering) -> Relation Name r -> Set r
forall a b.
(Ord a, Ord b) =>
(a -> Ordering) -> Relation a b -> Set b
R.searchDom (Name -> Name -> Ordering
compareSuffix Name
suffix) Relation Name r
rel
  where
    orElse :: Set a -> Set a -> Set a
orElse Set a
s1 Set a
s2 = if Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
s1 then Set a
s2 else Set a
s1

-- | Like 'searchBySuffix', but also keeps the names around.
filterBySuffix :: (Ord r) => Name -> R.Relation Name r -> R.Relation Name r
filterBySuffix :: forall r. Ord r => Name -> Relation Name r -> Relation Name r
filterBySuffix Name
suffix Relation Name r
rel =
  case Name -> Map Name (Set r) -> Maybe (Set r)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
suffix (Relation Name r -> Map Name (Set r)
forall a b. Relation a b -> Map a (Set b)
R.domain Relation Name r
rel) of
    Just Set r
refs -> Name -> Set r -> Relation Name r
forall (f :: * -> *) a b.
(Foldable f, Ord a, Ord b) =>
a -> f b -> Relation a b
R.fromManyRan Name
suffix Set r
refs
    Maybe (Set r)
Nothing -> (Name -> Set r -> Relation Name r)
-> (Name -> Ordering) -> Relation Name r -> Relation Name r
forall a c b.
(Ord a, Monoid c) =>
(a -> Set b -> c) -> (a -> Ordering) -> Relation a b -> c
R.searchDomG Name -> Set r -> Relation Name r
forall (f :: * -> *) a b.
(Foldable f, Ord a, Ord b) =>
a -> f b -> Relation a b
R.fromManyRan (Name -> Name -> Ordering
compareSuffix Name
suffix) Relation Name r
rel

-- Like `searchBySuffix`, but prefers local (outside `lib`) and direct (one `lib` deep) names to indirect (two or more
-- `lib` deep) names.
searchByRankedSuffix :: (Ord r) => Name -> R.Relation Name r -> Set r
searchByRankedSuffix :: forall r. Ord r => Name -> Relation Name r -> Set r
searchByRankedSuffix Name
suffix Relation Name r
rel =
  let rs :: Set r
rs = Name -> Relation Name r -> Set r
forall r. Ord r => Name -> Relation Name r -> Set r
searchBySuffix Name
suffix Relation Name r
rel
   in case Set r -> Int
forall a. Set a -> Int
Set.size Set r
rs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 of
        Bool
True -> Set r
rs
        Bool
False ->
          let ok :: Name -> Bool
ok Name
name = Name -> Name -> Ordering
compareSuffix Name
suffix Name
name Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ
              withNames :: [([Name], r)]
withNames = (r -> ([Name], r)) -> [r] -> [([Name], r)]
forall a b. (a -> b) -> [a] -> [b]
map (\r
r -> ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
ok (Set Name -> [Name]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (r -> Relation Name r -> Set Name
forall b a. Ord b => b -> Relation a b -> Set a
R.lookupRan r
r Relation Name r
rel)), r
r)) (Set r -> [r]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set r
rs)
           in [([Name], r)] -> Set r
forall r. Ord r => [([Name], r)] -> Set r
preferShallowLibDepth [([Name], r)]
withNames

-- | Like 'searchByRankedSuffix', but also keeps the names around.
filterByRankedSuffix :: (Ord r) => Name -> R.Relation Name r -> R.Relation Name r
filterByRankedSuffix :: forall r. Ord r => Name -> Relation Name r -> Relation Name r
filterByRankedSuffix Name
suffix Relation Name r
rel =
  let matches :: Relation Name r
matches = Name -> Relation Name r -> Relation Name r
forall r. Ord r => Name -> Relation Name r -> Relation Name r
filterBySuffix Name
suffix Relation Name r
rel
      highestNamePriority :: NamePriority ()
highestNamePriority = (Name -> NamePriority ()) -> Set Name -> NamePriority ()
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Name -> NamePriority ()
prio (Relation Name r -> Set Name
forall a b. Relation a b -> Set a
R.dom Relation Name r
matches)
      keep :: (Name, r) -> Bool
keep (Name
name, r
_) = Name -> NamePriority ()
prio Name
name NamePriority () -> NamePriority () -> Bool
forall a. Ord a => a -> a -> Bool
<= NamePriority ()
highestNamePriority
   in -- Keep only names that are at or less than the highest name priority. This effectively throws out all indirect
      -- dependencies (NamePriorityTwo) if there are any direct dependencies (NamePriorityOne) or local definitions
      -- (also NamePriorityOne).
      ((Name, r) -> Bool) -> Relation Name r -> Relation Name r
forall a b.
(Ord a, Ord b) =>
((a, b) -> Bool) -> Relation a b -> Relation a b
R.filter (Name, r) -> Bool
keep Relation Name r
matches
  where
    prio :: Name -> NamePriority ()
prio = NameLocation -> NamePriority ()
nameLocationPriority (NameLocation -> NamePriority ())
-> (Name -> NameLocation) -> Name -> NamePriority ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NameLocation
classifyNameLocation

-- | precondition: input list is deduped, and so is the Name list in
-- the tuple
preferShallowLibDepth :: (Ord r) => [([Name], r)] -> Set r
preferShallowLibDepth :: forall r. Ord r => [([Name], r)] -> Set r
preferShallowLibDepth = \case
  [] -> Set r
forall a. Set a
Set.empty
  [([Name], r)
x] -> r -> Set r
forall a. a -> Set a
Set.singleton (([Name], r) -> r
forall a b. (a, b) -> b
snd ([Name], r)
x)
  [([Name], r)]
rs ->
    let byPriority :: Map (NamePriority ()) [r]
byPriority = [(NamePriority (), r)] -> Map (NamePriority ()) [r]
forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
f (k, v) -> Map k [v]
List.multimap ((([Name], r) -> (NamePriority (), r))
-> [([Name], r)] -> [(NamePriority (), r)]
forall a b. (a -> b) -> [a] -> [b]
map (([Name] -> NamePriority ()) -> ([Name], r) -> (NamePriority (), r)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Name] -> NamePriority ()
minLibs) [([Name], r)]
rs)
        minLibs :: [Name] -> NamePriority ()
minLibs [] = () -> NamePriority ()
forall a. a -> NamePriority a
NamePriorityOne ()
        minLibs [Name]
ns = [NamePriority ()] -> NamePriority ()
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((Name -> NamePriority ()) -> [Name] -> [NamePriority ()]
forall a b. (a -> b) -> [a] -> [b]
map (NameLocation -> NamePriority ()
nameLocationPriority (NameLocation -> NamePriority ())
-> (Name -> NameLocation) -> Name -> NamePriority ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NameLocation
classifyNameLocation) [Name]
ns)
     in case NamePriority () -> Map (NamePriority ()) [r] -> Maybe [r]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (() -> NamePriority ()
forall a. a -> NamePriority a
NamePriorityOne ()) Map (NamePriority ()) [r]
byPriority Maybe [r] -> Maybe [r] -> Maybe [r]
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> NamePriority () -> Map (NamePriority ()) [r] -> Maybe [r]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (() -> NamePriority ()
forall a. a -> NamePriority a
NamePriorityTwo ()) Map (NamePriority ()) [r]
byPriority of
          Maybe [r]
Nothing -> [r] -> Set r
forall a. Ord a => [a] -> Set a
Set.fromList ((([Name], r) -> r) -> [([Name], r)] -> [r]
forall a b. (a -> b) -> [a] -> [b]
map ([Name], r) -> r
forall a b. (a, b) -> b
snd [([Name], r)]
rs)
          Just [r]
rs -> [r] -> Set r
forall a. Ord a => [a] -> Set a
Set.fromList [r]
rs

data NameLocation
  = NameLocation'Local -- outside lib
  | NameLocation'DirectDep -- inside lib, but outside lib.*.lib
  | NameLocation'IndirectDep -- inside lib.*.lib

classifyNameLocation :: Name -> NameLocation
classifyNameLocation :: Name -> NameLocation
classifyNameLocation Name
name =
  case Name -> NonEmpty NameSegment
segments Name
name of
    ((NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
NameSegment.libSegment) -> Bool
True) :| NameSegment
_ : ((NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
NameSegment.libSegment) -> Bool
True) : [NameSegment]
_ -> NameLocation
NameLocation'IndirectDep
    ((NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
NameSegment.libSegment) -> Bool
True) :| [NameSegment]
_ -> NameLocation
NameLocation'DirectDep
    NonEmpty NameSegment
_ -> NameLocation
NameLocation'Local

data NamePriority a
  = NamePriorityOne !a -- highest priority: local names and direct dep names
  | NamePriorityTwo !a -- lowest priority: indirect dep names
  deriving stock (NamePriority a -> NamePriority a -> Bool
(NamePriority a -> NamePriority a -> Bool)
-> (NamePriority a -> NamePriority a -> Bool)
-> Eq (NamePriority a)
forall a. Eq a => NamePriority a -> NamePriority a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => NamePriority a -> NamePriority a -> Bool
== :: NamePriority a -> NamePriority a -> Bool
$c/= :: forall a. Eq a => NamePriority a -> NamePriority a -> Bool
/= :: NamePriority a -> NamePriority a -> Bool
Eq, (forall a b. (a -> b) -> NamePriority a -> NamePriority b)
-> (forall a b. a -> NamePriority b -> NamePriority a)
-> Functor NamePriority
forall a b. a -> NamePriority b -> NamePriority a
forall a b. (a -> b) -> NamePriority a -> NamePriority b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> NamePriority a -> NamePriority b
fmap :: forall a b. (a -> b) -> NamePriority a -> NamePriority b
$c<$ :: forall a b. a -> NamePriority b -> NamePriority a
<$ :: forall a b. a -> NamePriority b -> NamePriority a
Functor, Eq (NamePriority a)
Eq (NamePriority a) =>
(NamePriority a -> NamePriority a -> Ordering)
-> (NamePriority a -> NamePriority a -> Bool)
-> (NamePriority a -> NamePriority a -> Bool)
-> (NamePriority a -> NamePriority a -> Bool)
-> (NamePriority a -> NamePriority a -> Bool)
-> (NamePriority a -> NamePriority a -> NamePriority a)
-> (NamePriority a -> NamePriority a -> NamePriority a)
-> Ord (NamePriority a)
NamePriority a -> NamePriority a -> Bool
NamePriority a -> NamePriority a -> Ordering
NamePriority a -> NamePriority a -> NamePriority a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (NamePriority a)
forall a. Ord a => NamePriority a -> NamePriority a -> Bool
forall a. Ord a => NamePriority a -> NamePriority a -> Ordering
forall a.
Ord a =>
NamePriority a -> NamePriority a -> NamePriority a
$ccompare :: forall a. Ord a => NamePriority a -> NamePriority a -> Ordering
compare :: NamePriority a -> NamePriority a -> Ordering
$c< :: forall a. Ord a => NamePriority a -> NamePriority a -> Bool
< :: NamePriority a -> NamePriority a -> Bool
$c<= :: forall a. Ord a => NamePriority a -> NamePriority a -> Bool
<= :: NamePriority a -> NamePriority a -> Bool
$c> :: forall a. Ord a => NamePriority a -> NamePriority a -> Bool
> :: NamePriority a -> NamePriority a -> Bool
$c>= :: forall a. Ord a => NamePriority a -> NamePriority a -> Bool
>= :: NamePriority a -> NamePriority a -> Bool
$cmax :: forall a.
Ord a =>
NamePriority a -> NamePriority a -> NamePriority a
max :: NamePriority a -> NamePriority a -> NamePriority a
$cmin :: forall a.
Ord a =>
NamePriority a -> NamePriority a -> NamePriority a
min :: NamePriority a -> NamePriority a -> NamePriority a
Ord)

instance (Monoid a) => Monoid (NamePriority a) where
  mempty :: NamePriority a
mempty = a -> NamePriority a
forall a. a -> NamePriority a
NamePriorityTwo a
forall a. Monoid a => a
mempty

instance (Semigroup a) => Semigroup (NamePriority a) where
  NamePriorityOne a
x <> :: NamePriority a -> NamePriority a -> NamePriority a
<> NamePriorityOne a
y = a -> NamePriority a
forall a. a -> NamePriority a
NamePriorityOne (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)
  NamePriorityOne a
x <> NamePriorityTwo a
_ = a -> NamePriority a
forall a. a -> NamePriority a
NamePriorityOne a
x
  NamePriorityTwo a
_ <> NamePriorityOne a
y = a -> NamePriority a
forall a. a -> NamePriority a
NamePriorityOne a
y
  NamePriorityTwo a
x <> NamePriorityTwo a
y = a -> NamePriority a
forall a. a -> NamePriority a
NamePriorityTwo (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)

unNamePriority :: NamePriority a -> a
unNamePriority :: forall a. NamePriority a -> a
unNamePriority = \case
  NamePriorityOne a
x -> a
x
  NamePriorityTwo a
x -> a
x

nameLocationPriority :: NameLocation -> NamePriority ()
nameLocationPriority :: NameLocation -> NamePriority ()
nameLocationPriority = \case
  NameLocation
NameLocation'Local -> () -> NamePriority ()
forall a. a -> NamePriority a
NamePriorityOne ()
  NameLocation
NameLocation'DirectDep -> () -> NamePriority ()
forall a. a -> NamePriority a
NamePriorityOne ()
  NameLocation
NameLocation'IndirectDep -> () -> NamePriority ()
forall a. a -> NamePriority a
NamePriorityTwo ()

sortByText :: (a -> Text) -> [a] -> [a]
sortByText :: forall a. (a -> Text) -> [a] -> [a]
sortByText a -> Text
by [a]
as =
  let as' :: [(a, Text)]
as' = [(a
a, a -> Text
by a
a) | a
a <- [a]
as]
      comp :: (a, Text) -> (a, Text) -> Ordering
comp (a
_, Text
s) (a
_, Text
s2) = Text -> Text -> Ordering
RFC5051.compareUnicode Text
s Text
s2
   in (a, Text) -> a
forall a b. (a, b) -> a
fst ((a, Text) -> a) -> [(a, Text)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((a, Text) -> (a, Text) -> Ordering) -> [(a, Text)] -> [(a, Text)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (a, Text) -> (a, Text) -> Ordering
forall {a} {a}. (a, Text) -> (a, Text) -> Ordering
comp [(a, Text)]
as'

sortNamed :: (Name -> Text) -> (a -> Name) -> [a] -> [a]
sortNamed :: forall a. (Name -> Text) -> (a -> Name) -> [a] -> [a]
sortNamed Name -> Text
toText a -> Name
f =
  (a -> Text) -> [a] -> [a]
forall a. (a -> Text) -> [a] -> [a]
sortByText (Name -> Text
toText (Name -> Text) -> (a -> Name) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
f)

sortNames :: (Name -> Text) -> [Name] -> [Name]
sortNames :: (Name -> Text) -> [Name] -> [Name]
sortNames Name -> Text
toText =
  (Name -> Text) -> (Name -> Name) -> [Name] -> [Name]
forall a. (Name -> Text) -> (a -> Name) -> [a] -> [a]
sortNamed Name -> Text
toText Name -> Name
forall a. a -> a
id

-- | Return all "splits" of a relative name, which pair a possibly-empty prefix of name segments with a suffix, such
-- that the original name is equivalent to @prefix + suffix@.
--
-- Note: always returns a non-empty list, but (currently) does not use @NonEmpty@ for convenience, as none of the
-- call-sites care if the list is empty or not.
--
-- @
-- > splits foo.bar.baz
--
--   prefix    suffix
--   ------    ------
--   ∅         foo.bar.baz
--   foo       bar.baz
--   foo.bar   baz
-- @
--
-- /Precondition/: the name is relative.
splits :: (HasCallStack) => Name -> [([NameSegment], Name)]
splits :: HasCallStack => Name -> [([NameSegment], Name)]
splits (Name Position
p NonEmpty NameSegment
ss0) =
  NonEmpty NameSegment
ss0
    NonEmpty NameSegment
-> (NonEmpty NameSegment -> [NameSegment]) -> [NameSegment]
forall a b. a -> (a -> b) -> b
& NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
List.NonEmpty.toList
    [NameSegment] -> ([NameSegment] -> [NameSegment]) -> [NameSegment]
forall a b. a -> (a -> b) -> b
& [NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse
    [NameSegment]
-> ([NameSegment] -> [([NameSegment], NonEmpty NameSegment)])
-> [([NameSegment], NonEmpty NameSegment)]
forall a b. a -> (a -> b) -> b
& [NameSegment] -> [([NameSegment], NonEmpty NameSegment)]
forall a. HasCallStack => [a] -> [([a], NonEmpty a)]
splits0
    [([NameSegment], NonEmpty NameSegment)]
-> ([([NameSegment], NonEmpty NameSegment)]
    -> [([NameSegment], Name)])
-> [([NameSegment], Name)]
forall a b. a -> (a -> b) -> b
& ASetter
  [([NameSegment], NonEmpty NameSegment)]
  [([NameSegment], Name)]
  (NonEmpty NameSegment)
  Name
-> (NonEmpty NameSegment -> Name)
-> [([NameSegment], NonEmpty NameSegment)]
-> [([NameSegment], Name)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((([NameSegment], NonEmpty NameSegment)
 -> Identity ([NameSegment], Name))
-> [([NameSegment], NonEmpty NameSegment)]
-> Identity [([NameSegment], Name)]
Setter
  [([NameSegment], NonEmpty NameSegment)]
  [([NameSegment], Name)]
  ([NameSegment], NonEmpty NameSegment)
  ([NameSegment], Name)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((([NameSegment], NonEmpty NameSegment)
  -> Identity ([NameSegment], Name))
 -> [([NameSegment], NonEmpty NameSegment)]
 -> Identity [([NameSegment], Name)])
-> ((NonEmpty NameSegment -> Identity Name)
    -> ([NameSegment], NonEmpty NameSegment)
    -> Identity ([NameSegment], Name))
-> ASetter
     [([NameSegment], NonEmpty NameSegment)]
     [([NameSegment], Name)]
     (NonEmpty NameSegment)
     Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty NameSegment -> Identity Name)
-> ([NameSegment], NonEmpty NameSegment)
-> Identity ([NameSegment], Name)
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  ([NameSegment], NonEmpty NameSegment)
  ([NameSegment], Name)
  (NonEmpty NameSegment)
  Name
_2) (Position -> NonEmpty NameSegment -> Name
Name Position
p (NonEmpty NameSegment -> Name)
-> (NonEmpty NameSegment -> NonEmpty NameSegment)
-> NonEmpty NameSegment
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty NameSegment -> NonEmpty NameSegment
forall a. NonEmpty a -> NonEmpty a
List.NonEmpty.reverse)
  where
    -- splits a.b.c
    -- ([], a.b.c) : over (mapped . _1) (a.) (splits b.c)
    -- ([], a.b.c) : over (mapped . _1) (a.) (([], b.c) : over (mapped . _1) (b.) (splits c))
    -- [([], a.b.c), ([a], b.c), ([a.b], c)]
    splits0 :: (HasCallStack) => [a] -> [([a], NonEmpty a)]
    splits0 :: forall a. HasCallStack => [a] -> [([a], NonEmpty a)]
splits0 = \case
      [] -> []
      [a
x] -> [([], a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [])]
      a
x : [a]
xs -> ([], a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs) ([a], NonEmpty a) -> [([a], NonEmpty a)] -> [([a], NonEmpty a)]
forall a. a -> [a] -> [a]
: ASetter [([a], NonEmpty a)] [([a], NonEmpty a)] [a] [a]
-> ([a] -> [a]) -> [([a], NonEmpty a)] -> [([a], NonEmpty a)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((([a], NonEmpty a) -> Identity ([a], NonEmpty a))
-> [([a], NonEmpty a)] -> Identity [([a], NonEmpty a)]
Setter
  [([a], NonEmpty a)]
  [([a], NonEmpty a)]
  ([a], NonEmpty a)
  ([a], NonEmpty a)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((([a], NonEmpty a) -> Identity ([a], NonEmpty a))
 -> [([a], NonEmpty a)] -> Identity [([a], NonEmpty a)])
-> (([a] -> Identity [a])
    -> ([a], NonEmpty a) -> Identity ([a], NonEmpty a))
-> ASetter [([a], NonEmpty a)] [([a], NonEmpty a)] [a] [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> Identity [a])
-> ([a], NonEmpty a) -> Identity ([a], NonEmpty a)
forall s t a b. Field1 s t a b => Lens s t a b
Lens ([a], NonEmpty a) ([a], NonEmpty a) [a] [a]
_1) (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [([a], NonEmpty a)]
forall a. HasCallStack => [a] -> [([a], NonEmpty a)]
splits0 [a]
xs)

-- | @stripNamePrefix x y@ strips prefix @x@ from name @y@, and returns the resulting name. Returns @Nothing@ @x@ is not
-- a proper (meaning shorter-than) prefix of @y@.
--
-- >>> stripNamePrefix "a.b" "a.b.c"
-- Just "c"
--
-- >>> stripNamePrefix ".a.b" "a.b.c"
-- Nothing
--
-- >>> stripNamePrefix "a.b.c" "a.b.c"
-- Nothing
stripNamePrefix :: Name -> Name -> Maybe Name
stripNamePrefix :: Name -> Name -> Maybe Name
stripNamePrefix (Name Position
p0 NonEmpty NameSegment
ss0) (Name Position
p1 NonEmpty NameSegment
ss1) = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Position
p0 Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
p1)
  NameSegment
s : [NameSegment]
ss <- [NameSegment] -> [NameSegment] -> Maybe [NameSegment]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix ([NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty NameSegment
ss0)) ([NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty NameSegment
ss1))
  Name -> Maybe Name
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Position -> NonEmpty NameSegment -> Name
Name Position
Relative (NonEmpty NameSegment -> NonEmpty NameSegment
forall a. NonEmpty a -> NonEmpty a
List.NonEmpty.reverse (NameSegment
s NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| [NameSegment]
ss)))

-- | Return all relative suffixes of a name, in ascending-length order. The returned list will always be non-empty.
--
-- >>> suffixes "a.b.c"
-- ["a.b.c", "a.b", "c"]
--
-- >>> suffixes ".a.b.c"
-- ["a.b.c", "a.b", "c"]
suffixes :: Name -> [Name]
suffixes :: Name -> [Name]
suffixes (Name Position
_ NonEmpty NameSegment
ss0) = do
  [NameSegment]
ss <- NonEmpty [NameSegment] -> [[NameSegment]]
forall a. NonEmpty a -> [a]
List.NonEmpty.tail (NonEmpty NameSegment -> NonEmpty [NameSegment]
forall (f :: * -> *) a. Foldable f => f a -> NonEmpty [a]
List.NonEmpty.inits NonEmpty NameSegment
ss0)
  -- fromList is safe here because all elements of `tail . inits` are non-empty
  Name -> [Name]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Position -> NonEmpty NameSegment -> Name
Name Position
Relative ([NameSegment] -> NonEmpty NameSegment
forall a. HasCallStack => [a] -> NonEmpty a
List.NonEmpty.fromList [NameSegment]
ss))

-- suffixFrom Int builtin.Int.+ ==> Int.+
-- suffixFrom Int Int.negate    ==> Int.negate
--
-- Currently used as an implementation detail of expanding wildcard
-- imports, (like `use Int` should catch `builtin.Int.+`)
-- but it may be generally useful elsewhere. See `expandWildcardImports`
-- for details.
suffixFrom :: Name -> Name -> Maybe Name
suffixFrom :: Name -> Name -> Maybe Name
suffixFrom (Name Position
p0 NonEmpty NameSegment
ss0) (Name Position
_ NonEmpty NameSegment
ss1) = do
  -- it doesn't make sense to pass an absolute name as the first arg
  Position
Relative <- Position -> Maybe Position
forall a. a -> Maybe a
Just Position
p0
  NameSegment
s : [NameSegment]
ss <- [NameSegment] -> [NameSegment] -> Maybe [NameSegment]
forall a. Eq a => [a] -> [a] -> Maybe [a]
align (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty NameSegment
ss0) (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty NameSegment
ss1)
  -- the returned name is always relative... right?
  Name -> Maybe Name
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Position -> NonEmpty NameSegment -> Name
Name Position
Relative (NameSegment
s NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| [NameSegment]
ss))
  where
    -- Slide the first non-empty list along the second; if there's a match, return the prefix of the second that ends on
    -- that match.
    --
    -- align [a,b] [x,a,b,y] = Just [x,a,b]
    align :: forall a. (Eq a) => [a] -> [a] -> Maybe [a]
    align :: forall a. Eq a => [a] -> [a] -> Maybe [a]
align [a]
xs =
      ([a] -> [a]) -> [a] -> Maybe [a]
go [a] -> [a]
forall a. a -> a
id
      where
        go :: ([a] -> [a]) -> [a] -> Maybe [a]
        go :: ([a] -> [a]) -> [a] -> Maybe [a]
go [a] -> [a]
prepend = \case
          [] -> Maybe [a]
forall a. Maybe a
Nothing
          ys0 :: [a]
ys0@(a
y : [a]
ys) ->
            if [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf [a]
xs [a]
ys0
              then [a] -> Maybe [a]
forall a. a -> Maybe a
Just ([a] -> [a]
prepend [a]
xs)
              else ([a] -> [a]) -> [a] -> Maybe [a]
go ([a] -> [a]
prepend ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) [a]
ys

-- | Drop all leading segments from a name, retaining only the last segment as a relative name.
--
-- >>> unqualified "a.b.c"
-- "c"
--
-- >>> unqualified ".a.b.c"
-- "c"
unqualified :: Name -> Name
unqualified :: Name -> Name
unqualified (Name Position
_ (NameSegment
s :| [NameSegment]
_)) =
  Position -> NonEmpty NameSegment -> Name
Name Position
Relative (NameSegment
s NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| [])

isUnqualified :: Name -> Bool
isUnqualified :: Name -> Bool
isUnqualified = \case
  Name Position
Relative (NameSegment
_ :| []) -> Bool
True
  Name Position
_ (NameSegment
_ :| [NameSegment]
_) -> Bool
False

-- Tries to shorten `fqn` to the smallest suffix that still unambiguously refers to the same name.
--
-- Indirect dependency names don't cause ambiguity in the presence of one or more non-indirect-dependency names. For
-- example, if there are two names "lib.base.List.map" and "lib.something.lib.base.Set.map", then "map" would
-- unambiguously refer to "lib.base.List.map".
--
-- Uses an efficient logarithmic lookup in the provided relation.
--
-- NB: Only works if the `Ord` instance for `Name` orders based on `Name.reverseSegments`.
suffixifyByName :: forall r. (Ord r) => Name -> R.Relation Name r -> Name
suffixifyByName :: forall r. Ord r => Name -> Relation Name r -> Name
suffixifyByName Name
fqn Relation Name r
rel =
  Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
fqn ((Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find Name -> Bool
isOk (Name -> [Name]
suffixes Name
fqn))
  where
    isOk :: Name -> Bool
    isOk :: Name -> Bool
isOk Name
suffix = Int
matchingNameCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
      where
        matchingNameCount :: Int
        matchingNameCount :: Int
matchingNameCount =
          Sum Int -> Int
forall a. Sum a -> a
getSum (NamePriority (Sum Int) -> Sum Int
forall a. NamePriority a -> a
unNamePriority ((Name -> Set r -> NamePriority (Sum Int))
-> (Name -> Ordering) -> Relation Name r -> NamePriority (Sum Int)
forall a c b.
(Ord a, Monoid c) =>
(a -> Set b -> c) -> (a -> Ordering) -> Relation a b -> c
R.searchDomG Name -> Set r -> NamePriority (Sum Int)
f (Name -> Name -> Ordering
compareSuffix Name
suffix) Relation Name r
rel))
          where
            f :: Name -> Set r -> NamePriority (Sum Int)
            f :: Name -> Set r -> NamePriority (Sum Int)
f Name
name Set r
_refs =
              case NameLocation -> NamePriority ()
nameLocationPriority (Name -> NameLocation
classifyNameLocation Name
name) of
                NamePriorityOne () -> Sum Int -> NamePriority (Sum Int)
forall a. a -> NamePriority a
NamePriorityOne (Int -> Sum Int
forall a. a -> Sum a
Sum Int
1)
                NamePriorityTwo () -> Sum Int -> NamePriority (Sum Int)
forall a. a -> NamePriority a
NamePriorityTwo (Int -> Sum Int
forall a. a -> Sum a
Sum Int
1)

-- Tries to shorten `fqn` to the smallest suffix that still refers the same references.
--
-- Like `suffixifyByName`, indirect dependency names don't cause ambiguity in the presence of one or more
-- non-indirect-dependency names.
--
-- Uses an efficient logarithmic lookup in the provided relation. The returned `Name` may refer to multiple hashes if
-- the original FQN did as well.
--
-- NB: Only works if the `Ord` instance for `Name` orders based on `Name.reverseSegments`.
suffixifyByHash :: forall r. (Ord r) => Name -> R.Relation Name r -> Name
suffixifyByHash :: forall r. Ord r => Name -> Relation Name r -> Name
suffixifyByHash Name
fqn Relation Name r
rel =
  Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
fqn ((Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find Name -> Bool
isOk (Name -> [Name]
suffixes Name
fqn))
  where
    allRefs :: Set r
    allRefs :: Set r
allRefs =
      Name -> Relation Name r -> Set r
forall a b. Ord a => a -> Relation a b -> Set b
R.lookupDom Name
fqn Relation Name r
rel

    isOk :: Name -> Bool
    isOk :: Name -> Bool
isOk Name
suffix =
      Set r
matchingRefs Set r -> Set r -> Bool
forall a. Eq a => a -> a -> Bool
== Set r
allRefs
      where
        matchingRefs :: Set r
        matchingRefs :: Set r
matchingRefs =
          NamePriority (Set r) -> Set r
forall a. NamePriority a -> a
unNamePriority ((Name -> Set r -> NamePriority (Set r))
-> (Name -> Ordering) -> Relation Name r -> NamePriority (Set r)
forall a c b.
(Ord a, Monoid c) =>
(a -> Set b -> c) -> (a -> Ordering) -> Relation a b -> c
R.searchDomG Name -> Set r -> NamePriority (Set r)
f (Name -> Name -> Ordering
compareSuffix Name
suffix) Relation Name r
rel)
          where
            f :: Name -> Set r -> NamePriority (Set r)
            f :: Name -> Set r -> NamePriority (Set r)
f Name
name Set r
refs =
              Set r
refs Set r -> NamePriority () -> NamePriority (Set r)
forall a b. a -> NamePriority b -> NamePriority a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ NameLocation -> NamePriority ()
nameLocationPriority (Name -> NameLocation
classifyNameLocation Name
name)

-- Like `suffixifyByHash`, but "keeps going" (i.e. keeps adding more segments, looking for the best name) if the current
-- suffix could refer to a local definition (i.e. outside lib). This is because such definitions could end up being
-- edited in a scratch file, where "suffixify by hash" doesn't work.
suffixifyByHashName :: forall r. (Ord r) => Name -> R.Relation Name r -> Name
suffixifyByHashName :: forall r. Ord r => Name -> Relation Name r -> Name
suffixifyByHashName Name
fqn Relation Name r
rel =
  Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
fqn ((Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find Name -> Bool
isOk (Name -> [Name]
suffixes Name
fqn))
  where
    allRefs :: Set r
    allRefs :: Set r
allRefs =
      Name -> Relation Name r -> Set r
forall a b. Ord a => a -> Relation a b -> Set b
R.lookupDom Name
fqn Relation Name r
rel

    isOk :: Name -> Bool
    isOk :: Name -> Bool
isOk Name
suffix =
      Set r
matchingRefs Set r -> Set r -> Bool
forall a. Eq a => a -> a -> Bool
== Set r
allRefs
        -- Don't use a suffix of 2+ aliases if any of then are non-local names
        Bool -> Bool -> Bool
&& case Int
numLocalNames of
          Int
0 -> Bool
True
          Int
1 -> Int
numNonLocalNames Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          Int
_ -> Bool
False
      where
        numLocalNames :: Int
        numNonLocalNames :: Int
        matchingRefs :: Set r
        (Sum Int -> Int
forall a. Sum a -> a
getSum -> Int
numLocalNames, Sum Int -> Int
forall a. Sum a -> a
getSum -> Int
numNonLocalNames, NamePriority (Set r) -> Set r
forall a. NamePriority a -> a
unNamePriority -> Set r
matchingRefs) =
          (Name -> Set r -> (Sum Int, Sum Int, NamePriority (Set r)))
-> (Name -> Ordering)
-> Relation Name r
-> (Sum Int, Sum Int, NamePriority (Set r))
forall a c b.
(Ord a, Monoid c) =>
(a -> Set b -> c) -> (a -> Ordering) -> Relation a b -> c
R.searchDomG Name -> Set r -> (Sum Int, Sum Int, NamePriority (Set r))
f (Name -> Name -> Ordering
compareSuffix Name
suffix) Relation Name r
rel
          where
            f :: Name -> Set r -> (Sum Int, Sum Int, NamePriority (Set r))
            f :: Name -> Set r -> (Sum Int, Sum Int, NamePriority (Set r))
f Name
name Set r
refs =
              (Sum Int
numLocal, Sum Int
numNonLocal, Set r
refs Set r -> NamePriority () -> NamePriority (Set r)
forall a b. a -> NamePriority b -> NamePriority a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ NameLocation -> NamePriority ()
nameLocationPriority NameLocation
location)
              where
                location :: NameLocation
location = Name -> NameLocation
classifyNameLocation Name
name
                numLocal :: Sum Int
numLocal =
                  case NameLocation
location of
                    NameLocation
NameLocation'Local -> Int -> Sum Int
forall a. a -> Sum a
Sum Int
1
                    NameLocation
NameLocation'DirectDep -> Int -> Sum Int
forall a. a -> Sum a
Sum Int
0
                    NameLocation
NameLocation'IndirectDep -> Int -> Sum Int
forall a. a -> Sum a
Sum Int
0
                numNonLocal :: Sum Int
numNonLocal =
                  case NameLocation
location of
                    NameLocation
NameLocation'Local -> Int -> Sum Int
forall a. a -> Sum a
Sum Int
0
                    NameLocation
NameLocation'DirectDep -> Int -> Sum Int
forall a. a -> Sum a
Sum Int
1
                    NameLocation
NameLocation'IndirectDep -> Int -> Sum Int
forall a. a -> Sum a
Sum Int
1

-- | Returns the common prefix of two names as segments
--
-- Note: the returned segments are NOT reversed.
--
-- >>> commonPrefix "a.b.x" "a.b.y"
-- [a,b]
--
-- >>> commonPrefix "x.y.z" "a.b.c"
-- []
--
-- >>> commonPrefix "a.b.c" "a.b.c.d.e"
-- [a,b,c]
--
-- Must have equivalent positions or no there's no common prefix
-- >>> commonPrefix ".a.b.c" "a.b.c.d.e"
-- []
--
-- Prefix matches are performed at the *segment* level:
-- >>> commonPrefix "a.bears" "a.beats"
-- [a]
commonPrefix :: Name -> Name -> [NameSegment]
commonPrefix :: Name -> Name -> [NameSegment]
commonPrefix x :: Name
x@(Name Position
p1 NonEmpty NameSegment
_) y :: Name
y@(Name Position
p2 NonEmpty NameSegment
_)
  | Position
p1 Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
/= Position
p2 = []
  | Bool
otherwise =
      [NameSegment] -> [NameSegment] -> [NameSegment]
forall {a}. Eq a => [a] -> [a] -> [a]
commonPrefix' (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty NameSegment -> [NameSegment])
-> NonEmpty NameSegment -> [NameSegment]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty NameSegment
segments Name
x) (NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty NameSegment -> [NameSegment])
-> NonEmpty NameSegment -> [NameSegment]
forall a b. (a -> b) -> a -> b
$ Name -> NonEmpty NameSegment
segments Name
y)
  where
    commonPrefix' :: [a] -> [a] -> [a]
commonPrefix' (a
a : [a]
as) (a
b : [a]
bs)
      | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
commonPrefix' [a]
as [a]
bs
    commonPrefix' [a]
_ [a]
_ = []