mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-23 08:18:04 +03:00
Merge branch 'topic/codebaseserver-morenames' of github.com:unisonweb/unison into topic/codebaseserver-openapi
This commit is contained in:
commit
5da295feb0
@ -1156,10 +1156,10 @@ loop = do
|
||||
entryToHQString :: ShallowListEntry v Ann -> String
|
||||
entryToHQString e =
|
||||
fixup $ case e of
|
||||
ShallowTypeEntry _ hq -> HQ'.toString hq
|
||||
ShallowTermEntry _ hq _ -> HQ'.toString hq
|
||||
ShallowBranchEntry ns _ -> NameSegment.toString ns
|
||||
ShallowPatchEntry ns -> NameSegment.toString ns
|
||||
ShallowTypeEntry _ hq -> HQ'.toString hq
|
||||
ShallowTermEntry _ hq _ -> HQ'.toString hq
|
||||
ShallowBranchEntry ns _ _ -> NameSegment.toString ns
|
||||
ShallowPatchEntry ns -> NameSegment.toString ns
|
||||
where
|
||||
fixup s = case pathArgStr of
|
||||
"" -> s
|
||||
@ -2073,6 +2073,8 @@ handleBackendError = \case
|
||||
Backend.CouldntExpandBranchHash sbh -> respond $ NoBranchWithHash sbh
|
||||
Backend.AmbiguousBranchHash h hashes ->
|
||||
respond $ BranchHashAmbiguous h hashes
|
||||
Backend.MissingSignatureForTerm r ->
|
||||
respond $ TermMissingType r
|
||||
|
||||
respond :: Output v -> Action m i v ()
|
||||
respond output = eval $ Notify output
|
||||
|
@ -181,6 +181,7 @@ data Output v
|
||||
(Map Reference (DisplayObject (Decl v Ann)))
|
||||
(Map Reference (DisplayObject (Term v Ann)))
|
||||
| MetadataMissingType PPE.PrettyPrintEnv Referent
|
||||
| TermMissingType Reference
|
||||
| MetadataAmbiguous (HQ.HashQualified Name) PPE.PrettyPrintEnv [Referent]
|
||||
-- todo: tell the user to run `todo` on the same patch they just used
|
||||
| NothingToPatch PatchPath Path'
|
||||
@ -319,6 +320,7 @@ isFailure o = case o of
|
||||
NoOp -> False
|
||||
ListDependencies{} -> False
|
||||
ListDependents{} -> False
|
||||
TermMissingType{} -> True
|
||||
DumpUnisonFileHashes _ x y z -> x == mempty && y == mempty && z == mempty
|
||||
|
||||
isNumberedFailure :: NumberedOutput v -> Bool
|
||||
|
@ -364,6 +364,15 @@ notifyUser dir o = case o of
|
||||
else putPretty' " 🚫 "
|
||||
pure mempty
|
||||
|
||||
TermMissingType ref ->
|
||||
pure . P.fatalCallout . P.lines $ [
|
||||
P.wrap $ "The type signature for reference "
|
||||
<> P.blue (P.text (Reference.toText ref))
|
||||
<> " is missing from the codebase! This means something might be wrong "
|
||||
<> " with the codebase, or the term was deleted just now "
|
||||
<> " by someone else. Trying your command again might fix it."
|
||||
]
|
||||
|
||||
MetadataMissingType ppe ref -> pure . P.fatalCallout . P.lines $ [
|
||||
P.wrap $ "The metadata value " <> P.red (prettyTermName ppe ref)
|
||||
<> "is missing a type signature in the codebase.",
|
||||
@ -529,10 +538,10 @@ notifyUser dir o = case o of
|
||||
ShallowTypeEntry r hq ->
|
||||
(P.syntaxToColor . prettyHashQualified' . fmap Name.fromSegment $ hq
|
||||
,isBuiltin r)
|
||||
ShallowBranchEntry ns count ->
|
||||
ShallowBranchEntry ns _ count ->
|
||||
((P.syntaxToColor . prettyName . Name.fromSegment) ns <> "/"
|
||||
,case count of
|
||||
1 -> P.lit ("(1 definition)")
|
||||
1 -> P.lit "(1 definition)"
|
||||
_n -> P.lit "(" <> P.shown count <> P.lit " definitions)")
|
||||
ShallowPatchEntry ns ->
|
||||
((P.syntaxToColor . prettyName . Name.fromSegment) ns
|
||||
|
@ -48,33 +48,38 @@ import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
import Unison.Type (Type)
|
||||
import qualified Unison.Type as Type
|
||||
import qualified Unison.Util.Relation as R
|
||||
import qualified Unison.Util.Star3 as Star3
|
||||
import Unison.Var (Var)
|
||||
import Unison.Server.Types
|
||||
import Unison.Server.QueryResult
|
||||
import Unison.Util.SyntaxText (SyntaxText)
|
||||
import Unison.Util.SyntaxText (SyntaxText, SyntaxText')
|
||||
import qualified Unison.Util.SyntaxText as SyntaxText
|
||||
import Unison.Util.List (uniqueBy)
|
||||
import Unison.ShortHash
|
||||
import qualified Unison.Codebase.ShortBranchHash as SBH
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
|
||||
import qualified Unison.TermPrinter as TermPrinter
|
||||
import qualified Unison.TypePrinter as TypePrinter
|
||||
import qualified Unison.DeclPrinter as DeclPrinter
|
||||
import Unison.Util.Pretty (Width)
|
||||
import qualified Data.Text as Text
|
||||
|
||||
data ShallowListEntry v a
|
||||
= ShallowTermEntry Referent HQ'.HQSegment (Maybe (Type v a))
|
||||
| ShallowTypeEntry Reference HQ'.HQSegment
|
||||
| ShallowBranchEntry NameSegment Int -- number of child definitions
|
||||
-- The integer here represents the number of children
|
||||
| ShallowBranchEntry NameSegment ShortBranchHash Int
|
||||
| ShallowPatchEntry NameSegment
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
listEntryName :: ShallowListEntry v a -> Text
|
||||
listEntryName = \case
|
||||
ShallowTermEntry _ s _ -> HQ'.toText s
|
||||
ShallowTypeEntry _ s -> HQ'.toText s
|
||||
ShallowBranchEntry n _ -> NameSegment.toText n
|
||||
ShallowPatchEntry n -> NameSegment.toText n
|
||||
ShallowTermEntry _ s _ -> HQ'.toText s
|
||||
ShallowTypeEntry _ s -> HQ'.toText s
|
||||
ShallowBranchEntry n _ _ -> NameSegment.toText n
|
||||
ShallowPatchEntry n -> NameSegment.toText n
|
||||
|
||||
data BackendError
|
||||
= NoSuchNamespace Path.Absolute
|
||||
@ -82,6 +87,7 @@ data BackendError
|
||||
| CouldntExpandBranchHash ShortBranchHash
|
||||
| AmbiguousBranchHash ShortBranchHash (Set ShortBranchHash)
|
||||
| NoBranchForHash Branch.Hash
|
||||
| MissingSignatureForTerm Reference
|
||||
|
||||
type Backend m a = ExceptT BackendError m a
|
||||
|
||||
@ -184,7 +190,9 @@ findShallow codebase path' = do
|
||||
| (r, ns) <- R.toList . Star3.d1 $ Branch._types b0
|
||||
]
|
||||
branchEntries =
|
||||
[ ShallowBranchEntry ns (defnCount b)
|
||||
[ ShallowBranchEntry ns
|
||||
(SBH.fullFromHash $ Branch.headHash b)
|
||||
(defnCount b)
|
||||
| (ns, b) <- Map.toList $ Branch._children b0
|
||||
]
|
||||
patchEntries =
|
||||
@ -394,8 +402,24 @@ expandShortBranchHash codebase hash = do
|
||||
_ ->
|
||||
throwError . AmbiguousBranchHash hash $ Set.map (SBH.fromHash len) hashSet
|
||||
|
||||
prettyType
|
||||
:: Var v
|
||||
=> Width
|
||||
-> PPE.PrettyPrintEnvDecl
|
||||
-> Type v Ann
|
||||
-> SyntaxText' UnisonHash
|
||||
prettyType width ppe =
|
||||
mungeSyntaxText . Pretty.render width . TypePrinter.pretty0
|
||||
(PPE.suffixifiedPPE ppe)
|
||||
mempty
|
||||
(-1)
|
||||
|
||||
mungeSyntaxText :: Functor g => Functor h => g (h Reference) -> g (h Text)
|
||||
mungeSyntaxText = fmap $ fmap Reference.toText
|
||||
|
||||
prettyDefinitionsBySuffixes
|
||||
:: Monad m
|
||||
:: forall v m
|
||||
. Monad m
|
||||
=> Var v
|
||||
=> Maybe Path
|
||||
-> Maybe Branch.Hash
|
||||
@ -413,18 +437,65 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth codebase query = do
|
||||
-- We might like to make sure that the user search terms get used as
|
||||
-- the names in the pretty-printer, but the current implementation
|
||||
-- doesn't.
|
||||
let printNames =
|
||||
getCurrentPrettyNames (fromMaybe Path.empty relativeTo) branch
|
||||
ppe = PPE.fromNamesDecl hqLength printNames
|
||||
width = mayDefault renderWidth
|
||||
renderedDisplayTerms =
|
||||
Map.mapKeys Reference.toShortHash $ termsToSyntax width ppe terms
|
||||
renderedDisplayTypes =
|
||||
Map.mapKeys Reference.toShortHash $ typesToSyntax width ppe types
|
||||
pure $ DefinitionDisplayResults
|
||||
(Map.map (fmap (fmap (fmap Reference.toShortHash))) renderedDisplayTerms)
|
||||
(Map.map (fmap (fmap (fmap Reference.toShortHash))) renderedDisplayTypes)
|
||||
misses
|
||||
let
|
||||
printNames = getCurrentPrettyNames (fromMaybe Path.empty relativeTo) branch
|
||||
parseNames = getCurrentParseNames (fromMaybe Path.empty relativeTo) branch
|
||||
ppe = PPE.fromNamesDecl hqLength printNames
|
||||
width = mayDefault renderWidth
|
||||
termFqns :: Map Reference (Set Text)
|
||||
termFqns = Map.mapWithKey f terms
|
||||
where
|
||||
f k _ =
|
||||
R.lookupRan (Referent.IdRef k)
|
||||
. R.filterDom (\n -> "." `Text.isPrefixOf` n && n /= ".")
|
||||
. R.mapDom Name.toText
|
||||
. Names.terms
|
||||
$ currentNames parseNames
|
||||
typeFqns :: Map Reference (Set Text)
|
||||
typeFqns = Map.mapWithKey f types
|
||||
where
|
||||
f k _ =
|
||||
R.lookupRan k
|
||||
. R.filterDom (\n -> "." `Text.isPrefixOf` n && n /= ".")
|
||||
. R.mapDom Name.toText
|
||||
. Names.types
|
||||
$ currentNames parseNames
|
||||
flatten = Set.toList . fromMaybe Set.empty
|
||||
mkTermDefinition r tm = mk =<< lift (Codebase.getTypeOfTerm codebase r)
|
||||
where
|
||||
mk Nothing = throwError $ MissingSignatureForTerm r
|
||||
mk (Just typeSig) =
|
||||
pure
|
||||
. TermDefinition
|
||||
(flatten $ Map.lookup r termFqns)
|
||||
( Text.pack
|
||||
. Pretty.render width
|
||||
. fmap SyntaxText.toPlain
|
||||
. TermPrinter.pretty0 @v (PPE.suffixifiedPPE ppe)
|
||||
TermPrinter.emptyAc
|
||||
$ Term.ref mempty r
|
||||
)
|
||||
(fmap mungeSyntaxText tm)
|
||||
$ prettyType width ppe typeSig
|
||||
mkTypeDefinition r tp =
|
||||
TypeDefinition
|
||||
(flatten $ Map.lookup r typeFqns)
|
||||
( Text.pack
|
||||
. Pretty.render width
|
||||
. fmap SyntaxText.toPlain
|
||||
. TypePrinter.pretty0 @v (PPE.suffixifiedPPE ppe) mempty (-1)
|
||||
$ Type.ref () r
|
||||
)
|
||||
$ fmap mungeSyntaxText tp
|
||||
typeDefinitions =
|
||||
Map.mapWithKey mkTypeDefinition $ typesToSyntax width ppe types
|
||||
termDefinitions <- Map.traverseWithKey mkTermDefinition
|
||||
$ termsToSyntax width ppe terms
|
||||
let renderedDisplayTerms = Map.mapKeys Reference.toText termDefinitions
|
||||
renderedDisplayTypes = Map.mapKeys Reference.toText typeDefinitions
|
||||
pure $ DefinitionDisplayResults renderedDisplayTerms
|
||||
renderedDisplayTypes
|
||||
misses
|
||||
|
||||
resolveBranchHash
|
||||
:: Monad m => Maybe Branch.Hash -> Codebase m v Ann -> Backend m (Branch m)
|
||||
|
@ -55,10 +55,10 @@ import Unison.Server.Types ( HashQualifiedName
|
||||
, mayDefault
|
||||
, formatType
|
||||
)
|
||||
import Unison.ShortHash ( ShortHash )
|
||||
import Unison.Util.Pretty ( Width )
|
||||
import Unison.Util.SyntaxText ( SyntaxText' )
|
||||
import Unison.Var ( Var )
|
||||
import qualified Unison.Codebase.ShortBranchHash as SBH
|
||||
|
||||
type NamespaceAPI =
|
||||
"list" :> QueryParam "namespace" HashQualifiedName
|
||||
@ -78,8 +78,8 @@ instance ToSample NamespaceListing where
|
||||
<> "listed by default"
|
||||
, NamespaceListing
|
||||
"."
|
||||
"gjlk0dna8dongct6lsd19d1o9hi5n642t8jttga5e81e91fviqjdffem0tlddj7ahodjo5"
|
||||
[Subnamespace $ NamedNamespace "base" 1244]
|
||||
"#gjlk0dna8dongct6lsd19d1o9hi5n642t8jttga5e81e91fviqjdffem0tlddj7ahodjo5"
|
||||
[Subnamespace $ NamedNamespace "base" "#19d1o9hi5n642t8jttg" 1244]
|
||||
)
|
||||
]
|
||||
|
||||
@ -106,8 +106,9 @@ instance ToJSON NamespaceObject
|
||||
deriving instance ToSchema NamespaceObject
|
||||
|
||||
data NamedNamespace = NamedNamespace
|
||||
{ namespaceName :: UnisonName,
|
||||
namespaceSize :: Size
|
||||
{ namespaceName :: UnisonName
|
||||
, namespaceHash :: UnisonHash
|
||||
, namespaceSize :: Size
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
@ -116,9 +117,9 @@ instance ToJSON NamedNamespace
|
||||
deriving instance ToSchema NamedNamespace
|
||||
|
||||
data NamedTerm = NamedTerm
|
||||
{ termName :: HashQualifiedName,
|
||||
termHash :: UnisonHash,
|
||||
termType :: Maybe (SyntaxText' ShortHash)
|
||||
{ termName :: HashQualifiedName
|
||||
, termHash :: UnisonHash
|
||||
, termType :: Maybe (SyntaxText' UnisonHash)
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
@ -136,9 +137,7 @@ instance ToJSON NamedType
|
||||
|
||||
deriving instance ToSchema NamedType
|
||||
|
||||
newtype NamedPatch = NamedPatch
|
||||
{ patchName :: HashQualifiedName
|
||||
}
|
||||
newtype NamedPatch = NamedPatch { patchName :: HashQualifiedName }
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance ToJSON NamedPatch
|
||||
@ -166,8 +165,9 @@ backendListEntryToNamespaceObject ppe typeWidth = \case
|
||||
}
|
||||
Backend.ShallowTypeEntry r name -> TypeObject
|
||||
$ NamedType { typeName = HQ'.toText name, typeHash = Reference.toText r }
|
||||
Backend.ShallowBranchEntry name size -> Subnamespace $ NamedNamespace
|
||||
Backend.ShallowBranchEntry name hash size -> Subnamespace $ NamedNamespace
|
||||
{ namespaceName = NameSegment.toText name
|
||||
, namespaceHash = "#" <> SBH.toText hash
|
||||
, namespaceSize = size
|
||||
}
|
||||
Backend.ShallowPatchEntry name ->
|
||||
@ -196,7 +196,9 @@ serveNamespace codebase mayHQN = case mayHQN of
|
||||
pure
|
||||
. NamespaceListing
|
||||
(Name.toText n)
|
||||
(Hash.base32Hex . Causal.unRawHash $ Branch.headHash root)
|
||||
(("#" <>) . Hash.base32Hex . Causal.unRawHash $ Branch.headHash
|
||||
root
|
||||
)
|
||||
$ fmap (backendListEntryToNamespaceObject ppe Nothing) entries
|
||||
HQ.HashOnly _ -> hashOnlyNotSupported
|
||||
HQ.HashQualified _ _ -> hashQualifiedNotSupported
|
||||
|
@ -13,6 +13,7 @@ import Servant (ServerError (..), err400, err404, err500)
|
||||
import qualified Unison.Codebase as Codebase
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Codebase.ShortBranchHash as SBH
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Server.Backend as Backend
|
||||
import Unison.Server.Types
|
||||
( HashQualifiedName,
|
||||
@ -39,6 +40,7 @@ backendError = \case
|
||||
noSuchNamespace . Text.toStrict . Text.pack $ show h
|
||||
Backend.AmbiguousBranchHash sbh hashes ->
|
||||
ambiguousNamespace (SBH.toText sbh) (Set.map SBH.toText hashes)
|
||||
Backend.MissingSignatureForTerm r -> missingSigForTerm $ Reference.toText r
|
||||
|
||||
rootBranchError :: Codebase.GetRootBranchError -> ServerError
|
||||
rootBranchError rbe = err500
|
||||
@ -69,3 +71,13 @@ ambiguousNamespace name namespaces = err400
|
||||
<> ". It could refer to any of "
|
||||
<> mungeShow (Set.toList namespaces)
|
||||
}
|
||||
|
||||
missingSigForTerm :: HashQualifiedName -> ServerError
|
||||
missingSigForTerm r = err500
|
||||
{ errBody = "The type signature for reference "
|
||||
<> munge r
|
||||
<> " is missing! "
|
||||
<> "This means something might be wrong with the codebase, "
|
||||
<> "or the term was deleted just now. "
|
||||
<> "Try making the request again."
|
||||
}
|
||||
|
@ -84,23 +84,42 @@ instance ToJSON r => ToJSON (SyntaxText' r)
|
||||
|
||||
deriving instance ToSchema r => ToSchema (SyntaxText' r)
|
||||
|
||||
instance ToJSON TypeDefinition
|
||||
|
||||
deriving instance ToSchema TypeDefinition
|
||||
|
||||
instance ToJSON TermDefinition
|
||||
|
||||
deriving instance ToSchema TermDefinition
|
||||
|
||||
instance ToJSON DefinitionDisplayResults
|
||||
|
||||
deriving instance ToSchema DefinitionDisplayResults
|
||||
|
||||
data TermDefinition = TermDefinition
|
||||
{ termNames :: [HashQualifiedName]
|
||||
, bestTermName :: HashQualifiedName
|
||||
, termDefinition :: DisplayObject (SyntaxText' UnisonHash)
|
||||
, signature :: SyntaxText' UnisonHash
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
data TypeDefinition = TypeDefinition
|
||||
{ typeNames :: [HashQualifiedName]
|
||||
, bestTypeName :: HashQualifiedName
|
||||
, typeDefinition :: DisplayObject (SyntaxText' UnisonHash)
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
data DefinitionDisplayResults =
|
||||
DefinitionDisplayResults
|
||||
{ termDefinitions :: Map ShortHash (DisplayObject (SyntaxText' ShortHash))
|
||||
, typeDefinitions :: Map ShortHash (DisplayObject (SyntaxText' ShortHash))
|
||||
{ termDefinitions :: Map UnisonHash TermDefinition
|
||||
, typeDefinitions :: Map UnisonHash TypeDefinition
|
||||
, missingDefinitions :: [HQ.HashQualified Name]
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
formatType
|
||||
:: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText' ShortHash
|
||||
:: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText' UnisonHash
|
||||
formatType ppe w =
|
||||
fmap (fmap Reference.toShortHash) . render w . TypePrinter.pretty0 ppe
|
||||
mempty
|
||||
(-1)
|
||||
fmap (fmap Reference.toText) . render w . TypePrinter.pretty0 ppe mempty (-1)
|
||||
|
||||
munge :: Text -> LZ.ByteString
|
||||
munge = Text.encodeUtf8 . Text.fromStrict
|
||||
|
@ -47,11 +47,13 @@ import Unison.Builtin.Decls (pattern TuplePattern, pattern TupleTerm')
|
||||
import qualified Unison.ConstructorType as CT
|
||||
|
||||
pretty :: Var v => PrettyPrintEnv -> Term v a -> Pretty ColorText
|
||||
pretty env tm = PP.syntaxToColor $ pretty0 env (ac (-1) Normal Map.empty MaybeDoc) (printAnnotate env tm)
|
||||
pretty env = PP.syntaxToColor . pretty0 env emptyAc . printAnnotate env
|
||||
|
||||
pretty' :: Var v => Maybe Int -> PrettyPrintEnv -> Term v a -> ColorText
|
||||
pretty' (Just width) n t = PP.render width $ PP.syntaxToColor $ pretty0 n (ac (-1) Normal Map.empty MaybeDoc) (printAnnotate n t)
|
||||
pretty' Nothing n t = PP.renderUnbroken $ PP.syntaxToColor $ pretty0 n (ac (-1) Normal Map.empty MaybeDoc) (printAnnotate n t)
|
||||
pretty' (Just width) n t =
|
||||
PP.render width $ PP.syntaxToColor $ pretty0 n emptyAc (printAnnotate n t)
|
||||
pretty' Nothing n t =
|
||||
PP.renderUnbroken $ PP.syntaxToColor $ pretty0 n emptyAc (printAnnotate n t)
|
||||
|
||||
-- Information about the context in which a term appears, which affects how the
|
||||
-- term should be rendered.
|
||||
@ -519,7 +521,7 @@ prettyBinding
|
||||
-> HQ.HashQualified Name
|
||||
-> Term2 v at ap v a
|
||||
-> Pretty SyntaxText
|
||||
prettyBinding n = prettyBinding0 n $ ac (-1) Block Map.empty MaybeDoc
|
||||
prettyBinding n = prettyBinding0 n emptyAc
|
||||
|
||||
prettyBinding'
|
||||
:: Var v
|
||||
@ -661,6 +663,9 @@ isBlank :: String -> Bool
|
||||
isBlank ('_' : rest) | (isJust ((readMaybe rest) :: Maybe Int)) = True
|
||||
isBlank _ = False
|
||||
|
||||
emptyAc :: AmbientContext
|
||||
emptyAc = ac (-1) Block Map.empty MaybeDoc
|
||||
|
||||
ac :: Int -> BlockContext -> Imports -> DocLiteralContext -> AmbientContext
|
||||
ac prec bc im doc = AmbientContext prec bc NonInfix im doc
|
||||
|
||||
|
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
Loading…
Reference in New Issue
Block a user