module Unison.Codebase.Editor.UriParser
  ( readRemoteNamespaceParser,
    parseReadShareLooseCode,
    writeRemoteNamespace,
  )
where

import Data.Char (isAlphaNum)
import Data.Text qualified as Text
import Data.These (These)
import Data.Void
import Text.Megaparsec qualified as P
import Text.Megaparsec.Char qualified as C
import Unison.Codebase.Editor.RemoteRepo
  ( ReadRemoteNamespace (..),
    ReadShareLooseCode (..),
    ShareCodeserver (DefaultCodeserver),
    ShareUserHandle (..),
  )
import Unison.Codebase.Path qualified as Path
import Unison.NameSegment (NameSegment)
import Unison.Prelude
import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser)
import Unison.Syntax.Lexer qualified
import Unison.Syntax.NameSegment qualified as NameSegment
import Unison.Util.Pretty qualified as P
import Unison.Util.Pretty.MegaParsec qualified as P

type P = P.Parsec Void Text.Text

readRemoteNamespaceParser :: ProjectBranchSpecifier branch -> P (ReadRemoteNamespace (These ProjectName branch))
readRemoteNamespaceParser :: forall branch.
ProjectBranchSpecifier branch
-> P (ReadRemoteNamespace (These ProjectName branch))
readRemoteNamespaceParser ProjectBranchSpecifier branch
specifier =
  These ProjectName branch
-> ReadRemoteNamespace (These ProjectName branch)
forall a. a -> ReadRemoteNamespace a
ReadShare'ProjectBranch (These ProjectName branch
 -> ReadRemoteNamespace (These ProjectName branch))
