{-
   This module defines tab-completion strategies for entering info via the CLI
-}
{-# LANGUAGE RecordWildCards #-}

module Unison.CommandLine.Completion
  ( -- * Completers
    exactComplete,
    prefixCompleteTermOrType,
    prefixCompleteTerm,
    prefixCompleteType,
    prefixCompletePatch,
    noCompletions,
    prefixCompleteNamespace,
    -- Unused for now, but may be useful later
    prettyCompletion,
    fixupCompletion,
    haskelineTabComplete,
    sharePathCompletion,
  )
where

import Control.Lens
import Control.Lens qualified as Lens
import Data.Aeson qualified as Aeson
import Data.List (isPrefixOf)
import Data.List qualified as List
import Data.List.Extra (nubOrdOn)
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as Map
import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as NESet
import Data.Text qualified as Text
import Network.HTTP.Client qualified as HTTP
import Network.URI qualified as URI
import System.Console.Haskeline qualified as Line
import System.Console.Haskeline.Completion (Completion)
import System.Console.Haskeline.Completion qualified as Haskeline
import Text.Megaparsec qualified as P
import U.Codebase.Branch qualified as V2Branch
import U.Codebase.Causal qualified as V2Causal
import U.Codebase.Reference qualified as Reference
import U.Codebase.Referent qualified as Referent
import Unison.Auth.HTTPClient (AuthenticatedHttpClient (..))
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Path.Parse qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
import Unison.CommandLine.InputPattern qualified as IP
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Name qualified as Name
import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.Prelude
import Unison.Server.Local.Endpoints.NamespaceListing (NamespaceListing (NamespaceListing))
import Unison.Server.Local.Endpoints.NamespaceListing qualified as Server
import Unison.Server.Types qualified as Server
import Unison.Share.Codeserver qualified as Codeserver
import Unison.Share.Types qualified as Share
import Unison.Sqlite qualified as Sqlite
import Unison.Syntax.Name qualified as Name
import Unison.Syntax.NameSegment qualified as NameSegment
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.Pretty qualified as P
import UnliftIO qualified
import Prelude hiding (readFile, writeFile)

-- | A completion func for use with Haskeline
haskelineTabComplete ::
  (MonadIO m) =>
  Map String IP.InputPattern ->
  Codebase m v a ->
  AuthenticatedHttpClient ->
  PP.ProjectPath ->
  Line.CompletionFunc m
haskelineTabComplete :: forall (m :: * -> *) v a.
MonadIO m =>
Map String InputPattern
-> Codebase m v a
-> AuthenticatedHttpClient
-> ProjectPath
-> CompletionFunc m
haskelineTabComplete Map String InputPattern
patterns Codebase m v a
codebase AuthenticatedHttpClient
authedHTTPClient ProjectPath
ppCtx = Maybe Char
-> String
-> (String -> String -> m [Completion])
-> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> String
-> (String -> String -> m [Completion])
-> CompletionFunc m
Line.completeWordWithPrev Maybe Char
forall a. Maybe a
Nothing String
" " ((String -> String -> m [Completion]) -> CompletionFunc m)
-> (String -> String -> m [Completion]) -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ \String
prev String
word ->
  -- User hasn't finished a command name, complete from command names
  if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
prev
    then [Completion] -> m [Completion]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Completion] -> m [Completion])
-> ([String] -> [Completion]) -> [String] -> m [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [Completion]
exactComplete String
word ([String] -> m [Completion]) -> [String] -> m [Completion]
forall a b. (a -> b) -> a -> b
$ Map String InputPattern -> [String]
forall k a. Map k a -> [k]
Map.keys Map String InputPattern
patterns
    else -- User has finished a command name; use completions for that command
    case String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
prev of
      String
h : [String]
t -> m [Completion] -> Maybe (m [Completion]) -> m [Completion]
forall a. a -> Maybe a -> a
fromMaybe ([Completion] -> m [Completion]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Maybe (m [Completion]) -> m [Completion])
-> Maybe (m [Completion]) -> m [Completion]
forall a b. (a -> b) -> a -> b
$ do
        InputPattern
p <- String -> Map String InputPattern -> Maybe InputPattern
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
h Map String InputPattern
patterns
        ArgumentType
argType <- InputPattern -> Int -> Maybe ArgumentType
IP.argType InputPattern
p ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
t)
        pure $ ArgumentType
-> forall (m :: * -> *) v a.
   MonadIO m =>
   String
   -> Codebase m v a
   -> AuthenticatedHttpClient
   -> ProjectPath
   -> m [Completion]
IP.suggestions ArgumentType
argType String
word Codebase m v a
codebase AuthenticatedHttpClient
authedHTTPClient ProjectPath
ppCtx
      [String]
_ -> [Completion] -> m [Completion]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Things which we may want to complete for.
data CompletionType
  = NamespaceCompletion
  | TermCompletion
  | TypeCompletion
  | PatchCompletion
  deriving (Int -> CompletionType -> String -> String
[CompletionType] -> String -> String
CompletionType -> String
(Int -> CompletionType -> String -> String)
-> (CompletionType -> String)
-> ([CompletionType] -> String -> String)
-> Show CompletionType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> CompletionType -> String -> String
showsPrec :: Int -> CompletionType -> String -> String
$cshow :: CompletionType -> String
show :: CompletionType -> String
$cshowList :: [CompletionType] -> String -> String
showList :: [CompletionType] -> String -> String
Show, CompletionType -> CompletionType -> Bool
(CompletionType -> CompletionType -> Bool)
-> (CompletionType -> CompletionType -> Bool) -> Eq CompletionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompletionType -> CompletionType -> Bool
== :: CompletionType -> CompletionType -> Bool
$c/= :: CompletionType -> CompletionType -> Bool
/= :: CompletionType -> CompletionType -> Bool
Eq, Eq CompletionType
Eq CompletionType =>
(CompletionType -> CompletionType -> Ordering)
-> (CompletionType -> CompletionType -> Bool)
-> (CompletionType -> CompletionType -> Bool)
-> (CompletionType -> CompletionType -> Bool)
-> (CompletionType -> CompletionType -> Bool)
-> (CompletionType -> CompletionType -> CompletionType)
-> (CompletionType -> CompletionType -> CompletionType)
-> Ord CompletionType
CompletionType -> CompletionType -> Bool
CompletionType -> CompletionType -> Ordering
CompletionType -> CompletionType -> CompletionType
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 :: CompletionType -> CompletionType -> Ordering
compare :: CompletionType -> CompletionType -> Ordering
$c< :: CompletionType -> CompletionType -> Bool
< :: CompletionType -> CompletionType -> Bool
$c<= :: CompletionType -> CompletionType -> Bool
<= :: CompletionType -> CompletionType -> Bool
$c> :: CompletionType -> CompletionType -> Bool
> :: CompletionType -> CompletionType -> Bool
$c>= :: CompletionType -> CompletionType -> Bool
>= :: CompletionType -> CompletionType -> Bool
$cmax :: CompletionType -> CompletionType -> CompletionType
max :: CompletionType -> CompletionType -> CompletionType
$cmin :: CompletionType -> CompletionType -> CompletionType
min :: CompletionType -> CompletionType -> CompletionType
Ord)

