{-# OPTIONS_GHC -fno-warn-orphans #-}

module Unison.Codebase.Path
  ( Path,
    Path' (..),
    Pathy (..),
    Namey (..),
    Absolute (..),
    absPath_,
    Resolve (..),
    pattern Current,
    pattern Current',
    pattern Root,
    pattern Root',
    singleton,
    isAbsolute,
    parentOfName,
    maybePrefix,
    unprefix,
    maybePrefixName,
    prefixNameIfRel,
    unprefixName,
    Split,
    ancestors,

    -- * utilities
    longestPathPrefix,

    -- * tests
    isRoot,

    -- * conversions
    absoluteToPath',
    fromList,
    fromName,
    fromName',
    fromPath',
    unsafeParseText,
    unsafeParseText',
    toAbsoluteSplit,
    toList,
    splitFromName,
  )
where

import Control.Lens
import Data.Foldable qualified as Foldable
import Data.List.Extra (dropPrefix)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.Sequence (Seq ((:|>)))
import Data.Sequence qualified as Seq
import Data.Text qualified as Text
import GHC.Exts qualified as GHC
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment)
import Unison.Prelude hiding (empty, toList)
import Unison.Syntax.Name qualified as Name (toText, unsafeParseText)
import Unison.Util.List qualified as List
import Unison.Util.Recursion (Recursive, XNor, cata, embed)

-- | A `Path` is an internal structure representing some namespace in the codebase.
--
--  @Foo.Bar.baz@ becomes @["Foo", "Bar", "baz"]@.
newtype Path = Path {Path -> Seq NameSegment
toSeq :: Seq NameSegment}
  deriving stock (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
/= :: Path -> Path -> Bool
Eq, Eq Path
Eq Path =>
(Path -> Path -> Ordering)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Bool)
-> (Path -> Path -> Path)
-> (Path -> Path -> Path)
-> Ord Path
Path -> Path -> Bool
Path -> Path -> Ordering
Path -> Path -> Path
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
$ccompare :: Path -> Path -> Ordering
compare :: Path -> Path -> Ordering
$c< :: Path -> Path -> Bool
< :: Path -> Path -> Bool
$c<= :: Path -> Path -> Bool
<= :: Path -> Path -> Bool
$c> :: Path -> Path -> Bool
> :: Path -> Path -> Bool
$c>= :: Path -> Path -> Bool
>= :: Path -> Path -> Bool
$cmax :: Path -> Path -> Path
max :: Path -> Path -> Path
$cmin :: Path -> Path -> Path
min :: Path -> Path -> Path
Ord, Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
(Int -> Path -> ShowS)
-> (Path -> String) -> ([Path] -> ShowS) -> Show Path
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Path -> ShowS
showsPrec :: Int -> Path -> ShowS
$cshow :: Path -> String
show :: Path -> String
$cshowList :: [Path] -> ShowS
showList :: [Path] -> ShowS
Show)
  deriving newtype (NonEmpty Path -> Path
Path -> Path -> Path
(Path -> Path -> Path)
-> (NonEmpty Path -> Path)
-> (forall b. Integral b => b -> Path -> Path)
-> Semigroup Path
forall b. Integral b => b -> Path -> Path
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Path -> Path -> Path
<> :: Path -> Path -> Path
$csconcat :: NonEmpty Path -> Path
sconcat :: NonEmpty Path -> Path
$cstimes :: forall b. Integral b => b -> Path -> Path
stimes :: forall b. Integral b => b -> Path -> Path
Semigroup, Semigroup Path
Path
Semigroup Path =>
Path -> (Path -> Path -> Path) -> ([Path] -> Path) -> Monoid Path
[Path] -> Path
Path -> Path -> Path
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Path
mempty :: Path
$cmappend :: Path -> Path -> Path
mappend :: Path -> Path -> Path
$cmconcat :: [Path] -> Path
mconcat :: [Path] -> Path
Monoid)

instance From Path Text where
  from :: Path -> Text
from = Path -> Text
forall path. Pathy path => path -> Text
toText

instance Recursive Path (XNor NameSegment) where
  cata :: forall a. Algebra (XNor NameSegment) a -> Path -> a
cata Algebra (XNor NameSegment) a
φ = Algebra (XNor NameSegment) a -> Seq NameSegment -> a
forall a. Algebra (XNor NameSegment) a -> Seq NameSegment -> a
forall t (f :: * -> *) a. Recursive t f => Algebra f a -> t -> a
cata Algebra (XNor NameSegment) a
φ (Seq NameSegment -> a) -> (Path -> Seq NameSegment) -> Path -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Seq NameSegment
toSeq
  embed :: XNor NameSegment Path -> Path
