{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Unison.Server.Local.Endpoints.FuzzyFind where

import Data.Aeson
import Data.OpenApi (ToSchema)
import Servant
  ( QueryParam,
    (:>),
  )
import Servant.Docs
  ( DocQueryParam (..),
    ParamKind (Normal),
    ToParam (..),
    ToSample (..),
    noSamples,
  )
import Servant.OpenApi ()
import Text.FuzzyFind qualified as FZF
import U.Codebase.HashTags (CausalHash)
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Editor.DisplayObject
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ShortCausalHash qualified as SCH
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyPrintEnvDecl qualified as PPE
import Unison.Server.Backend qualified as Backend
import Unison.Server.Syntax (SyntaxText)
import Unison.Server.Types
  ( APIGet,
    ExactName (..),
    HashQualifiedName,
    NamedTerm,
    NamedType,
    UnisonName,
    mayDefaultWidth,
  )
import Unison.Symbol (Symbol)
import Unison.Syntax.Name qualified as Name
import Unison.Util.Pretty (Width)

type FuzzyFindAPI =
  "find"
    :> QueryParam "relativeTo" Path.Path
    :> QueryParam "limit" Int
    :> QueryParam "renderWidth" Width
    :> QueryParam "query" String
    :> APIGet [(FZF.Alignment, FoundResult)]

instance ToSample FZF.Alignment where
  toSamples :: Proxy Alignment -> [(Text, Alignment)]
toSamples Proxy Alignment
_ = [(Text, Alignment)]
forall a. [(Text, a)]
noSamples

instance ToParam (QueryParam "limit" Int) where
  toParam :: Proxy (QueryParam "limit" Int) -> DocQueryParam
toParam Proxy (QueryParam "limit" Int)
_ =
    String -> [String] -> String -> ParamKind -> DocQueryParam
DocQueryParam
      String
"limit"
      [String
"1", String
"10", String
"20"]
      String
"The maximum number of results to return. Defaults to 10."
      ParamKind
Normal

instance ToParam (QueryParam "query" String) where
  toParam :: Proxy (QueryParam "query" String) -> DocQueryParam
toParam Proxy (QueryParam "query" String)
_ =
    String -> [String] -> String -> ParamKind -> DocQueryParam
DocQueryParam
      String
"query"
      [String
"foo", String
"ff", String
"td nr"]
      String
"Space-separated subsequences to find in the name of a type or term."
      ParamKind
Normal

instance ToJSON FZF.Alignment where
  toJSON :: Alignment -> Value
toJSON (FZF.Alignment {Int
score :: Int
score :: Alignment -> Int
score, Result
result :: Result
result :: Alignment -> Result
result}) =
    [Pair] -> Value
object [Key
"score" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Int
score, Key
"result" Key -> Result -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Result
result]

instance ToJSON FZF.Result where
  toJSON :: Result -> Value
toJSON (FZF.Result {Seq ResultSegment
segments :: Seq ResultSegment
segments :: Result -> Seq ResultSegment
segments}) = [Pair] -> Value
object [Key
"segments" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Seq ResultSegment -> Value
forall a. ToJSON a => a -> Value
toJSON Seq ResultSegment
segments]

instance ToJSON FZF.ResultSegment where
  toJSON :: ResultSegment -> Value
toJSON = \case
    FZF.Gap String
s -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"Gap", Key
"contents" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String
s]
    FZF.Match String
s -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"Match", Key
"contents" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String
s]

deriving instance ToSchema FZF.Alignment

deriving anyclass instance ToSchema FZF.Result

deriving instance ToSchema FZF.ResultSegment

data FoundTerm = FoundTerm
  { FoundTerm -> Text
bestFoundTermName :: HashQualifiedName,
    FoundTerm -> NamedTerm
namedTerm :: NamedTerm
  }
  deriving ((forall x. FoundTerm -> Rep FoundTerm x)
-> (forall x. Rep FoundTerm x -> FoundTerm) -> Generic FoundTerm
forall x. Rep FoundTerm x -> FoundTerm
forall x. FoundTerm -> Rep FoundTerm x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FoundTerm -> Rep FoundTerm x
from :: forall x. FoundTerm -> Rep FoundTerm x
$cto :: forall x. Rep FoundTerm x -> FoundTerm
to :: forall x. Rep FoundTerm x -> FoundTerm
Generic, Int -> FoundTerm -> ShowS
[FoundTerm] -> ShowS
FoundTerm -> String
(Int -> FoundTerm -> ShowS)
-> (FoundTerm -> String)
-> ([FoundTerm] -> ShowS)
-> Show FoundTerm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FoundTerm -> ShowS
showsPrec :: Int -> FoundTerm -> ShowS
$cshow :: FoundTerm -> String
show :: FoundTerm -> String
$cshowList :: [FoundTerm] -> ShowS
showList :: [FoundTerm] -> ShowS
Show)