-- | The empty completor.
noCompletions ::
  (MonadIO m) =>
  String ->
  Codebase m v a ->
  AuthenticatedHttpClient ->
  PP.ProjectPath ->
  m [System.Console.Haskeline.Completion.Completion]
noCompletions :: forall (m :: * -> *) v a.
MonadIO m =>
String
-> Codebase m v a
-> AuthenticatedHttpClient
-> ProjectPath
-> m [Completion]
noCompletions String
_ Codebase m v a
_ AuthenticatedHttpClient
_ ProjectPath
_ = [Completion] -> m [Completion]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Finds names of the selected completion types within the path provided by the query.
--
-- Given a codebase with these terms:
--
-- @@
-- .base.List.map.doc
-- .base.List
-- .bar.foo
-- @@
--
-- We will return:
--
-- @@
-- .> cd bas<Tab>
-- base
--
-- .> cd base<Tab>
-- base
-- base.List
--
-- .> cd base.<Tab>
-- base.List
--
-- .> cd base.List.<Tab>
-- base.List.map
--
-- If conflicted, or if there's a # in the query, we expand completions into short-hashes.
-- This is also a convenient way to just see the shorthash for a given term.
--
-- .> view base.List.map#<Tab>
-- base.List.map#0q926sgnn6
completeWithinNamespace ::
  -- | The types of completions to return
  NESet CompletionType ->
  -- | The portion of this are that the user has already typed.
  String ->
  PP.ProjectPath ->
  Sqlite.Transaction [System.Console.Haskeline.Completion.Completion]
completeWithinNamespace :: NESet CompletionType
-> String -> ProjectPath -> Transaction [Completion]
completeWithinNamespace NESet CompletionType
compTypes String
query ProjectPath
ppCtx = do
  Int
shortHashLen <- Transaction Int
Codebase.hashLength
  Branch Transaction
b <- ProjectPath -> Transaction (Branch Transaction)
Codebase.getShallowBranchAtProjectPath ProjectPath
queryProjectPath
  [Completion]
currentBranchSuggestions <- do
    [(CompletionType, Bool, Text)]
nib <- Int
-> Branch Transaction -> Transaction [(CompletionType, Bool, Text)]
namesInBranch Int
shortHashLen Branch Transaction
b
    [(CompletionType, Bool, Text)]
nib
      [(CompletionType, Bool, Text)]
-> ([(CompletionType, Bool, Text)] -> [(Bool, String)])
-> [(Bool, String)]
forall a b. a -> (a -> b) -> b
& ((CompletionType, Bool, Text) -> (Bool, String))
-> [(CompletionType, Bool, Text)] -> [(Bool, String)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( \(CompletionType
ty, Bool
isFinished, Text
match) ->
            ( Bool
isFinished,
              Text -> String
Text.unpack (CompletionType -> Text -> Text
dotifyNamespace CompletionType
ty (Path' -> Text
Path.toText' (Path'
queryPathPrefix Path' -> NameSegment -> Path'
forall a b. Snoc a a b b => a -> b -> a
Lens.:> Text -> NameSegment
NameSegment Text
match)))
            )
        )
      [(Bool, String)]
-> ([(Bool, String)] -> [(Bool, String)]) -> [(Bool, String)]
forall a b. a -> (a -> b) -> b
& ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Bool
_isFinished, String
match) -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
query String
match)
      [(Bool, String)]
-> ([(Bool, String)] -> [Completion]) -> [Completion]
forall a b. a -> (a -> b) -> b
& ((Bool, String) -> Completion) -> [(Bool, String)] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Bool
isFinished, String
match) -> Bool -> String -> String -> Completion
prettyCompletionWithQueryPrefix Bool
isFinished String
query String
match)
      [Completion]
-> ([Completion] -> Transaction [Completion])
-> Transaction [Completion]
forall a b. a -> (a -> b) -> b
& [Completion] -> Transaction [Completion]
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  [Completion]
childSuggestions <- Int -> Branch Transaction -> Transaction [Completion]
getChildSuggestions Int
shortHashLen Branch Transaction
b
  let allSuggestions :: [Completion]
allSuggestions =
        [Completion]
currentBranchSuggestions
          -- Only show child suggestions when the current branch isn't ambiguous
          [Completion] -> [Completion] -> [Completion]
forall a. Semigroup a => a -> a -> a
<> Bool -> [Completion] -> [Completion]
forall a. Monoid a => Bool -> a -> a
Monoid.whenM ([Completion] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Completion]
currentBranchSuggestions Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1) [Completion]
childSuggestions
  [Completion] -> Transaction [Completion]
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Completion] -> Transaction [Completion])
-> ([Completion] -> [Completion])
-> [Completion]
-> Transaction [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Completion -> String) -> [Completion] -> [Completion]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn Completion -> String
Haskeline.replacement ([Completion] -> [Completion])
-> ([Completion] -> [Completion]) -> [Completion] -> [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Completion -> String) -> [Completion] -> [Completion]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Completion -> String
Haskeline.replacement ([Completion] -> Transaction [Completion])
-> [Completion] -> Transaction [Completion]
forall a b. (a -> b) -> a -> b
$ [Completion]
allSuggestions
  where
    queryPathPrefix :: Path.Path'
    querySuffix :: Text
    (Path'
queryPathPrefix, Text
querySuffix) = Text -> (Path', Text)
parseLaxPath'Query (String -> Text
Text.pack String
query)
    queryProjectPath :: PP.ProjectPath
    queryProjectPath :: ProjectPath
queryProjectPath = ProjectPath
ppCtx ProjectPath -> (ProjectPath -> ProjectPath) -> ProjectPath
forall a b. a -> (a -> b) -> b
& (Absolute -> Identity Absolute)
-> ProjectPath -> Identity ProjectPath
forall p b (f :: * -> *).
Functor f =>
(Absolute -> f Absolute)
-> ProjectPathG p b -> f (ProjectPathG p b)
PP.absPath_ ((Absolute -> Identity Absolute)
 -> ProjectPath -> Identity ProjectPath)
