diff --git a/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs b/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs index 4d6721285..042a589c3 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs @@ -5,10 +5,10 @@ module Unison.Codebase.Editor.DisplayObject where import Unison.Prelude import Unison.ShortHash -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 +toMaybe :: DisplayObject b a -> Maybe a toMaybe = \case UserObject a -> Just a _ -> Nothing diff --git a/parser-typechecker/src/Unison/Codebase/Editor/TodoOutput.hs b/parser-typechecker/src/Unison/Codebase/Editor/TodoOutput.hs index fd8af80b7..9d8f61b0e 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/TodoOutput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/TodoOutput.hs @@ -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) diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index f80d82ff4..691088112 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -48,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 @@ -81,8 +82,7 @@ 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 @@ -267,19 +267,26 @@ typeDeclHeader => Codebase m v Ann -> PPE.PrettyPrintEnv -> Reference - -> Backend m (DisplayObject Syntax.SyntaxText) + -> 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 pretty - where - name = PPE.typeName ppe r - pretty = Syntax.convertElement <$> - Pretty.render defaultWidth (DeclPrinter.prettyDeclHeader name decl) + DisplayObject.UserObject $ + Syntax.convertElement <$> + Pretty.render defaultWidth (DeclPrinter.prettyDeclHeader name decl) Nothing -> - pure DisplayObject.BuiltinObject + pure (DisplayObject.BuiltinObject (formatTypeName ppe r)) + where + name = PPE.typeName ppe r + +formatTypeName :: Var v => PPE.PrettyPrintEnv -> Reference -> Syntax.SyntaxText +formatTypeName ppe r = + fmap Syntax.convertElement . + Pretty.renderUnbroken . + NP.styleHashQualified id $ + PPE.typeName ppe r termEntryToNamedTerm :: Var v => PPE.PrettyPrintEnv -> Maybe Width -> TermEntry v a -> NamedTerm @@ -510,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] } @@ -553,7 +560,7 @@ prettyType width ppe = (-1) mungeSyntaxText - :: Functor g => g (SyntaxText.Element Reference) -> g Syntax.Element + :: Functor g => g (UST.Element Reference) -> g Syntax.Element mungeSyntaxText = fmap Syntax.convertElement prettyDefinitionsBySuffixes @@ -696,7 +703,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 @@ -705,7 +712,7 @@ bestNameForType bestNameForType ppe width = Text.pack . Pretty.render width - . fmap SyntaxText.toPlain + . fmap UST.toPlain . TypePrinter.pretty0 @v ppe mempty (-1) . Type.ref () @@ -761,13 +768,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 @@ -776,8 +785,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) @@ -788,8 +797,11 @@ 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 _ -> error "todo" undefined + DisplayObject.MissingObject sh -> DisplayObject.MissingObject sh + DisplayObject.UserObject tm -> DisplayObject.UserObject . + Pretty.render width . TermPrinter.prettyBinding (ppeBody r) n $ tm typesToSyntax :: Var v @@ -797,8 +809,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) typesToSyntax suff width ppe0 types = Map.fromList $ map go . Map.toList $ Map.mapKeys (first (PPE.typeName ppeDecl) . dupe) @@ -840,9 +852,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 diff --git a/parser-typechecker/src/Unison/Server/Doc.hs b/parser-typechecker/src/Unison/Server/Doc.hs index 308b4d260..a20063af9 100644 --- a/parser-typechecker/src/Unison/Server/Doc.hs +++ b/parser-typechecker/src/Unison/Server/Doc.hs @@ -84,8 +84,8 @@ type UnisonHash = Text data Ref a = Term a | Type a deriving (Eq,Show,Generic,Functor,Foldable,Traversable) data SpecialForm - = Source [Ref (UnisonHash, DisplayObject Src)] - | FoldedSource [Ref (UnisonHash, DisplayObject Src)] + = Source [Ref (UnisonHash, DisplayObject SyntaxText Src)] + | FoldedSource [Ref (UnisonHash, DisplayObject SyntaxText Src)] | Example SyntaxText | ExampleBlock SyntaxText | Link SyntaxText @@ -144,6 +144,7 @@ renderDoc pped terms typeOf eval types = go where _ -> mzero formatPretty = fmap Syntax.convertElement . P.render (P.Width 70) + formatPrettyType ppe typ = formatPretty (TypePrinter.prettySyntax ppe typ) source :: Term v () -> MaybeT m SyntaxText source tm = (pure . formatPretty . TermPrinter.prettyBlock' True (PPE.suffixifiedPPE pped)) tm @@ -218,14 +219,17 @@ renderDoc pped terms typeOf eval types = go where evalErrMsg = "🆘 An error occured during evaluation" - goSrc :: [Term v ()] -> MaybeT m [Ref (UnisonHash, DisplayObject Src)] + goSrc :: [Term v ()] -> MaybeT 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 -> MaybeT m (Ref (UnisonHash, DisplayObject Src)) - goType r@(Reference.Builtin _) = pure (Type (Reference.toText r, DO.BuiltinObject)) + goType :: Reference -> MaybeT 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 <- lift (types r) case d of @@ -236,9 +240,9 @@ renderDoc pped terms typeOf eval types = go 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 Src)]) + go :: (Set.Set Reference, [Ref (UnisonHash, DisplayObject SyntaxText Src)]) -> Term v () - -> MaybeT m (Set.Set Reference, [Ref (UnisonHash, DisplayObject Src)]) + -> MaybeT 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] -> @@ -246,7 +250,9 @@ renderDoc pped terms typeOf eval types = go where where acc' = case tm of Term.Ref' r | Set.notMember r seen -> (:acc) . Term . (Reference.toText r,) <$> case r of - Reference.Builtin _ -> pure DO.BuiltinObject + Reference.Builtin _ -> lift (typeOf (Referent.Ref r)) <&> \case + Nothing -> DO.BuiltinObject ("🆘 missing type signature") + Just ty -> DO.BuiltinObject (formatPrettyType ppe ty) ref -> lift (terms ref) >>= \case Nothing -> pure $ DO.MissingObject (SH.unsafeFromText $ Reference.toText ref) Just tm -> do diff --git a/parser-typechecker/src/Unison/Server/SearchResult'.hs b/parser-typechecker/src/Unison/Server/SearchResult'.hs index 19261b360..080c97095 100644 --- a/parser-typechecker/src/Unison/Server/SearchResult'.hs +++ b/parser-typechecker/src/Unison/Server/SearchResult'.hs @@ -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) diff --git a/parser-typechecker/src/Unison/Server/Types.hs b/parser-typechecker/src/Unison/Server/Types.hs index 2c62c1a85..49ec2d770 100644 --- a/parser-typechecker/src/Unison/Server/Types.hs +++ b/parser-typechecker/src/Unison/Server/Types.hs @@ -71,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 @@ -111,7 +111,7 @@ 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) @@ -120,7 +120,7 @@ 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) diff --git a/parser-typechecker/src/Unison/TypePrinter.hs b/parser-typechecker/src/Unison/TypePrinter.hs index 18e4458ae..12677efa4 100644 --- a/parser-typechecker/src/Unison/TypePrinter.hs +++ b/parser-typechecker/src/Unison/TypePrinter.hs @@ -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 =