data FoundType = FoundType
  { FoundType -> Text
bestFoundTypeName :: HashQualifiedName,
    FoundType -> DisplayObject SyntaxText SyntaxText
typeDef :: DisplayObject SyntaxText SyntaxText,
    FoundType -> NamedType
namedType :: NamedType
  }
  deriving ((forall x. FoundType -> Rep FoundType x)
-> (forall x. Rep FoundType x -> FoundType) -> Generic FoundType
forall x. Rep FoundType x -> FoundType
forall x. FoundType -> Rep FoundType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FoundType -> Rep FoundType x
from :: forall x. FoundType -> Rep FoundType x
$cto :: forall x. Rep FoundType x -> FoundType
to :: forall x. Rep FoundType x -> FoundType
Generic, Int -> FoundType -> ShowS
[FoundType] -> ShowS
FoundType -> String
(Int -> FoundType -> ShowS)
-> (FoundType -> String)
-> ([FoundType] -> ShowS)
-> Show FoundType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FoundType -> ShowS
showsPrec :: Int -> FoundType -> ShowS
$cshow :: FoundType -> String
show :: FoundType -> String
$cshowList :: [FoundType] -> ShowS
showList :: [FoundType] -> ShowS
Show)

instance ToJSON FoundType where
  toJSON :: FoundType -> Value
toJSON (FoundType {Text
$sel:bestFoundTypeName:FoundType :: FoundType -> Text
bestFoundTypeName :: Text
bestFoundTypeName, DisplayObject SyntaxText SyntaxText
$sel:typeDef:FoundType :: FoundType -> DisplayObject SyntaxText SyntaxText
typeDef :: DisplayObject SyntaxText SyntaxText
typeDef, NamedType
$sel:namedType:FoundType :: FoundType -> NamedType
namedType :: NamedType
namedType}) =
    [Pair] -> Value
object
      [ Key
"bestFoundTypeName" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
bestFoundTypeName,
        Key
"typeDef" Key -> DisplayObject SyntaxText SyntaxText -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= DisplayObject SyntaxText SyntaxText
typeDef,
        Key
"namedType" Key -> NamedType -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= NamedType
namedType
      ]

deriving instance ToSchema FoundType

instance ToJSON FoundTerm where
  toJSON :: FoundTerm -> Value
toJSON (FoundTerm {Text
$sel:bestFoundTermName:FoundTerm :: FoundTerm -> Text
bestFoundTermName :: Text
bestFoundTermName, NamedTerm
$sel:namedTerm:FoundTerm :: FoundTerm -> NamedTerm
namedTerm :: NamedTerm
namedTerm}) =
    [Pair] -> Value
object
      [ Key
"bestFoundTermName" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
bestFoundTermName,
        Key
"namedTerm" Key -> NamedTerm -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= NamedTerm
namedTerm
      ]

deriving instance ToSchema FoundTerm

data FoundResult
  = FoundTermResult FoundTerm
  | FoundTypeResult FoundType
  deriving ((forall x. FoundResult -> Rep FoundResult x)
-> (forall x. Rep FoundResult x -> FoundResult)
-> Generic FoundResult
forall x. Rep FoundResult x -> FoundResult
forall x. FoundResult -> Rep FoundResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FoundResult -> Rep FoundResult x
from :: forall x. FoundResult -> Rep FoundResult x
$cto :: forall x. Rep FoundResult x -> FoundResult
to :: forall x. Rep FoundResult x -> FoundResult
Generic, Int -> FoundResult -> ShowS
[FoundResult] -> ShowS
FoundResult -> String
(Int -> FoundResult -> ShowS)
-> (FoundResult -> String)
-> ([FoundResult] -> ShowS)
-> Show FoundResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FoundResult -> ShowS
showsPrec :: Int -> FoundResult -> ShowS
$cshow :: FoundResult -> String
show :: FoundResult -> String
$cshowList :: [FoundResult] -> ShowS
showList :: [FoundResult] -> ShowS
Show)