-> (Absolute -> Absolute) -> ProjectPath -> ProjectPath
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Absolute
curPath -> Absolute -> Path' -> Absolute
forall l r o. Resolve l r o => l -> r -> o
Path.resolve Absolute
curPath Path'
queryPathPrefix
    getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion]
    getChildSuggestions :: Int -> Branch Transaction -> Transaction [Completion]
getChildSuggestions Int
shortHashLen Branch Transaction
b
      | Text -> Bool
Text.null Text
querySuffix = [Completion] -> Transaction [Completion]
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Bool
otherwise =
          case Text -> Either Text NameSegment
NameSegment.parseText Text
querySuffix of
            Left Text
_ -> [Completion] -> Transaction [Completion]
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            Right NameSegment
suffix -> do
              Map NameSegment (CausalBranch Transaction)
nonEmptyChildren <- Branch Transaction
-> Transaction (Map NameSegment (CausalBranch Transaction))
forall (m :: * -> *).
Branch m -> Transaction (Map NameSegment (CausalBranch m))
V2Branch.nonEmptyChildren Branch Transaction
b
              case NameSegment
-> Map NameSegment (CausalBranch Transaction)
-> Maybe (CausalBranch Transaction)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NameSegment
suffix Map NameSegment (CausalBranch Transaction)
nonEmptyChildren of
                Maybe (CausalBranch Transaction)
Nothing -> [Completion] -> Transaction [Completion]
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                Just CausalBranch Transaction
childCausal -> do
                  Branch Transaction
childBranch <- CausalBranch Transaction -> Transaction (Branch Transaction)
forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> m e
V2Causal.value CausalBranch Transaction
childCausal
                  [(CompletionType, Bool, Text)]
nib <- Int
-> Branch Transaction -> Transaction [(CompletionType, Bool, Text)]
namesInBranch Int
shortHashLen Branch Transaction
childBranch
                  [(CompletionType, Bool, Text)]
nib
                    [(CompletionType, Bool, Text)]
-> ([(CompletionType, Bool, Text)] -> [(Bool, String)])
-> [(Bool, String)]
forall a b. a -> (a -> b) -> b
& ((CompletionType, Bool, Text) -> (Bool, String))
-> [(CompletionType, Bool, Text)] -> [(Bool, String)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                      ( \(CompletionType
ty, Bool
isFinished, Text
match) ->
                          ( Bool
isFinished,
                            Text -> String
Text.unpack (CompletionType -> Text -> Text
dotifyNamespace CompletionType
ty (Path' -> Text
Path.toText' (Path'
queryPathPrefix Path' -> NameSegment -> Path'
forall a b. Snoc a a b b => a -> b -> a
Lens.:> NameSegment
suffix Path' -> NameSegment -> Path'
forall a b. Snoc a a b b => a -> b -> a
Lens.:> Text -> NameSegment
NameSegment Text
match)))
                          )
                      )
                    [(Bool, String)]
-> ([(Bool, String)] -> [(Bool, String)]) -> [(Bool, String)]
forall a b. a -> (a -> b) -> b
& ((Bool, String) -> Bool) -> [(Bool, String)] -> [(Bool, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Bool
_isFinished, String
match) -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
query String
match)
                    [(Bool, String)]
-> ([(Bool, String)] -> [Completion]) -> [Completion]
forall a b. a -> (a -> b) -> b
& ((Bool, String) -> Completion) -> [(Bool, String)] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Bool
isFinished, String
match) -> Bool -> String -> String -> Completion
prettyCompletionWithQueryPrefix Bool
isFinished String
query String
match)
                    [Completion]
-> ([Completion] -> Transaction [Completion])
-> Transaction [Completion]
forall a b. a -> (a -> b) -> b
& [Completion] -> Transaction [Completion]
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    namesInBranch :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [(CompletionType, Bool, Text)]
    namesInBranch :: Int
-> Branch Transaction -> Transaction [(CompletionType, Bool, Text)]
namesInBranch Int
hashLen Branch Transaction
b = do
      Map NameSegment (CausalBranch Transaction)
