unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-23 08:18:04 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'topic/codebaseserver-morenames' of github.com:unisonweb/unison into topic/codebaseserver-openapi

Browse Source
This commit is contained in:
runarorama 2021-02-24 15:21:00 -05:00
commit 5da295feb0
9 changed files with 171 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -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

2
parser-typechecker/src/Unison/Codebase/Editor/Output.hs
View File

@ -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

13
parser-typechecker/src/Unison/CommandLine/OutputMessages.hs
View File

@ -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

111
parser-typechecker/src/Unison/Server/Backend.hs
View File

@ -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)

28
parser-typechecker/src/Unison/Server/Endpoints/ListNamespace.hs
View File

@ -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

12
parser-typechecker/src/Unison/Server/Errors.hs
View File

@ -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."
}

31
parser-typechecker/src/Unison/Server/Types.hs
View File

@ -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

13
parser-typechecker/src/Unison/TermPrinter.hs
View File

@ -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
unison-core/src/Unison/Type.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}