mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-22 15:58:34 +03:00
Merge pull request #2116 from unisonweb/feature/2112
Add docs to `getDefinition` endpoint
This commit is contained in:
mergify[bot]
GitHub
commit
ce3b0c0c18
@ -16,6 +16,7 @@ module Unison.Builtin
|
||||
,intrinsicTermReferences
|
||||
,intrinsicTypeReferences
|
||||
,isBuiltinType
|
||||
,typeOf
|
||||
,typeLookup
|
||||
,termRefTypes
|
||||
) where
|
||||
@ -247,6 +248,9 @@ termRefTypes = foldl' go mempty builtinsSrc where
|
||||
D r t -> Map.insert (R.Builtin r) t m
|
||||
_ -> m
|
||||
|
||||
typeOf :: Var v => a -> (Type v -> a) -> R.Reference -> a
|
||||
typeOf a f r = maybe a f (Map.lookup r termRefTypes)
|
||||
|
||||
builtinsSrc :: Var v => [BuiltinDSL v]
|
||||
builtinsSrc =
|
||||
[ B "Int.+" $ int --> int --> int
|
||||
|
||||
@ -75,8 +75,10 @@ constructorId ref name = do
|
||||
(_,_,dd) <- find (\(_,r,_) -> Reference.DerivedId r == ref) (builtinDataDecls @Symbol)
|
||||
elemIndex name $ DD.constructorNames dd
|
||||
|
||||
okConstructorId, failConstructorId, docBlobId, docLinkId, docSignatureId, docSourceId, docEvaluateId, docJoinId, linkTermId, linkTypeId, eitherRightId, eitherLeftId :: ConstructorId
|
||||
noneId, someId, okConstructorId, failConstructorId, docBlobId, docLinkId, docSignatureId, docSourceId, docEvaluateId, docJoinId, linkTermId, linkTypeId, eitherRightId, eitherLeftId :: ConstructorId
|
||||
isPropagatedConstructorId, isTestConstructorId, bufferModeNoBufferingId, bufferModeLineBufferingId, bufferModeBlockBufferingId, bufferModeSizedBlockBufferingId :: ConstructorId
|
||||
Just noneId = constructorId optionalRef "Optional.None"
|
||||
Just someId = constructorId optionalRef "Optional.Some"
|
||||
Just isPropagatedConstructorId = constructorId isPropagatedRef "IsPropagated.IsPropagated"
|
||||
Just isTestConstructorId = constructorId isTestRef "IsTest.IsTest"
|
||||
Just okConstructorId = constructorId testResultRef "Test.Result.Ok"
|
||||
@ -300,6 +302,8 @@ pattern UnitRef <- (unUnitRef -> True)
|
||||
pattern PairRef <- (unPairRef -> True)
|
||||
pattern EitherRef <- ((==) eitherRef -> True)
|
||||
pattern OptionalRef <- (unOptionalRef -> True)
|
||||
pattern OptionalNone' <- Term.Constructor' OptionalRef ((==) noneId -> True)
|
||||
pattern OptionalSome' d <- Term.App' (Term.Constructor' OptionalRef ((==) someId -> True)) d
|
||||
pattern TupleType' ts <- (unTupleType -> Just ts)
|
||||
pattern TupleTerm' xs <- (unTupleTerm -> Just xs)
|
||||
pattern TuplePattern ps <- (unTuplePattern -> Just ps)
|
||||
|
||||
@ -203,6 +203,12 @@ getTypeOfConstructor codebase (Reference.DerivedId r) cid = do
|
||||
getTypeOfConstructor _ r cid =
|
||||
error $ "Don't know how to getTypeOfConstructor " ++ show r ++ " " ++ show cid
|
||||
|
||||
lookupWatchCache :: (Monad m) => Codebase m v a -> Reference -> m (Maybe (Term v a))
|
||||
lookupWatchCache codebase (Reference.DerivedId h) = do
|
||||
m1 <- getWatch codebase UF.RegularWatch h
|
||||
maybe (getWatch codebase UF.TestWatch h) (pure . Just) m1
|
||||
lookupWatchCache _ Reference.Builtin{} = pure Nothing
|
||||
|
||||
typeLookupForDependencies
|
||||
:: (Monad m, Var v, BuiltinAnnotation a)
|
||||
=> Codebase m v a -> Set Reference -> m (TL.TypeLookup v a)
|
||||
@ -323,6 +329,11 @@ getTypeOfTerm c r = case r of
|
||||
pure $ fmap (const builtinAnnotation)
|
||||
<$> Map.lookup r Builtin.termRefTypes
|
||||
|
||||
getTypeOfReferent :: (BuiltinAnnotation a, Var v, Monad m)
|
||||
=> Codebase m v a -> Referent.Referent -> m (Maybe (Type v a))
|
||||
getTypeOfReferent c (Referent.Ref r) = getTypeOfTerm c r
|
||||
getTypeOfReferent c (Referent.Con r cid _) =
|
||||
getTypeOfConstructor c r cid
|
||||
|
||||
-- The dependents of a builtin type is the set of builtin terms which
|
||||
-- mention that type.
|
||||
|
||||
@ -4,11 +4,17 @@ module Unison.Codebase.Editor.DisplayObject where
|
||||
|
||||
import Unison.Prelude
|
||||
import Unison.ShortHash
|
||||
import Data.Bifunctor
|
||||
|
||||
data DisplayObject a = BuiltinObject | MissingObject ShortHash | UserObject a
|
||||
data DisplayObject b a = BuiltinObject b | MissingObject ShortHash | UserObject a
|
||||
deriving (Eq, Ord, Show, Functor, Generic)
|
||||
|
||||
toMaybe :: DisplayObject a -> Maybe a
|
||||
instance Bifunctor DisplayObject where
|
||||
bimap _ _ (MissingObject sh) = MissingObject sh
|
||||
bimap f _ (BuiltinObject b) = BuiltinObject (f b)
|
||||
bimap _ f (UserObject a) = UserObject (f a)
|
||||
|
||||
toMaybe :: DisplayObject b a -> Maybe a
|
||||
toMaybe = \case
|
||||
UserObject a -> Just a
|
||||
_ -> Nothing
|
||||
|
||||
@ -1357,7 +1357,7 @@ loop = do
|
||||
in case t of
|
||||
HQ.HashOnly h ->
|
||||
hashConflicted h rs'
|
||||
(Path.parseHQSplit' . HQ.toString -> Right n) ->
|
||||
(Path.parseHQSplit' . HQ.toString -> Right n) ->
|
||||
termConflicted n rs'
|
||||
_ -> respond . BadName $ HQ.toString t
|
||||
|
||||
@ -2666,7 +2666,7 @@ doSlurpUpdates typeEdits termEdits deprecated b0 =
|
||||
|
||||
loadDisplayInfo ::
|
||||
Set Reference -> Action m i v ([(Reference, Maybe (Type v Ann))]
|
||||
,[(Reference, DisplayObject (DD.Decl v Ann))])
|
||||
,[(Reference, DisplayObject () (DD.Decl v Ann))])
|
||||
loadDisplayInfo refs = do
|
||||
termRefs <- filterM (eval . IsTerm) (toList refs)
|
||||
typeRefs <- filterM (eval . IsType) (toList refs)
|
||||
@ -2698,9 +2698,9 @@ makeHistoricalParsingNames lexedHQs = do
|
||||
fixupNamesRelative currentPath rawHistoricalNames)
|
||||
|
||||
loadTypeDisplayObject
|
||||
:: Reference -> Action m i v (DisplayObject (DD.Decl v Ann))
|
||||
:: Reference -> Action m i v (DisplayObject () (DD.Decl v Ann))
|
||||
loadTypeDisplayObject = \case
|
||||
Reference.Builtin _ -> pure BuiltinObject
|
||||
Reference.Builtin _ -> pure (BuiltinObject ())
|
||||
Reference.DerivedId id ->
|
||||
maybe (MissingObject $ Reference.idToShortHash id) UserObject
|
||||
<$> eval (LoadType id)
|
||||
|
||||
@ -158,8 +158,8 @@ data Output v
|
||||
-- "display" definitions, possibly to a FilePath on disk (e.g. editing)
|
||||
| DisplayDefinitions (Maybe FilePath)
|
||||
PPE.PrettyPrintEnvDecl
|
||||
(Map Reference (DisplayObject (Decl v Ann)))
|
||||
(Map Reference (DisplayObject (Term v Ann)))
|
||||
(Map Reference (DisplayObject () (Decl v Ann)))
|
||||
(Map Reference (DisplayObject (Type v Ann) (Term v Ann)))
|
||||
-- | Invariant: there's at least one conflict or edit in the TodoOutput.
|
||||
| TodoOutput PPE.PrettyPrintEnvDecl (TO.TodoOutput v Ann)
|
||||
| TestIncrementalOutputStart PPE.PrettyPrintEnv (Int,Int) Reference (Term v Ann)
|
||||
@ -181,8 +181,8 @@ data Output v
|
||||
| ConfiguredGitUrlParseError PushPull Path' Text String
|
||||
| ConfiguredGitUrlIncludesShortBranchHash PushPull RemoteRepo ShortBranchHash Path
|
||||
| DisplayLinks PPE.PrettyPrintEnvDecl Metadata.Metadata
|
||||
(Map Reference (DisplayObject (Decl v Ann)))
|
||||
(Map Reference (DisplayObject (Term v Ann)))
|
||||
(Map Reference (DisplayObject () (Decl v Ann)))
|
||||
(Map Reference (DisplayObject (Type v Ann) (Term v Ann)))
|
||||
| MetadataMissingType PPE.PrettyPrintEnv Referent
|
||||
| TermMissingType Reference
|
||||
| MetadataAmbiguous (HQ.HashQualified Name) PPE.PrettyPrintEnv [Referent]
|
||||
|
||||
@ -24,10 +24,10 @@ data TodoOutput v a = TodoOutput
|
||||
{ todoScore :: Score
|
||||
, todoFrontier ::
|
||||
( [(Reference, Maybe (Type v a))]
|
||||
, [(Reference, DisplayObject (Decl v a))])
|
||||
, [(Reference, DisplayObject () (Decl v a))])
|
||||
, todoFrontierDependents ::
|
||||
( [(Score, Reference, Maybe (Type v a))]
|
||||
, [(Score, Reference, DisplayObject (Decl v a))])
|
||||
, [(Score, Reference, DisplayObject () (Decl v a))])
|
||||
, nameConflicts :: Names0
|
||||
, editConflicts :: Patch
|
||||
} deriving (Show)
|
||||
|
||||
@ -30,6 +30,7 @@ import qualified Unison.Util.SyntaxText as S
|
||||
import qualified Unison.Codebase.Editor.DisplayObject as DO
|
||||
import qualified Unison.CommandLine.OutputMessages as OutputMessages
|
||||
import qualified Unison.ConstructorType as CT
|
||||
import qualified Unison.Builtin as Builtin
|
||||
|
||||
type Pretty = P.Pretty P.ColorText
|
||||
|
||||
@ -132,19 +133,18 @@ displayPretty pped terms typeOf eval types tm = go tm
|
||||
tms = [ ref | DD.TupleTerm' [DD.EitherRight' (DD.Doc2Term (toRef -> Just ref)),_anns] <- toList es ]
|
||||
typeMap <- let
|
||||
-- todo: populate the variable names / kind once BuiltinObject supports that
|
||||
go ref@(Reference.Builtin _) = pure (ref, DO.BuiltinObject)
|
||||
go ref@(Reference.Builtin _) = pure (ref, DO.BuiltinObject ())
|
||||
go ref = (ref,) <$> do
|
||||
decl <- types ref
|
||||
let missing = DO.MissingObject (SH.unsafeFromText $ Reference.toText ref)
|
||||
pure $ maybe missing DO.UserObject decl
|
||||
in Map.fromList <$> traverse go tys
|
||||
termMap <- let
|
||||
-- todo: populate the type signature once BuiltinObject supports that
|
||||
go ref@(Reference.Builtin _) = pure (ref, DO.BuiltinObject)
|
||||
go ref = (ref,) <$> do
|
||||
tm <- terms ref
|
||||
let missing = DO.MissingObject (SH.unsafeFromText $ Reference.toText ref)
|
||||
pure $ maybe missing DO.UserObject tm
|
||||
go ref = (ref,) <$> case ref of
|
||||
Reference.Builtin _ -> pure $ Builtin.typeOf missing DO.BuiltinObject ref
|
||||
_ -> maybe missing DO.UserObject <$> terms ref
|
||||
where
|
||||
missing = DO.MissingObject (SH.unsafeFromText $ Reference.toText ref)
|
||||
in Map.fromList <$> traverse go tms
|
||||
-- in docs, we use suffixed names everywhere
|
||||
let pped' = pped { PPE.unsuffixifiedPPE = PPE.suffixifiedPPE pped }
|
||||
|
||||
@ -39,7 +39,6 @@ import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Codebase.Runtime as Runtime
|
||||
import qualified Unison.Codebase as Codebase
|
||||
import qualified Unison.CommandLine.InputPattern as IP
|
||||
import qualified Unison.Runtime.Interface as RTI
|
||||
import qualified Unison.Util.Pretty as P
|
||||
import qualified Unison.Util.TQueue as Q
|
||||
import Text.Regex.TDFA
|
||||
@ -157,10 +156,11 @@ main
|
||||
-> Path.Absolute
|
||||
-> (Config, IO ())
|
||||
-> [Either Event Input]
|
||||
-> Runtime.Runtime Symbol
|
||||
-> Codebase IO Symbol Ann
|
||||
-> String
|
||||
-> IO ()
|
||||
main dir defaultBaseLib initialPath (config,cancelConfig) initialInputs codebase version = do
|
||||
main dir defaultBaseLib initialPath (config,cancelConfig) initialInputs runtime codebase version = do
|
||||
dir' <- shortenDirectory dir
|
||||
root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase
|
||||
putPrettyLn $ case defaultBaseLib of
|
||||
@ -169,7 +169,6 @@ main dir defaultBaseLib initialPath (config,cancelConfig) initialInputs codebase
|
||||
_ -> welcomeMessage dir' version
|
||||
eventQueue <- Q.newIO
|
||||
do
|
||||
runtime <- RTI.startRuntime
|
||||
-- we watch for root branch tip changes, but want to ignore ones we expect.
|
||||
rootRef <- newIORef root
|
||||
pathRef <- newIORef initialPath
|
||||
|
||||
@ -1141,8 +1141,8 @@ formatMissingStuff terms types =
|
||||
|
||||
displayDefinitions' :: Var v => Ord a1
|
||||
=> PPE.PrettyPrintEnvDecl
|
||||
-> Map Reference.Reference (DisplayObject (DD.Decl v a1))
|
||||
-> Map Reference.Reference (DisplayObject (Term v a1))
|
||||
-> Map Reference.Reference (DisplayObject () (DD.Decl v a1))
|
||||
-> Map Reference.Reference (DisplayObject (Type v a1) (Term v a1))
|
||||
-> Pretty
|
||||
displayDefinitions' ppe0 types terms = P.syntaxToColor $ P.sep "\n\n" (prettyTypes <> prettyTerms)
|
||||
where
|
||||
@ -1156,12 +1156,14 @@ displayDefinitions' ppe0 types terms = P.syntaxToColor $ P.sep "\n\n" (prettyTyp
|
||||
go ((n, r), dt) =
|
||||
case dt of
|
||||
MissingObject r -> missing n r
|
||||
BuiltinObject -> builtin n
|
||||
BuiltinObject typ ->
|
||||
P.hang ("builtin " <> prettyHashQualified n <> " :")
|
||||
(TypePrinter.prettySyntax (ppeBody r) typ)
|
||||
UserObject tm -> TermPrinter.prettyBinding (ppeBody r) n tm
|
||||
go2 ((n, r), dt) =
|
||||
case dt of
|
||||
MissingObject r -> missing n r
|
||||
BuiltinObject -> builtin n
|
||||
BuiltinObject _ -> builtin n
|
||||
UserObject decl -> case decl of
|
||||
Left d -> DeclPrinter.prettyEffectDecl (ppeBody r) r n d
|
||||
Right d -> DeclPrinter.prettyDataDecl (ppeBody r) r n d
|
||||
@ -1199,8 +1201,8 @@ displayRendered outputLoc pp =
|
||||
displayDefinitions :: Var v => Ord a1 =>
|
||||
Maybe FilePath
|
||||
-> PPE.PrettyPrintEnvDecl
|
||||
-> Map Reference.Reference (DisplayObject (DD.Decl v a1))
|
||||
-> Map Reference.Reference (DisplayObject (Term v a1))
|
||||
-> Map Reference.Reference (DisplayObject () (DD.Decl v a1))
|
||||
-> Map Reference.Reference (DisplayObject (Type v a1) (Term v a1))
|
||||
-> IO Pretty
|
||||
displayDefinitions _outputLoc _ppe types terms | Map.null types && Map.null terms =
|
||||
pure $ P.callout "😶" "No results to display."
|
||||
@ -1307,17 +1309,17 @@ prettyTypeResultHeaderFull' (SR'.TypeResult' (HQ'.toHQ -> name) dt r (Set.map HQ
|
||||
where greyHash = styleHashQualified' id P.hiBlack
|
||||
|
||||
prettyDeclTriple :: Var v =>
|
||||
(HQ.HashQualified Name, Reference.Reference, DisplayObject (DD.Decl v a))
|
||||
(HQ.HashQualified Name, Reference.Reference, DisplayObject () (DD.Decl v a))
|
||||
-> Pretty
|
||||
prettyDeclTriple (name, _, displayDecl) = case displayDecl of
|
||||
BuiltinObject -> P.hiBlack "builtin " <> P.hiBlue "type " <> P.blue (P.syntaxToColor $ prettyHashQualified name)
|
||||
BuiltinObject _ -> P.hiBlack "builtin " <> P.hiBlue "type " <> P.blue (P.syntaxToColor $ prettyHashQualified name)
|
||||
MissingObject _ -> mempty -- these need to be handled elsewhere
|
||||
UserObject decl -> case decl of
|
||||
Left ed -> P.syntaxToColor $ DeclPrinter.prettyEffectHeader name ed
|
||||
Right dd -> P.syntaxToColor $ DeclPrinter.prettyDataHeader name dd
|
||||
|
||||
prettyDeclPair :: Var v =>
|
||||
PPE.PrettyPrintEnv -> (Reference, DisplayObject (DD.Decl v a))
|
||||
PPE.PrettyPrintEnv -> (Reference, DisplayObject () (DD.Decl v a))
|
||||
-> Pretty
|
||||
prettyDeclPair ppe (r, dt) = prettyDeclTriple (PPE.typeName ppe r, r, dt)
|
||||
|
||||
|
||||
@ -103,6 +103,64 @@ prettyAnnotatedRef = typeNamed "Pretty.Annotated"
|
||||
ansiColorRef = typeNamed "ANSI.Color"
|
||||
consoleTextRef = typeNamed "ConsoleText"
|
||||
|
||||
pattern Doc2Ref <- ((== doc2Ref) -> True)
|
||||
doc2WordId = constructorNamed doc2Ref "Doc2.Word"
|
||||
doc2CodeId = constructorNamed doc2Ref "Doc2.Code"
|
||||
doc2CodeBlockId = constructorNamed doc2Ref "Doc2.CodeBlock"
|
||||
doc2BoldId = constructorNamed doc2Ref "Doc2.Bold"
|
||||
doc2ItalicId = constructorNamed doc2Ref "Doc2.Italic"
|
||||
doc2StrikethroughId = constructorNamed doc2Ref "Doc2.Strikethrough"
|
||||
doc2StyleId = constructorNamed doc2Ref "Doc2.Style"
|
||||
doc2AnchorId = constructorNamed doc2Ref "Doc2.Anchor"
|
||||
doc2BlockquoteId = constructorNamed doc2Ref "Doc2.Blockquote"
|
||||
doc2BlanklineId = constructorNamed doc2Ref "Doc2.Blankline"
|
||||
doc2LinebreakId = constructorNamed doc2Ref "Doc2.Linebreak"
|
||||
doc2SectionBreakId = constructorNamed doc2Ref "Doc2.SectionBreak"
|
||||
doc2TooltipId = constructorNamed doc2Ref "Doc2.Tooltip"
|
||||
doc2AsideId = constructorNamed doc2Ref "Doc2.Aside"
|
||||
doc2CalloutId = constructorNamed doc2Ref "Doc2.Callout"
|
||||
doc2TableId = constructorNamed doc2Ref "Doc2.Table"
|
||||
doc2FoldedId = constructorNamed doc2Ref "Doc2.Folded"
|
||||
doc2ParagraphId = constructorNamed doc2Ref "Doc2.Paragraph"
|
||||
doc2BulletedListId = constructorNamed doc2Ref "Doc2.BulletedList"
|
||||
doc2NumberedListId = constructorNamed doc2Ref "Doc2.NumberedList"
|
||||
doc2SectionId = constructorNamed doc2Ref "Doc2.Section"
|
||||
doc2NamedLinkId = constructorNamed doc2Ref "Doc2.NamedLink"
|
||||
doc2ImageId = constructorNamed doc2Ref "Doc2.Image"
|
||||
doc2SpecialId = constructorNamed doc2Ref "Doc2.Special"
|
||||
doc2JoinId = constructorNamed doc2Ref "Doc2.Join"
|
||||
doc2UntitledSectionId = constructorNamed doc2Ref "Doc2.UntitledSection"
|
||||
doc2ColumnId = constructorNamed doc2Ref "Doc2.Column"
|
||||
doc2GroupId = constructorNamed doc2Ref "Doc2.Group"
|
||||
|
||||
pattern Doc2Word txt <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2WordId -> True)) (Term.Text' txt)
|
||||
pattern Doc2Code d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2CodeId -> True)) d
|
||||
pattern Doc2CodeBlock lang d <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2CodeBlockId -> True)) [Term.Text' lang, d]
|
||||
pattern Doc2Bold d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2BoldId -> True)) d
|
||||
pattern Doc2Italic d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2ItalicId -> True)) d
|
||||
pattern Doc2Strikethrough d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2StrikethroughId -> True)) d
|
||||
pattern Doc2Style s d <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2StyleId -> True)) [Term.Text' s, d]
|
||||
pattern Doc2Anchor id d <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2AnchorId -> True)) [Term.Text' id, d]
|
||||
pattern Doc2Blockquote d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2BlockquoteId -> True)) d
|
||||
pattern Doc2Blankline <- Term.Constructor' Doc2Ref ((==) doc2BlanklineId -> True)
|
||||
pattern Doc2Linebreak <- Term.Constructor' Doc2Ref ((==) doc2LinebreakId -> True)
|
||||
pattern Doc2SectionBreak <- Term.Constructor' Doc2Ref ((==) doc2SectionBreakId -> True)
|
||||
pattern Doc2Tooltip d tip <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2TooltipId -> True)) [d, tip]
|
||||
pattern Doc2Aside d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2AsideId -> True)) d
|
||||
pattern Doc2Callout icon d <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2CalloutId -> True)) [icon, d]
|
||||
pattern Doc2Table ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2TableId -> True)) (Term.List' (toList -> ds))
|
||||
pattern Doc2Folded isFolded d d2 <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2FoldedId -> True)) [Term.Boolean' isFolded, d, d2]
|
||||
pattern Doc2Paragraph ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2ParagraphId -> True)) (Term.List' (toList -> ds))
|
||||
pattern Doc2BulletedList ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2BulletedListId -> True)) (Term.List' (toList -> ds))
|
||||
pattern Doc2Section title ds <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2SectionId -> True)) [title, Term.List' (toList -> ds)]
|
||||
pattern Doc2NamedLink name dest <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2NamedLinkId -> True)) [name, dest]
|
||||
pattern Doc2Image alt link caption <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2ImageId -> True)) [alt, link, caption]
|
||||
pattern Doc2Special sf <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2SpecialId -> True)) sf
|
||||
pattern Doc2Join ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2JoinId -> True)) (Term.List' (toList -> ds))
|
||||
pattern Doc2UntitledSection ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2UntitledSectionId -> True)) (Term.List' (toList -> ds))
|
||||
pattern Doc2Column ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2ColumnId -> True)) (Term.List' (toList -> ds))
|
||||
pattern Doc2Group d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2GroupId -> True)) d
|
||||
|
||||
pattern Doc2SpecialFormRef <- ((== doc2SpecialFormRef) -> True)
|
||||
doc2SpecialFormSourceId = constructorNamed doc2SpecialFormRef "Doc2.SpecialForm.Source"
|
||||
doc2SpecialFormFoldedSourceId = constructorNamed doc2SpecialFormRef "Doc2.SpecialForm.FoldedSource"
|
||||
@ -135,8 +193,6 @@ pattern Doc2Example vs body <- Term.App' _term (Term.App' _any (Term.LamNamed' _
|
||||
-- pulls out `body` in `Doc2.Term (Any 'body)`
|
||||
pattern Doc2Term body <- Term.App' _term (Term.App' _any (Term.LamNamed' _ body))
|
||||
|
||||
pattern Doc2Ref <- ((== doc2Ref) -> True)
|
||||
|
||||
pattern Doc2TermRef <- ((== doc2TermRef) -> True)
|
||||
|
||||
pattern PrettyAnnotatedRef <- ((== prettyAnnotatedRef) -> True)
|
||||
|
||||
@ -1,20 +1,21 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Server.Backend where
|
||||
|
||||
import Control.Lens (_2, over)
|
||||
import Control.Error.Util ((??))
|
||||
import Control.Error.Util ((??),hush)
|
||||
import Control.Monad.Except
|
||||
( ExceptT (..),
|
||||
throwError,
|
||||
)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Bifunctor (first,bimap)
|
||||
import Data.List.Extra (nubOrd)
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
@ -24,6 +25,8 @@ import qualified Text.FuzzyFind as FZF
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Builtin as B
|
||||
import qualified Unison.Builtin.Decls as Decls
|
||||
import qualified Unison.Codebase.Runtime as Rt
|
||||
import qualified Unison.Runtime.IOSource as DD
|
||||
import Unison.Codebase (Codebase)
|
||||
import qualified Unison.Codebase as Codebase
|
||||
import Unison.Codebase.Branch (Branch, Branch0)
|
||||
@ -45,6 +48,7 @@ import Unison.Name as Name
|
||||
( unsafeFromText,
|
||||
)
|
||||
import qualified Unison.Name as Name
|
||||
import qualified Unison.NamePrinter as NP
|
||||
import Unison.NameSegment (NameSegment(..))
|
||||
import qualified Unison.NameSegment as NameSegment
|
||||
import qualified Unison.Names2 as Names
|
||||
@ -78,9 +82,11 @@ import Unison.Util.Pretty (Width)
|
||||
import qualified Unison.Util.Pretty as Pretty
|
||||
import qualified Unison.Util.Relation as R
|
||||
import qualified Unison.Util.Star3 as Star3
|
||||
import Unison.Util.SyntaxText (SyntaxText)
|
||||
import qualified Unison.Util.SyntaxText as SyntaxText
|
||||
import qualified Unison.Util.SyntaxText as UST
|
||||
import Unison.Var (Var)
|
||||
import qualified Unison.Server.Doc as Doc
|
||||
import qualified Unison.UnisonFile as UF
|
||||
import qualified Unison.Codebase.Editor.DisplayObject as DisplayObject
|
||||
|
||||
data ShallowListEntry v a
|
||||
= ShallowTermEntry (TermEntry v a)
|
||||
@ -228,7 +234,8 @@ termListEntry codebase b0 r n = do
|
||||
ot <- lift $ loadReferentType codebase r
|
||||
-- A term is a doc if its type conforms to the `Doc` type.
|
||||
let isDoc = case ot of
|
||||
Just t -> Typechecker.isSubtype t $ Type.ref mempty Decls.docRef
|
||||
Just t -> Typechecker.isSubtype t (Type.ref mempty Decls.docRef) ||
|
||||
Typechecker.isSubtype t (Type.ref mempty DD.doc2Ref)
|
||||
Nothing -> False
|
||||
-- A term is a test if it has a link of type `IsTest`.
|
||||
isTest =
|
||||
@ -254,6 +261,37 @@ typeListEntry codebase r n = do
|
||||
_ -> pure Data
|
||||
pure $ TypeEntry r n tag
|
||||
|
||||
typeDeclHeader
|
||||
:: forall v m
|
||||
. Monad m
|
||||
=> Var v
|
||||
=> Codebase m v Ann
|
||||
-> PPE.PrettyPrintEnv
|
||||
-> Reference
|
||||
-> Backend m (DisplayObject Syntax.SyntaxText Syntax.SyntaxText)
|
||||
typeDeclHeader code ppe r = case Reference.toId r of
|
||||
Just rid ->
|
||||
(lift $ Codebase.getTypeDeclaration code rid) <&> \case
|
||||
Nothing -> DisplayObject.MissingObject (Reference.toShortHash r)
|
||||
Just decl ->
|
||||
DisplayObject.UserObject $
|
||||
Syntax.convertElement <$>
|
||||
Pretty.render defaultWidth (DeclPrinter.prettyDeclHeader name decl)
|
||||
Nothing ->
|
||||
pure (DisplayObject.BuiltinObject (formatTypeName ppe r))
|
||||
where
|
||||
name = PPE.typeName ppe r
|
||||
|
||||
formatTypeName :: PPE.PrettyPrintEnv -> Reference -> Syntax.SyntaxText
|
||||
formatTypeName ppe =
|
||||
fmap Syntax.convertElement . formatTypeName' ppe
|
||||
|
||||
formatTypeName' :: PPE.PrettyPrintEnv -> Reference -> UST.SyntaxText
|
||||
formatTypeName' ppe r =
|
||||
Pretty.renderUnbroken .
|
||||
NP.styleHashQualified id $
|
||||
PPE.typeName ppe r
|
||||
|
||||
termEntryToNamedTerm
|
||||
:: Var v => PPE.PrettyPrintEnv -> Maybe Width -> TermEntry v a -> NamedTerm
|
||||
termEntryToNamedTerm ppe typeWidth (TermEntry r name mayType tag) = NamedTerm
|
||||
@ -479,8 +517,8 @@ hqNameQuerySuffixify = hqNameQuery' True
|
||||
-- TODO: Move this to its own module
|
||||
data DefinitionResults v =
|
||||
DefinitionResults
|
||||
{ termResults :: Map Reference (DisplayObject (Term v Ann))
|
||||
, typeResults :: Map Reference (DisplayObject (DD.Decl v Ann))
|
||||
{ termResults :: Map Reference (DisplayObject (Type v Ann) (Term v Ann))
|
||||
, typeResults :: Map Reference (DisplayObject () (DD.Decl v Ann))
|
||||
, noResults :: [HQ.HashQualified Name]
|
||||
}
|
||||
|
||||
@ -509,34 +547,37 @@ expandShortBranchHash codebase hash = do
|
||||
_ ->
|
||||
throwError . AmbiguousBranchHash hash $ Set.map (SBH.fromHash len) hashSet
|
||||
|
||||
prettyType
|
||||
formatType' :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> UST.SyntaxText
|
||||
formatType' ppe w =
|
||||
Pretty.render w . TypePrinter.pretty0 ppe mempty (-1)
|
||||
|
||||
formatType :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> Syntax.SyntaxText
|
||||
formatType ppe w = mungeSyntaxText . formatType' ppe w
|
||||
|
||||
formatSuffixedType
|
||||
:: Var v
|
||||
=> Width
|
||||
-> PPE.PrettyPrintEnvDecl
|
||||
=> PPE.PrettyPrintEnvDecl
|
||||
-> Width
|
||||
-> Type v Ann
|
||||
-> Syntax.SyntaxText
|
||||
prettyType width ppe =
|
||||
mungeSyntaxText . Pretty.render width . TypePrinter.pretty0
|
||||
(PPE.suffixifiedPPE ppe)
|
||||
mempty
|
||||
(-1)
|
||||
formatSuffixedType ppe = formatType (PPE.suffixifiedPPE ppe)
|
||||
|
||||
mungeSyntaxText
|
||||
:: Functor g => g (SyntaxText.Element Reference) -> g Syntax.Element
|
||||
:: Functor g => g (UST.Element Reference) -> g Syntax.Element
|
||||
mungeSyntaxText = fmap Syntax.convertElement
|
||||
|
||||
prettyDefinitionsBySuffixes
|
||||
:: forall v m
|
||||
. Monad m
|
||||
=> Var v
|
||||
:: forall v
|
||||
. Var v
|
||||
=> Maybe Path
|
||||
-> Maybe Branch.Hash
|
||||
-> Maybe Width
|
||||
-> Suffixify
|
||||
-> Codebase m v Ann
|
||||
-> Rt.Runtime v
|
||||
-> Codebase IO v Ann
|
||||
-> [HQ.HashQualified Name]
|
||||
-> Backend m DefinitionDisplayResults
|
||||
prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings codebase query
|
||||
-> Backend IO DefinitionDisplayResults
|
||||
prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings rt codebase query
|
||||
= do
|
||||
branch <- resolveBranchHash root codebase
|
||||
DefinitionResults terms types misses <- definitionsBySuffixes relativeTo
|
||||
@ -568,33 +609,89 @@ prettyDefinitionsBySuffixes relativeTo root renderWidth suffixifyBindings codeba
|
||||
f k _ = Set.fromList . fmap Name.toText . filter isAbsolute . toList
|
||||
$ R.lookupRan k rel
|
||||
flatten = Set.toList . fromMaybe Set.empty
|
||||
|
||||
docNames :: Set (HQ'.HashQualified Name) -> [Name]
|
||||
docNames hqs = fmap docify . nubOrd . join . map toList . Set.toList $ hqs
|
||||
where docify n = Name.joinDot n "doc"
|
||||
|
||||
selectDocs :: [Referent] -> Backend IO [Reference]
|
||||
selectDocs rs = do
|
||||
rts <- fmap join . for rs $ \case
|
||||
Referent.Ref r ->
|
||||
maybe [] (pure . (r,)) <$> lift (Codebase.getTypeOfTerm codebase r)
|
||||
_ -> pure []
|
||||
pure [ r | (r, t) <- rts, Typechecker.isSubtype t (Type.ref mempty DD.doc2Ref) ]
|
||||
|
||||
renderDoc :: Reference -> Backend IO [(HashQualifiedName, UnisonHash, Doc.Doc)]
|
||||
renderDoc r = do
|
||||
let name = bestNameForTerm @v (PPE.suffixifiedPPE ppe) width (Referent.Ref r)
|
||||
let hash = Reference.toText r
|
||||
map (name,hash,) . pure <$>
|
||||
let tm = Term.ref () r
|
||||
in Doc.renderDoc @v ppe terms typeOf eval decls tm
|
||||
where
|
||||
terms r@(Reference.Builtin _) = pure (Just (Term.ref () r))
|
||||
terms (Reference.DerivedId r) =
|
||||
fmap Term.unannotate <$> lift (Codebase.getTerm codebase r)
|
||||
|
||||
typeOf r = fmap void <$> lift (Codebase.getTypeOfReferent codebase r)
|
||||
eval (Term.amap (const mempty) -> tm) = do
|
||||
let ppes = PPE.suffixifiedPPE ppe
|
||||
let codeLookup = Codebase.toCodeLookup codebase
|
||||
let cache r = fmap Term.unannotate <$> Codebase.lookupWatchCache codebase r
|
||||
r <- fmap hush . liftIO $ Rt.evaluateTerm' codeLookup cache ppes rt tm
|
||||
lift $ case r of
|
||||
Just tmr -> Codebase.putWatch codebase UF.RegularWatch
|
||||
(Term.hashClosedTerm tm)
|
||||
(Term.amap (const mempty) tmr)
|
||||
Nothing -> pure ()
|
||||
pure $ r <&> Term.amap (const mempty)
|
||||
|
||||
decls (Reference.DerivedId r) = fmap (DD.amap (const ())) <$> lift (Codebase.getTypeDeclaration codebase r)
|
||||
decls _ = pure Nothing
|
||||
|
||||
-- rs0 can be empty or the term fetched, so when viewing a doc term
|
||||
-- you get both its source and its rendered form
|
||||
docResults :: [Reference] -> [Name] -> Backend IO [(HashQualifiedName, UnisonHash, Doc.Doc)]
|
||||
docResults rs0 docs = do
|
||||
let refsFor n = Names3.lookupHQTerm (HQ.NameOnly n) parseNames
|
||||
let rs = Set.unions (refsFor <$> docs) <> Set.fromList (Referent.Ref <$> rs0)
|
||||
-- lookup the type of each, make sure it's a doc
|
||||
docs <- selectDocs (toList rs)
|
||||
-- render all the docs
|
||||
join <$> traverse renderDoc docs
|
||||
|
||||
mkTermDefinition r tm = do
|
||||
ts <- lift (Codebase.getTypeOfTerm codebase r)
|
||||
let bn =
|
||||
bestNameForTerm @v (PPE.suffixifiedPPE ppe) width (Referent.Ref r)
|
||||
let bn = bestNameForTerm @v (PPE.suffixifiedPPE ppe) width (Referent.Ref r)
|
||||
tag <- termEntryTag <$> termListEntry codebase
|
||||
(Branch.head branch)
|
||||
(Referent.Ref r)
|
||||
(HQ'.NameOnly (NameSegment bn))
|
||||
mk ts bn tag
|
||||
docs <- docResults [r] $ docNames (Names3.termName hqLength (Referent.Ref r) printNames)
|
||||
mk docs ts bn tag
|
||||
where
|
||||
mk Nothing _ _ = throwError $ MissingSignatureForTerm r
|
||||
mk (Just typeSig) bn tag =
|
||||
pure
|
||||
. TermDefinition (flatten $ Map.lookup r termFqns)
|
||||
mk _ Nothing _ _ = throwError $ MissingSignatureForTerm r
|
||||
mk docs (Just typeSig) bn tag =
|
||||
pure $
|
||||
TermDefinition (flatten $ Map.lookup r termFqns)
|
||||
bn
|
||||
tag
|
||||
(fmap mungeSyntaxText tm)
|
||||
$ prettyType width ppe typeSig
|
||||
(bimap mungeSyntaxText mungeSyntaxText tm)
|
||||
(formatSuffixedType ppe width typeSig)
|
||||
docs
|
||||
mkTypeDefinition r tp = do
|
||||
let bn = bestNameForType @v (PPE.suffixifiedPPE ppe) width r
|
||||
tag <- Just . typeEntryTag <$> typeListEntry
|
||||
codebase
|
||||
r
|
||||
(HQ'.NameOnly (NameSegment bn))
|
||||
pure . TypeDefinition (flatten $ Map.lookup r typeFqns) bn tag $ fmap
|
||||
mungeSyntaxText
|
||||
tp
|
||||
docs <- docResults [] $ docNames (Names3.typeName hqLength r printNames)
|
||||
pure $ TypeDefinition (flatten $ Map.lookup r typeFqns)
|
||||
bn
|
||||
tag
|
||||
(bimap mungeSyntaxText mungeSyntaxText tp)
|
||||
docs
|
||||
typeDefinitions <- Map.traverseWithKey mkTypeDefinition
|
||||
$ typesToSyntax suffixifyBindings width ppe types
|
||||
termDefinitions <- Map.traverseWithKey mkTermDefinition
|
||||
@ -611,7 +708,7 @@ bestNameForTerm
|
||||
bestNameForTerm ppe width =
|
||||
Text.pack
|
||||
. Pretty.render width
|
||||
. fmap SyntaxText.toPlain
|
||||
. fmap UST.toPlain
|
||||
. TermPrinter.pretty0 @v ppe TermPrinter.emptyAc
|
||||
. Term.fromReferent mempty
|
||||
|
||||
@ -620,7 +717,7 @@ bestNameForType
|
||||
bestNameForType ppe width =
|
||||
Text.pack
|
||||
. Pretty.render width
|
||||
. fmap SyntaxText.toPlain
|
||||
. fmap UST.toPlain
|
||||
. TypePrinter.pretty0 @v ppe mempty (-1)
|
||||
. Type.ref ()
|
||||
|
||||
@ -634,7 +731,7 @@ resolveBranchHash h codebase = case h of
|
||||
|
||||
definitionsBySuffixes
|
||||
:: forall m v
|
||||
. Monad m
|
||||
. (MonadIO m)
|
||||
=> Var v
|
||||
=> Maybe Path
|
||||
-> Branch m
|
||||
@ -676,13 +773,15 @@ definitionsBySuffixes relativeTo branch codebase query = do
|
||||
Just (tm, typ) -> case tm of
|
||||
Term.Ann' _ _ -> UserObject tm
|
||||
_ -> UserObject (Term.ann (ABT.annotation tm) tm typ)
|
||||
r@(Reference.Builtin _) -> pure (r, BuiltinObject)
|
||||
r@(Reference.Builtin _) -> pure $ (r,) $ case Map.lookup r B.termRefTypes of
|
||||
Nothing -> MissingObject $ Reference.toShortHash r
|
||||
Just typ -> BuiltinObject (mempty <$ typ)
|
||||
let loadedDisplayTypes = Map.fromList . (`fmap` toList collatedTypes) $ \case
|
||||
r@(Reference.DerivedId i) ->
|
||||
(r, )
|
||||
. maybe (MissingObject $ Reference.idToShortHash i) UserObject
|
||||
$ Map.lookup i loadedDerivedTypes
|
||||
r@(Reference.Builtin _) -> (r, BuiltinObject)
|
||||
r@(Reference.Builtin _) -> (r, BuiltinObject ())
|
||||
pure $ DefinitionResults loadedDisplayTerms loadedDisplayTypes misses
|
||||
|
||||
termsToSyntax
|
||||
@ -691,8 +790,8 @@ termsToSyntax
|
||||
=> Suffixify
|
||||
-> Width
|
||||
-> PPE.PrettyPrintEnvDecl
|
||||
-> Map Reference.Reference (DisplayObject (Term v a))
|
||||
-> Map Reference.Reference (DisplayObject SyntaxText)
|
||||
-> Map Reference.Reference (DisplayObject (Type v a) (Term v a))
|
||||
-> Map Reference.Reference (DisplayObject UST.SyntaxText UST.SyntaxText)
|
||||
termsToSyntax suff width ppe0 terms =
|
||||
Map.fromList . map go . Map.toList $ Map.mapKeys
|
||||
(first (PPE.termName ppeDecl . Referent.Ref) . dupe)
|
||||
@ -703,8 +802,12 @@ termsToSyntax suff width ppe0 terms =
|
||||
else PPE.declarationPPE ppe0 r
|
||||
ppeDecl =
|
||||
(if suffixified suff then PPE.suffixifiedPPE else PPE.unsuffixifiedPPE) ppe0
|
||||
go ((n, r), dt) =
|
||||
(r, Pretty.render width . TermPrinter.prettyBinding (ppeBody r) n <$> dt)
|
||||
go ((n, r), dt) = (r,) $ case dt of
|
||||
DisplayObject.BuiltinObject typ -> DisplayObject.BuiltinObject $
|
||||
formatType' (ppeBody r) width typ
|
||||
DisplayObject.MissingObject sh -> DisplayObject.MissingObject sh
|
||||
DisplayObject.UserObject tm -> DisplayObject.UserObject .
|
||||
Pretty.render width . TermPrinter.prettyBinding (ppeBody r) n $ tm
|
||||
|
||||
typesToSyntax
|
||||
:: Var v
|
||||
@ -712,8 +815,8 @@ typesToSyntax
|
||||
=> Suffixify
|
||||
-> Width
|
||||
-> PPE.PrettyPrintEnvDecl
|
||||
-> Map Reference.Reference (DisplayObject (DD.Decl v a))
|
||||
-> Map Reference.Reference (DisplayObject SyntaxText)
|
||||
-> Map Reference.Reference (DisplayObject () (DD.Decl v a))
|
||||
-> Map Reference.Reference (DisplayObject UST.SyntaxText UST.SyntaxText)
|
||||
typesToSyntax suff width ppe0 types =
|
||||
Map.fromList $ map go . Map.toList $ Map.mapKeys
|
||||
(first (PPE.typeName ppeDecl) . dupe)
|
||||
@ -725,16 +828,11 @@ typesToSyntax suff width ppe0 types =
|
||||
ppeDecl = if suffixified suff
|
||||
then PPE.suffixifiedPPE ppe0
|
||||
else PPE.unsuffixifiedPPE ppe0
|
||||
go ((n, r), dt) =
|
||||
( r
|
||||
, (\case
|
||||
Left d ->
|
||||
Pretty.render width $ DeclPrinter.prettyEffectDecl (ppeBody r) r n d
|
||||
Right d ->
|
||||
Pretty.render width $ DeclPrinter.prettyDataDecl (ppeBody r) r n d
|
||||
)
|
||||
<$> dt
|
||||
)
|
||||
go ((n, r), dt) = (r,) $ case dt of
|
||||
BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r)
|
||||
MissingObject sh -> MissingObject sh
|
||||
UserObject d -> UserObject . Pretty.render width $
|
||||
DeclPrinter.prettyDecl (ppeBody r) r n d
|
||||
|
||||
loadSearchResults
|
||||
:: (Var v, Applicative m)
|
||||
@ -755,9 +853,9 @@ loadTypeDisplayObject
|
||||
:: Applicative m
|
||||
=> Codebase m v Ann
|
||||
-> Reference
|
||||
-> m (DisplayObject (DD.Decl v Ann))
|
||||
-> m (DisplayObject () (DD.Decl v Ann))
|
||||
loadTypeDisplayObject c = \case
|
||||
Reference.Builtin _ -> pure BuiltinObject
|
||||
Reference.Builtin _ -> pure (BuiltinObject ())
|
||||
Reference.DerivedId id ->
|
||||
maybe (MissingObject $ Reference.idToShortHash id) UserObject
|
||||
<$> Codebase.getTypeDeclaration c id
|
||||
|
||||
@ -92,6 +92,7 @@ import System.FilePath ((</>))
|
||||
import qualified System.FilePath as FilePath
|
||||
import System.Random.Stateful (getStdGen, newAtomicGenM, uniformByteStringM)
|
||||
import Unison.Codebase (Codebase)
|
||||
import qualified Unison.Codebase.Runtime as Rt
|
||||
import Unison.Parser (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.Server.Endpoints.FuzzyFind (FuzzyFindAPI, serveFuzzyFind)
|
||||
@ -166,12 +167,13 @@ serverAPI = Proxy
|
||||
|
||||
app
|
||||
:: Var v
|
||||
=> Codebase IO v Ann
|
||||
=> Rt.Runtime v
|
||||
-> Codebase IO v Ann
|
||||
-> FilePath
|
||||
-> Strict.ByteString
|
||||
-> Application
|
||||
app codebase uiPath expectedToken =
|
||||
serve serverAPI $ server codebase uiPath expectedToken
|
||||
app rt codebase uiPath expectedToken =
|
||||
serve serverAPI $ server rt codebase uiPath expectedToken
|
||||
|
||||
genToken :: IO Strict.ByteString
|
||||
genToken = do
|
||||
@ -208,10 +210,11 @@ ucmTokenVar = "UCM_TOKEN"
|
||||
-- The auth token required for accessing the server is passed to the function k
|
||||
start
|
||||
:: Var v
|
||||
=> Codebase IO v Ann
|
||||
=> Rt.Runtime v
|
||||
-> Codebase IO v Ann
|
||||
-> (Strict.ByteString -> Port -> IO ())
|
||||
-> IO ()
|
||||
start codebase k = do
|
||||
start rt codebase k = do
|
||||
envToken <- lookupEnv ucmTokenVar
|
||||
envHost <- lookupEnv ucmHostVar
|
||||
envPort <- (readMaybe =<<) <$> lookupEnv ucmPortVar
|
||||
@ -253,19 +256,20 @@ start codebase k = do
|
||||
mayOpts =
|
||||
getParseResult $ execParserPure defaultPrefs (info p forwardOptions) args
|
||||
case mayOpts of
|
||||
Just (_, token, host, port, ui) -> startServer codebase k token host port ui
|
||||
Nothing -> startServer codebase k Nothing Nothing Nothing Nothing
|
||||
Just (_, token, host, port, ui) -> startServer rt codebase k token host port ui
|
||||
Nothing -> startServer rt codebase k Nothing Nothing Nothing Nothing
|
||||
|
||||
startServer
|
||||
:: Var v
|
||||
=> Codebase IO v Ann
|
||||
=> Rt.Runtime v
|
||||
-> Codebase IO v Ann
|
||||
-> (Strict.ByteString -> Port -> IO ())
|
||||
-> Maybe String
|
||||
-> Maybe String
|
||||
-> Maybe Port
|
||||
-> Maybe String
|
||||
-> IO ()
|
||||
startServer codebase k envToken envHost envPort envUI0 = do
|
||||
startServer rt codebase k envToken envHost envPort envUI0 = do
|
||||
-- the `canonicalizePath` resolves symlinks
|
||||
exePath <- canonicalizePath =<< getExecutablePath
|
||||
envUI <- canonicalizePath $ fromMaybe (FilePath.takeDirectory exePath </> "ui") envUI0
|
||||
@ -277,7 +281,7 @@ startServer codebase k envToken envHost envPort envUI0 = do
|
||||
<> foldMap (Endo . setHost . fromString) envHost
|
||||
)
|
||||
defaultSettings
|
||||
a = app codebase envUI token
|
||||
a = app rt codebase envUI token
|
||||
case envPort of
|
||||
Nothing -> withApplicationSettings settings (pure a) (k token)
|
||||
Just p -> do
|
||||
@ -311,16 +315,17 @@ serveUI tryAuth path _ = tryAuth *> serveIndex path
|
||||
|
||||
server
|
||||
:: Var v
|
||||
=> Codebase IO v Ann
|
||||
=> Rt.Runtime v
|
||||
-> Codebase IO v Ann
|
||||
-> FilePath
|
||||
-> Strict.ByteString
|
||||
-> Server AuthedServerAPI
|
||||
server codebase uiPath token =
|
||||
server rt codebase uiPath token =
|
||||
serveDirectoryWebApp (uiPath </> "static")
|
||||
:<|> ((\t ->
|
||||
serveUI (tryAuth t) uiPath
|
||||
:<|> ( ( (serveNamespace (tryAuth t) codebase)
|
||||
:<|> (serveDefinitions (tryAuth t) codebase)
|
||||
:<|> (serveDefinitions (tryAuth t) rt codebase)
|
||||
:<|> (serveFuzzyFind (tryAuth t) codebase)
|
||||
)
|
||||
:<|> serveOpenAPI
|
||||
|
||||
275
parser-typechecker/src/Unison/Server/Doc.hs
Normal file
275
parser-typechecker/src/Unison/Server/Doc.hs
Normal file
@ -0,0 +1,275 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Server.Doc where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Word
|
||||
import GHC.Generics (Generic)
|
||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject)
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Server.Syntax (SyntaxText)
|
||||
import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import Unison.Var (Var)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Builtin.Decls as DD
|
||||
import qualified Unison.Builtin.Decls as Decls
|
||||
import qualified Unison.Codebase.Editor.DisplayObject as DO
|
||||
import qualified Unison.DataDeclaration as DD
|
||||
import qualified Unison.DeclPrinter as DeclPrinter
|
||||
import qualified Unison.NamePrinter as NP
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.Runtime.IOSource as DD
|
||||
import qualified Unison.Server.Syntax as Syntax
|
||||
import qualified Unison.ShortHash as SH
|
||||
import qualified Unison.Term as Term
|
||||
import qualified Unison.TermPrinter as TermPrinter
|
||||
import qualified Unison.Type as Type
|
||||
import qualified Unison.TypePrinter as TypePrinter
|
||||
import qualified Unison.Util.Pretty as P
|
||||
import qualified Unison.Util.SyntaxText as S
|
||||
|
||||
type Nat = Word64
|
||||
|
||||
data Doc
|
||||
= Word Text
|
||||
| Code Doc
|
||||
| CodeBlock Text Doc
|
||||
| Bold Doc
|
||||
| Italic Doc
|
||||
| Strikethrough Doc
|
||||
| Style Text Doc
|
||||
| Anchor Text Doc
|
||||
| Blockquote Doc
|
||||
| Blankline
|
||||
| Linebreak
|
||||
| SectionBreak
|
||||
| Tooltip Doc Doc
|
||||
| Aside Doc
|
||||
| Callout (Maybe Doc) Doc
|
||||
| Table [[Doc]]
|
||||
| Folded Bool Doc Doc
|
||||
| Paragraph [Doc]
|
||||
| BulletedList [Doc]
|
||||
| NumberedList Nat [Doc]
|
||||
| Section Doc [Doc]
|
||||
| NamedLink Doc Doc
|
||||
| Image Doc Doc (Maybe Doc)
|
||||
| Special SpecialForm
|
||||
| Join [Doc]
|
||||
| UntitledSection [Doc]
|
||||
| Column [Doc]
|
||||
| Group Doc
|
||||
deriving (Eq,Show,Generic)
|
||||
|
||||
type UnisonHash = Text
|
||||
|
||||
data Ref a = Term a | Type a deriving (Eq,Show,Generic,Functor,Foldable,Traversable)
|
||||
|
||||
data SpecialForm
|
||||
= Source [Ref (UnisonHash, DisplayObject SyntaxText Src)]
|
||||
| FoldedSource [Ref (UnisonHash, DisplayObject SyntaxText Src)]
|
||||
| Example SyntaxText
|
||||
| ExampleBlock SyntaxText
|
||||
| Link SyntaxText
|
||||
| Signature [SyntaxText]
|
||||
| SignatureInline SyntaxText
|
||||
| Eval SyntaxText SyntaxText
|
||||
| EvalInline SyntaxText SyntaxText
|
||||
| Embed SyntaxText
|
||||
| EmbedInline SyntaxText
|
||||
deriving (Eq,Show,Generic)
|
||||
|
||||
-- `Src folded unfolded`
|
||||
data Src = Src SyntaxText SyntaxText deriving (Eq,Show,Generic)
|
||||
|
||||
renderDoc :: forall v m . (Var v, Monad m)
|
||||
=> PPE.PrettyPrintEnvDecl
|
||||
-> (Reference -> m (Maybe (Term v ())))
|
||||
-> (Referent -> m (Maybe (Type v ())))
|
||||
-> (Term v () -> m (Maybe (Term v ())))
|
||||
-> (Reference -> m (Maybe (DD.Decl v ())))
|
||||
-> Term v ()
|
||||
-> m Doc
|
||||
renderDoc pped terms typeOf eval types tm = eval tm >>= \case
|
||||
Nothing -> pure $ Word "🆘 doc rendering failed during evaluation"
|
||||
Just tm -> go tm
|
||||
where
|
||||
go = \case
|
||||
DD.Doc2Word txt -> pure $ Word txt
|
||||
DD.Doc2Code d -> Code <$> go d
|
||||
DD.Doc2CodeBlock lang d -> CodeBlock lang <$> go d
|
||||
DD.Doc2Bold d -> Bold <$> go d
|
||||
DD.Doc2Italic d -> Italic <$> go d
|
||||
DD.Doc2Strikethrough d -> Strikethrough <$> go d
|
||||
DD.Doc2Style s d -> Style s <$> go d
|
||||
DD.Doc2Anchor id d -> Anchor id <$> go d
|
||||
DD.Doc2Blockquote d -> Blockquote <$> go d
|
||||
DD.Doc2Blankline -> pure Blankline
|
||||
DD.Doc2Linebreak -> pure Linebreak
|
||||
DD.Doc2SectionBreak -> pure SectionBreak
|
||||
DD.Doc2Tooltip d1 d2 -> Tooltip <$> go d1 <*> go d2
|
||||
DD.Doc2Aside d -> Aside <$> go d
|
||||
DD.Doc2Callout Decls.OptionalNone' d -> Callout Nothing <$> go d
|
||||
DD.Doc2Callout (Decls.OptionalSome' icon) d -> Callout <$> (Just <$> go icon) <*> go d
|
||||
DD.Doc2Table rows -> Table <$> traverse r rows
|
||||
where r (Term.List' ds) = traverse go (toList ds)
|
||||
r _ = pure [Word "🆘 invalid table"]
|
||||
DD.Doc2Folded isFolded d d2 -> Folded isFolded <$> go d <*> go d2
|
||||
DD.Doc2Paragraph ds -> Paragraph <$> traverse go ds
|
||||
DD.Doc2BulletedList ds -> BulletedList <$> traverse go ds
|
||||
DD.Doc2Section title ds -> Section <$> go title <*> traverse go ds
|
||||
DD.Doc2NamedLink d1 d2 -> NamedLink <$> go d1 <*> go d2
|
||||
DD.Doc2Image d1 d2 Decls.OptionalNone' -> Image <$> go d1 <*> go d2 <*> pure Nothing
|
||||
DD.Doc2Image d1 d2 (Decls.OptionalSome' d) -> Image <$> go d1 <*> go d2 <*> (Just <$> go d)
|
||||
DD.Doc2Special sf -> Special <$> goSpecial sf
|
||||
DD.Doc2Join ds -> Join <$> traverse go ds
|
||||
DD.Doc2UntitledSection ds -> UntitledSection <$> traverse go ds
|
||||
DD.Doc2Column ds -> Column <$> traverse go ds
|
||||
DD.Doc2Group d -> Group <$> go d
|
||||
wat -> pure . Word . Text.pack . P.toPlain (P.Width 80) . P.indent "🆘 "
|
||||
. TermPrinter.pretty (PPE.suffixifiedPPE pped) $ wat
|
||||
|
||||
formatPretty = fmap Syntax.convertElement . P.render (P.Width 70)
|
||||
formatPrettyType ppe typ = formatPretty (TypePrinter.prettySyntax ppe typ)
|
||||
|
||||
source :: Term v () -> m SyntaxText
|
||||
source tm = (pure . formatPretty . TermPrinter.prettyBlock' True (PPE.suffixifiedPPE pped)) tm
|
||||
|
||||
goSignatures :: [Referent] -> m [P.Pretty S.SyntaxText]
|
||||
goSignatures rs = runMaybeT (traverse (MaybeT . typeOf) rs) >>= \case
|
||||
Nothing -> pure ["🆘 codebase is missing type signature for these definitions"]
|
||||
Just types -> pure . fmap P.group $
|
||||
TypePrinter.prettySignatures''
|
||||
(PPE.suffixifiedPPE pped)
|
||||
[ (PPE.termName (PPE.suffixifiedPPE pped) r, ty) | (r,ty) <- zip rs types]
|
||||
|
||||
goSpecial :: Term v () -> m SpecialForm
|
||||
goSpecial = \case
|
||||
|
||||
DD.Doc2SpecialFormFoldedSource (Term.List' es) -> FoldedSource <$> goSrc (toList es)
|
||||
|
||||
-- Source [Either Link.Type Doc2.Term]
|
||||
DD.Doc2SpecialFormSource (Term.List' es) -> Source <$> goSrc (toList es)
|
||||
|
||||
-- Example Nat Doc2.Term
|
||||
-- Examples like `foo x y` are encoded as `Example 2 (_ x y -> foo)`, where
|
||||
-- 2 is the number of variables that should be dropped from the rendering.
|
||||
-- So this will render as `foo x y`.
|
||||
DD.Doc2SpecialFormExample n (DD.Doc2Example vs body) ->
|
||||
Example <$> source ex
|
||||
where ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) vs) body
|
||||
|
||||
DD.Doc2SpecialFormExampleBlock n (DD.Doc2Example vs body) ->
|
||||
ExampleBlock <$> source ex
|
||||
where ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) vs) body
|
||||
|
||||
-- Link (Either Link.Type Doc2.Term)
|
||||
DD.Doc2SpecialFormLink e -> let
|
||||
ppe = PPE.suffixifiedPPE pped
|
||||
tm :: Referent -> P.Pretty S.SyntaxText
|
||||
tm r = (NP.styleHashQualified'' (NP.fmt (S.Referent r)) . PPE.termName ppe) r
|
||||
ty :: Reference -> P.Pretty S.SyntaxText
|
||||
ty r = (NP.styleHashQualified'' (NP.fmt (S.Reference r)) . PPE.typeName ppe) r
|
||||
in Link <$> case e of
|
||||
DD.EitherLeft' (Term.TypeLink' r) -> (pure . formatPretty . ty) r
|
||||
DD.EitherRight' (DD.Doc2Term (Term.Referent' r)) -> (pure . formatPretty . tm) r
|
||||
_ -> source e
|
||||
|
||||
DD.Doc2SpecialFormSignature (Term.List' tms) ->
|
||||
let rs = [ r | DD.Doc2Term (Term.Referent' r) <- toList tms ]
|
||||
in goSignatures rs <&> \s -> Signature (map formatPretty s)
|
||||
|
||||
-- SignatureInline Doc2.Term
|
||||
DD.Doc2SpecialFormSignatureInline (DD.Doc2Term (Term.Referent' r)) ->
|
||||
goSignatures [r] <&> \s -> SignatureInline (formatPretty (P.lines s))
|
||||
|
||||
-- Eval Doc2.Term
|
||||
DD.Doc2SpecialFormEval (DD.Doc2Term tm) -> eval tm >>= \case
|
||||
Nothing -> Eval <$> source tm <*> pure evalErrMsg
|
||||
Just result -> Eval <$> source tm <*> source result
|
||||
|
||||
-- EvalInline Doc2.Term
|
||||
DD.Doc2SpecialFormEvalInline (DD.Doc2Term tm) -> eval tm >>= \case
|
||||
Nothing -> EvalInline <$> source tm <*> pure evalErrMsg
|
||||
Just result -> EvalInline <$> source tm <*> source result
|
||||
|
||||
-- Embed Any
|
||||
DD.Doc2SpecialFormEmbed (Term.App' _ any) ->
|
||||
source any <&> \p -> Embed ("{{ embed {{" <> p <> "}} }}")
|
||||
|
||||
-- EmbedInline Any
|
||||
DD.Doc2SpecialFormEmbedInline any ->
|
||||
source any <&> \p -> EmbedInline ("{{ embed {{" <> p <> "}} }}")
|
||||
|
||||
tm -> source tm <&> \p -> Embed ("🆘 unable to render " <> p)
|
||||
|
||||
evalErrMsg = "🆘 An error occured during evaluation"
|
||||
|
||||
goSrc :: [Term v ()] -> m [Ref (UnisonHash, DisplayObject SyntaxText Src)]
|
||||
goSrc es = do
|
||||
let toRef (Term.Ref' r) = Set.singleton r
|
||||
toRef (Term.RequestOrCtor' r _) = Set.singleton r
|
||||
toRef _ = mempty
|
||||
ppe = PPE.suffixifiedPPE pped
|
||||
goType :: Reference -> m (Ref (UnisonHash, DisplayObject SyntaxText Src))
|
||||
goType r@(Reference.Builtin _) =
|
||||
pure (Type (Reference.toText r, DO.BuiltinObject name))
|
||||
where name = formatPretty . NP.styleHashQualified (NP.fmt (S.Reference r))
|
||||
. PPE.typeName ppe $ r
|
||||
goType r = Type . (Reference.toText r,) <$> do
|
||||
d <- types r
|
||||
case d of
|
||||
Nothing -> pure (DO.MissingObject (SH.unsafeFromText $ Reference.toText r))
|
||||
Just decl ->
|
||||
pure $ DO.UserObject (Src folded full)
|
||||
where
|
||||
full = formatPretty (DeclPrinter.prettyDecl ppe r (PPE.typeName ppe r) decl)
|
||||
folded = formatPretty (DeclPrinter.prettyDeclHeader (PPE.typeName ppe r) decl)
|
||||
|
||||
go :: (Set.Set Reference, [Ref (UnisonHash, DisplayObject SyntaxText Src)])
|
||||
-> Term v ()
|
||||
-> m (Set.Set Reference, [Ref (UnisonHash, DisplayObject SyntaxText Src)])
|
||||
go s1@(!seen,!acc) = \case
|
||||
-- we ignore the annotations; but this could be extended later
|
||||
DD.TupleTerm' [DD.EitherRight' (DD.Doc2Term tm), _anns] ->
|
||||
(seen <> toRef tm,) <$> acc'
|
||||
where
|
||||
acc' = case tm of
|
||||
Term.Ref' r | Set.notMember r seen -> (:acc) . Term . (Reference.toText r,) <$> case r of
|
||||
Reference.Builtin _ -> typeOf (Referent.Ref r) <&> \case
|
||||
Nothing -> DO.BuiltinObject ("🆘 missing type signature")
|
||||
Just ty -> DO.BuiltinObject (formatPrettyType ppe ty)
|
||||
ref -> terms ref >>= \case
|
||||
Nothing -> pure $ DO.MissingObject (SH.unsafeFromText $ Reference.toText ref)
|
||||
Just tm -> do
|
||||
typ <- fromMaybe (Type.builtin() "unknown") <$> typeOf (Referent.Ref ref)
|
||||
let name = PPE.termName ppe (Referent.Ref ref)
|
||||
let full = formatPretty (TermPrinter.prettyBinding ppe name tm)
|
||||
let folded = formatPretty . P.lines $ TypePrinter.prettySignatures'' ppe [(name, typ)]
|
||||
pure (DO.UserObject (Src folded full))
|
||||
Term.RequestOrCtor' r _ | Set.notMember r seen -> (:acc) <$> goType r
|
||||
_ -> pure acc
|
||||
DD.TupleTerm' [DD.EitherLeft' (Term.TypeLink' ref), _anns]
|
||||
| Set.notMember ref seen
|
||||
-> (Set.insert ref seen,) . (:acc) <$> goType ref
|
||||
_ -> pure s1
|
||||
reverse . snd <$> foldM go mempty es
|
||||
|
||||
@ -15,7 +15,6 @@ import Control.Lens (view, _1)
|
||||
import Data.Aeson
|
||||
import Data.Function (on)
|
||||
import Data.List (sortBy)
|
||||
import qualified Data.Map as Map
|
||||
import Data.OpenApi (ToSchema)
|
||||
import Data.Ord (Down (..))
|
||||
import qualified Data.Text as Text
|
||||
@ -40,12 +39,10 @@ import qualified Unison.Codebase.Branch as Branch
|
||||
import Unison.Codebase.Editor.DisplayObject
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Codebase.ShortBranchHash as SBH
|
||||
import qualified Unison.HashQualified as HQ
|
||||
import qualified Unison.HashQualified' as HQ'
|
||||
import Unison.NameSegment
|
||||
import Unison.Parser (Ann)
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Server.Backend as Backend
|
||||
import Unison.Server.Errors
|
||||
( backendError,
|
||||
@ -55,12 +52,9 @@ import Unison.Server.Syntax (SyntaxText)
|
||||
import Unison.Server.Types
|
||||
( APIGet,
|
||||
APIHeaders,
|
||||
DefinitionDisplayResults (..),
|
||||
HashQualifiedName,
|
||||
NamedTerm,
|
||||
NamedType,
|
||||
Suffixify (..),
|
||||
TypeDefinition (..),
|
||||
addHeaders,
|
||||
mayDefault,
|
||||
)
|
||||
@ -112,7 +106,7 @@ data FoundTerm = FoundTerm
|
||||
|
||||
data FoundType = FoundType
|
||||
{ bestFoundTypeName :: HashQualifiedName
|
||||
, typeDef :: DisplayObject SyntaxText
|
||||
, typeDef :: DisplayObject SyntaxText SyntaxText
|
||||
, namedType :: NamedType
|
||||
} deriving (Generic, Show)
|
||||
|
||||
@ -165,9 +159,9 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query =
|
||||
join <$> traverse (loadEntry root (Just rel) ppe b0) alignments
|
||||
errFromEither backendError ea
|
||||
where
|
||||
loadEntry root rel ppe b0 (a, (HQ'.NameOnly . NameSegment) -> n, refs) =
|
||||
traverse
|
||||
(\case
|
||||
loadEntry _root _rel ppe b0 (a, (HQ'.NameOnly . NameSegment) -> n, refs) =
|
||||
for refs $
|
||||
\case
|
||||
Backend.FoundTermRef r ->
|
||||
(\te ->
|
||||
( a
|
||||
@ -179,29 +173,12 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query =
|
||||
)
|
||||
<$> Backend.termListEntry codebase b0 r n
|
||||
Backend.FoundTypeRef r -> do
|
||||
te <- Backend.typeListEntry codebase r n
|
||||
DefinitionDisplayResults _ ts _ <- Backend.prettyDefinitionsBySuffixes
|
||||
rel
|
||||
root
|
||||
typeWidth
|
||||
(Suffixify True)
|
||||
codebase
|
||||
[HQ.HashOnly $ Reference.toShortHash r]
|
||||
let
|
||||
t = Map.lookup (Reference.toText r) ts
|
||||
td = case t of
|
||||
Just t -> t
|
||||
Nothing ->
|
||||
TypeDefinition mempty mempty Nothing
|
||||
. MissingObject
|
||||
$ Reference.toShortHash r
|
||||
namedType = Backend.typeEntryToNamedType te
|
||||
pure
|
||||
( a
|
||||
, FoundTypeResult
|
||||
$ FoundType (bestTypeName td) (typeDefinition td) namedType
|
||||
)
|
||||
)
|
||||
refs
|
||||
te <- Backend.typeListEntry codebase r n
|
||||
let namedType = Backend.typeEntryToNamedType te
|
||||
let typeName = Backend.bestNameForType @v ppe (mayDefault typeWidth) r
|
||||
typeHeader <- Backend.typeDeclHeader codebase ppe r
|
||||
let ft = FoundType typeName typeHeader namedType
|
||||
pure (a, FoundTypeResult ft)
|
||||
|
||||
parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p
|
||||
errFromEither f = either (throwError . f) pure
|
||||
|
||||
@ -24,6 +24,7 @@ import Servant.Docs
|
||||
import Servant.Server (Handler)
|
||||
import Unison.Codebase (Codebase)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Codebase.Runtime as Rt
|
||||
import Unison.Codebase.ShortBranchHash
|
||||
( ShortBranchHash,
|
||||
)
|
||||
@ -108,6 +109,7 @@ instance ToSample DefinitionDisplayResults where
|
||||
serveDefinitions
|
||||
:: Var v
|
||||
=> Handler ()
|
||||
-> Rt.Runtime v
|
||||
-> Codebase IO v Ann
|
||||
-> Maybe ShortBranchHash
|
||||
-> Maybe HashQualifiedName
|
||||
@ -115,7 +117,7 @@ serveDefinitions
|
||||
-> Maybe Width
|
||||
-> Maybe Suffixify
|
||||
-> Handler (APIHeaders DefinitionDisplayResults)
|
||||
serveDefinitions h codebase mayRoot relativePath hqns width suff =
|
||||
serveDefinitions h rt codebase mayRoot relativePath hqns width suff =
|
||||
addHeaders <$> do
|
||||
h
|
||||
rel <-
|
||||
@ -126,6 +128,7 @@ serveDefinitions h codebase mayRoot relativePath hqns width suff =
|
||||
root
|
||||
width
|
||||
(fromMaybe (Suffixify True) suff)
|
||||
rt
|
||||
codebase
|
||||
$ HQ.unsafeFromText
|
||||
<$> hqns
|
||||
|
||||
@ -32,7 +32,7 @@ data TermResult' v a =
|
||||
|
||||
data TypeResult' v a =
|
||||
TypeResult' (HQ'.HashQualified Name)
|
||||
(DisplayObject (Decl v a))
|
||||
(DisplayObject () (Decl v a))
|
||||
Reference
|
||||
(Set (HQ'.HashQualified Name))
|
||||
deriving (Eq, Show)
|
||||
|
||||
@ -35,17 +35,11 @@ import Unison.ConstructorType (ConstructorType)
|
||||
import qualified Unison.HashQualified as HQ
|
||||
import Unison.Name (Name)
|
||||
import Unison.Prelude
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import Unison.Server.Doc (Doc)
|
||||
import qualified Unison.Server.Doc as Doc
|
||||
import Unison.Server.Syntax (SyntaxText)
|
||||
import qualified Unison.Server.Syntax as Syntax
|
||||
import Unison.ShortHash (ShortHash)
|
||||
import Unison.Type (Type)
|
||||
import qualified Unison.TypePrinter as TypePrinter
|
||||
import Unison.Util.Pretty
|
||||
( Width (..),
|
||||
render,
|
||||
)
|
||||
import Unison.Var (Var)
|
||||
import Unison.Util.Pretty ( Width (..) )
|
||||
|
||||
type APIHeaders x =
|
||||
Headers
|
||||
@ -77,9 +71,9 @@ deriving instance ToParamSchema ShortBranchHash
|
||||
deriving via Int instance FromHttpApiData Width
|
||||
deriving instance ToParamSchema Width
|
||||
|
||||
instance ToJSON a => ToJSON (DisplayObject a) where
|
||||
instance (ToJSON b, ToJSON a) => ToJSON (DisplayObject b a) where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
deriving instance ToSchema a => ToSchema (DisplayObject a)
|
||||
deriving instance (ToSchema b, ToSchema a) => ToSchema (DisplayObject b a)
|
||||
|
||||
instance ToJSON ShortHash where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
@ -117,15 +111,17 @@ data TermDefinition = TermDefinition
|
||||
{ termNames :: [HashQualifiedName]
|
||||
, bestTermName :: HashQualifiedName
|
||||
, defnTermTag :: Maybe TermTag
|
||||
, termDefinition :: DisplayObject SyntaxText
|
||||
, termDefinition :: DisplayObject SyntaxText SyntaxText
|
||||
, signature :: SyntaxText
|
||||
, termDocs :: [(HashQualifiedName, UnisonHash, Doc)]
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
data TypeDefinition = TypeDefinition
|
||||
{ typeNames :: [HashQualifiedName]
|
||||
, bestTypeName :: HashQualifiedName
|
||||
, defnTypeTag :: Maybe TypeTag
|
||||
, typeDefinition :: DisplayObject SyntaxText
|
||||
, typeDefinition :: DisplayObject SyntaxText SyntaxText
|
||||
, typeDocs :: [(HashQualifiedName, UnisonHash, Doc)]
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
data DefinitionDisplayResults =
|
||||
@ -196,9 +192,14 @@ instance ToJSON TypeTag where
|
||||
|
||||
deriving instance ToSchema TypeTag
|
||||
|
||||
formatType :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText
|
||||
formatType ppe w =
|
||||
fmap Syntax.convertElement . render w . TypePrinter.pretty0 ppe mempty (-1)
|
||||
instance ToJSON Doc where
|
||||
instance ToJSON Doc.SpecialForm where
|
||||
instance ToJSON Doc.Src where
|
||||
instance ToJSON a => ToJSON (Doc.Ref a) where
|
||||
instance ToSchema Doc where
|
||||
instance ToSchema Doc.SpecialForm where
|
||||
instance ToSchema Doc.Src where
|
||||
instance ToSchema a => ToSchema (Doc.Ref a) where
|
||||
|
||||
munge :: Text -> LZ.ByteString
|
||||
munge = Text.encodeUtf8 . Text.fromStrict
|
||||
|
||||
@ -51,9 +51,11 @@ pretty :: Var v => PrettyPrintEnv -> Term v a -> Pretty ColorText
|
||||
pretty env = PP.syntaxToColor . pretty0 env emptyAc . printAnnotate env
|
||||
|
||||
prettyBlock :: Var v => Bool -> PrettyPrintEnv -> Term v a -> Pretty ColorText
|
||||
prettyBlock elideUnit env =
|
||||
PP.syntaxToColor . pretty0 env (emptyBlockAc { elideUnit = elideUnit })
|
||||
. printAnnotate env
|
||||
prettyBlock elideUnit env = PP.syntaxToColor . prettyBlock' elideUnit env
|
||||
|
||||
prettyBlock' :: Var v => Bool -> PrettyPrintEnv -> Term v a -> Pretty SyntaxText
|
||||
prettyBlock' elideUnit env =
|
||||
pretty0 env (emptyBlockAc { elideUnit = elideUnit }) . printAnnotate env
|
||||
|
||||
pretty' :: Var v => Maybe Width -> PrettyPrintEnv -> Term v a -> ColorText
|
||||
pretty' (Just width) n t =
|
||||
|
||||
@ -23,7 +23,10 @@ import qualified Unison.Var as Var
|
||||
import qualified Unison.Builtin.Decls as DD
|
||||
|
||||
pretty :: forall v a . (Var v) => PrettyPrintEnv -> Type v a -> Pretty ColorText
|
||||
pretty ppe = PP.syntaxToColor . pretty0 ppe mempty (-1)
|
||||
pretty ppe = PP.syntaxToColor . prettySyntax ppe
|
||||
|
||||
prettySyntax :: forall v a . (Var v) => PrettyPrintEnv -> Type v a -> Pretty SyntaxText
|
||||
prettySyntax ppe = pretty0 ppe mempty (-1)
|
||||
|
||||
pretty' :: Var v => Maybe Width -> PrettyPrintEnv -> Type v a -> String
|
||||
pretty' (Just width) n t =
|
||||
@ -143,7 +146,13 @@ prettySignatures'
|
||||
:: Var v => PrettyPrintEnv
|
||||
-> [(HashQualified Name, Type v a)]
|
||||
-> [Pretty ColorText]
|
||||
prettySignatures' env ts = map PP.syntaxToColor $ PP.align
|
||||
prettySignatures' env ts = map PP.syntaxToColor $ prettySignatures'' env ts
|
||||
|
||||
prettySignatures''
|
||||
:: Var v => PrettyPrintEnv
|
||||
-> [(HashQualified Name, Type v a)]
|
||||
-> [Pretty SyntaxText]
|
||||
prettySignatures'' env ts = PP.align
|
||||
[ ( styleHashQualified'' (fmt $ S.HashQualifier name) name
|
||||
, (fmt S.TypeAscriptionColon ": " <> pretty0 env Map.empty (-1) typ)
|
||||
`PP.orElse` ( fmt S.TypeAscriptionColon ": "
|
||||
|
||||
@ -57,7 +57,7 @@ data Element r = NumericLiteral
|
||||
| DocDelimiter
|
||||
-- the 'include' in @[include], etc
|
||||
| DocKeyword
|
||||
deriving (Eq, Ord, Show, Generic, Functor)
|
||||
deriving (Eq, Ord, Show, Functor)
|
||||
|
||||
syntax :: Element r -> SyntaxText' r -> SyntaxText' r
|
||||
syntax = annotate
|
||||
|
||||
@ -115,6 +115,7 @@ library
|
||||
Unison.Runtime.Vector
|
||||
Unison.Server.Backend
|
||||
Unison.Server.CodebaseServer
|
||||
Unison.Server.Doc
|
||||
Unison.Server.Endpoints.FuzzyFind
|
||||
Unison.Server.Endpoints.GetDefinitions
|
||||
Unison.Server.Endpoints.ListNamespace
|
||||
|
||||
@ -45,6 +45,7 @@ import Unison.CommandLine (plural', watchConfig)
|
||||
import qualified Unison.CommandLine.Main as CommandLine
|
||||
import Unison.Parser (Ann)
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Codebase.Runtime as Rt
|
||||
import qualified Unison.PrettyTerminal as PT
|
||||
import qualified Unison.Runtime.Interface as RTI
|
||||
import qualified Unison.Server.CodebaseServer as Server
|
||||
@ -185,8 +186,9 @@ main = do
|
||||
Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable."
|
||||
Right contents -> do
|
||||
(closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
|
||||
rt <- RTI.startRuntime
|
||||
let fileEvent = Input.UnisonFileChanged (Text.pack file) contents
|
||||
launch currentDir config theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI]
|
||||
launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI]
|
||||
closeCodebase
|
||||
"run.pipe" : [mainName] -> do
|
||||
e <- safeReadUtf8StdIn
|
||||
@ -194,9 +196,10 @@ main = do
|
||||
Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input."
|
||||
Right contents -> do
|
||||
(closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
|
||||
rt <- RTI.startRuntime
|
||||
let fileEvent = Input.UnisonFileChanged (Text.pack "<standard input>") contents
|
||||
launch
|
||||
currentDir config theCodebase
|
||||
currentDir config rt theCodebase
|
||||
[Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI]
|
||||
closeCodebase
|
||||
"transcript" : args' ->
|
||||
@ -211,7 +214,8 @@ main = do
|
||||
args -> do
|
||||
let headless = listToMaybe args == Just "headless"
|
||||
(closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
|
||||
Server.start theCodebase $ \token port -> do
|
||||
runtime <- RTI.startRuntime
|
||||
Server.start runtime theCodebase $ \token port -> do
|
||||
let url =
|
||||
"http://127.0.0.1:" <> show port <> "/" <> URI.encode (unpack token)
|
||||
when headless $
|
||||
@ -229,7 +233,7 @@ main = do
|
||||
takeMVar mvar
|
||||
else do
|
||||
PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager..."
|
||||
launch currentDir config theCodebase []
|
||||
launch currentDir config runtime theCodebase []
|
||||
closeCodebase
|
||||
|
||||
upgradeCodebase :: Maybe Codebase.CodebasePath -> IO ()
|
||||
@ -338,11 +342,12 @@ initialPath = Path.absoluteEmpty
|
||||
launch
|
||||
:: FilePath
|
||||
-> (Config, IO ())
|
||||
-> _
|
||||
-> Rt.Runtime Symbol
|
||||
-> Codebase.Codebase IO Symbol Ann
|
||||
-> [Either Input.Event Input.Input]
|
||||
-> IO ()
|
||||
launch dir config code inputs =
|
||||
CommandLine.main dir defaultBaseLib initialPath config inputs code Version.gitDescribe
|
||||
launch dir config rt code inputs =
|
||||
CommandLine.main dir defaultBaseLib initialPath config inputs rt code Version.gitDescribe
|
||||
|
||||
isMarkdown :: String -> Bool
|
||||
isMarkdown md = case FP.takeExtension md of
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Unison.HashQualified' where
|
||||
@ -19,7 +20,7 @@ import qualified Unison.ShortHash as SH
|
||||
import qualified Unison.HashQualified as HQ
|
||||
|
||||
data HashQualified n = NameOnly n | HashQualified n ShortHash
|
||||
deriving (Eq, Functor, Generic)
|
||||
deriving (Eq, Functor, Generic, Foldable)
|
||||
|
||||
type HQSegment = HashQualified NameSegment
|
||||
|
||||
|
||||
@ -38,7 +38,7 @@ The `view` and `display` commands also benefit from this:
|
||||
```ucm
|
||||
.> view List.drop
|
||||
|
||||
-- builtin.List.drop is built-in.
|
||||
builtin builtin.List.drop : Nat -> [a] -> [a]
|
||||
|
||||
.> display bar.a
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user