nonEmptyChildren <- Branch Transaction
-> Transaction (Map NameSegment (CausalBranch Transaction))
forall (m :: * -> *).
Branch m -> Transaction (Map NameSegment (CausalBranch m))
V2Branch.nonEmptyChildren Branch Transaction
b
      pure $
        [[(CompletionType, Bool, Text)]] -> [(CompletionType, Bool, Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ (CompletionType
NamespaceCompletion,Bool
False,) (Text -> (CompletionType, Bool, Text))
-> [Text] -> [(CompletionType, Bool, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NameSegment -> Text) -> [NameSegment] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NameSegment -> Text
NameSegment.toEscapedText ([NameSegment] -> [Text])
-> (Map NameSegment (CausalBranch Transaction) -> [NameSegment])
-> Map NameSegment (CausalBranch Transaction)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map NameSegment (CausalBranch Transaction) -> [NameSegment]
forall k a. Map k a -> [k]
Map.keys (Map NameSegment (CausalBranch Transaction) -> [Text])
-> Map NameSegment (CausalBranch Transaction) -> [Text]
forall a b. (a -> b) -> a -> b
$ Map NameSegment (CausalBranch Transaction)
nonEmptyChildren),
            Bool
-> [(CompletionType, Bool, Text)] -> [(CompletionType, Bool, Text)]
forall a. Monoid a => Bool -> a -> a
Monoid.whenM
              (CompletionType -> NESet CompletionType -> Bool
forall a. Ord a => a -> NESet a -> Bool
NESet.member CompletionType
TermCompletion NESet CompletionType
compTypes)
              (((Bool, Text) -> (CompletionType, Bool, Text))
-> [(Bool, Text)] -> [(CompletionType, Bool, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
x, Text
y) -> (CompletionType
TermCompletion, Bool
x, Text
y)) ((NameSegment -> Referent -> HashQualified NameSegment)
-> Map NameSegment (Map Referent (Transaction MdValues))
-> [(Bool, Text)]
forall r metadata.
(NameSegment -> r -> HashQualified NameSegment)
-> Map NameSegment (Map r metadata) -> [(Bool, Text)]
textifyHQ (Int -> NameSegment -> Referent -> HashQualified NameSegment
hqFromNamedV2Referent Int
hashLen) (Map NameSegment (Map Referent (Transaction MdValues))
 -> [(Bool, Text)])
-> Map NameSegment (Map Referent (Transaction MdValues))
-> [(Bool, Text)]
forall a b. (a -> b) -> a -> b
$ Branch Transaction
-> Map NameSegment (Map Referent (Transaction MdValues))
forall (m :: * -> *).
Branch m -> Map NameSegment (Map Referent (m MdValues))
V2Branch.terms Branch Transaction
b)),
            Bool
-> [(CompletionType, Bool, Text)] -> [(CompletionType, Bool, Text)]
forall a. Monoid a => Bool -> a -> a
Monoid.whenM
              (CompletionType -> NESet CompletionType -> Bool
forall a. Ord a => a -> NESet a -> Bool
NESet.member CompletionType
TypeCompletion NESet CompletionType
compTypes)
              (((Bool, Text) -> (CompletionType, Bool, Text))
-> [(Bool, Text)] -> [(CompletionType, Bool, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
x, Text
y) -> (CompletionType
TypeCompletion, Bool
x, Text
y)) ((NameSegment -> Reference -> HashQualified NameSegment)
-> Map NameSegment (Map Reference (Transaction MdValues))
-> [(Bool, Text)]
forall r metadata.
(NameSegment -> r -> HashQualified NameSegment)
-> Map NameSegment (Map r metadata) -> [(Bool, Text)]
textifyHQ (Int -> NameSegment -> Reference -> HashQualified NameSegment
hqFromNamedV2Reference Int
hashLen) (Map NameSegment (Map Reference (Transaction MdValues))
 -> [(Bool, Text)])
-> Map NameSegment (Map Reference (Transaction MdValues))
-> [(Bool, Text)]
forall a b. (a -> b) -> a -> b
$ Branch Transaction
-> Map NameSegment (Map Reference (Transaction MdValues))
forall (m :: * -> *).
Branch m -> Map NameSegment (Map Reference (m MdValues))
V2Branch.types Branch Transaction
b)),
            Bool
-> [(CompletionType, Bool, Text)] -> [(CompletionType, Bool, Text)]
forall a. Monoid a => Bool -> a -> a
Monoid.whenM
              (CompletionType -> NESet CompletionType -> Bool
forall a. Ord a => a -> NESet a -> Bool
NESet.member CompletionType
PatchCompletion NESet CompletionType
compTypes)
              ((NameSegment -> (CompletionType, Bool, Text))
-> [NameSegment] -> [(CompletionType, Bool, Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CompletionType
PatchCompletion,Bool
True,) (Text -> (CompletionType, Bool, Text))
-> (NameSegment -> Text)
-> NameSegment
-> (CompletionType, Bool, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSegment -> Text
NameSegment.toEscapedText) ([NameSegment] -> [(CompletionType, Bool, Text)])
-> (Map NameSegment (PatchHash, Transaction Patch)
    -> [NameSegment])
-> Map NameSegment (PatchHash, Transaction Patch)
-> [(CompletionType, Bool, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map NameSegment (PatchHash, Transaction Patch) -> [NameSegment]
forall k a. Map k a -> [k]
Map.keys (Map NameSegment (PatchHash, Transaction Patch)
 -> [(CompletionType, Bool, Text)])
-> Map NameSegment (PatchHash, Transaction Patch)
-> [(CompletionType, Bool, Text)]
forall a b. (a -> b) -> a -> b
$ Branch Transaction
-> Map NameSegment (PatchHash, Transaction Patch)
forall (m :: * -> *).
Branch m -> Map NameSegment (PatchHash, m Patch)
V2Branch.patches Branch Transaction
b)
          ]

    textifyHQ :: (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [(Bool, Text)]
    textifyHQ :: forall r metadata.
(NameSegment -> r -> HashQualified NameSegment)
-> Map NameSegment (Map r metadata) -> [(Bool, Text)]
textifyHQ NameSegment -> r -> HashQualified NameSegment
f Map NameSegment (Map r metadata)
xs =
      Map NameSegment (Map r metadata)
xs
        Map NameSegment (Map r metadata)
-> (Map NameSegment (Map r metadata)
    -> [HashQualified NameSegment])
-> [HashQualified NameSegment]
forall a b. a -> (a -> b) -> b
& (NameSegment -> r -> HashQualified NameSegment)
-> Map NameSegment (Map r metadata) -> [HashQualified NameSegment]
forall r metadata.
(NameSegment -> r -> HashQualified NameSegment)
-> Map NameSegment (Map r metadata) -> [HashQualified NameSegment]
hashQualifyCompletions NameSegment -> r -> HashQualified NameSegment
f
        [HashQualified NameSegment]
-> ([HashQualified NameSegment] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (HashQualified NameSegment -> Text)
-> [HashQualified NameSegment] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NameSegment -> Text) -> HashQualified NameSegment -> Text
forall n. (n -> Text) -> HashQualified n -> Text
HQ'.toTextWith NameSegment -> Text
NameSegment.toEscapedText)
        [Text] -> ([Text] -> [(Bool, Text)]) -> [(Bool, Text)]
forall a b. a -> (a -> b) -> b
& (Text -> (Bool, Text)) -> [Text] -> [(Bool, Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool
True,)
    -- Regrettably there'shqFromNamedV2Referencenot a great spot to combinators for V2 references and shorthashes right now.
    hqFromNamedV2Referent :: Int -> NameSegment -> Referent.Referent -> HQ'.HashQualified NameSegment
    hqFromNamedV2Referent :: Int -> NameSegment -> Referent -> HashQualified NameSegment
hqFromNamedV2Referent Int
hashLen NameSegment
n Referent
r = NameSegment -> ShortHash -> HashQualified NameSegment
forall n. n -> ShortHash -> HashQualified n
HQ'.HashQualified NameSegment
n (Maybe Int -> Referent -> ShortHash
Cv.referent2toshorthash1 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
hashLen) Referent
r)
    hqFromNamedV2Reference :: Int -> NameSegment -> Reference.Reference -> HQ'.HashQualified NameSegment
    hqFromNamedV2Reference :: Int -> NameSegment -> Reference -> HashQualified NameSegment
hqFromNamedV2Reference Int
hashLen NameSegment
n Reference
r = NameSegment -> ShortHash -> HashQualified NameSegment
forall n. n -> ShortHash -> HashQualified n
HQ'.HashQualified NameSegment
n (Maybe Int -> Reference -> ShortHash
Cv.reference2toshorthash1 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
hashLen) Reference
r)
    hashQualifyCompletions :: forall r metadata. (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [HQ'.HashQualified NameSegment]
    hashQualifyCompletions :: forall r metadata.
(NameSegment -> r -> HashQualified NameSegment)
-> Map NameSegment (Map r metadata) -> [HashQualified NameSegment]
hashQualifyCompletions NameSegment -> r -> HashQualified NameSegment
qualify Map NameSegment (Map r metadata)
defs = (NameSegment -> Map r metadata -> [HashQualified NameSegment])
-> Map NameSegment (Map r metadata) -> [HashQualified NameSegment]
forall m a.
Monoid m =>
(NameSegment -> a -> m) -> Map NameSegment a -> m
forall i (f :: * -> *) m a.
(FoldableWithIndex i f, Monoid m) =>
(i -> a -> m) -> f a -> m
ifoldMap NameSegment -> Map r metadata -> [HashQualified NameSegment]
qualifyRefs Map NameSegment (Map r metadata)
defs
      where
        -- Qualify any conflicted definitions. If the query has a "#" in it, then qualify ALL
        -- completions.
        qualifyRefs :: NameSegment -> Map r metadata -> [HQ'.HashQualified NameSegment]
        qualifyRefs :: NameSegment -> Map r metadata -> [HashQualified NameSegment]
qualifyRefs NameSegment
n Map r metadata
refs
          | Text -> Text -> Bool
Text.isInfixOf Text
"#" Text
querySuffix Bool -> Bool -> Bool
|| Map r metadata -> Int
forall a. Map r a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map r metadata
refs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = Map r metadata
refs Map r metadata -> (Map r metadata -> [r]) -> [r]
forall a b. a -> (a -> b) -> b
& Map r metadata -> [r]
forall k a. Map k a -> [k]
Map.keys [r]
-> (r -> HashQualified NameSegment) -> [HashQualified NameSegment]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> NameSegment -> r -> HashQualified NameSegment
qualify NameSegment
n
          | Bool
otherwise = [NameSegment -> HashQualified NameSegment
forall n. n -> HashQualified n
HQ'.NameOnly NameSegment
n]

    -- If we're not completing namespaces, then all namespace completions should automatically
    -- drill-down by adding a trailing '.'
    dotifyNamespace :: CompletionType -> Text -> Text
    dotifyNamespace :: CompletionType -> Text -> Text
dotifyNamespace CompletionType
NamespaceCompletion | Bool -> Bool
not (CompletionType -> NESet CompletionType -> Bool
forall a. Ord a => a -> NESet a -> Bool
NESet.member CompletionType
NamespaceCompletion NESet CompletionType
compTypes) = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".")
    dotifyNamespace CompletionType
_ = Text -> Text
forall a. a -> a
id

-- | A path parser which which is more lax with respect to well formed paths,
-- specifically we can determine a valid path prefix with a (possibly empty) suffix query.
-- This is used in tab-completion where the difference between `.base` and `.base.` is
-- relevant, but can't be detected when running something like 'Path.fromText''
--
-- >>> parseLaxPath'Query ".base."
-- (.base,"")
--
-- >>> parseLaxPath'Query ".base"
-- (.,"base")
--
-- >>> parseLaxPath'Query ".base.List"
-- (.base,"List")
--
-- >>> parseLaxPath'Query ""
-- (,"")
--
-- >>> parseLaxPath'Query "base"
-- (,"base")
--
-- >>> parseLaxPath'Query "base."
-- (base,"")
--
-- >>> parseLaxPath'Query "base.List"
-- (base,"List")
parseLaxPath'Query :: Text -> (Path.Path', Text)
parseLaxPath'Query :: Text -> (Path', Text)
parseLaxPath'Query Text
txt =
  case Parsec (Token Text) String (Split', String)
-> String
-> String
-> Either (ParseErrorBundle String (Token Text)) (Split', String)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.runParser ((,) (Split' -> String -> (Split', String))
-> ParsecT (Token Text) String Identity Split'
-> ParsecT
     (Token Text) String Identity (String -> (Split', String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Text) String Identity Split'
Path.splitP' ParsecT (Token Text) String Identity (String -> (Split', String))
-> ParsecT (Token Text) String Identity String
-> Parsec (Token Text) String (Split', String)
forall a b.
ParsecT (Token Text) String Identity (a -> b)
-> ParsecT (Token Text) String Identity a
-> ParsecT (Token Text) String Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT (Token Text) String Identity String
ParsecT (Token Text) String Identity (Tokens String)
forall e s (m :: * -> *). MonadParsec e s m => m (Tokens s)
P.takeRest) String
"" (Text -> String
Text.unpack Text
txt) of
    Left ParseErrorBundle String (Token Text)
_err -> (Path'
Path.relativeEmpty', Text
txt)
    Right ((Path'
path, NameSegment
segment), String
rest) ->
      if Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
rest String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"."
        then (Split' -> Path'
Path.unsplit' (Path'
path, NameSegment
segment), Text
Text.empty)
        else (Path'
path, NameSegment -> Text
NameSegment.toEscapedText NameSegment
segment)

-- | Completes a namespace argument by prefix-matching against the query.
prefixCompleteNamespace ::
  String ->
  PP.ProjectPath ->
  Sqlite.Transaction [Line.Completion]
prefixCompleteNamespace :: String -> ProjectPath -> Transaction [Completion]
prefixCompleteNamespace = NESet CompletionType
-> String -> ProjectPath -> Transaction [Completion]
completeWithinNamespace (CompletionType -> NESet CompletionType
forall a. a -> NESet a
NESet.singleton CompletionType
NamespaceCompletion)

-- | Completes a term or type argument by prefix-matching against the query.
prefixCompleteTermOrType ::
  String ->
  PP.ProjectPath ->
  Sqlite.Transaction [Line.Completion]
prefixCompleteTermOrType :: String -> ProjectPath -> Transaction [Completion]
prefixCompleteTermOrType = NESet CompletionType
-> String -> ProjectPath -> Transaction [Completion]
completeWithinNamespace (NonEmpty CompletionType -> NESet CompletionType
forall a. Ord a => NonEmpty a -> NESet a
NESet.fromList (CompletionType
TermCompletion CompletionType -> [CompletionType] -> NonEmpty CompletionType
forall a. a -> [a] -> NonEmpty a
NE.:| [CompletionType
TypeCompletion]))

-- | Completes a term argument by prefix-matching against the query.
prefixCompleteTerm ::
  String ->
  PP.ProjectPath ->
  Sqlite.Transaction [Line.Completion]
prefixCompleteTerm :: String -> ProjectPath -> Transaction [Completion]
prefixCompleteTerm = NESet CompletionType
-> String -> ProjectPath -> Transaction [Completion]
completeWithinNamespace (CompletionType -> NESet CompletionType
forall a. a -> NESet a
NESet.singleton CompletionType
TermCompletion)

-- | Completes a term or type argument by prefix-matching against the query.
prefixCompleteType ::
  String ->
  PP.ProjectPath ->
  Sqlite.Transaction [Line.Completion]
prefixCompleteType :: String -> ProjectPath -> Transaction [Completion]
prefixCompleteType = NESet CompletionType
-> String -> ProjectPath -> Transaction [Completion]
completeWithinNamespace (CompletionType -> NESet CompletionType
forall a. a -> NESet a
NESet.singleton CompletionType
TypeCompletion)

-- | Completes a patch argument by prefix-matching against the query.
prefixCompletePatch ::
  String ->
  PP.ProjectPath ->
  Sqlite.Transaction [Line.Completion]
prefixCompletePatch :: String -> ProjectPath -> Transaction [Completion]
prefixCompletePatch = NESet CompletionType
-> String -> ProjectPath -> Transaction [Completion]
completeWithinNamespace (CompletionType -> NESet CompletionType
forall a. a -> NESet a
NESet.singleton CompletionType
PatchCompletion)

-- | Renders a completion option with the prefix matching the query greyed out.
prettyCompletionWithQueryPrefix ::
  Bool ->
  -- | query
  String ->
  -- | completion
  String ->
  Line.Completion
prettyCompletionWithQueryPrefix :: Bool -> String -> String -> Completion
prettyCompletionWithQueryPrefix Bool
endWithSpace String
query String
s =
  let coloredMatch :: Pretty ColorText
coloredMatch = Pretty ColorText -> Pretty ColorText
P.hiBlack (String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
query) Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
query) String
s)
   in String -> String -> Bool -> Completion
Line.Completion String
s (Pretty ColorText -> String
P.toAnsiUnbroken Pretty ColorText
coloredMatch) Bool
endWithSpace

-- discards formatting in favor of better alignment
-- prettyCompletion (s, p) = Line.Completion s (P.toPlainUnbroken p) True
-- preserves formatting, but Haskeline doesn't know how to align
prettyCompletion :: Bool -> (String, P.Pretty P.ColorText) -> Line.Completion
prettyCompletion :: Bool -> (String, Pretty ColorText) -> Completion
prettyCompletion Bool
endWithSpace (String
s, Pretty ColorText
p) = String -> String -> Bool -> Completion
Line.Completion String
s (Pretty ColorText -> String
P.toAnsiUnbroken Pretty ColorText
p) Bool
endWithSpace

-- | Constructs a list of 'Completion's from a query and completion options by
-- filtering them for prefix matches. A completion will be selected if it's an exact match for
-- a provided option.
exactComplete :: String -> [String] -> [Line.Completion]
exactComplete :: String -> [String] -> [Completion]
exactComplete String
q [String]
ss = String -> Completion
go (String -> Completion) -> [String] -> [Completion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
q) [String]
ss
  where
    go :: String -> Completion
go String
s = Bool -> String -> String -> Completion
prettyCompletionWithQueryPrefix (String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
q) String
q String
s

-- workaround for https://github.com/judah/haskeline/issues/100
-- if the common prefix of all the completions is smaller than
-- the query, we make all the replacements equal to the query,
-- which will preserve what the user has typed
fixupCompletion :: String -> [Line.Completion] -> [Line.Completion]
fixupCompletion :: String -> [Completion] -> [Completion]
fixupCompletion String
_q [] = []
fixupCompletion String
_q [Completion
c] = [Completion
c]
fixupCompletion String
q cs :: [Completion]
cs@(Completion
h : [Completion]
t) =
  let commonPrefix :: String -> String -> String
commonPrefix (Char
h1 : String
t1) (Char
h2 : String
t2) | Char
h1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
h2 = Char
h1 Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String -> String
commonPrefix String
t1 String
t2
      commonPrefix String
_ String
_ = String
""
      overallCommonPrefix :: String
overallCommonPrefix =
        (String -> String -> String) -> String -> [String] -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl String -> String -> String
commonPrefix (Completion -> String
Line.replacement Completion
h) (Completion -> String
Line.replacement (Completion -> String) -> [Completion] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Completion]
t)
   in if Bool -> Bool
not (String
q String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
overallCommonPrefix)
        then [Completion
c {Line.replacement = q} | Completion
c <- [Completion]
cs]
        else [Completion]
cs

sharePathCompletion ::
  (MonadIO m) =>
  AuthenticatedHttpClient ->
  String ->
  m [Completion]
sharePathCompletion :: forall (m :: * -> *).
MonadIO m =>
AuthenticatedHttpClient -> String -> m [Completion]
sharePathCompletion = NESet CompletionType
-> AuthenticatedHttpClient -> String -> m [Completion]
forall (m :: * -> *).
MonadIO m =>
NESet CompletionType
-> AuthenticatedHttpClient -> String -> m [Completion]
shareCompletion (CompletionType -> NESet CompletionType
forall a. a -> NESet a
NESet.singleton CompletionType
NamespaceCompletion)

shareCompletion ::
  (MonadIO m) =>
  NESet CompletionType ->
  AuthenticatedHttpClient ->
  String ->
  m [Completion]
shareCompletion :: forall (m :: * -> *).
MonadIO m =>
NESet CompletionType
-> AuthenticatedHttpClient -> String -> m [Completion]
shareCompletion NESet CompletionType
completionTypes AuthenticatedHttpClient
authHTTPClient String
str =
  [Completion] -> Maybe [Completion] -> [Completion]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Completion] -> [Completion])