-> ParsecT Void Text Identity (These ProjectName branch)
-> ParsecT
     Void Text Identity (ReadRemoteNamespace (These ProjectName branch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectBranchSpecifier branch
-> ParsecT Void Text Identity (These ProjectName branch)
forall branch.
ProjectBranchSpecifier branch -> P (These ProjectName branch)
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier branch
specifier
    ParsecT
  Void Text Identity (ReadRemoteNamespace (These ProjectName branch))
-> ParsecT
     Void Text Identity (ReadRemoteNamespace (These ProjectName branch))
-> ParsecT
     Void Text Identity (ReadRemoteNamespace (These ProjectName branch))
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadShareLooseCode
-> ReadRemoteNamespace (These ProjectName branch)
forall a. ReadShareLooseCode -> ReadRemoteNamespace a
ReadShare'LooseCode (ReadShareLooseCode
 -> ReadRemoteNamespace (These ProjectName branch))
-> ParsecT Void Text Identity ReadShareLooseCode
-> ParsecT
     Void Text Identity (ReadRemoteNamespace (These ProjectName branch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity ReadShareLooseCode
readShareLooseCode

projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ::
  ProjectBranchSpecifier branch ->
  P (These ProjectName branch)
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths :: forall branch.
ProjectBranchSpecifier branch -> P (These ProjectName branch)
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier branch
specifier =
  ParsecT Void Text Identity (These ProjectName branch)
-> ParsecT Void Text Identity (These ProjectName branch)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try do
    These ProjectName branch
projectAndBranch <- ProjectBranchSpecifier branch
-> ParsecT Void Text Identity (These ProjectName branch)
forall branch.
ProjectBranchSpecifier branch -> P (These ProjectName branch)
projectAndBranchNamesParser ProjectBranchSpecifier branch
specifier
    -- we don't want to succeed parsing the 'foo' off of 'foo.bar', leaving '.bar' behind
    ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
P.notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
Token Text
'.')
    pure These ProjectName branch
projectAndBranch

parseReadShareLooseCode :: String -> String -> Either (P.Pretty P.ColorText) ReadShareLooseCode
parseReadShareLooseCode :: String -> String -> Either (Pretty ColorText) ReadShareLooseCode
parseReadShareLooseCode String
label String
input =
  let printError :: ParseErrorBundle Text Void -> Pretty ColorText
printError ParseErrorBundle Text Void
err = [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines [String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
"I couldn't parse this as a share path.", String -> ParseErrorBundle Text Void -> Pretty ColorText
P.prettyPrintParseError String
input ParseErrorBundle Text Void
err]
   in (ParseErrorBundle Text Void -> Pretty ColorText)
-> Either (ParseErrorBundle Text Void) ReadShareLooseCode
-> Either (Pretty ColorText) ReadShareLooseCode
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle Text Void -> Pretty ColorText
printError (ParsecT Void Text Identity ReadShareLooseCode
-> String
-> Text
-> Either (ParseErrorBundle Text Void) ReadShareLooseCode
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.parse ParsecT Void Text Identity ReadShareLooseCode
readShareLooseCode String
label (String -> Text
Text.pack String
input))

-- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4"
-- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}))
writeRemoteNamespace :: P (These ProjectName ProjectBranchName)
writeRemoteNamespace :: P (These ProjectName ProjectBranchName)
writeRemoteNamespace =
  (ProjectBranchSpecifier ProjectBranchName
-> P (These ProjectName ProjectBranchName)
forall branch.
ProjectBranchSpecifier branch -> P (These ProjectName branch)
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ProjectBranchSpecifier ProjectBranchName
ProjectBranchSpecifier'Name)

-- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4"
-- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4"
-- Nothing
-- Just (ReadShareLooseCode {server = DefaultCodeserver, repo = ShareUserHandle {shareUserHandleToText = "unisonweb"}, path = base._releases.M4})
readShareLooseCode :: P ReadShareLooseCode
readShareLooseCode :: ParsecT Void Text Identity ReadShareLooseCode
readShareLooseCode = do
  String
-> ParsecT Void Text Identity ReadShareLooseCode
-> ParsecT Void Text Identity ReadShareLooseCode
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
P.label String
"read share loose code" (ParsecT Void Text Identity ReadShareLooseCode
 -> ParsecT Void Text Identity ReadShareLooseCode)
-> ParsecT Void Text Identity ReadShareLooseCode
-> ParsecT Void Text Identity ReadShareLooseCode
forall a b. (a -> b) -> a -> b
$
    ShareCodeserver -> ShareUserHandle -> Path -> ReadShareLooseCode
ReadShareLooseCode
      (ShareCodeserver -> ShareUserHandle -> Path -> ReadShareLooseCode)
-> ParsecT Void Text Identity ShareCodeserver
-> ParsecT
     Void Text Identity (ShareUserHandle -> Path -> ReadShareLooseCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShareCodeserver -> ParsecT Void Text Identity ShareCodeserver
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShareCodeserver
DefaultCodeserver
      -- <*> sch <- P.optional shortBranchHash
      ParsecT
  Void Text Identity (ShareUserHandle -> Path -> ReadShareLooseCode)
-> ParsecT Void Text Identity ShareUserHandle
-> ParsecT Void Text Identity (Path -> ReadShareLooseCode)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity ShareUserHandle
shareUserHandle
      ParsecT Void Text Identity (Path -> ReadShareLooseCode)
-> ParsecT Void Text Identity Path
-> ParsecT Void Text Identity ReadShareLooseCode
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([NameSegment] -> Path
Path.fromList ([NameSegment] -> Path)
-> ParsecT Void Text Identity [NameSegment]
-> ParsecT Void Text Identity Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity NameSegment
-> ParsecT Void Text Identity [NameSegment]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
C.char Char
Token Text
'.' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity NameSegment
-> ParsecT Void Text Identity NameSegment
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity NameSegment
nameSegment))

-- | We're lax in our share user rules here, Share is the source of truth
-- for this stuff and can provide better error messages if required.
--
-- >>> P.parseMaybe shareUserHandle "unison"
-- Just (ShareUserHandle {shareUserHandleToText = "unison"})
--
-- >>> P.parseMaybe shareUserHandle "unison-1337"
-- Just (ShareUserHandle {shareUserHandleToText = "unison-1337"})
shareUserHandle :: P ShareUserHandle
shareUserHandle :: ParsecT Void Text Identity ShareUserHandle
shareUserHandle = do
  Text -> ShareUserHandle
ShareUserHandle (Text -> ShareUserHandle)
-> (String -> Text) -> String -> ShareUserHandle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> ShareUserHandle)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity ShareUserHandle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy \Token Text
c -> Char -> Bool
isAlphaNum Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')

data Scheme = Ssh | Https
  deriving (Scheme -> Scheme -> Bool
(Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Bool) -> Eq Scheme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Scheme -> Scheme -> Bool
== :: Scheme -> Scheme -> Bool
$c/= :: Scheme -> Scheme -> Bool
/= :: Scheme -> Scheme -> Bool
Eq, Eq Scheme
Eq Scheme =>
(Scheme -> Scheme -> Ordering)
-> (Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Scheme)
-> (Scheme -> Scheme -> Scheme)
-> Ord Scheme
Scheme -> Scheme -> Bool
Scheme -> Scheme -> Ordering
Scheme -> Scheme -> Scheme
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 :: Scheme -> Scheme -> Ordering
compare :: Scheme -> Scheme -> Ordering
$c< :: Scheme -> Scheme -> Bool
< :: Scheme -> Scheme -> Bool
$c<= :: Scheme -> Scheme -> Bool
<= :: Scheme -> Scheme -> Bool
$c> :: Scheme -> Scheme -> Bool
> :: Scheme -> Scheme -> Bool
$c>= :: Scheme -> Scheme -> Bool
>= :: Scheme -> Scheme -> Bool
$cmax :: Scheme -> Scheme -> Scheme
max :: Scheme -> Scheme -> Scheme
$cmin :: Scheme -> Scheme -> Scheme
min :: Scheme -> Scheme -> Scheme
Ord, Int -> Scheme -> ShowS
[Scheme] -> ShowS
Scheme -> String
(Int -> Scheme -> ShowS)
-> (Scheme -> String) -> ([Scheme] -> ShowS) -> Show Scheme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Scheme -> ShowS
showsPrec :: Int -> Scheme -> ShowS
$cshow :: Scheme -> String
show :: Scheme -> String
$cshowList :: [Scheme] -> ShowS
showList :: [Scheme] -> ShowS
Show)

