mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-26 11:07:48 +03:00
Split doc evaluation from doc rendering (#3694)
This commit is contained in:
Chris Penner
GitHub
parent
50594818a8
commit
2e0ffc7832
@ -17,8 +17,10 @@ module Unison.DataDeclaration
|
||||
constructorIds,
|
||||
declConstructorReferents,
|
||||
declDependencies,
|
||||
labeledDeclDependencies,
|
||||
declFields,
|
||||
dependencies,
|
||||
labeledDependencies,
|
||||
generateRecordAccessors,
|
||||
unhashComponent,
|
||||
mkDataDecl',
|
||||
@ -41,6 +43,7 @@ import qualified Unison.ABT as ABT
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import qualified Unison.ConstructorType as CT
|
||||
import Unison.DataDeclaration.ConstructorId (ConstructorId)
|
||||
import qualified Unison.LabeledDependency as LD
|
||||
import qualified Unison.Name as Name
|
||||
import qualified Unison.Names.ResolutionResult as Names
|
||||
import qualified Unison.Pattern as Pattern
|
||||
@ -70,6 +73,9 @@ asDataDecl = either toDataDecl id
|
||||
declDependencies :: Ord v => Decl v a -> Set Reference
|
||||
declDependencies = either (dependencies . toDataDecl) dependencies
|
||||
|
||||
labeledDeclDependencies :: Ord v => Decl v a -> Set LD.LabeledDependency
|
||||
labeledDeclDependencies = Set.map LD.TypeReference . declDependencies
|
||||
|
||||
constructorType :: Decl v a -> CT.ConstructorType
|
||||
constructorType = \case
|
||||
Left {} -> CT.Effect
|
||||
@ -254,6 +260,9 @@ dependencies :: Ord v => DataDeclaration v a -> Set Reference
|
||||
dependencies dd =
|
||||
Set.unions (Type.dependencies <$> constructorTypes dd)
|
||||
|
||||
labeledDependencies :: Ord v => DataDeclaration v a -> Set LD.LabeledDependency
|
||||
labeledDependencies = Set.map LD.TypeReference . dependencies
|
||||
|
||||
mkEffectDecl' ::
|
||||
Modifier -> a -> [v] -> [(a, v, Type v a)] -> EffectDeclaration v a
|
||||
mkEffectDecl' m a b cs = EffectDeclaration (DataDeclaration m a b cs)
|
||||
|
||||
@ -11,6 +11,7 @@ import Data.Monoid (Any (..))
|
||||
import qualified Data.Set as Set
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Kind as K
|
||||
import qualified Unison.LabeledDependency as LD
|
||||
import qualified Unison.Name as Name
|
||||
import qualified Unison.Names.ResolutionResult as Names
|
||||
import Unison.Prelude
|
||||
@ -522,6 +523,9 @@ dependencies t = Set.fromList . Writer.execWriter $ ABT.visit' f t
|
||||
f t@(Ref r) = Writer.tell [r] $> t
|
||||
f t = pure t
|
||||
|
||||
labeledDependencies :: Ord v => Type v a -> Set LD.LabeledDependency
|
||||
labeledDependencies = Set.map LD.TypeReference . dependencies
|
||||
|
||||
updateDependencies :: Ord v => Map Reference Reference -> Type v a -> Type v a
|
||||
updateDependencies typeUpdates = ABT.rebuildUp go
|
||||
where
|
||||
|
||||
@ -974,7 +974,7 @@ renderDoc ppe width rt codebase r = do
|
||||
let hash = Reference.toText r
|
||||
(name,hash,)
|
||||
<$> let tm = Term.ref () r
|
||||
in Doc.renderDoc
|
||||
in Doc.evalAndRenderDoc
|
||||
ppe
|
||||
terms
|
||||
typeOf
|
||||
|
||||
@ -3,25 +3,20 @@
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Server.Doc where
|
||||
|
||||
import Control.Lens (view, (^.))
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
|
||||
import Data.Aeson (ToJSON)
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.OpenApi (ToSchema)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Word
|
||||
import GHC.Generics (Generic)
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Builtin.Decls as DD
|
||||
import qualified Unison.Builtin.Decls as Decls
|
||||
@ -29,6 +24,8 @@ import Unison.Codebase.Editor.DisplayObject (DisplayObject)
|
||||
import qualified Unison.Codebase.Editor.DisplayObject as DO
|
||||
import qualified Unison.ConstructorReference as ConstructorReference
|
||||
import qualified Unison.DataDeclaration as DD
|
||||
import qualified Unison.LabeledDependency as LD
|
||||
import Unison.Prelude
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import qualified Unison.PrettyPrintEnvDecl as PPE
|
||||
import Unison.Reference (Reference)
|
||||
@ -57,37 +54,48 @@ type Nat = Word64
|
||||
|
||||
type SSyntaxText = S.SyntaxText' Reference
|
||||
|
||||
data Doc
|
||||
-- | A doc rendered down to SyntaxText.
|
||||
type Doc = DocG RenderedSpecialForm
|
||||
|
||||
-- | A doc which has been evaluated and includes all information necessary to be rendered.
|
||||
type EvaluatedDoc v = DocG (EvaluatedSpecialForm v)
|
||||
|
||||
type SrcRefs = Ref (UnisonHash, DisplayObject SyntaxText Src)
|
||||
|
||||
-- | A doc parameterized by its special forms.
|
||||
data DocG specialForm
|
||||
= Word Text
|
||||
| Code Doc
|
||||
| CodeBlock Text Doc
|
||||
| Bold Doc
|
||||
| Italic Doc
|
||||
| Strikethrough Doc
|
||||
| Style Text Doc
|
||||
| Anchor Text Doc
|
||||
| Blockquote Doc
|
||||
| Code (DocG specialForm)
|
||||
| CodeBlock Text (DocG specialForm)
|
||||
| Bold (DocG specialForm)
|
||||
| Italic (DocG specialForm)
|
||||
| Strikethrough (DocG specialForm)
|
||||
| Style Text (DocG specialForm)
|
||||
| Anchor Text (DocG specialForm)
|
||||
| Blockquote (DocG specialForm)
|
||||
| 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 stock (Eq, Show, Generic)
|
||||
deriving anyclass (ToJSON, ToSchema)
|
||||
| Tooltip (DocG specialForm) (DocG specialForm)
|
||||
| Aside (DocG specialForm)
|
||||
| Callout (Maybe (DocG specialForm)) (DocG specialForm)
|
||||
| Table [[(DocG specialForm)]]
|
||||
| Folded Bool (DocG specialForm) (DocG specialForm)
|
||||
| Paragraph [(DocG specialForm)]
|
||||
| BulletedList [(DocG specialForm)]
|
||||
| NumberedList Nat [(DocG specialForm)]
|
||||
| Section (DocG specialForm) [(DocG specialForm)]
|
||||
| NamedLink (DocG specialForm) (DocG specialForm)
|
||||
| Image (DocG specialForm) (DocG specialForm) (Maybe (DocG specialForm))
|
||||
| Special specialForm
|
||||
| Join [(DocG specialForm)]
|
||||
| UntitledSection [(DocG specialForm)]
|
||||
| Column [(DocG specialForm)]
|
||||
| Group (DocG specialForm)
|
||||
deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable)
|
||||
deriving anyclass (ToJSON)
|
||||
|
||||
deriving instance ToSchema specialForm => ToSchema (DocG specialForm)
|
||||
|
||||
type UnisonHash = Text
|
||||
|
||||
@ -101,9 +109,9 @@ data MediaSource = MediaSource {mediaSourceUrl :: Text, mediaSourceMimeType :: M
|
||||
deriving stock (Eq, Show, Generic)
|
||||
deriving anyclass (ToJSON, ToSchema)
|
||||
|
||||
data SpecialForm
|
||||
= Source [Ref (UnisonHash, DisplayObject SyntaxText Src)]
|
||||
| FoldedSource [Ref (UnisonHash, DisplayObject SyntaxText Src)]
|
||||
data RenderedSpecialForm
|
||||
= Source [SrcRefs]
|
||||
| FoldedSource [SrcRefs]
|
||||
| Example SyntaxText
|
||||
| ExampleBlock SyntaxText
|
||||
| Link SyntaxText
|
||||
@ -115,15 +123,36 @@ data SpecialForm
|
||||
| EmbedInline SyntaxText
|
||||
| Video [MediaSource] (Map Text Text)
|
||||
| FrontMatter (Map Text [Text])
|
||||
| RenderError (RenderError SyntaxText)
|
||||
deriving stock (Eq, Show, Generic)
|
||||
deriving anyclass (ToJSON, ToSchema)
|
||||
|
||||
data EvaluatedSpecialForm v
|
||||
= ESource [(EvaluatedSrc v)]
|
||||
| EFoldedSource [(EvaluatedSrc v)]
|
||||
| EExample (Term v ())
|
||||
| EExampleBlock (Term v ())
|
||||
| ELink (Either (Term v ()) LD.LabeledDependency)
|
||||
| ESignature [(Referent, Type v ())]
|
||||
| ESignatureInline (Referent, Type v ())
|
||||
| -- Result is Nothing if there was an Eval failure
|
||||
EEval (Term v ()) (Maybe (Term v ()))
|
||||
| -- Result is Nothing if there was an Eval failure
|
||||
EEvalInline (Term v ()) (Maybe (Term v ()))
|
||||
| EEmbed (Term v ())
|
||||
| EEmbedInline (Term v ())
|
||||
| EVideo [MediaSource] (Map Text Text)
|
||||
| EFrontMatter (Map Text [Text])
|
||||
| ERenderError (RenderError (Term v ()))
|
||||
deriving stock (Eq, Show, Generic)
|
||||
|
||||
-- `Src folded unfolded`
|
||||
data Src = Src SyntaxText SyntaxText
|
||||
deriving stock (Eq, Show, Generic)
|
||||
deriving anyclass (ToJSON, ToSchema)
|
||||
|
||||
renderDoc ::
|
||||
-- | Evaluate the doc, then render it.
|
||||
evalAndRenderDoc ::
|
||||
forall v m.
|
||||
(Var v, Monad m) =>
|
||||
PPE.PrettyPrintEnvDecl ->
|
||||
@ -133,11 +162,118 @@ renderDoc ::
|
||||
(Reference -> m (Maybe (DD.Decl v ()))) ->
|
||||
Term v () ->
|
||||
m Doc
|
||||
renderDoc pped terms typeOf eval types tm =
|
||||
evalAndRenderDoc pped terms typeOf eval types tm =
|
||||
renderDoc pped <$> evalDoc terms typeOf eval types tm
|
||||
|
||||
-- | Renders the given doc, which must have been evaluated using 'evalDoc'
|
||||
renderDoc ::
|
||||
forall v.
|
||||
Var v =>
|
||||
PPE.PrettyPrintEnvDecl ->
|
||||
EvaluatedDoc v ->
|
||||
Doc
|
||||
renderDoc pped doc = renderSpecial <$> doc
|
||||
where
|
||||
suffixifiedPPE = PPE.suffixifiedPPE pped
|
||||
formatPretty = fmap Syntax.convertElement . P.render (P.Width 70)
|
||||
|
||||
formatPrettyType :: PPE.PrettyPrintEnv -> Type v a -> SyntaxText
|
||||
formatPrettyType ppe typ = formatPretty (TypePrinter.prettySyntax ppe typ)
|
||||
|
||||
source :: Term v () -> SyntaxText
|
||||
source tm = formatPretty $ TermPrinter.prettyBlock' True (PPE.suffixifiedPPE pped) tm
|
||||
|
||||
goSignatures :: [(Referent, Type v ())] -> [P.Pretty SSyntaxText]
|
||||
goSignatures types =
|
||||
fmap P.group $
|
||||
TypePrinter.prettySignaturesST
|
||||
(PPE.suffixifiedPPE pped)
|
||||
[(r, PPE.termName (PPE.suffixifiedPPE pped) r, ty) | (r, ty) <- types]
|
||||
|
||||
renderSpecial :: EvaluatedSpecialForm v -> RenderedSpecialForm
|
||||
renderSpecial = \case
|
||||
ESource srcs -> Source (renderSrc srcs)
|
||||
EFoldedSource srcs -> FoldedSource (renderSrc srcs)
|
||||
EExample trm -> Example (source trm)
|
||||
EExampleBlock trm -> ExampleBlock (source trm)
|
||||
ELink ref ->
|
||||
let ppe = PPE.suffixifiedPPE pped
|
||||
tm :: Referent -> P.Pretty SSyntaxText
|
||||
tm r = (NP.styleHashQualified'' (NP.fmt (S.TermReference r)) . PPE.termName ppe) r
|
||||
ty :: Reference -> P.Pretty SSyntaxText
|
||||
ty r = (NP.styleHashQualified'' (NP.fmt (S.TypeReference r)) . PPE.typeName ppe) r
|
||||
in Link $ case ref of
|
||||
Left trm -> source trm
|
||||
Right ld -> case ld of
|
||||
LD.TermReferent r -> (formatPretty . tm) r
|
||||
LD.TypeReference r -> (formatPretty . ty) r
|
||||
ESignature rs -> Signature (map formatPretty $ goSignatures rs)
|
||||
ESignatureInline r -> SignatureInline (formatPretty (P.lines $ goSignatures [r]))
|
||||
EEval trm result ->
|
||||
let renderedTrm = source trm
|
||||
in case result of
|
||||
Nothing -> Eval renderedTrm evalErrMsg
|
||||
Just renderedResult -> Eval renderedTrm (source renderedResult)
|
||||
EEvalInline trm result ->
|
||||
let renderedTrm = source trm
|
||||
in case result of
|
||||
Nothing -> EvalInline renderedTrm evalErrMsg
|
||||
Just renderedResult -> EvalInline renderedTrm (source renderedResult)
|
||||
EEmbed any -> Embed ("{{ embed {{" <> source any <> "}} }}")
|
||||
EEmbedInline any -> EmbedInline ("{{ embed {{" <> source any <> "}} }}")
|
||||
EVideo sources config -> Video sources config
|
||||
EFrontMatter frontMatter -> FrontMatter frontMatter
|
||||
ERenderError (InvalidTerm tm) -> Embed ("🆘 unable to render " <> source tm)
|
||||
|
||||
evalErrMsg :: SyntaxText
|
||||
evalErrMsg = "🆘 An error occured during evaluation"
|
||||
|
||||
renderSrc :: [EvaluatedSrc v] -> [Ref (UnisonHash, DisplayObject SyntaxText Src)]
|
||||
renderSrc srcs =
|
||||
srcs & foldMap \case
|
||||
EvaluatedSrcDecl srcDecl -> case srcDecl of
|
||||
MissingDecl r -> [(Type (Reference.toText r, DO.MissingObject (SH.unsafeFromText $ Reference.toText r)))]
|
||||
BuiltinDecl r ->
|
||||
let name =
|
||||
formatPretty . NP.styleHashQualified (NP.fmt (S.TypeReference r))
|
||||
. PPE.typeName suffixifiedPPE
|
||||
$ r
|
||||
in [Type (Reference.toText r, DO.BuiltinObject name)]
|
||||
FoundDecl r decl -> [Type (Reference.toText r, DO.UserObject (Src folded full))]
|
||||
where
|
||||
full = formatPretty (DeclPrinter.prettyDecl pped r (PPE.typeName suffixifiedPPE r) decl)
|
||||
folded = formatPretty (DeclPrinter.prettyDeclHeader (PPE.typeName suffixifiedPPE r) decl)
|
||||
EvaluatedSrcTerm srcTerm -> case srcTerm of
|
||||
MissingBuiltinTypeSig r -> [(Type (Reference.toText r, DO.BuiltinObject "🆘 missing type signature"))]
|
||||
BuiltinTypeSig r typ -> [Type (Reference.toText r, DO.BuiltinObject (formatPrettyType suffixifiedPPE typ))]
|
||||
MissingTerm r -> [Term (Reference.toText r, DO.MissingObject (SH.unsafeFromText $ Reference.toText r))]
|
||||
FoundTerm ref typ tm ->
|
||||
let name = PPE.termName suffixifiedPPE (Referent.Ref ref)
|
||||
folded =
|
||||
formatPretty . P.lines $
|
||||
TypePrinter.prettySignaturesST suffixifiedPPE [(Referent.Ref ref, name, typ)]
|
||||
full tm@(Term.Ann' _ _) _ =
|
||||
formatPretty (TermPrinter.prettyBinding suffixifiedPPE name tm)
|
||||
full tm typ =
|
||||
formatPretty (TermPrinter.prettyBinding suffixifiedPPE name (Term.ann () tm typ))
|
||||
in [Term (Reference.toText ref, DO.UserObject (Src folded (full tm typ)))]
|
||||
|
||||
-- | Evaluates the given doc, expanding transclusions, expressions, etc.
|
||||
evalDoc ::
|
||||
forall v m.
|
||||
(Var v, Monad m) =>
|
||||
(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 (EvaluatedDoc v)
|
||||
evalDoc terms typeOf eval types tm =
|
||||
eval tm >>= \case
|
||||
Nothing -> pure $ Word "🆘 doc rendering failed during evaluation"
|
||||
Just tm -> go tm
|
||||
where
|
||||
go :: Term v () -> m (EvaluatedDoc v)
|
||||
go = \case
|
||||
DD.Doc2Word txt -> pure $ Word txt
|
||||
DD.Doc2Code d -> Code <$> go d
|
||||
@ -172,78 +308,62 @@ renderDoc pped terms typeOf eval types tm =
|
||||
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
|
||||
wat -> pure $ Special $ ERenderError (InvalidTerm 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 SSyntaxText]
|
||||
goSignatures :: [Referent] -> m [(Referent, Type v ())]
|
||||
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.prettySignaturesST
|
||||
(PPE.suffixifiedPPE pped)
|
||||
[(r, PPE.termName (PPE.suffixifiedPPE pped) r, ty) | (r, ty) <- zip rs types]
|
||||
Nothing -> error "🆘 codebase is missing type signature for these definitions"
|
||||
Just types -> pure (zip rs types)
|
||||
|
||||
goSpecial :: Term v () -> m SpecialForm
|
||||
goSpecial :: Term v () -> m (EvaluatedSpecialForm v)
|
||||
goSpecial = \case
|
||||
DD.Doc2SpecialFormFoldedSource (Term.List' es) -> FoldedSource <$> goSrc (toList es)
|
||||
DD.Doc2SpecialFormFoldedSource (Term.List' es) -> EFoldedSource <$> goSrc (toList es)
|
||||
-- Source [Either Link.Type Doc2.Term]
|
||||
DD.Doc2SpecialFormSource (Term.List' es) -> Source <$> goSrc (toList es)
|
||||
DD.Doc2SpecialFormSource (Term.List' es) -> ESource <$> 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
|
||||
pure $ EExample ex
|
||||
where
|
||||
ex = Term.lam' (ABT.annotation body) (drop (fromIntegral n) vs) body
|
||||
DD.Doc2SpecialFormExampleBlock n (DD.Doc2Example vs body) ->
|
||||
ExampleBlock <$> source ex
|
||||
pure $ EExampleBlock 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 SSyntaxText
|
||||
tm r = (NP.styleHashQualified'' (NP.fmt (S.TermReference r)) . PPE.termName ppe) r
|
||||
ty :: Reference -> P.Pretty SSyntaxText
|
||||
ty r = (NP.styleHashQualified'' (NP.fmt (S.TypeReference r)) . PPE.typeName ppe) r
|
||||
in Link <$> case e of
|
||||
DD.EitherLeft' (Term.TypeLink' r) -> (pure . formatPretty . ty) r
|
||||
let tm :: Referent -> (Either a LD.LabeledDependency)
|
||||
tm r = Right $ LD.TermReferent r
|
||||
ty :: Reference -> (Either a LD.LabeledDependency)
|
||||
ty r = Right $ LD.TypeReference r
|
||||
in ELink <$> case e of
|
||||
DD.EitherLeft' (Term.TypeLink' r) -> pure $ ty r
|
||||
DD.EitherRight' (DD.Doc2Term t) ->
|
||||
case Term.etaNormalForm t of
|
||||
Term.Referent' r -> (pure . formatPretty . tm) r
|
||||
x -> source x
|
||||
_ -> source e
|
||||
Term.Referent' r -> pure $ tm r
|
||||
x -> pure $ Left x
|
||||
_ -> pure $ Left e
|
||||
DD.Doc2SpecialFormSignature (Term.List' tms) ->
|
||||
let rs = [r | DD.Doc2Term (Term.Referent' r) <- toList tms]
|
||||
in goSignatures rs <&> \s -> Signature (map formatPretty s)
|
||||
in goSignatures rs <&> \s -> ESignature s
|
||||
-- SignatureInline Doc2.Term
|
||||
DD.Doc2SpecialFormSignatureInline (DD.Doc2Term (Term.Referent' r)) ->
|
||||
goSignatures [r] <&> \s -> SignatureInline (formatPretty (P.lines s))
|
||||
goSignatures [r] <&> \[s] -> ESignatureInline 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
|
||||
DD.Doc2SpecialFormEval (DD.Doc2Term tm) -> do
|
||||
result <- eval tm
|
||||
pure $ EEval tm 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
|
||||
DD.Doc2SpecialFormEvalInline (DD.Doc2Term tm) -> do
|
||||
result <- eval tm
|
||||
pure $ EEvalInline tm result
|
||||
-- Embed Video
|
||||
DD.Doc2SpecialFormEmbedVideo sources config ->
|
||||
pure $ Video sources' config'
|
||||
pure $ EVideo sources' config'
|
||||
where
|
||||
sources' = [MediaSource url mimeType | DD.Doc2MediaSource (Term.Text' url) (maybeText -> mimeType) <- sources]
|
||||
config' = Map.fromList [(k, v) | Decls.TupleTerm' [Term.Text' k, Term.Text' v] <- config]
|
||||
@ -252,49 +372,37 @@ renderDoc pped terms typeOf eval types tm =
|
||||
|
||||
-- Embed FrontMatter
|
||||
DD.Doc2SpecialFormEmbedFrontMatter frontMatter ->
|
||||
pure $ FrontMatter frontMatter'
|
||||
pure $ EFrontMatter frontMatter'
|
||||
where
|
||||
frontMatter' = List.multimap [(k, v) | Decls.TupleTerm' [Term.Text' k, Term.Text' v] <- frontMatter]
|
||||
|
||||
-- Embed Any
|
||||
DD.Doc2SpecialFormEmbed (Term.App' _ any) ->
|
||||
source any <&> \p -> Embed ("{{ embed {{" <> p <> "}} }}")
|
||||
pure $ EEmbed any
|
||||
-- EmbedInline Any
|
||||
DD.Doc2SpecialFormEmbedInline any ->
|
||||
source any <&> \p -> EmbedInline ("{{ embed {{" <> p <> "}} }}")
|
||||
tm -> source tm <&> \p -> Embed ("🆘 unable to render " <> p)
|
||||
pure $ EEmbedInline any
|
||||
tm -> pure $ ERenderError (InvalidTerm tm)
|
||||
|
||||
evalErrMsg = "🆘 An error occured during evaluation"
|
||||
|
||||
goSrc :: [Term v ()] -> m [Ref (UnisonHash, DisplayObject SyntaxText Src)]
|
||||
goSrc :: [Term v ()] -> m [EvaluatedSrc v]
|
||||
goSrc es = do
|
||||
let toRef (Term.Ref' r) = Set.singleton r
|
||||
toRef (Term.RequestOrCtor' r) = Set.singleton (r ^. ConstructorReference.reference_)
|
||||
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.TypeReference 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 pped r (PPE.typeName ppe r) decl)
|
||||
folded = formatPretty (DeclPrinter.prettyDeclHeader (PPE.typeName ppe r) decl)
|
||||
goType :: Reference -> m (EvaluatedSrc v)
|
||||
goType r@(Reference.Builtin _builtin) =
|
||||
pure (EvaluatedSrcDecl (BuiltinDecl r))
|
||||
goType r = do
|
||||
d <- types r
|
||||
case d of
|
||||
Nothing -> pure (EvaluatedSrcDecl $ MissingDecl r)
|
||||
Just decl ->
|
||||
pure $ EvaluatedSrcDecl (FoundDecl r decl)
|
||||
|
||||
go ::
|
||||
(Set.Set Reference, [Ref (UnisonHash, DisplayObject SyntaxText Src)]) ->
|
||||
(Set.Set Reference, [EvaluatedSrc v]) ->
|
||||
Term v () ->
|
||||
m (Set.Set Reference, [Ref (UnisonHash, DisplayObject SyntaxText Src)])
|
||||
m (Set.Set Reference, [EvaluatedSrc v])
|
||||
go s1@(!seen, !acc) = \case
|
||||
-- we ignore the annotations; but this could be extended later
|
||||
DD.TupleTerm' [DD.EitherRight' (DD.Doc2Term tm), _anns] ->
|
||||
@ -303,29 +411,85 @@ renderDoc pped terms typeOf eval types tm =
|
||||
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 folded =
|
||||
formatPretty . P.lines $
|
||||
TypePrinter.prettySignaturesST ppe [(Referent.Ref ref, name, typ)]
|
||||
let full tm@(Term.Ann' _ _) _ =
|
||||
formatPretty (TermPrinter.prettyBinding ppe name tm)
|
||||
full tm typ =
|
||||
formatPretty (TermPrinter.prettyBinding ppe name (Term.ann () tm typ))
|
||||
pure (DO.UserObject (Src folded (full tm typ)))
|
||||
(: acc) <$> case r of
|
||||
Reference.Builtin _ ->
|
||||
typeOf (Referent.Ref r) <&> \case
|
||||
Nothing -> EvaluatedSrcTerm (MissingBuiltinTypeSig r)
|
||||
Just ty -> EvaluatedSrcTerm (BuiltinTypeSig r ty)
|
||||
ref ->
|
||||
terms ref >>= \case
|
||||
Nothing -> pure . EvaluatedSrcTerm . MissingTerm $ ref
|
||||
Just tm -> do
|
||||
typ <- fromMaybe (Type.builtin () "unknown") <$> typeOf (Referent.Ref ref)
|
||||
pure $ EvaluatedSrcTerm (FoundTerm ref typ tm)
|
||||
Term.RequestOrCtor' (view ConstructorReference.reference_ -> 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
|
||||
(Set.insert ref seen,) . (: acc) <$> goType ref
|
||||
_ -> pure s1
|
||||
reverse . snd <$> foldM go mempty es
|
||||
|
||||
data RenderError trm
|
||||
= InvalidTerm trm
|
||||
deriving stock (Eq, Show, Generic)
|
||||
deriving anyclass (ToJSON)
|
||||
|
||||
deriving anyclass instance ToSchema trm => ToSchema (RenderError trm)
|
||||
|
||||
data EvaluatedSrc v
|
||||
= EvaluatedSrcDecl (EvaluatedDecl v)
|
||||
| EvaluatedSrcTerm (EvaluatedTerm v)
|
||||
deriving stock (Show, Eq, Generic)
|
||||
|
||||
data EvaluatedDecl v
|
||||
= MissingDecl Reference
|
||||
| BuiltinDecl Reference
|
||||
| FoundDecl Reference (DD.Decl v ())
|
||||
deriving stock (Show, Eq, Generic)
|
||||
|
||||
data EvaluatedTerm v
|
||||
= MissingTerm Reference
|
||||
| BuiltinTypeSig Reference (Type v ())
|
||||
| MissingBuiltinTypeSig Reference
|
||||
| FoundTerm Reference (Type v ()) (Term v ())
|
||||
deriving stock (Show, Eq, Generic)
|
||||
|
||||
-- Determines all dependencies which will be required to render a doc.
|
||||
dependencies :: Ord v => EvaluatedDoc v -> Set LD.LabeledDependency
|
||||
dependencies = foldMap dependenciesSpecial
|
||||
|
||||
-- | Determines all dependencies of a special form
|
||||
dependenciesSpecial :: forall v. Ord v => EvaluatedSpecialForm v -> Set LD.LabeledDependency
|
||||
dependenciesSpecial = \case
|
||||
ESource srcs -> srcDeps srcs
|
||||
EFoldedSource srcs -> srcDeps srcs
|
||||
EExample trm -> Term.labeledDependencies trm
|
||||
EExampleBlock trm -> Term.labeledDependencies trm
|
||||
ELink ref -> either Term.labeledDependencies Set.singleton ref
|
||||
ESignature sigtyps -> sigtypDeps sigtyps
|
||||
ESignatureInline sig -> sigtypDeps [sig]
|
||||
EEval trm mayTrm -> Term.labeledDependencies trm <> foldMap Term.labeledDependencies mayTrm
|
||||
EEvalInline trm mayTrm -> Term.labeledDependencies trm <> foldMap Term.labeledDependencies mayTrm
|
||||
EEmbed trm -> Term.labeledDependencies trm
|
||||
EEmbedInline trm -> Term.labeledDependencies trm
|
||||
EVideo {} -> mempty
|
||||
EFrontMatter {} -> mempty
|
||||
ERenderError (InvalidTerm trm) -> Term.labeledDependencies trm
|
||||
where
|
||||
sigtypDeps :: [(Referent, Type v a)] -> Set LD.LabeledDependency
|
||||
sigtypDeps sigtyps =
|
||||
sigtyps & foldMap \(ref, typ) ->
|
||||
Set.singleton (LD.TermReferent ref) <> Type.labeledDependencies typ
|
||||
srcDeps :: [EvaluatedSrc v] -> Set LD.LabeledDependency
|
||||
srcDeps srcs =
|
||||
srcs & foldMap \case
|
||||
EvaluatedSrcDecl srcDecl -> case srcDecl of
|
||||
MissingDecl ref -> Set.singleton (LD.TypeReference ref)
|
||||
BuiltinDecl ref -> Set.singleton (LD.TypeReference ref)
|
||||
FoundDecl ref decl -> Set.singleton (LD.TypeReference ref) <> DD.labeledDeclDependencies decl
|
||||
EvaluatedSrcTerm srcTerm -> case srcTerm of
|
||||
MissingTerm ref -> Set.singleton (LD.TermReference ref)
|
||||
BuiltinTypeSig ref _ -> Set.singleton (LD.TermReference ref)
|
||||
MissingBuiltinTypeSig ref -> Set.singleton (LD.TermReference ref)
|
||||
FoundTerm ref typ trm -> Set.singleton (LD.TermReference ref) <> Type.labeledDependencies typ <> Term.labeledDependencies trm
|
||||
|
||||
@ -11,7 +11,6 @@ import qualified Data.Char as Char
|
||||
import Data.Foldable
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Unison.Syntax.Name as Name (toText)
|
||||
import Data.Maybe
|
||||
import Data.Sequence (Seq)
|
||||
import Data.Text (Text)
|
||||
@ -27,6 +26,7 @@ import Unison.Server.Doc
|
||||
import qualified Unison.Server.Doc as Doc
|
||||
import Unison.Server.Syntax (SyntaxText)
|
||||
import qualified Unison.Server.Syntax as Syntax
|
||||
import qualified Unison.Syntax.Name as Name (toText)
|
||||
|
||||
data NamedLinkHref
|
||||
= Href Text
|
||||
@ -478,6 +478,7 @@ toHtml docNamesByRef document =
|
||||
pure $ div_ [class_ "source rich embed"] $ codeBlock [] (Syntax.toHtml syntax)
|
||||
EmbedInline syntax ->
|
||||
pure $ span_ [class_ "source rich embed-inline"] $ inlineCode [] (Syntax.toHtml syntax)
|
||||
RenderError (InvalidTerm err) -> pure $ Syntax.toHtml err
|
||||
Join docs ->
|
||||
span_ [class_ "join"] <$> renderSequence currentSectionLevelToHtml (mergeWords " " docs)
|
||||
UntitledSection docs ->
|
||||
|
||||
Loading…
Reference in New Issue
Block a user