-> m (Maybe [Completion]) -> m [Completion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT m [Completion] -> m (Maybe [Completion])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    case Path -> [NameSegment]
Path.toList (Path -> [NameSegment])
-> Either Text Path -> Either Text [NameSegment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either Text Path
Path.parsePath String
str of
      Left Text
_err -> MaybeT m [Completion]
forall a. MaybeT m a
forall (f :: * -> *) a. Alternative f => f a
empty
      Right [] -> MaybeT m [Completion]
forall a. MaybeT m a
forall (f :: * -> *) a. Alternative f => f a
empty
      Right [NameSegment
userPrefix] -> do
        [Text]
userHandles <- AuthenticatedHttpClient -> Text -> MaybeT m [Text]
forall (m :: * -> *).
MonadIO m =>
AuthenticatedHttpClient -> Text -> m [Text]
searchUsers AuthenticatedHttpClient
authHTTPClient (NameSegment -> Text
NameSegment.toEscapedText NameSegment
userPrefix)
        pure $
          [Text]
userHandles
            [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
userHandle -> NameSegment -> Text
NameSegment.toEscapedText NameSegment
userPrefix Text -> Text -> Bool
`Text.isPrefixOf` Text
userHandle)
            [Text] -> (Text -> Completion) -> [Completion]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Text
handle -> Bool -> String -> String -> Completion
prettyCompletionWithQueryPrefix Bool
False (Text -> String
Text.unpack (NameSegment -> Text
NameSegment.toEscapedText NameSegment
userPrefix)) (Text -> String
Text.unpack Text
handle)
      Right (NameSegment
userHandle : [NameSegment]
path0) -> do
        let (Path
path, Text
pathSuffix) =
              case [NameSegment] -> Maybe ([NameSegment], NameSegment)
forall s a. Snoc s s a a => s -> Maybe (s, a)
unsnoc [NameSegment]
path0 of
                Just ([NameSegment]
path, NameSegment
pathSuffix) -> ([NameSegment] -> Path
Path.fromList [NameSegment]
path, NameSegment -> Text
NameSegment.toEscapedText NameSegment
pathSuffix)
                Maybe ([NameSegment], NameSegment)
Nothing -> (Path
Path.empty, Text
"")
        NamespaceListing {[NamespaceObject]
namespaceListingChildren :: [NamespaceObject]
$sel:namespaceListingChildren:NamespaceListing :: NamespaceListing -> [NamespaceObject]
namespaceListingChildren} <- m (Maybe NamespaceListing) -> MaybeT m NamespaceListing
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe NamespaceListing) -> MaybeT m NamespaceListing)
-> m (Maybe NamespaceListing) -> MaybeT m NamespaceListing
forall a b. (a -> b) -> a -> b
$ AuthenticatedHttpClient
-> Text -> Path -> m (Maybe NamespaceListing)
forall (m :: * -> *).
MonadIO m =>
AuthenticatedHttpClient
-> Text -> Path -> m (Maybe NamespaceListing)
fetchShareNamespaceInfo AuthenticatedHttpClient
authHTTPClient (NameSegment -> Text
NameSegment.toEscapedText NameSegment
userHandle) Path
path
        [NamespaceObject]