data User = User Text
  deriving (User -> User -> Bool
(User -> User -> Bool) -> (User -> User -> Bool) -> Eq User
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: User -> User -> Bool
== :: User -> User -> Bool
$c/= :: User -> User -> Bool
/= :: User -> User -> Bool
Eq, Eq User
Eq User =>
(User -> User -> Ordering)
-> (User -> User -> Bool)
-> (User -> User -> Bool)
-> (User -> User -> Bool)
-> (User -> User -> Bool)
-> (User -> User -> User)
-> (User -> User -> User)
-> Ord User
User -> User -> Bool
User -> User -> Ordering
User -> User -> User
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 :: User -> User -> Ordering
compare :: User -> User -> Ordering
$c< :: User -> User -> Bool
< :: User -> User -> Bool
$c<= :: User -> User -> Bool
<= :: User -> User -> Bool
$c> :: User -> User -> Bool
> :: User -> User -> Bool
$c>= :: User -> User -> Bool
>= :: User -> User -> Bool
$cmax :: User -> User -> User
max :: User -> User -> User
$cmin :: User -> User -> User
min :: User -> User -> User
Ord, Int -> User -> ShowS
[User] -> ShowS
User -> String
(Int -> User -> ShowS)
-> (User -> String) -> ([User] -> ShowS) -> Show User
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> User -> ShowS
showsPrec :: Int -> User -> ShowS
$cshow :: User -> String
show :: User -> String
$cshowList :: [User] -> ShowS
showList :: [User] -> ShowS
Show)

data HostInfo = HostInfo Text (Maybe Text)
  deriving (HostInfo -> HostInfo -> Bool
(HostInfo -> HostInfo -> Bool)
-> (HostInfo -> HostInfo -> Bool) -> Eq HostInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HostInfo -> HostInfo -> Bool
== :: HostInfo -> HostInfo -> Bool
$c/= :: HostInfo -> HostInfo -> Bool
/= :: HostInfo -> HostInfo -> Bool
Eq, Eq HostInfo
Eq HostInfo =>
(HostInfo -> HostInfo -> Ordering)
-> (HostInfo -> HostInfo -> Bool)
-> (HostInfo -> HostInfo -> Bool)
-> (HostInfo -> HostInfo -> Bool)
-> (HostInfo -> HostInfo -> Bool)
-> (HostInfo -> HostInfo -> HostInfo)
-> (HostInfo -> HostInfo -> HostInfo)
-> Ord HostInfo
HostInfo -> HostInfo -> Bool
HostInfo -> HostInfo -> Ordering
HostInfo -> HostInfo -> HostInfo
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 :: HostInfo -> HostInfo -> Ordering
compare :: HostInfo -> HostInfo -> Ordering
$c< :: HostInfo -> HostInfo -> Bool
< :: HostInfo -> HostInfo -> Bool
$c<= :: HostInfo -> HostInfo -> Bool
<= :: HostInfo -> HostInfo -> Bool
$c> :: HostInfo -> HostInfo -> Bool
> :: HostInfo -> HostInfo -> Bool
$c>= :: HostInfo -> HostInfo -> Bool
>= :: HostInfo -> HostInfo -> Bool
$cmax :: HostInfo -> HostInfo -> HostInfo
max :: HostInfo -> HostInfo -> HostInfo
$cmin :: HostInfo -> HostInfo -> HostInfo
min :: HostInfo -> HostInfo -> HostInfo
Ord, Int -> HostInfo -> ShowS
[HostInfo] -> ShowS
HostInfo -> String
(Int -> HostInfo -> ShowS)
-> (HostInfo -> String) -> ([HostInfo] -> ShowS) -> Show HostInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HostInfo -> ShowS
showsPrec :: Int -> HostInfo -> ShowS
$cshow :: HostInfo -> String
show :: HostInfo -> String
$cshowList :: [HostInfo] -> ShowS
showList :: [HostInfo] -> ShowS
Show)

nameSegment :: P NameSegment
nameSegment :: ParsecT Void Text Identity NameSegment
nameSegment =
  Text -> NameSegment
NameSegment.unsafeParseText (Text -> NameSegment) -> (String -> Text) -> String -> NameSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
    (String -> NameSegment)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity NameSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( (:)
            (Char -> ShowS)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy Char -> Bool
Token Text -> Bool
Unison.Syntax.Lexer.wordyIdStartChar
            ParsecT Void Text Identity ShowS
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy Char -> Bool
Token Text -> Bool
Unison.Syntax.Lexer.wordyIdChar)
        )