instance ToJSON FoundResult where
  toJSON :: FoundResult -> Value
toJSON = \case
    FoundTermResult FoundTerm
ft -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"FoundTermResult", Key
"contents" Key -> FoundTerm -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= FoundTerm
ft]
    FoundTypeResult FoundType
ft -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"FoundTypeResult", Key
"contents" Key -> FoundType -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= FoundType
ft]

deriving instance ToSchema FoundResult

instance ToSample FoundResult where
  toSamples :: Proxy FoundResult -> [(Text, FoundResult)]
toSamples Proxy FoundResult
_ = [(Text, FoundResult)]
forall a. [(Text, a)]
noSamples

serveFuzzyFind ::
  forall m.
  (MonadIO m) =>
  Codebase m Symbol Ann ->
  Either SCH.ShortCausalHash CausalHash ->
  Maybe Path.Path ->
  Maybe Int ->
  Maybe Width ->
  Maybe String ->
  Backend.Backend m [(FZF.Alignment, FoundResult)]
serveFuzzyFind :: forall (m :: * -> *).
MonadIO m =>
Codebase m Symbol Ann
-> Either ShortCausalHash CausalHash
-> Maybe Path
-> Maybe Int
-> Maybe Width
-> Maybe String
-> Backend m [(Alignment, FoundResult)]
serveFuzzyFind Codebase m Symbol Ann
codebase Either ShortCausalHash CausalHash
root Maybe Path
relativeTo Maybe Int
limit Maybe Width
typeWidth Maybe String
query = do
  let path :: Path
path = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
Path.empty Maybe Path
relativeTo
  CausalBranch Transaction
rootCausal <-
    (forall x. Transaction x -> m x)
-> Backend Transaction (CausalBranch Transaction)
-> Backend m (CausalBranch Transaction)
forall (m :: * -> *) (n :: * -> *) a.
(forall x. m x -> n x) -> Backend m a -> Backend n a
Backend.hoistBackend (Codebase m Symbol Ann -> Transaction x -> m x
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase m Symbol Ann
codebase) do
      Either ShortCausalHash CausalHash
-> Backend Transaction (CausalBranch Transaction)
Backend.normaliseRootCausalHash Either ShortCausalHash CausalHash
root
  (Names
localNamesOnly, PrettyPrintEnvDecl
ppe) <- Codebase m Symbol Ann
-> CausalBranch Transaction
-> Path
-> Backend m (Names, PrettyPrintEnvDecl)
forall (m :: * -> *) (n :: * -> *) v a.
MonadIO m =>
Codebase m v a
-> CausalBranch n -> Path -> Backend m (Names, PrettyPrintEnvDecl)
Backend.namesAtPathFromRootBranchHash Codebase m Symbol Ann
codebase CausalBranch Transaction
rootCausal Path
path
  let alignments ::
        ( [ ( FZF.Alignment,
              UnisonName,
              [Backend.FoundRef]
            )
          ]
        )
      alignments :: [(Alignment, Text, [FoundRef])]
alignments =
        Int
-> [(Alignment, Text, [FoundRef])]
-> [(Alignment, Text, [FoundRef])]
forall a. Int -> [a] -> [a]
take (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
10 Maybe Int
limit) ([(Alignment, Text, [FoundRef])]
 -> [(Alignment, Text, [FoundRef])])
-> [(Alignment, Text, [FoundRef])]
-> [(Alignment, Text, [FoundRef])]
forall a b. (a -> b) -> a -> b
$ Names -> String -> [(Alignment, Text, [FoundRef])]
Backend.fuzzyFind Names
localNamesOnly (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
query)
  m [(Alignment, FoundResult)]