namespaceListingChildren
          [NamespaceObject]
-> ([NamespaceObject] -> [(CompletionType, Text)])
-> [(CompletionType, Text)]
forall a b. a -> (a -> b) -> b
& (NamespaceObject -> (CompletionType, Text))
-> [NamespaceObject] -> [(CompletionType, Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ( \case
                Server.Subnamespace NamedNamespace
nn ->
                  let name :: Text
name = NamedNamespace -> Text
Server.namespaceName NamedNamespace
nn
                   in (CompletionType
NamespaceCompletion, Text
name)
                Server.TermObject NamedTerm
nt ->
                  let name :: Text
name = (Name -> Text) -> HashQualified Name -> Text
forall n. (n -> Text) -> HashQualified n -> Text
HQ'.toTextWith Name -> Text
Name.toText (HashQualified Name -> Text) -> HashQualified Name -> Text
forall a b. (a -> b) -> a -> b
$ NamedTerm -> HashQualified Name
Server.termName NamedTerm
nt
                   in (CompletionType
NamespaceCompletion, Text
name)
                Server.TypeObject NamedType
nt ->
                  let name :: Text
name = (Name -> Text) -> HashQualified Name -> Text
forall n. (n -> Text) -> HashQualified n -> Text
HQ'.toTextWith Name -> Text
Name.toText (HashQualified Name -> Text) -> HashQualified Name -> Text
forall a b. (a -> b) -> a -> b
$ NamedType -> HashQualified Name
Server.typeName NamedType
nt
                   in (CompletionType
TermCompletion, Text
name)
                Server.PatchObject NamedPatch
np ->
                  let name :: Text
name = NamedPatch -> Text
Server.patchName NamedPatch
np
                   in (CompletionType
NamespaceCompletion, Text
name)
            )
          [(CompletionType, Text)]
-> ([(CompletionType, Text)] -> [(CompletionType, Text)])
-> [(CompletionType, Text)]
forall a b. a -> (a -> b) -> b
& ((CompletionType, Text) -> Bool)
-> [(CompletionType, Text)] -> [(CompletionType, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(CompletionType
typ, Text
name) -> CompletionType
typ CompletionType -> NESet CompletionType -> Bool
forall a. Ord a => a -> NESet a -> Bool
`NESet.member` NESet CompletionType
completionTypes Bool -> Bool -> Bool
&& Text
pathSuffix Text -> Text -> Bool
`Text.isPrefixOf` Text
name)
          [(CompletionType, Text)]
-> ([(CompletionType, Text)] -> [Completion]) -> [Completion]
forall a b. a -> (a -> b) -> b
& ((CompletionType, Text) -> Completion)
-> [(CompletionType, Text)] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ( \(CompletionType
_, Text
name) ->
                let queryPath :: [NameSegment]
queryPath = NameSegment
userHandle NameSegment -> [NameSegment] -> [NameSegment]
forall a. a -> [a] -> [a]
: Path -> [NameSegment]
Path.toList Path
path
                    result :: String
result =
                      ([NameSegment]
queryPath [NameSegment] -> [NameSegment] -> [NameSegment]
forall a. [a] -> [a] -> [a]
++ [Text -> NameSegment
NameSegment.unsafeParseText Text
name])
                        [NameSegment]
-> ([NameSegment] -> NonEmpty NameSegment) -> NonEmpty NameSegment
forall a b. a -> (a -> b) -> b
& [NameSegment] -> NonEmpty NameSegment
forall a. HasCallStack => [a] -> NonEmpty a
List.NonEmpty.fromList
                        NonEmpty NameSegment -> (NonEmpty NameSegment -> Name) -> Name
forall a b. a -> (a -> b) -> b
& NonEmpty NameSegment -> Name
Name.fromSegments
                        Name -> (Name -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Name -> Text
Name.toText
                        Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
Text.unpack
                 in Bool -> String -> String -> Completion
prettyCompletionWithQueryPrefix Bool
False String
str String
result
            )
          [Completion]
-> ([Completion] -> MaybeT m [Completion]) -> MaybeT m [Completion]
forall a b. a -> (a -> b) -> b
& [Completion] -> MaybeT m [Completion]
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

fetchShareNamespaceInfo :: (MonadIO m) => AuthenticatedHttpClient -> Text -> Path.Path -> m (Maybe NamespaceListing)
fetchShareNamespaceInfo :: forall (m :: * -> *).
MonadIO m =>
AuthenticatedHttpClient
-> Text -> Path -> m (Maybe NamespaceListing)
fetchShareNamespaceInfo (AuthenticatedHttpClient Manager
httpManager) Text
userHandle Path
path = MaybeT m NamespaceListing -> m (Maybe NamespaceListing)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
  let uri :: URI
uri =
        (CodeserverURI -> URI
Share.codeserverToURI CodeserverURI
Codeserver.defaultCodeserver)
          { URI.uriPath = Text.unpack $ "/codebases/" <> userHandle <> "/browse",
            URI.uriQuery =
              if not . null $ Path.toList path
                then Text.unpack $ "?relativeTo=" <> tShow path
                else ""
          }
  Request
req <- m (Maybe Request) -> MaybeT m Request
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Request) -> MaybeT m Request)
-> m (Maybe Request) -> MaybeT m Request
forall a b. (a -> b) -> a -> b
$ Maybe Request -> m (Maybe Request)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI -> Maybe Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
HTTP.requestFromURI URI
uri)
  Either SomeException (Response ByteString)
fullResp <- IO (Either SomeException (Response ByteString))
-> MaybeT m (Either SomeException (Response ByteString))
forall a. IO a -> MaybeT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException (Response ByteString))
 -> MaybeT m (Either SomeException (Response ByteString)))