embed = Seq NameSegment -> Path
Path (Seq NameSegment -> Path)
-> (XNor NameSegment Path -> Seq NameSegment)
-> XNor NameSegment Path
-> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XNor NameSegment (Seq NameSegment) -> Seq NameSegment
forall t (f :: * -> *). Recursive t f => f t -> t
embed (XNor NameSegment (Seq NameSegment) -> Seq NameSegment)
-> (XNor NameSegment Path -> XNor NameSegment (Seq NameSegment))
-> XNor NameSegment Path
-> Seq NameSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Seq NameSegment)
-> XNor NameSegment Path -> XNor NameSegment (Seq NameSegment)
forall a b. (a -> b) -> XNor NameSegment a -> XNor NameSegment b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path -> Seq NameSegment
toSeq

-- | Meant for use mostly in doc-tests where it's
-- sometimes convenient to specify paths as lists.
instance GHC.IsList Path where
  type Item Path = NameSegment
  toList :: Path -> [Item Path]
toList (Path Seq NameSegment
segs) = Seq NameSegment -> [NameSegment]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq NameSegment
segs
  fromList :: [Item Path] -> Path
fromList = Seq NameSegment -> Path
Path (Seq NameSegment -> Path)
-> ([NameSegment] -> Seq NameSegment) -> [NameSegment] -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSegment] -> Seq NameSegment
forall a. [a] -> Seq a
Seq.fromList

-- | An absolute from the current project root
newtype Absolute = Absolute {Absolute -> Path
unabsolute :: Path} deriving (Absolute -> Absolute -> Bool
(Absolute -> Absolute -> Bool)
-> (Absolute -> Absolute -> Bool) -> Eq Absolute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Absolute -> Absolute -> Bool
== :: Absolute -> Absolute -> Bool
$c/= :: Absolute -> Absolute -> Bool
/= :: Absolute -> Absolute -> Bool
Eq, Eq Absolute
Eq Absolute =>
(Absolute -> Absolute -> Ordering)
-> (Absolute -> Absolute -> Bool)
-> (Absolute -> Absolute -> Bool)
-> (Absolute -> Absolute -> Bool)
-> (Absolute -> Absolute -> Bool)
-> (Absolute -> Absolute -> Absolute)
-> (Absolute -> Absolute -> Absolute)
-> Ord Absolute
Absolute -> Absolute -> Bool
Absolute -> Absolute -> Ordering
Absolute -> Absolute -> Absolute
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
$ccompare :: Absolute -> Absolute -> Ordering
compare :: Absolute -> Absolute -> Ordering
$c< :: Absolute -> Absolute -> Bool
< :: Absolute -> Absolute -> Bool
$c<= :: Absolute -> Absolute -> Bool
<= :: Absolute -> Absolute -> Bool
$c> :: Absolute -> Absolute -> Bool
> :: Absolute -> Absolute -> Bool
$c>= :: Absolute -> Absolute -> Bool
>= :: Absolute -> Absolute -> Bool
$cmax :: Absolute -> Absolute -> Absolute
max :: Absolute -> Absolute -> Absolute
$cmin :: Absolute -> Absolute -> Absolute
min :: Absolute -> Absolute -> Absolute
Ord, Int -> Absolute -> ShowS
[Absolute] -> ShowS
Absolute -> String
(Int -> Absolute -> ShowS)
-> (Absolute -> String) -> ([Absolute] -> ShowS) -> Show Absolute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Absolute -> ShowS
showsPrec :: Int -> Absolute -> ShowS
$cshow :: Absolute -> String
show :: Absolute -> String
$cshowList :: [Absolute] -> ShowS
showList :: [Absolute] -> ShowS
Show)

instance From Absolute Text where
  from :: Absolute -> Text
from = Absolute -> Text
forall path. Pathy path => path -> Text
toText

instance Recursive Absolute (XNor NameSegment) where
  cata :: forall a. Algebra (XNor NameSegment) a -> Absolute -> a
cata Algebra (XNor NameSegment) a
φ = Algebra (XNor NameSegment) a -> Path -> a
forall a. Algebra (XNor NameSegment) a -> Path -> a
forall t (f :: * -> *) a. Recursive t f => Algebra f a -> t -> a
cata Algebra (XNor NameSegment) a
φ (Path -> a) -> (Absolute -> Path) -> Absolute -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> Path
unabsolute
  embed :: XNor NameSegment Absolute -> Absolute