-> Backend m [(Alignment, FoundResult)]
forall (m :: * -> *) a. Monad m => m a -> Backend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([[(Alignment, FoundResult)]] -> [(Alignment, FoundResult)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[(Alignment, FoundResult)]] -> [(Alignment, FoundResult)])
-> m [[(Alignment, FoundResult)]] -> m [(Alignment, FoundResult)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Alignment, Text, [FoundRef]) -> m [(Alignment, FoundResult)])
-> [(Alignment, Text, [FoundRef])]
-> m [[(Alignment, FoundResult)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (PrettyPrintEnv
-> (Alignment, Text, [FoundRef]) -> m [(Alignment, FoundResult)]
loadEntry (PrettyPrintEnvDecl -> PrettyPrintEnv
PPE.suffixifiedPPE PrettyPrintEnvDecl
ppe)) [(Alignment, Text, [FoundRef])]
alignments)
  where
    loadEntry :: PrettyPrintEnv
-> (Alignment, Text, [FoundRef]) -> m [(Alignment, FoundResult)]
loadEntry PrettyPrintEnv
ppe (Alignment
a, Text
n, [FoundRef]
refs) = do
      [FoundRef]
-> (FoundRef -> m (Alignment, FoundResult))
-> m [(Alignment, FoundResult)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [FoundRef]
refs \case
        Backend.FoundTermRef Referent
r ->
          ( \TermEntry Symbol Ann
te ->
              ( Alignment
a,
                FoundTerm -> FoundResult
FoundTermResult
                  (FoundTerm -> FoundResult)
-> (NamedTerm -> FoundTerm) -> NamedTerm -> FoundResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NamedTerm -> FoundTerm
FoundTerm
                    (forall v. Var v => PrettyPrintEnv -> Width -> Referent -> Text
Backend.bestNameForTerm @Symbol PrettyPrintEnv
ppe (Maybe Width -> Width
mayDefaultWidth Maybe Width
typeWidth) Referent
r)
                  (NamedTerm -> FoundResult) -> NamedTerm -> FoundResult
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Maybe Width -> TermEntry Symbol Ann -> NamedTerm
forall v a.
Var v =>
PrettyPrintEnv -> Maybe Width -> TermEntry v a -> NamedTerm
Backend.termEntryToNamedTerm PrettyPrintEnv
ppe Maybe Width
typeWidth TermEntry Symbol Ann
te
              )
          )
            (TermEntry Symbol Ann -> (Alignment, FoundResult))
-> m (TermEntry Symbol Ann) -> m (Alignment, FoundResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codebase m Symbol Ann
-> ExactName Name Referent -> m (TermEntry Symbol Ann)
forall (m :: * -> *).
MonadIO m =>
Codebase m Symbol Ann
-> ExactName Name Referent -> m (TermEntry Symbol Ann)
Backend.termListEntry Codebase m Symbol Ann
codebase (Name -> Referent -> ExactName Name Referent
forall name ref. name -> ref -> ExactName name ref
ExactName (HasCallStack => Text -> Name
Text -> Name
Name.unsafeParseText Text
n) (Referent -> Referent
Cv.referent1to2 Referent
r))
        Backend.FoundTypeRef Reference
r ->
          Codebase m Symbol Ann
-> Transaction (Alignment, FoundResult)
-> m (Alignment, FoundResult)
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase m Symbol Ann
codebase do
            TypeEntry
te <- Codebase m Symbol Ann
-> ExactName Name Reference -> Transaction TypeEntry
forall v (m :: * -> *).
Var v =>
Codebase m v Ann
-> ExactName Name Reference -> Transaction TypeEntry
Backend.typeListEntry Codebase m Symbol Ann
codebase (Name -> Reference -> ExactName Name Reference
forall name ref. name -> ref -> ExactName name ref
ExactName (HasCallStack => Text -> Name
Text -> Name
Name.unsafeParseText Text
n) Reference
r)
            let namedType :: NamedType
namedType = TypeEntry -> NamedType
Backend.typeEntryToNamedType TypeEntry
te
            let typeName :: Text
typeName = forall v. Var v => PrettyPrintEnv -> Width -> Reference -> Text
Backend.bestNameForType @Symbol PrettyPrintEnv
ppe (Maybe Width -> Width
mayDefaultWidth Maybe Width
typeWidth) Reference
r
            DisplayObject SyntaxText SyntaxText
typeHeader <- Codebase m Symbol Ann
-> PrettyPrintEnv
-> Reference
-> Transaction (DisplayObject SyntaxText SyntaxText)
forall v (m :: * -> *).
Var v =>
Codebase m v Ann
-> PrettyPrintEnv
-> Reference
-> Transaction (DisplayObject SyntaxText SyntaxText)
Backend.typeDeclHeader Codebase m Symbol Ann
codebase PrettyPrintEnv
ppe Reference
r
            let ft :: FoundType
ft = Text
-> DisplayObject SyntaxText SyntaxText -> NamedType -> FoundType
FoundType Text
typeName DisplayObject SyntaxText SyntaxText
typeHeader NamedType
namedType
            (Alignment, FoundResult) -> Transaction (Alignment, FoundResult)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Alignment
a, FoundType -> FoundResult
FoundTypeResult FoundType
ft)