-> IO (Either SomeException (Response ByteString))
-> MaybeT m (Either SomeException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Response ByteString)
-> IO (Either SomeException (Response ByteString))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnliftIO.tryAny (IO (Response ByteString)
 -> IO (Either SomeException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either SomeException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
httpManager
  Response ByteString
resp <- (SomeException -> MaybeT m (Response ByteString))
-> (Response ByteString -> MaybeT m (Response ByteString))
-> Either SomeException (Response ByteString)
-> MaybeT m (Response ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MaybeT m (Response ByteString)
-> SomeException -> MaybeT m (Response ByteString)
forall a b. a -> b -> a
const MaybeT m (Response ByteString)
forall a. MaybeT m a
forall (f :: * -> *) a. Alternative f => f a
empty) Response ByteString -> MaybeT m (Response ByteString)
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (Response ByteString)
 -> MaybeT m (Response ByteString))
-> Either SomeException (Response ByteString)
-> MaybeT m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Either SomeException (Response ByteString)
fullResp
  m (Maybe NamespaceListing) -> MaybeT m NamespaceListing
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe NamespaceListing) -> MaybeT m NamespaceListing)
-> (ByteString -> m (Maybe NamespaceListing))
-> ByteString
-> MaybeT m NamespaceListing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe NamespaceListing -> m (Maybe NamespaceListing)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NamespaceListing -> m (Maybe NamespaceListing))
-> (ByteString -> Maybe NamespaceListing)
-> ByteString
-> m (Maybe NamespaceListing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode @Server.NamespaceListing (ByteString -> MaybeT m NamespaceListing)
-> ByteString -> MaybeT m NamespaceListing
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
resp

searchUsers :: (MonadIO m) => AuthenticatedHttpClient -> Text -> m [Text]
searchUsers :: forall (m :: * -> *).
MonadIO m =>
AuthenticatedHttpClient -> Text -> m [Text]
searchUsers AuthenticatedHttpClient
_ Text
"" = [Text] -> m [Text]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
searchUsers (AuthenticatedHttpClient Manager
httpManager) Text
userHandlePrefix =
  [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> m (Maybe [Text]) -> m [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT m [Text] -> m (Maybe [Text])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
    let uri :: URI
uri =
          (CodeserverURI -> URI
Share.codeserverToURI CodeserverURI
Codeserver.defaultCodeserver)
            { URI.uriPath = "/search",
              URI.uriQuery = Text.unpack $ "?query=" <> userHandlePrefix
            }
    Request
req <- m (Maybe Request) -> MaybeT m Request
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Request) -> MaybeT m Request)
-> m (Maybe Request) -> MaybeT m Request
forall a b. (a -> b) -> a -> b
$ Maybe Request -> m (Maybe Request)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI -> Maybe Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
HTTP.requestFromURI URI
uri)
    Either SomeException (Response ByteString)