embed = Path -> Absolute
Absolute (Path -> Absolute)
-> (XNor NameSegment Absolute -> Path)
-> XNor NameSegment Absolute
-> Absolute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XNor NameSegment Path -> Path
forall t (f :: * -> *). Recursive t f => f t -> t
embed (XNor NameSegment Path -> Path)
-> (XNor NameSegment Absolute -> XNor NameSegment Path)
-> XNor NameSegment Absolute
-> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Absolute -> Path)
-> XNor NameSegment Absolute -> XNor NameSegment Path
forall a b. (a -> b) -> XNor NameSegment a -> XNor NameSegment b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Absolute -> Path
unabsolute

absPath_ :: Lens' Absolute Path
absPath_ :: Lens' Absolute Path
absPath_ = (Absolute -> Path)
-> (Absolute -> Path -> Absolute) -> Lens' Absolute Path
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Absolute -> Path
unabsolute (\Absolute
_ Path
new -> Path -> Absolute
Absolute Path
new)

-- | A namespace that may be either absolute or relative, This is the most general type that should be used.
data Path'
  = AbsolutePath' Absolute
  | RelativePath' Path
  deriving (Path' -> Path' -> Bool
(Path' -> Path' -> Bool) -> (Path' -> Path' -> Bool) -> Eq Path'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Path' -> Path' -> Bool
== :: Path' -> Path' -> Bool
$c/= :: Path' -> Path' -> Bool
/= :: Path' -> Path' -> Bool
Eq, Eq Path'
Eq Path' =>
(Path' -> Path' -> Ordering)
-> (Path' -> Path' -> Bool)
-> (Path' -> Path' -> Bool)
-> (Path' -> Path' -> Bool)
-> (Path' -> Path' -> Bool)
-> (Path' -> Path' -> Path')
-> (Path' -> Path' -> Path')
-> Ord Path'
Path' -> Path' -> Bool
Path' -> Path' -> Ordering
Path' -> Path' -> Path'
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
$ccompare :: Path' -> Path' -> Ordering
compare :: Path' -> Path' -> Ordering
$c< :: Path' -> Path' -> Bool
< :: Path' -> Path' -> Bool
$c<= :: Path' -> Path' -> Bool
<= :: Path' -> Path' -> Bool
$c> :: Path' -> Path' -> Bool
> :: Path' -> Path' -> Bool
$c>= :: Path' -> Path' -> Bool
>= :: Path' -> Path' -> Bool
$cmax :: Path' -> Path' -> Path'
max :: Path' -> Path' -> Path'
$cmin :: Path' -> Path' -> Path'
min :: Path' -> Path' -> Path'
Ord, Int -> Path' -> ShowS
[Path'] -> ShowS
Path' -> String
(Int -> Path' -> ShowS)
-> (Path' -> String) -> ([Path'] -> ShowS) -> Show Path'
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Path' -> ShowS
showsPrec :: Int -> Path' -> ShowS
$cshow :: Path' -> String
show :: Path' -> String
$cshowList :: [Path'] -> ShowS
showList :: [Path'] -> ShowS
Show)

instance From Path' Text where
  from :: Path' -> Text
from = Path' -> Text
forall path. Pathy path => path -> Text
toText

isAbsolute :: Path' -> Bool
isAbsolute :: Path' -> Bool
isAbsolute (AbsolutePath' Absolute
_) = Bool
True
isAbsolute Path'
_ = Bool
False

pattern Current :: Path
pattern $mCurrent :: forall {r}. Path -> ((# #) -> r) -> ((# #) -> r) -> r
$bCurrent :: Path
Current = Path Seq.Empty

pattern Current' :: Path'
pattern $mCurrent' :: forall {r}. Path' -> ((# #) -> r) -> ((# #) -> r) -> r
$bCurrent' :: Path'
Current' = RelativePath' Current

isRoot :: Absolute -> Bool
isRoot :: Absolute -> Bool
isRoot = Seq NameSegment -> Bool
forall a. Seq a -> Bool
Seq.null (Seq NameSegment -> Bool)
-> (Absolute -> Seq NameSegment) -> Absolute -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Seq NameSegment
toSeq (Path -> Seq NameSegment)
-> (Absolute -> Path) -> Absolute -> Seq NameSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> Path
unabsolute

absoluteToPath' :: Absolute -> Path'
absoluteToPath' :: Absolute -> Path'
absoluteToPath' = Absolute -> Path'
AbsolutePath'

type Split path = (path, NameSegment)

-- | examples:
--   unprefix foo.bar .blah == .blah (absolute paths left alone)
--   unprefix foo.bar id    == id    (relative paths starting w/ nonmatching prefix left alone)
--   unprefix foo.bar foo.bar.baz == baz (relative paths w/ common prefix get stripped)
unprefix :: Path -> Path' -> Path'
unprefix :: Path -> Path' -> Path'
unprefix Path
prefix = \case
  AbsolutePath' Absolute
abs -> Absolute -> Path'
AbsolutePath' Absolute
abs
  RelativePath' Path
rel -> Path -> Path'
RelativePath' (Path -> Path') -> (Path -> Path) -> Path -> Path'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSegment] -> Path
fromList ([NameSegment] -> Path) -> (Path -> [NameSegment]) -> Path -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSegment] -> [NameSegment] -> [NameSegment]
forall a. Eq a => [a] -> [a] -> [a]
dropPrefix (Path -> [NameSegment]
toList Path
prefix) ([NameSegment] -> [NameSegment])
-> (Path -> [NameSegment]) -> Path -> [NameSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [NameSegment]
toList (Path -> Path') -> Path -> Path'
forall a b. (a -> b) -> a -> b
$ Path
rel

-- | Returns `Nothing` if the second argument is absolute. A common pattern is
--   @fromMaybe path $ maybePrefix prefix path@ to use the unmodified path in that case.
maybePrefix :: Path' -> Path' -> Maybe Path'
maybePrefix :: Path' -> Path' -> Maybe Path'
maybePrefix Path'
pre = \case
  AbsolutePath' Absolute
_ -> Maybe Path'
forall a. Maybe a
Nothing
  RelativePath' Path
rel -> Path' -> Maybe Path'
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path' -> Maybe Path') -> Path' -> Maybe Path'
forall a b. (a -> b) -> a -> b
$ Path' -> Path -> Path'
forall path. Pathy path => path -> Path -> path
prefix Path'
pre Path
rel

-- | Finds the longest shared path prefix of two paths.
-- Returns (shared prefix, path to first location from shared prefix, path to second location from shared prefix)
--
-- >>> longestPathPrefix ("a" :< "b" :< "x" :< Empty) ("a" :< "b" :< "c" :< Empty)
-- (a.b,x,c)
--
-- >>> longestPathPrefix Empty ("a" :< "b" :< "c" :< Empty)
-- (,,a.b.c)
longestPathPrefix :: Absolute -> Absolute -> (Absolute, Path, Path)
longestPathPrefix :: Absolute -> Absolute -> (Absolute, Path, Path)
longestPathPrefix Absolute
a Absolute
b =
  [NameSegment]
-> [NameSegment] -> ([NameSegment], [NameSegment], [NameSegment])
forall a. Eq a => [a] -> [a] -> ([a], [a], [a])
List.splitOnLongestCommonPrefix (Path -> [NameSegment]
toList (Path -> [NameSegment]) -> Path -> [NameSegment]
forall a b. (a -> b) -> a -> b
$ Absolute -> Path
unabsolute Absolute
a) (Path -> [NameSegment]
toList (Path -> [NameSegment]) -> Path -> [NameSegment]
forall a b. (a -> b) -> a -> b
$ Absolute -> Path
unabsolute Absolute
b)
    ([NameSegment], [NameSegment], [NameSegment])
-> (([NameSegment], [NameSegment], [NameSegment])
    -> (Absolute, Path, Path))
-> (Absolute, Path, Path)
forall a b. a -> (a -> b) -> b
& \([NameSegment]
a, [NameSegment]
b, [NameSegment]
c) -> (Path -> Absolute
Absolute (Path -> Absolute) -> Path -> Absolute
forall a b. (a -> b) -> a -> b
$ [NameSegment] -> Path
fromList [NameSegment]
a, [NameSegment] -> Path
fromList [NameSegment]
b, [NameSegment] -> Path
fromList [NameSegment]
c)

toAbsoluteSplit :: Absolute -> Split Path' -> Split Absolute
toAbsoluteSplit :: Absolute -> Split Path' -> Split Absolute
toAbsoluteSplit = (Path' -> Absolute) -> Split Path' -> Split Absolute
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 ((Path' -> Absolute) -> Split Path' -> Split Absolute)
-> (Absolute -> Path' -> Absolute)
-> Absolute
-> Split Path'
-> Split Absolute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> Path' -> Absolute
forall l r o. Resolve l r o => l -> r -> o
resolve

pattern Root :: Absolute
pattern $mRoot :: forall {r}. Absolute -> ((# #) -> r) -> ((# #) -> r) -> r
$bRoot :: Absolute
Root = Absolute (Path Seq.Empty)

pattern Root' :: Path'
pattern $mRoot' :: forall {r}. Path' -> ((# #) -> r) -> ((# #) -> r) -> r
$bRoot' :: Path'
Root' = AbsolutePath' Root

-- Forget whether the path is absolute or relative
fromPath' :: Path' -> Path
fromPath' :: Path' -> Path
fromPath' = \case
  AbsolutePath' (Absolute Path
p) -> Path
p
  RelativePath' Path
p -> Path
p

toList :: Path -> [NameSegment]
toList :: Path -> [NameSegment]
toList = Seq NameSegment -> [NameSegment]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (Seq NameSegment -> [NameSegment])
-> (Path -> Seq NameSegment) -> Path -> [NameSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Seq NameSegment
toSeq

fromList :: [NameSegment] -> Path
fromList :: [NameSegment] -> Path
fromList = Seq NameSegment -> Path
Path (Seq NameSegment -> Path)
-> ([NameSegment] -> Seq NameSegment) -> [NameSegment] -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSegment] -> Seq NameSegment
forall a. [a] -> Seq a
Seq.fromList

ancestors :: Absolute -> Seq Absolute
ancestors :: Absolute -> Seq Absolute
ancestors (Absolute (Path Seq NameSegment
segments)) = Path -> Absolute
Absolute (Path -> Absolute)
-> (Seq NameSegment -> Path) -> Seq NameSegment -> Absolute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq NameSegment -> Path
Path (Seq NameSegment -> Absolute)
-> Seq (Seq NameSegment) -> Seq Absolute
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq NameSegment -> Seq (Seq NameSegment)
forall a. Seq a -> Seq (Seq a)
Seq.inits Seq NameSegment
segments

-- |
-- >>> splitFromName "a.b.c"
-- (a.b,c)
--
-- >>> splitFromName "foo"
-- (,foo)
splitFromName :: Name -> Split Path
splitFromName :: Name -> Split Path
splitFromName Name
name =
  case Name -> NonEmpty NameSegment
Name.reverseSegments Name
name of
    NameSegment
h :| [NameSegment]
t -> ([NameSegment] -> Path
fromList ([NameSegment] -> Path) -> [NameSegment] -> Path
forall a b. (a -> b) -> a -> b
$ [NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse [NameSegment]
t, NameSegment
h)

-- | Remove a path prefix from a name.
-- Returns 'Nothing' if there are no remaining segments to construct the name from.
--
-- >>> unprefixName (Relative $ fromList ["base", "List"]) (Name.unsafeFromText "base.List.map")
-- Just (Name Relative (NameSegment {toText = "map"} :| []))
unprefixName :: Path -> Name -> Maybe Name
unprefixName :: Path -> Name -> Maybe Name
unprefixName Path
prefix = Path' -> Maybe Name
forall path. Namey path => path -> Maybe Name
toName (Path' -> Maybe Name) -> (Name -> Path') -> Name -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Path' -> Path'
unprefix Path
prefix (Path' -> Path') -> (Name -> Path') -> Name -> Path'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Path'
fromName'

-- | Returns `Nothing` if the second argument is absolute. A common pattern is
--   @fromMaybe name $ maybePrefixName prefix name@ to use the unmodified path in that case.
maybePrefixName :: Path' -> Name -> Maybe Name
maybePrefixName :: Path' -> Name -> Maybe Name
maybePrefixName Path'
pre Name
name =
  if Name -> Bool
Name.isAbsolute Name
name
    then Maybe Name
forall a. Maybe a
Nothing
    else
      Name -> Maybe Name
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        let newName :: Name
newName = case Name -> NonEmpty NameSegment
Name.reverseSegments Name
name of
              NameSegment
h :| [NameSegment]
t -> NonEmpty NameSegment -> Name
Name.fromReverseSegments (NonEmpty NameSegment -> Name) -> NonEmpty NameSegment -> Name
forall a b. (a -> b) -> a -> b
$ NameSegment
h NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
:| [NameSegment]
t [NameSegment] -> [NameSegment] -> [NameSegment]
forall a. Semigroup a => a -> a -> a
<> [NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse (Path -> [NameSegment]
toList (Path -> [NameSegment]) -> Path -> [NameSegment]
forall a b. (a -> b) -> a -> b
$ Path' -> Path
fromPath' Path'
pre)
         in if Path' -> Bool
isAbsolute Path'
pre then Name -> Name
Name.makeAbsolute Name
newName else Name
newName

prefixNameIfRel :: Path' -> Name -> Name
prefixNameIfRel :: Path' -> Name -> Name
prefixNameIfRel Path'
p Name
name = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
name (Maybe Name -> Name) -> Maybe Name -> Name
forall a b. (a -> b) -> a -> b
$ Path' -> Name -> Maybe Name
maybePrefixName Path'
p Name
name

singleton :: NameSegment -> Path
singleton :: NameSegment -> Path
singleton NameSegment
n = [NameSegment] -> Path
fromList [NameSegment
n]

class Pathy path where
  ascend :: path -> Maybe path
  ascend = ((path, NameSegment) -> path)
-> Maybe (path, NameSegment) -> Maybe path
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (path, NameSegment) -> path
forall a b. (a, b) -> a
fst (Maybe (path, NameSegment) -> Maybe path)
-> (path -> Maybe (path, NameSegment)) -> path -> Maybe path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. path -> Maybe (path, NameSegment)
forall path. Pathy path => path -> Maybe (path, NameSegment)
split
  descend :: path -> NameSegment -> path

  prefix :: path -> Path -> path

  split :: path -> Maybe (Split path)

  unsplit :: Split path -> path
  unsplit = (path -> NameSegment -> path) -> (path, NameSegment) -> path
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry path -> NameSegment -> path
forall path. Pathy path => path -> NameSegment -> path
descend
  toText :: path -> Text

class (Pathy path) => Namey path where
  nameFromSplit :: Split path -> Name

  -- | Convert a path' to a `Name`
  toName :: path -> Maybe Name
  toName = (Split path -> Name) -> Maybe (Split path) -> Maybe Name
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Split path -> Name
forall path. Namey path => Split path -> Name
nameFromSplit (Maybe (Split path) -> Maybe Name)
-> (path -> Maybe (Split path)) -> path -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. path -> Maybe (Split path)
forall path. Pathy path => path -> Maybe (path, NameSegment)
split

instance Pathy Path where
  descend :: Path -> NameSegment -> Path
descend (Path Seq NameSegment
p) = Seq NameSegment -> Path
Path (Seq NameSegment -> Path)
-> (NameSegment -> Seq NameSegment) -> NameSegment -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq NameSegment
p Seq NameSegment -> NameSegment -> Seq NameSegment
forall a. Seq a -> a -> Seq a
:|>)
  prefix :: Path -> Path -> Path
prefix = Path -> Path -> Path
forall l r o. Resolve l r o => l -> r -> o
resolve
  split :: Path -> Maybe (Split Path)
split (Path Seq NameSegment
seq) = case Seq NameSegment
seq of
    Seq NameSegment
Seq.Empty -> Maybe (Split Path)
forall a. Maybe a
Nothing
    Seq NameSegment
p :|> NameSegment
n -> Split Path -> Maybe (Split Path)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq NameSegment -> Path
Path Seq NameSegment
p, NameSegment
n)

  -- Note: This treats the path as relative.
  toText :: Path -> Text
toText = Text -> (Name -> Text) -> Maybe Name -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty Name -> Text
Name.toText (Maybe Name -> Text) -> (Path -> Maybe Name) -> Path -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Maybe Name
forall path. Namey path => path -> Maybe Name
toName

instance Namey Path where
  nameFromSplit :: Split Path -> Name
nameFromSplit = NonEmpty NameSegment -> Name
Name.fromReverseSegments (NonEmpty NameSegment -> Name)
-> (Split Path -> NonEmpty NameSegment) -> Split Path -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([NameSegment] -> NameSegment -> NonEmpty NameSegment)
-> ([NameSegment], NameSegment) -> NonEmpty NameSegment
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((NameSegment -> [NameSegment] -> NonEmpty NameSegment)
-> [NameSegment] -> NameSegment -> NonEmpty NameSegment
forall a b c. (a -> b -> c) -> b -> a -> c
flip NameSegment -> [NameSegment] -> NonEmpty NameSegment
forall a. a -> [a] -> NonEmpty a
(:|)) (([NameSegment], NameSegment) -> NonEmpty NameSegment)
-> (Split Path -> ([NameSegment], NameSegment))
-> Split Path
-> NonEmpty NameSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> [NameSegment])
-> Split Path -> ([NameSegment], NameSegment)
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 ([NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse ([NameSegment] -> [NameSegment])
-> (Path -> [NameSegment]) -> Path -> [NameSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [NameSegment]
toList)

instance Pathy Absolute where
  descend :: Absolute -> NameSegment -> Absolute
descend (Absolute Path
p) = Path -> Absolute
Absolute (Path -> Absolute)
-> (NameSegment -> Path) -> NameSegment -> Absolute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> NameSegment -> Path
forall path. Pathy path => path -> NameSegment -> path
descend Path
p
  prefix :: Absolute -> Path -> Absolute
prefix = Absolute -> Path -> Absolute
forall l r o. Resolve l r o => l -> r -> o
resolve
  split :: Absolute -> Maybe (Split Absolute)
split (Absolute Path
p) = (Path -> Absolute) -> Split Path -> Split Absolute
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 Path -> Absolute
Absolute (Split Path -> Split Absolute)
-> Maybe (Split Path) -> Maybe (Split Absolute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> Maybe (Split Path)
forall path. Pathy path => path -> Maybe (path, NameSegment)
split Path
p
  toText :: Absolute -> Text
toText = (Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Absolute -> Text) -> Absolute -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Text
forall path. Pathy path => path -> Text
toText (Path -> Text) -> (Absolute -> Path) -> Absolute -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> Path
unabsolute

instance Namey Absolute where
  nameFromSplit :: Split Absolute -> Name
nameFromSplit = Name -> Name
Name.makeAbsolute (Name -> Name)
-> (Split Absolute -> Name) -> Split Absolute -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Split Path -> Name
forall path. Namey path => Split path -> Name
nameFromSplit (Split Path -> Name)
-> (Split Absolute -> Split Path) -> Split Absolute -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Absolute -> Path) -> Split Absolute -> Split Path
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 Absolute -> Path
unabsolute

instance Pathy Path' where
  descend :: Path' -> NameSegment -> Path'
descend = \case
    AbsolutePath' Absolute
p -> Absolute -> Path'
AbsolutePath' (Absolute -> Path')
-> (NameSegment -> Absolute) -> NameSegment -> Path'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> NameSegment -> Absolute
forall path. Pathy path => path -> NameSegment -> path
descend Absolute
p
    RelativePath' Path
p -> Path -> Path'
RelativePath' (Path -> Path') -> (NameSegment -> Path) -> NameSegment -> Path'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> NameSegment -> Path
forall path. Pathy path => path -> NameSegment -> path
descend Path
p
  prefix :: Path' -> Path -> Path'
prefix = Path' -> Path -> Path'
forall l r o. Resolve l r o => l -> r -> o
resolve
  split :: Path' -> Maybe (Split Path')
split = \case
    AbsolutePath' Absolute
p -> (Absolute -> Path') -> Split Absolute -> Split Path'
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 Absolute -> Path'
AbsolutePath' (Split Absolute -> Split Path')
-> Maybe (Split Absolute) -> Maybe (Split Path')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Absolute -> Maybe (Split Absolute)
forall path. Pathy path => path -> Maybe (path, NameSegment)
split Absolute
p
    RelativePath' Path
p -> (Path -> Path') -> Split Path -> Split Path'
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 Path -> Path'
RelativePath' (Split Path -> Split Path')
-> Maybe (Split Path) -> Maybe (Split Path')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> Maybe (Split Path)
forall path. Pathy path => path -> Maybe (path, NameSegment)
split Path
p
  toText :: Path' -> Text
toText = \case
    AbsolutePath' Absolute
p -> Absolute -> Text
forall path. Pathy path => path -> Text
toText Absolute
p
    RelativePath' Path
p -> Path -> Text
forall path. Pathy path => path -> Text
toText Path
p

instance Namey Path' where
  nameFromSplit :: Split Path' -> Name
nameFromSplit (Path'
path, NameSegment
ns) = case Path'
path of
    AbsolutePath' Absolute
p -> Split Absolute -> Name
forall path. Namey path => Split path -> Name
nameFromSplit (Absolute
p, NameSegment
ns)
    RelativePath' Path
p -> Split Path -> Name
forall path. Namey path => Split path -> Name
nameFromSplit (Path
p, NameSegment
ns)

-- > Path.fromName . Name.unsafeFromText $ ".Foo.bar"
-- /Foo/bar
-- Int./  -> "Int"/"/"
-- pkg/Int.. -> "pkg"/"Int"/"."
-- Int./foo -> error because "/foo" is not a valid NameSegment
--                      and "Int." is not a valid NameSegment
--                      and "Int" / "" / "foo" is not a valid path (internal "")
-- todo: fromName needs to be a little more complicated if we want to allow
--       identifiers called Function.(.)
fromName :: Name -> Path
fromName :: Name -> Path
fromName = [NameSegment] -> Path
fromList ([NameSegment] -> Path) -> (Name -> [NameSegment]) -> Name -> Path
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
Name.segments

parentOfName :: Name -> Split Path'
parentOfName :: Name -> Split Path'
parentOfName Name
name =
  let NameSegment
h :| [NameSegment]
t = Name -> NonEmpty NameSegment
Name.reverseSegments Name
name
      path :: Path
path = [NameSegment] -> Path
fromList ([NameSegment] -> Path) -> [NameSegment] -> Path
forall a b. (a -> b) -> a -> b
$ [NameSegment] -> [NameSegment]
forall a. [a] -> [a]
reverse [NameSegment]
t
   in ( if Name -> Bool
Name.isAbsolute Name
name
          then Absolute -> Path'
AbsolutePath' (Path -> Absolute
Absolute Path
path)
          else Path -> Path'
RelativePath' Path
path,
        NameSegment
h
      )

fromName' :: Name -> Path'
fromName' :: Name -> Path'
fromName' Name
n
  | Name -> Bool
Name.isAbsolute Name
n = Absolute -> Path'
AbsolutePath' (Path -> Absolute
Absolute Path
path)
  | Bool
otherwise = Path -> Path'
RelativePath' Path
path
  where
    path :: Path
path = Name -> Path
fromName Name
n

unsafeParseText :: Text -> Path
unsafeParseText :: Text -> Path
unsafeParseText = \case
  Text
"" -> Path
forall a. Monoid a => a
mempty
  Text
text -> Name -> Path
fromName (HasCallStack => Text -> Name
Text -> Name
Name.unsafeParseText Text
text)

-- | Construct a Path' from a text
--
-- >>> fromText' "a.b.c"
-- a.b.c
--
-- >>> fromText' ".a.b.c"
-- .a.b.c
--
-- >>> show $ fromText' ""
-- ""
unsafeParseText' :: Text -> Path'
unsafeParseText' :: Text -> Path'
unsafeParseText' = \case
  Text
"" -> Path -> Path'
RelativePath' Path
forall a. Monoid a => a
mempty
  Text
"." -> Absolute -> Path'
AbsolutePath' (Path -> Absolute
Absolute Path
forall a. Monoid a => a
mempty)
  Text
text -> Name -> Path'
fromName' (HasCallStack => Text -> Name
Text -> Name
Name.unsafeParseText Text
text)

class Resolve l r o where
  resolve :: l -> r -> o

instance Resolve Absolute Path Absolute where
  resolve :: Absolute -> Path -> Absolute
resolve (Absolute Path
l) Path
r = Path -> Absolute
Absolute (Path -> Path -> Path
forall l r o. Resolve l r o => l -> r -> o
resolve Path
l Path
r)

instance Resolve Absolute Path' Absolute where
  resolve :: Absolute -> Path' -> Absolute
resolve Absolute
_ (AbsolutePath' Absolute
a) = Absolute
a
  resolve Absolute
a (RelativePath' Path
r) = Absolute -> Path -> Absolute
forall l r o. Resolve l r o => l -> r -> o
resolve Absolute
a Path
r

instance Resolve Absolute (Split Path) (Split Absolute) where
  resolve :: Absolute -> Split Path -> Split Absolute
resolve Absolute
l Split Path
r = (Path -> Absolute) -> Split Path -> Split Absolute
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 (Absolute -> Path -> Absolute
forall l r o. Resolve l r o => l -> r -> o
resolve Absolute
l) Split Path
r

instance Resolve Path Path Path where
  resolve :: Path -> Path -> Path
resolve (Path Seq NameSegment
l) (Path Seq NameSegment
r) = Seq NameSegment -> Path
Path (Seq NameSegment
l Seq NameSegment -> Seq NameSegment -> Seq NameSegment
forall a. Semigroup a => a -> a -> a
<> Seq NameSegment
r)

instance Resolve Path (Split Path) (Split Path) where
  resolve :: Path -> Split Path -> Split Path
resolve Path
l (Path
r, NameSegment
x) = (Path -> Path -> Path
forall l r o. Resolve l r o => l -> r -> o
resolve Path
l Path
r, NameSegment
x)

instance Resolve Path' Path Path' where
  resolve :: Path' -> Path -> Path'
resolve (AbsolutePath' Absolute
l) Path
r = Absolute -> Path'
AbsolutePath' (Absolute -> Path -> Absolute
forall l r o. Resolve l r o => l -> r -> o
resolve Absolute
l Path
r)
  resolve (RelativePath' Path
l) Path
r = Path -> Path'
RelativePath' (Path -> Path -> Path
forall l r o. Resolve l r o => l -> r -> o
resolve Path
l Path
r)

instance Resolve Path' Path' Path' where
  resolve :: Path' -> Path' -> Path'
resolve Path'
_ a :: Path'
a@(AbsolutePath' {}) = Path'
a
  resolve (AbsolutePath' Absolute
a) (RelativePath' Path
r) = Absolute -> Path'
AbsolutePath' (Absolute -> Path -> Absolute
forall l r o. Resolve l r o => l -> r -> o
resolve Absolute
a Path
r)
  resolve (RelativePath' Path
r1) (RelativePath' Path
r2) = Path -> Path'
RelativePath' (Path -> Path -> Path
forall l r o. Resolve l r o => l -> r -> o
resolve Path
r1 Path
r2)

instance Resolve (Split Absolute) (Split Path) (Split Absolute) where
  resolve :: Split Absolute -> Split Path -> Split Absolute
resolve (Absolute
l, NameSegment
x) (Path
r, NameSegment
y) = (Absolute -> Path -> Absolute
forall l r o. Resolve l r o => l -> r -> o
resolve (Absolute -> NameSegment -> Absolute
forall path. Pathy path => path -> NameSegment -> path
descend Absolute
l NameSegment
x) Path
r, NameSegment
y)