fullResp <- IO (Either SomeException (Response ByteString))
-> MaybeT m (Either SomeException (Response ByteString))
forall a. IO a -> MaybeT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException (Response ByteString))
 -> MaybeT m (Either SomeException (Response ByteString)))
-> IO (Either SomeException (Response ByteString))
-> MaybeT m (Either SomeException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Response ByteString)
-> IO (Either SomeException (Response ByteString))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnliftIO.tryAny (IO (Response ByteString)
 -> IO (Either SomeException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either SomeException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
httpManager
    Response ByteString
resp <- (SomeException -> MaybeT m (Response ByteString))
-> (Response ByteString -> MaybeT m (Response ByteString))
-> Either SomeException (Response ByteString)
-> MaybeT m (Response ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MaybeT m (Response ByteString)
-> SomeException -> MaybeT m (Response ByteString)
forall a b. a -> b -> a
const MaybeT m (Response ByteString)
forall a. MaybeT m a
forall (f :: * -> *) a. Alternative f => f a
empty) Response ByteString -> MaybeT m (Response ByteString)
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (Response ByteString)
 -> MaybeT m (Response ByteString))
-> Either SomeException (Response ByteString)
-> MaybeT m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Either SomeException (Response ByteString)
fullResp
    [SearchResult]
results <- (m (Maybe [SearchResult]) -> MaybeT m [SearchResult]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe [SearchResult]) -> MaybeT m [SearchResult])
-> (ByteString -> m (Maybe [SearchResult]))
-> ByteString
-> MaybeT m [SearchResult]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [SearchResult] -> m (Maybe [SearchResult])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [SearchResult] -> m (Maybe [SearchResult]))
-> (ByteString -> Maybe [SearchResult])
-> ByteString
-> m (Maybe [SearchResult])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode @[SearchResult] (ByteString -> MaybeT m [SearchResult])
-> ByteString -> MaybeT m [SearchResult]
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
resp)
    pure $
      [SearchResult]
results
        [SearchResult]
-> ([SearchResult] -> [SearchResult]) -> [SearchResult]
forall a b. a -> (a -> b) -> b
& (SearchResult -> Bool) -> [SearchResult] -> [SearchResult]
forall a. (a -> Bool) -> [a] -> [a]
filter (\SearchResult {Text
tag :: Text
$sel:tag:SearchResult :: SearchResult -> Text
tag} -> Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"User")
        [SearchResult] -> ([SearchResult] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (SearchResult -> Text) -> [SearchResult] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SearchResult -> Text
handle

data SearchResult = SearchResult
  { SearchResult -> Text
handle :: Text,
    SearchResult -> Text
tag :: Text
  }
  deriving (Int -> SearchResult -> String -> String
[SearchResult] -> String -> String
SearchResult -> String
(Int -> SearchResult -> String -> String)
-> (SearchResult -> String)
-> ([SearchResult] -> String -> String)
-> Show SearchResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SearchResult -> String -> String
showsPrec :: Int -> SearchResult -> String -> String
$cshow :: SearchResult -> String
show :: SearchResult -> String
$cshowList :: [SearchResult] -> String -> String
showList :: [SearchResult] -> String -> String
Show)

instance Aeson.FromJSON SearchResult where
  parseJSON :: Value -> Parser SearchResult
parseJSON = String
-> (Object -> Parser SearchResult) -> Value -> Parser SearchResult
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"SearchResult" \Object
obj -> do
    Text
handle <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"handle"
    Text
tag <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"tag"
    pure $ SearchResult {Text
$sel:tag:SearchResult :: Text
$sel:handle:SearchResult :: Text
handle :: Text
tag :: Text
..}