mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
⅄ trunk → 24-08-01-merge-api
This commit is contained in:
commit
b94698057d
8
.github/workflows/nix-dev-cache.yaml
vendored
8
.github/workflows/nix-dev-cache.yaml
vendored
@ -24,6 +24,12 @@ jobs:
|
||||
- macOS-14
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
- name: mount Nix store on larger partition
|
||||
# on the Linux runner `/` doesn't have enough space, but there's a `/mnt` which does.
|
||||
if: runner.os == 'Linux'
|
||||
run: |
|
||||
sudo mkdir /nix /mnt/nix
|
||||
sudo mount --bind /mnt/nix /nix
|
||||
- uses: cachix/install-nix-action@v27
|
||||
if: runner.os == 'Linux'
|
||||
with:
|
||||
@ -38,3 +44,5 @@ jobs:
|
||||
authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
|
||||
- name: build all packages and development shells
|
||||
run: nix -L build --accept-flake-config --no-link --keep-going '.#all'
|
||||
- name: print disk free status
|
||||
run: df -h
|
||||
|
@ -42,7 +42,7 @@ Some tests are executables instead:
|
||||
|
||||
* `stack exec transcripts` runs the transcripts-related integration tests, found in `unison-src/transcripts`. You can add more tests to this directory.
|
||||
* `stack exec transcripts -- prefix-of-filename` runs only transcript tests with a matching filename prefix.
|
||||
* `stack exec integration-tests` runs the additional integration tests for cli. These tests are not triggered by `tests` or `transcripts`.
|
||||
* `stack exec cli-integration-tests` runs the additional integration tests for cli. These tests are not triggered by `tests` or `transcripts`.
|
||||
* `stack exec unison -- transcript unison-src/transcripts-round-trip/main.md` runs the pretty-printing round trip tests
|
||||
* `stack exec unison -- transcript unison-src/transcripts-manual/benchmarks.md` runs the benchmark suite. Output goes in unison-src/transcripts-manual/benchmarks/output.txt.
|
||||
|
||||
@ -220,3 +220,7 @@ nix develop '.#cabal-unison-parser-typechecker'
|
||||
cd unison-cli
|
||||
cabal run --enable-profiling unison-cli-main:exe:unison -- +RTS -p
|
||||
```
|
||||
|
||||
## Native compilation
|
||||
|
||||
See the [readme](scheme-libs/racket/unison/Readme.md).
|
||||
|
@ -35,6 +35,7 @@ module Unison.PatternMatchCoverage
|
||||
)
|
||||
where
|
||||
|
||||
import Data.List.NonEmpty (nonEmpty)
|
||||
import Data.Set qualified as Set
|
||||
import Debug.Trace
|
||||
import Unison.Debug
|
||||
@ -53,24 +54,25 @@ import Unison.Util.Pretty qualified as P
|
||||
checkMatch ::
|
||||
forall vt v loc m.
|
||||
(Pmc vt v loc m) =>
|
||||
-- | the match location
|
||||
loc ->
|
||||
-- | scrutinee type
|
||||
Type.Type vt loc ->
|
||||
-- | match cases
|
||||
[Term.MatchCase loc (Term.Term' vt v loc)] ->
|
||||
-- | (redundant locations, inaccessible locations, inhabitants of uncovered refinement type)
|
||||
m ([loc], [loc], [Pattern ()])
|
||||
checkMatch matchLocation scrutineeType cases = do
|
||||
checkMatch scrutineeType cases = do
|
||||
ppe <- getPrettyPrintEnv
|
||||
v0 <- fresh
|
||||
grdtree0 <- desugarMatch matchLocation scrutineeType v0 cases
|
||||
doDebug (P.hang (title "desugared:") (prettyGrdTree (prettyPmGrd ppe) (\_ -> "<loc>") grdtree0)) (pure ())
|
||||
(uncovered, grdtree1) <- uncoverAnnotate (Set.singleton (NC.markDirty v0 $ NC.declVar v0 scrutineeType id NC.emptyNormalizedConstraints)) grdtree0
|
||||
mgrdtree0 <- traverse (desugarMatch scrutineeType v0) (nonEmpty cases)
|
||||
doDebug (P.hang (title "desugared:") (prettyGrdTreeMaybe (prettyPmGrd ppe) (\_ -> "<loc>") mgrdtree0)) (pure ())
|
||||
let initialUncovered = Set.singleton (NC.markDirty v0 $ NC.declVar v0 scrutineeType id NC.emptyNormalizedConstraints)
|
||||
(uncovered, grdtree1) <- case mgrdtree0 of
|
||||
Nothing -> pure (initialUncovered, Nothing)
|
||||
Just grdtree0 -> fmap Just <$> uncoverAnnotate initialUncovered grdtree0
|
||||
doDebug
|
||||
( P.sep
|
||||
"\n"
|
||||
[ P.hang (title "annotated:") (prettyGrdTree (NC.prettyDnf ppe) (NC.prettyDnf ppe . fst) grdtree1),
|
||||
[ P.hang (title "annotated:") (prettyGrdTreeMaybe (NC.prettyDnf ppe) (NC.prettyDnf ppe . fst) grdtree1),
|
||||
P.hang (title "uncovered:") (NC.prettyDnf ppe uncovered)
|
||||
]
|
||||
)
|
||||
@ -78,9 +80,14 @@ checkMatch matchLocation scrutineeType cases = do
|
||||
uncoveredExpanded <- concat . fmap Set.toList <$> traverse (expandSolution v0) (Set.toList uncovered)
|
||||
doDebug (P.hang (title "uncovered expanded:") (NC.prettyDnf ppe (Set.fromList uncoveredExpanded))) (pure ())
|
||||
let sols = map (generateInhabitants v0) uncoveredExpanded
|
||||
let (_accessible, inaccessible, redundant) = classify grdtree1
|
||||
let (_accessible, inaccessible, redundant) = case grdtree1 of
|
||||
Nothing -> ([], [], [])
|
||||
Just x -> classify x
|
||||
pure (redundant, inaccessible, sols)
|
||||
where
|
||||
prettyGrdTreeMaybe prettyNode prettyLeaf = \case
|
||||
Nothing -> "<empty>"
|
||||
Just x -> prettyGrdTree prettyNode prettyLeaf x
|
||||
title = P.bold
|
||||
doDebug out = case shouldDebug PatternCoverage of
|
||||
True -> trace (P.toAnsiUnbroken out)
|
||||
|
@ -20,19 +20,14 @@ import Unison.Type qualified as Type
|
||||
desugarMatch ::
|
||||
forall loc vt v m.
|
||||
(Pmc vt v loc m) =>
|
||||
-- | loc of match
|
||||
loc ->
|
||||
-- | scrutinee type
|
||||
Type vt loc ->
|
||||
-- | scrutinee variable
|
||||
v ->
|
||||
-- | match cases
|
||||
[MatchCase loc (Term' vt v loc)] ->
|
||||
NonEmpty (MatchCase loc (Term' vt v loc)) ->
|
||||
m (GrdTree (PmGrd vt v loc) loc)
|
||||
desugarMatch loc0 scrutineeType v0 cs0 =
|
||||
traverse desugarClause cs0 >>= \case
|
||||
[] -> pure $ Leaf loc0
|
||||
x : xs -> pure $ Fork (x :| xs)
|
||||
desugarMatch scrutineeType v0 cs0 = Fork <$> traverse desugarClause cs0
|
||||
where
|
||||
desugarClause :: MatchCase loc (Term' vt v loc) -> m (GrdTree (PmGrd vt v loc) loc)
|
||||
desugarClause MatchCase {matchPattern, matchGuard} =
|
||||
|
@ -54,7 +54,7 @@ import Unison.Result qualified as Result
|
||||
import Unison.Settings qualified as Settings
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
import Unison.Syntax.Lexer qualified as L
|
||||
import Unison.Syntax.Lexer.Unison qualified as L
|
||||
import Unison.Syntax.Name qualified as Name (toText)
|
||||
import Unison.Syntax.NamePrinter (prettyHashQualified0)
|
||||
import Unison.Syntax.Parser (Annotated, ann)
|
||||
@ -1336,7 +1336,7 @@ prettyParseError s e =
|
||||
lexerOutput :: Pretty (AnnotatedText a)
|
||||
lexerOutput =
|
||||
if showLexerOutput
|
||||
then "\nLexer output:\n" <> fromString (L.debugLex' s)
|
||||
then "\nLexer output:\n" <> fromString (L.debugPreParse' s)
|
||||
else mempty
|
||||
|
||||
renderParseErrors ::
|
||||
@ -1861,6 +1861,14 @@ renderParseErrors s = \case
|
||||
<> structuralVsUniqueDocsLink
|
||||
]
|
||||
in (msg, rangeForToken <$> [void keyword, void name])
|
||||
go (Parser.TypeNotAllowed tok) =
|
||||
let msg =
|
||||
Pr.lines
|
||||
[ Pr.wrap "I expected to see a term here, but instead it’s a type:",
|
||||
"",
|
||||
tokenAsErrorSite s $ HQ.toText <$> tok
|
||||
]
|
||||
in (msg, [rangeForToken tok])
|
||||
|
||||
unknownConstructor ::
|
||||
String -> L.Token (HashQualified Name) -> Pretty ColorText
|
||||
|
@ -12,6 +12,7 @@ module Unison.Syntax.TermParser
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Comonad.Cofree (Cofree ((:<)))
|
||||
import Control.Monad.Reader (asks, local)
|
||||
import Data.Char qualified as Char
|
||||
import Data.Foldable (foldrM)
|
||||
@ -24,7 +25,9 @@ import Data.Sequence qualified as Sequence
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Data.Tuple.Extra qualified as TupleE
|
||||
import Data.Void (absurd, vacuous)
|
||||
import Text.Megaparsec qualified as P
|
||||
import U.Codebase.Reference (ReferenceType (..))
|
||||
import U.Core.ABT qualified as ABT
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.Builtin.Decls qualified as DD
|
||||
@ -38,18 +41,19 @@ import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.NamesWithHistory qualified as Names
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Parser.Ann (Ann (Ann))
|
||||
import Unison.Parser.Ann qualified as Ann
|
||||
import Unison.Pattern (Pattern)
|
||||
import Unison.Pattern qualified as Pattern
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Syntax.Lexer qualified as L
|
||||
import Unison.Syntax.Lexer.Unison qualified as L
|
||||
import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
import Unison.Syntax.Parser hiding (seq)
|
||||
import Unison.Syntax.Parser qualified as Parser (seq, uniqueName)
|
||||
import Unison.Syntax.Parser.Doc.Data qualified as Doc
|
||||
import Unison.Syntax.TypeParser qualified as TypeParser
|
||||
import Unison.Term (IsTop, Term)
|
||||
import Unison.Term qualified as Term
|
||||
@ -101,7 +105,7 @@ rewriteBlock = do
|
||||
rewriteTermlike kw mk = do
|
||||
kw <- quasikeyword kw
|
||||
lhs <- term
|
||||
(_spanAnn, rhs) <- block "==>"
|
||||
(_spanAnn, rhs) <- layoutBlock "==>"
|
||||
pure (mk (ann kw <> ann rhs) lhs rhs)
|
||||
rewriteTerm = rewriteTermlike "term" DD.rewriteTerm
|
||||
rewriteCase = rewriteTermlike "case" DD.rewriteCase
|
||||
@ -113,8 +117,10 @@ rewriteBlock = do
|
||||
pure (DD.rewriteType (ann kw <> ann rhs) (L.payload <$> vs) lhs rhs)
|
||||
|
||||
typeLink' :: (Monad m, Var v) => P v m (L.Token Reference)
|
||||
typeLink' = do
|
||||
id <- hqPrefixId
|
||||
typeLink' = findUniqueType =<< hqPrefixId
|
||||
|
||||
findUniqueType :: (Monad m, Var v) => L.Token (HQ.HashQualified Name) -> P v m (L.Token Reference)
|
||||
findUniqueType id = do
|
||||
ns <- asks names
|
||||
case Names.lookupHQType Names.IncludeSuffixes (L.payload id) ns of
|
||||
s
|
||||
@ -160,13 +166,13 @@ match :: (Monad m, Var v) => TermP v m
|
||||
match = do
|
||||
start <- openBlockWith "match"
|
||||
scrutinee <- term
|
||||
_ <- closeBlock
|
||||
_ <- optionalCloseBlock
|
||||
_ <-
|
||||
P.try (openBlockWith "with") <|> do
|
||||
t <- anyToken
|
||||
P.customFailure (ExpectedBlockOpen "with" t)
|
||||
(_arities, cases) <- NonEmpty.unzip <$> matchCases1 start
|
||||
_ <- closeBlock
|
||||
_ <- optionalCloseBlock
|
||||
pure $
|
||||
Term.match
|
||||
(ann start <> ann (NonEmpty.last cases))
|
||||
@ -208,10 +214,10 @@ matchCase = do
|
||||
[ Nothing <$ P.try (quasikeyword "otherwise"),
|
||||
Just <$> infixAppOrBooleanOp
|
||||
]
|
||||
(_spanAnn, t) <- block "->"
|
||||
(_spanAnn, t) <- layoutBlock "->"
|
||||
pure (guard, t)
|
||||
let unguardedBlock = label "case match" do
|
||||
(_spanAnn, t) <- block "->"
|
||||
(_spanAnn, t) <- layoutBlock "->"
|
||||
pure (Nothing, t)
|
||||
-- a pattern's RHS is either one or more guards, or a single unguarded block.
|
||||
guardsAndBlocks <- guardedBlocks <|> (pure @[] <$> unguardedBlock)
|
||||
@ -294,12 +300,13 @@ parsePattern = label "pattern" root
|
||||
do _ <- anyToken; pure (Set.findMin s <$ tok)
|
||||
where
|
||||
isLower = Text.all Char.isLower . Text.take 1 . Name.toText
|
||||
isIgnored n = Text.take 1 (Name.toText n) == "_"
|
||||
die hq s = case L.payload hq of
|
||||
-- if token not hash qualified or uppercase,
|
||||
-- fail w/out consuming it to allow backtracking
|
||||
HQ.NameOnly n
|
||||
| Set.null s
|
||||
&& isLower n ->
|
||||
&& (isLower n || isIgnored n) ->
|
||||
fail $ "not a constructor name: " <> show n
|
||||
-- it was hash qualified, and wasn't found in the env, that's a failure!
|
||||
_ -> failCommitted $ err hq s
|
||||
@ -353,10 +360,10 @@ lam p = label "lambda" $ mkLam <$> P.try (some prefixDefinitionName <* reserved
|
||||
in Term.lam' (ann (head vs) <> ann b) annotatedArgs b
|
||||
|
||||
letBlock, handle, ifthen :: (Monad m, Var v) => TermP v m
|
||||
letBlock = label "let" $ (snd <$> block "let")
|
||||
letBlock = label "let" $ (snd <$> layoutBlock "let")
|
||||
handle = label "handle" do
|
||||
(handleSpan, b) <- block "handle"
|
||||
(_withSpan, handler) <- block "with"
|
||||
(_withSpan, handler) <- layoutBlock "with"
|
||||
-- We don't use the annotation span from 'with' here because it will
|
||||
-- include a dedent if it's at the end of block.
|
||||
-- Meaning the newline gets overwritten when pretty-printing and it messes things up.
|
||||
@ -373,7 +380,7 @@ lamCase = do
|
||||
start <- openBlockWith "cases"
|
||||
cases <- matchCases1 start
|
||||
(arity, cases) <- checkCasesArities cases
|
||||
_ <- closeBlock
|
||||
_ <- optionalCloseBlock
|
||||
lamvars <- replicateM arity (Parser.uniqueName 10)
|
||||
let vars =
|
||||
Var.named <$> [tweak v i | (v, i) <- lamvars `zip` [(1 :: Int) ..]]
|
||||
@ -392,7 +399,7 @@ ifthen = label "if" do
|
||||
start <- peekAny
|
||||
(_spanAnn, c) <- block "if"
|
||||
(_spanAnn, t) <- block "then"
|
||||
(_spanAnn, f) <- block "else"
|
||||
(_spanAnn, f) <- layoutBlock "else"
|
||||
pure $ Term.iff (ann start <> ann f) c t f
|
||||
|
||||
text :: (Var v) => TermP v m
|
||||
@ -434,7 +441,7 @@ resolveHashQualified tok = do
|
||||
names <- asks names
|
||||
case L.payload tok of
|
||||
HQ.NameOnly n -> pure $ Term.var (ann tok) (Name.toVar n)
|
||||
_ -> case Names.lookupHQTerm Names.IncludeSuffixes (L.payload tok) names of
|
||||
hqn -> case Names.lookupHQTerm Names.IncludeSuffixes hqn names of
|
||||
s
|
||||
| Set.null s -> failCommitted $ UnknownTerm tok s
|
||||
| Set.size s > 1 -> failCommitted $ UnknownTerm tok s
|
||||
@ -461,160 +468,173 @@ termLeaf =
|
||||
doc2Block <&> \(spanAnn, trm) -> trm {ABT.annotation = ABT.annotation trm <> spanAnn}
|
||||
]
|
||||
|
||||
-- Syntax for documentation v2 blocks, which are surrounded by {{ }}.
|
||||
-- | Gives a parser an explicit stream to parse, so that it consumes nothing from the original stream when it runs.
|
||||
--
|
||||
-- This is used inside the `Doc` -> `Term` conversion, where we have chunks of Unison code embedded that need to be
|
||||
-- parsed. It’s a consequence of parsing Doc in the midst of the Unison lexer.
|
||||
subParse :: (Ord v, Monad m) => P v m a -> [L.Token L.Lexeme] -> P v m a
|
||||
subParse p toks = do
|
||||
orig <- P.getInput
|
||||
P.setInput $ Input toks
|
||||
result <- p <* P.eof
|
||||
P.setInput orig
|
||||
pure result
|
||||
|
||||
-- | Syntax for documentation v2 blocks, which are surrounded by @{{@ @}}@.
|
||||
-- The lexer does most of the heavy lifting so there's not a lot for
|
||||
-- the parser to do. For instance, in
|
||||
--
|
||||
-- {{
|
||||
-- Hi there!
|
||||
--
|
||||
-- goodbye.
|
||||
-- }}
|
||||
-- > {{
|
||||
-- > Hi there!
|
||||
-- >
|
||||
-- > goodbye.
|
||||
-- > }}
|
||||
--
|
||||
-- the lexer will produce:
|
||||
--
|
||||
-- [Open "syntax.docUntitledSection",
|
||||
-- Open "syntax.docParagraph",
|
||||
-- Open "syntax.docWord", Textual "Hi", Close,
|
||||
-- Open "syntax.docWord", Textual "there!", Close,
|
||||
-- Close
|
||||
-- Open "syntax.docParagraph",
|
||||
-- Open "syntax.docWord", Textual "goodbye", Close,
|
||||
-- Close
|
||||
-- Close]
|
||||
-- > [ Doc
|
||||
-- > ( DocUntitledSection
|
||||
-- > (DocParagraph (DocWord "Hi" :| [DocWord "there!"]))
|
||||
-- > (DocParagraph (DocWord "goodbye" :| []))
|
||||
-- > )
|
||||
-- > ]
|
||||
--
|
||||
-- The parser will parse this into the Unison expression:
|
||||
--
|
||||
-- syntax.docUntitledSection [
|
||||
-- syntax.docParagraph [syntax.docWord "Hi", syntax.docWord "there!"],
|
||||
-- syntax.docParagraph [syntax.docWord "goodbye"]
|
||||
-- ]
|
||||
-- > syntax.docUntitledSection [
|
||||
-- > syntax.docParagraph [syntax.docWord "Hi", syntax.docWord "there!"],
|
||||
-- > syntax.docParagraph [syntax.docWord "goodbye"]
|
||||
-- > ]
|
||||
--
|
||||
-- Where `syntax.doc{Paragraph, UntitledSection,...}` are all ordinary term
|
||||
-- Where @syntax.doc{Paragraph, UntitledSection,...}@ are all ordinary term
|
||||
-- variables that will be looked up in the environment like anything else. This
|
||||
-- means that the documentation syntax can have its meaning changed by
|
||||
-- overriding what functions the names `syntax.doc*` correspond to.
|
||||
-- overriding what functions the names @syntax.doc*@ correspond to.
|
||||
doc2Block :: forall m v. (Monad m, Var v) => P v m (Ann {- Annotation for the whole spanning block -}, Term v Ann)
|
||||
doc2Block = do
|
||||
P.lookAhead (openBlockWith "syntax.docUntitledSection") *> elem
|
||||
L.Token docContents startDoc endDoc <- doc
|
||||
let docAnn = Ann startDoc endDoc
|
||||
(docAnn,) . docUntitledSection (gann docAnn) <$> traverse (cata $ docTop <=< sequenceA) docContents
|
||||
where
|
||||
-- For terms which aren't blocks the spanning annotation is the same as the
|
||||
-- term annotation.
|
||||
selfAnnotated :: Term v Ann -> (Ann, Term v Ann)
|
||||
selfAnnotated t = (ann t, t)
|
||||
elem :: P v m (Ann {- Annotation for the whole spanning block -}, Term v Ann)
|
||||
elem =
|
||||
(selfAnnotated <$> text) <|> do
|
||||
startTok <- openBlock
|
||||
let -- here, `t` will be something like `Open "syntax.docWord"`
|
||||
-- so `f` will be a term var with the name "syntax.docWord".
|
||||
f = f' startTok
|
||||
f' t = Term.var (ann t) (Var.nameds (L.payload t))
|
||||
cata :: (Functor f) => (f a -> a) -> Cofree f x -> a
|
||||
cata fn (_ :< fx) = fn $ cata fn <$> fx
|
||||
|
||||
-- follows are some common syntactic forms used for parsing child elements
|
||||
gann :: (Annotated a) => a -> Ann
|
||||
gann = Ann.GeneratedFrom . ann
|
||||
|
||||
-- regular is parsed into `f child1 child2 child3` for however many children
|
||||
regular = do
|
||||
cs <- P.many (snd <$> elem)
|
||||
endTok <- closeBlock
|
||||
let trm = Term.apps' f cs
|
||||
pure (ann startTok <> ann endTok, trm)
|
||||
addDelay :: Term v Ann -> Term v Ann
|
||||
addDelay tm = Term.delay (ann tm) tm
|
||||
|
||||
-- variadic is parsed into: `f [child1, child2, ...]`
|
||||
variadic = variadic' f
|
||||
variadic' f = do
|
||||
cs <- P.many (snd <$> elem)
|
||||
endTok <- closeBlock
|
||||
let trm = Term.apps' f [Term.list (ann cs) cs]
|
||||
pure (ann startTok <> ann endTok, trm)
|
||||
f :: (Annotated a) => a -> String -> Term v Ann
|
||||
f a = Term.var (gann a) . Var.nameds . ("syntax.doc" <>)
|
||||
|
||||
-- sectionLike is parsed into: `f tm [child1, child2, ...]`
|
||||
sectionLike = do
|
||||
arg1 <- (snd <$> elem)
|
||||
cs <- P.many (snd <$> elem)
|
||||
endTok <- closeBlock
|
||||
let trm = Term.apps' f [arg1, Term.list (ann cs) cs]
|
||||
pure (ann startTok <> ann endTok, trm)
|
||||
docUntitledSection :: Ann -> Doc.UntitledSection (Term v Ann) -> Term v Ann
|
||||
docUntitledSection ann (Doc.UntitledSection tops) =
|
||||
Term.app ann (f ann "UntitledSection") $ Term.list (gann tops) tops
|
||||
|
||||
evalLike wrap = do
|
||||
tm <- term
|
||||
endTok <- closeBlock
|
||||
let trm = Term.apps' f [wrap tm]
|
||||
pure (ann startTok <> ann endTok, trm)
|
||||
docTop :: Doc.Top (ReferenceType, HQ'.HashQualified Name) [L.Token L.Lexeme] (Term v Ann) -> TermP v m
|
||||
docTop d = case d of
|
||||
Doc.Section title body -> pure $ Term.apps' (f d "Section") [title, Term.list (gann body) body]
|
||||
Doc.Eval code ->
|
||||
Term.app (gann d) (f d "Eval") . addDelay . snd
|
||||
<$> subParse (block' False False "syntax.docEval" (pure $ pure ()) $ Ann.External <$ P.eof) code
|
||||
Doc.ExampleBlock code ->
|
||||
Term.apps' (f d "ExampleBlock") . (Term.nat (gann d) 0 :) . pure . addDelay . snd
|
||||
<$> subParse (block' False True "syntax.docExampleBlock" (pure $ pure ()) $ Ann.External <$ P.eof) code
|
||||
Doc.CodeBlock label body ->
|
||||
pure $
|
||||
Term.apps'
|
||||
(f d "CodeBlock")
|
||||
[Term.text (ann label) . Text.pack $ L.payload label, Term.text (ann body) . Text.pack $ L.payload body]
|
||||
Doc.BulletedList items ->
|
||||
pure $ Term.app (gann d) (f d "BulletedList") . Term.list (gann items) . toList $ docColumn <$> items
|
||||
Doc.NumberedList items@((n, _) :| _) ->
|
||||
pure $
|
||||
Term.apps'
|
||||
(f d "NumberedList")
|
||||
[Term.nat (ann d) $ L.payload n, Term.list (gann $ snd <$> items) . toList $ docColumn . snd <$> items]
|
||||
Doc.Paragraph leaves ->
|
||||
Term.app (gann d) (f d "Paragraph") . Term.list (ann leaves) . toList <$> traverse docLeaf leaves
|
||||
|
||||
-- converts `tm` to `'tm`
|
||||
--
|
||||
-- Embedded examples like ``1 + 1`` are represented as terms,
|
||||
-- but are wrapped in delays so they are left unevaluated for the
|
||||
-- code which renders documents. (We want the doc display to get
|
||||
-- the unevaluated expression `1 + 1` and not `2`)
|
||||
addDelay tm = Term.delay (ann tm) tm
|
||||
case L.payload startTok of
|
||||
"syntax.docJoin" -> variadic
|
||||
"syntax.docUntitledSection" -> variadic
|
||||
"syntax.docColumn" -> variadic
|
||||
"syntax.docParagraph" -> variadic
|
||||
"syntax.docSignature" -> variadic
|
||||
"syntax.docSource" -> variadic
|
||||
"syntax.docFoldedSource" -> variadic
|
||||
"syntax.docBulletedList" -> variadic
|
||||
"syntax.docSourceAnnotations" -> variadic
|
||||
"syntax.docSourceElement" -> do
|
||||
link <- (snd <$> elem)
|
||||
anns <- P.optional $ reserved "@" *> (snd <$> elem)
|
||||
endTok <- closeBlock
|
||||
let trm = Term.apps' f [link, fromMaybe (Term.list (ann link) mempty) anns]
|
||||
pure (ann startTok <> ann endTok, trm)
|
||||
"syntax.docNumberedList" -> do
|
||||
nitems@((n, _) : _) <- P.some nitem
|
||||
endTok <- closeBlock
|
||||
let items = snd <$> nitems
|
||||
let trm = Term.apps' f [n, Term.list (ann items) items]
|
||||
pure (ann startTok <> ann endTok, trm)
|
||||
where
|
||||
nitem = do
|
||||
n <- number
|
||||
t <- openBlockWith "syntax.docColumn"
|
||||
let f = f' ("syntax.docColumn" <$ t)
|
||||
(_spanAnn, child) <- variadic' f
|
||||
pure (n, child)
|
||||
"syntax.docSection" -> sectionLike
|
||||
-- @source{ type Blah, foo, type Bar }
|
||||
"syntax.docEmbedTermLink" -> do
|
||||
tm <- addDelay <$> (hashQualifiedPrefixTerm <|> hashQualifiedInfixTerm)
|
||||
endTok <- closeBlock
|
||||
let trm = Term.apps' f [tm]
|
||||
pure (ann startTok <> ann endTok, trm)
|
||||
"syntax.docEmbedSignatureLink" -> do
|
||||
tm <- addDelay <$> (hashQualifiedPrefixTerm <|> hashQualifiedInfixTerm)
|
||||
endTok <- closeBlock
|
||||
let trm = Term.apps' f [tm]
|
||||
pure (ann startTok <> ann endTok, trm)
|
||||
"syntax.docEmbedTypeLink" -> do
|
||||
r <- typeLink'
|
||||
endTok <- closeBlock
|
||||
let trm = Term.apps' f [Term.typeLink (ann r) (L.payload r)]
|
||||
pure (ann startTok <> ann endTok, trm)
|
||||
"syntax.docExample" -> do
|
||||
trm <- term
|
||||
endTok <- closeBlock
|
||||
let spanAnn = ann startTok <> ann endTok
|
||||
pure . (spanAnn,) $ case trm of
|
||||
tm@(Term.Apps' _ xs) ->
|
||||
let fvs = List.Extra.nubOrd $ concatMap (toList . Term.freeVars) xs
|
||||
n = Term.nat (ann tm) (fromIntegral (length fvs))
|
||||
lam = addDelay $ Term.lam' (ann tm) ((Ann.GeneratedFrom spanAnn,) <$> fvs) tm
|
||||
in Term.apps' f [n, lam]
|
||||
tm -> Term.apps' f [Term.nat (ann tm) 0, addDelay tm]
|
||||
"syntax.docTransclude" -> evalLike id
|
||||
"syntax.docEvalInline" -> evalLike addDelay
|
||||
"syntax.docExampleBlock" -> do
|
||||
(spanAnn, tm) <- block'' False True "syntax.docExampleBlock" (pure (void startTok)) closeBlock
|
||||
pure $ (spanAnn, Term.apps' f [Term.nat (ann tm) 0, addDelay tm])
|
||||
"syntax.docEval" -> do
|
||||
(spanAnn, tm) <- block' False "syntax.docEval" (pure (void startTok)) closeBlock
|
||||
pure $ (spanAnn, Term.apps' f [addDelay tm])
|
||||
_ -> regular
|
||||
docColumn :: Doc.Column (Term v Ann) -> Term v Ann
|
||||
docColumn d@(Doc.Column para sublist) =
|
||||
Term.app (gann d) (f d "Column") . Term.list (gann d) $ para : toList sublist
|
||||
|
||||
docLeaf :: Doc.Leaf (ReferenceType, HQ'.HashQualified Name) [L.Token L.Lexeme] (Term v Ann) -> TermP v m
|
||||
docLeaf d = case d of
|
||||
Doc.Link link -> Term.app (gann d) (f d "Link") <$> docEmbedLink link
|
||||
Doc.NamedLink para target -> Term.apps' (f d "NamedLink") . (para :) . pure <$> docLeaf (vacuous target)
|
||||
Doc.Example code -> do
|
||||
trm <- subParse term code
|
||||
pure . Term.apps' (f d "Example") $ case trm of
|
||||
tm@(Term.Apps' _ xs) ->
|
||||
let fvs = List.Extra.nubOrd $ concatMap (toList . Term.freeVars) xs
|
||||
n = Term.nat (ann tm) (fromIntegral (length fvs))
|
||||
lam = addDelay $ Term.lam' (ann tm) ((mempty,) <$> fvs) tm
|
||||
in [n, lam]
|
||||
tm -> [Term.nat (ann tm) 0, addDelay tm]
|
||||
Doc.Transclude code -> Term.app (gann d) (f d "Transclude") <$> subParse term code
|
||||
Doc.Bold para -> pure $ Term.app (gann d) (f d "Bold") para
|
||||
Doc.Italic para -> pure $ Term.app (gann d) (f d "Italic") para
|
||||
Doc.Strikethrough para -> pure $ Term.app (gann d) (f d "Strikethrough") para
|
||||
Doc.Verbatim leaf -> Term.app (gann d) (f d "Verbatim") <$> docLeaf (bimap absurd absurd leaf)
|
||||
Doc.Code leaf -> Term.app (gann d) (f d "Code") <$> docLeaf (bimap absurd absurd leaf)
|
||||
Doc.Source elems ->
|
||||
Term.app (gann d) (f d "Source") . Term.list (ann elems) . toList <$> traverse docSourceElement elems
|
||||
Doc.FoldedSource elems ->
|
||||
Term.app (gann d) (f d "FoldedSource") . Term.list (ann elems) . toList <$> traverse docSourceElement elems
|
||||
Doc.EvalInline code -> Term.app (gann d) (f d "EvalInline") . addDelay <$> subParse term code
|
||||
Doc.Signature links ->
|
||||
Term.app (gann d) (f d "Signature") . Term.list (ann links) . toList <$> traverse docEmbedSignatureLink links
|
||||
Doc.SignatureInline link -> Term.app (gann d) (f d "SignatureInline") <$> docEmbedSignatureLink link
|
||||
Doc.Word txt -> pure . Term.app (gann d) (f d "Word") . Term.text (ann txt) . Text.pack $ L.payload txt
|
||||
Doc.Group (Doc.Join leaves) ->
|
||||
Term.app (gann d) (f d "Group") . Term.app (gann d) (f d "Join") . Term.list (ann leaves) . toList
|
||||
<$> traverse docLeaf leaves
|
||||
|
||||
docEmbedLink :: Doc.EmbedLink (ReferenceType, HQ'.HashQualified Name) -> TermP v m
|
||||
docEmbedLink d@(Doc.EmbedLink (L.Token (level, ident) start end)) = case level of
|
||||
RtType ->
|
||||
Term.app (gann d) (f d "EmbedTypeLink") . Term.typeLink (ann d) . L.payload
|
||||
<$> findUniqueType (L.Token (HQ'.toHQ ident) start end)
|
||||
RtTerm ->
|
||||
Term.app (gann d) (f d "EmbedTermLink") . addDelay <$> resolveHashQualified (L.Token (HQ'.toHQ ident) start end)
|
||||
|
||||
docSourceElement ::
|
||||
Doc.SourceElement
|
||||
(ReferenceType, HQ'.HashQualified Name)
|
||||
(Doc.Leaf (ReferenceType, HQ'.HashQualified Name) [L.Token L.Lexeme] Void) ->
|
||||
TermP v m
|
||||
docSourceElement d@(Doc.SourceElement link anns) = do
|
||||
link' <- docEmbedLink link
|
||||
anns' <- traverse docEmbedAnnotation anns
|
||||
pure $ Term.apps' (f d "SourceElement") [link', Term.list (ann anns) anns']
|
||||
|
||||
docEmbedSignatureLink :: Doc.EmbedSignatureLink (ReferenceType, HQ'.HashQualified Name) -> TermP v m
|
||||
docEmbedSignatureLink d@(Doc.EmbedSignatureLink (L.Token (level, ident) start end)) = case level of
|
||||
RtType -> P.customFailure . TypeNotAllowed $ L.Token (HQ'.toHQ ident) start end
|
||||
RtTerm ->
|
||||
Term.app (gann d) (f d "EmbedSignatureLink") . addDelay
|
||||
<$> resolveHashQualified (L.Token (HQ'.toHQ ident) start end)
|
||||
|
||||
docEmbedAnnotation ::
|
||||
Doc.EmbedAnnotation
|
||||
(ReferenceType, HQ'.HashQualified Name)
|
||||
(Doc.Leaf (ReferenceType, HQ'.HashQualified Name) [L.Token L.Lexeme] Void) ->
|
||||
TermP v m
|
||||
docEmbedAnnotation d@(Doc.EmbedAnnotation a) =
|
||||
-- This is the only place I’m not sure we’re doing the right thing. In the lexer, this can be an identifier or a
|
||||
-- DocLeaf, but here it could be either /text/ or a Doc element. And I don’t think there’s any way the lexemes
|
||||
-- produced for an identifier and the lexemes consumed for text line up. So, I think this is a bugfix I can’t
|
||||
-- avoid.
|
||||
Term.app (gann d) (f d "EmbedAnnotation")
|
||||
<$> either
|
||||
( \(L.Token (level, ident) start end) -> case level of
|
||||
RtType -> P.customFailure . TypeNotAllowed $ L.Token (HQ'.toHQ ident) start end
|
||||
RtTerm -> resolveHashQualified $ L.Token (HQ'.toHQ ident) start end
|
||||
)
|
||||
(docLeaf . vacuous)
|
||||
a
|
||||
|
||||
docBlock :: (Monad m, Var v) => TermP v m
|
||||
docBlock = do
|
||||
@ -988,7 +1008,7 @@ delayQuote = P.label "quote" do
|
||||
|
||||
delayBlock :: (Monad m, Var v) => P v m (Ann {- Ann spanning the whole block -}, Term v Ann)
|
||||
delayBlock = P.label "do" do
|
||||
(spanAnn, b) <- block "do"
|
||||
(spanAnn, b) <- layoutBlock "do"
|
||||
let argSpan = (ann b {- would be nice to use the annotation for 'do' here, but it's not terribly important -})
|
||||
pure $ (spanAnn, DD.delayTerm (ann b) argSpan b)
|
||||
|
||||
@ -1075,7 +1095,7 @@ destructuringBind = do
|
||||
let boundVars' = snd <$> boundVars
|
||||
_ <- P.lookAhead (openBlockWith "=")
|
||||
pure (p, boundVars')
|
||||
(_spanAnn, scrute) <- block "=" -- Dwight K. Scrute ("The People's Scrutinee")
|
||||
(_spanAnn, scrute) <- layoutBlock "=" -- Dwight K. Scrute ("The People's Scrutinee")
|
||||
let guard = Nothing
|
||||
let absChain vs t = foldr (\v t -> ABT.abs' (ann t) v t) t vs
|
||||
thecase t = Term.MatchCase p (fmap (absChain boundVars) guard) $ absChain boundVars t
|
||||
@ -1143,7 +1163,10 @@ customFailure :: (P.MonadParsec e s m) => e -> m a
|
||||
customFailure = P.customFailure
|
||||
|
||||
block :: forall m v. (Monad m, Var v) => String -> P v m (Ann, Term v Ann)
|
||||
block s = block' False s (openBlockWith s) closeBlock
|
||||
block s = block' False False s (openBlockWith s) closeBlock
|
||||
|
||||
layoutBlock :: forall m v. (Monad m, Var v) => String -> P v m (Ann, Term v Ann)
|
||||
layoutBlock s = block' False False s (openBlockWith s) optionalCloseBlock
|
||||
|
||||
-- example: use Foo.bar.Baz + ++ x
|
||||
-- + ++ and x are called the "suffixes" of the `use` statement, and
|
||||
@ -1213,24 +1236,16 @@ substImports ns imports =
|
||||
]
|
||||
|
||||
block' ::
|
||||
(Monad m, Var v) =>
|
||||
IsTop ->
|
||||
String ->
|
||||
P v m (L.Token ()) ->
|
||||
P v m (L.Token ()) ->
|
||||
P v m (Ann {- ann which spans the whole block -}, Term v Ann)
|
||||
block' isTop = block'' isTop False
|
||||
|
||||
block'' ::
|
||||
forall m v end.
|
||||
(Monad m, Var v, Annotated end) =>
|
||||
IsTop ->
|
||||
Bool -> -- `True` means insert `()` at end of block if it ends with a statement
|
||||
-- | `True` means insert `()` at end of block if it ends with a statement
|
||||
Bool ->
|
||||
String ->
|
||||
P v m (L.Token ()) ->
|
||||
P v m end ->
|
||||
P v m (Ann {- ann which spans the whole block -}, Term v Ann)
|
||||
block'' isTop implicitUnitAtEnd s openBlock closeBlock = do
|
||||
block' isTop implicitUnitAtEnd s openBlock closeBlock = do
|
||||
open <- openBlock
|
||||
(names, imports) <- imports
|
||||
_ <- optional semi
|
||||
|
@ -51,7 +51,7 @@ import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Syntax.HashQualified qualified as HQ (unsafeFromVar)
|
||||
import Unison.Syntax.Lexer (showEscapeChar)
|
||||
import Unison.Syntax.Lexer.Unison (showEscapeChar)
|
||||
import Unison.Syntax.Name qualified as Name (isSymboly, parseText, parseTextEither, toText, unsafeParseText)
|
||||
import Unison.Syntax.NamePrinter (styleHashQualified'')
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
|
||||
|
@ -1525,7 +1525,7 @@ ensurePatternCoverage theMatch _theMatchType _scrutinee scrutineeType cases = do
|
||||
constructorCache = mempty
|
||||
}
|
||||
(redundant, _inaccessible, uncovered) <- flip evalStateT pmcState do
|
||||
checkMatch matchLoc scrutineeType cases
|
||||
checkMatch scrutineeType cases
|
||||
let checkUncovered = case Nel.nonEmpty uncovered of
|
||||
Nothing -> pure ()
|
||||
Just xs -> failWith (UncoveredPatterns matchLoc xs)
|
||||
|
6
scheme-libs/racket/unison/.gitignore
vendored
Normal file
6
scheme-libs/racket/unison/.gitignore
vendored
Normal file
@ -0,0 +1,6 @@
|
||||
compiled/
|
||||
boot-generated.ss
|
||||
builtin-generated.ss
|
||||
compound-wrappers.ss
|
||||
data-info.ss
|
||||
simple-wrappers.ss
|
@ -1,5 +1,18 @@
|
||||
This directory contains libraries necessary for building and running
|
||||
unison programs via Racket Scheme.
|
||||
unison programs via Racket Scheme. The rough steps are as follows:
|
||||
|
||||
* Build Racket libraries from the current Unison version.
|
||||
* Build the `unison-runtime` binary.
|
||||
* Pass the path to `unison-runtime` to `ucm`.
|
||||
|
||||
Native compilation is done via the `compile.native` `ucm` command.
|
||||
Under-the-hood, Unison does the following:
|
||||
|
||||
* Convert the function to bytecode (similar to how `compile` command works).
|
||||
* Call `unison-runtime` which will convert the bytecode to a temporary Racket
|
||||
file. The Racket file is usually placed in your `.cache/unisonlanguage`.
|
||||
* folder. Call `raco exe file.rkt -o executable` which will create a native
|
||||
executable from the Racket source code.
|
||||
|
||||
## Prerequisites
|
||||
|
||||
@ -9,20 +22,56 @@ You'll need to have a couple things installed on your system:
|
||||
* [Racket](https://racket-lang.org/), with the executable `racket` on your path somewhere
|
||||
* [BLAKE2](https://github.com/BLAKE2/libb2) (you may need to install this manually)
|
||||
|
||||
|
||||
In particular, our crypto functions require on both `libcrypto` (from openssl) and `libb2`. You may have to tell racket where to find `libb2`, by adding an entry to the hash table in your [`config.rktd` file](https://docs.racket-lang.org/raco/config-file.html). This is what I had, for an M1 mac w/ libb2 installed via Homebrew:
|
||||
In particular, our crypto functions require both `libcrypto` (from openssl or
|
||||
eg. libressl) and `libb2`. You may have to tell racket where to find `libb2`, by
|
||||
adding an entry to the hash table in your
|
||||
[`config.rktd` file](https://docs.racket-lang.org/raco/config-file.html).
|
||||
This is what I had, for an M1 mac with `libb2` installed via Homebrew:
|
||||
```
|
||||
(lib-search-dirs . (#f "/opt/homebrew/Cellar/libb2/0.98.1/lib/"))
|
||||
$ cat scheme-libs/racket/config/config.rktd
|
||||
#hash(
|
||||
(lib-search-dirs . (#f "/opt/homebrew/Cellar/libb2/0.98.1/lib/"))
|
||||
)
|
||||
```
|
||||
You'll also need to install `x509-lib` with `raco pkg install x509-lib`
|
||||
|
||||
Finally, some distributions only package `racket-minimal`. You'll need to
|
||||
install the full compiler suite using `raco pkg install compiler-lib`
|
||||
([source](https://www.dbrunner.de/blog/2016/01/12/using-racket-minimal-and-raco/))
|
||||
|
||||
## Building
|
||||
|
||||
First, make sure unison is built (see [development](../../../development.markdown))
|
||||
|
||||
Next, use unison to generate the racket libraries. These are dependencies for
|
||||
building `unison-runtime`.
|
||||
* Read [gen-racket-libs.md](../../../unison-src/transcripts-manual/gen-racket-libs.md).
|
||||
It will contain two things:
|
||||
* `ucm` and `unison` transcripts that generate the libraries
|
||||
* Instructions on how to build `unison-runtime` using `raco`
|
||||
|
||||
If everything went well you should now have a new executable in `scheme-libs/racket/unison-runtime`.
|
||||
For example:
|
||||
```
|
||||
$ file scheme-libs/racket/unison-runtime
|
||||
scheme-libs/racket/unison-runtime: Mach-O 64-bit executable arm64
|
||||
```
|
||||
|
||||
## Running the unison test suite
|
||||
|
||||
To run the test suite, first `stack build` (or `stack build --fast`), then:
|
||||
Note that if you set up `config.rktd` above, you'll need to pass the path to its
|
||||
folder in `PLTCONFIGDIR` before invoking unison or the test scripts:
|
||||
|
||||
```
|
||||
./unison-src/builtin-tests/jit-tests.sh $(stack exec which unison) --runtime-path <path>
|
||||
export PLTCONFIGDIR=$(pwd)/scheme-libs/racket/config
|
||||
```
|
||||
|
||||
If you don't, some of the tests will fail with eg `ffi-lib: could not load foreign library`.
|
||||
|
||||
To run the test suite you can do:
|
||||
|
||||
```
|
||||
./unison-src/builtin-tests/jit-tests.sh $(stack exec which unison) --runtime-path scheme-libs/racket/unison-runtime
|
||||
```
|
||||
|
||||
OR if you want to run the same tests in interpreted mode:
|
||||
@ -31,7 +80,9 @@ OR if you want to run the same tests in interpreted mode:
|
||||
./unison-src/builtin-tests/interpreter-tests.sh
|
||||
```
|
||||
|
||||
The above scripts fetch and cache a copy of base and the scheme-generating libraries, and copy this directory to `$XDG_DATA_DIRECTORY/unisonlanguage/scheme-libs`.
|
||||
The above scripts fetch and cache a copy of base and the scheme-generating
|
||||
libraries, and copy this directory to `$XDG_DATA_DIRECTORY/unisonlanguage/scheme-libs`.
|
||||
Both scripts _should_ pass.
|
||||
|
||||
## Iterating more quickly
|
||||
|
||||
|
@ -63,6 +63,7 @@ import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject)
|
||||
import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace)
|
||||
import Unison.Codebase.Editor.HandleInput.FindAndReplace (handleStructuredFindI, handleStructuredFindReplaceI)
|
||||
import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Format
|
||||
import Unison.Codebase.Editor.HandleInput.Global qualified as Global
|
||||
import Unison.Codebase.Editor.HandleInput.InstallLib (handleInstallLib)
|
||||
import Unison.Codebase.Editor.HandleInput.LSPDebug qualified as LSPDebug
|
||||
import Unison.Codebase.Editor.HandleInput.Load (EvalMode (Sandboxed), evalUnisonFile, handleLoad, loadUnisonFile)
|
||||
@ -151,8 +152,7 @@ import Unison.ShortHash qualified as SH
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualified qualified as HQ (parseTextWith, toText)
|
||||
import Unison.Syntax.Lexer qualified as L
|
||||
import Unison.Syntax.Lexer qualified as Lexer
|
||||
import Unison.Syntax.Lexer.Unison qualified as L
|
||||
import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
import Unison.Syntax.Parser qualified as Parser
|
||||
@ -497,23 +497,27 @@ loop e = do
|
||||
fixupOutput = HQ'.toHQ . Path.nameFromHQSplit
|
||||
NamesI global query -> do
|
||||
hqLength <- Cli.runTransaction Codebase.hashLength
|
||||
(names, pped) <-
|
||||
if global
|
||||
then do
|
||||
error "TODO: Implement names.global."
|
||||
else do
|
||||
names <- Cli.currentNames
|
||||
let searchNames names = do
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames names
|
||||
pure (names, pped)
|
||||
|
||||
let unsuffixifiedPPE = PPED.unsuffixifiedPPE pped
|
||||
terms = Names.lookupHQTerm Names.IncludeSuffixes query names
|
||||
types = Names.lookupHQType Names.IncludeSuffixes query names
|
||||
terms' :: [(Referent, [HQ'.HashQualified Name])]
|
||||
terms' = map (\r -> (r, PPE.allTermNames unsuffixifiedPPE r)) (Set.toList terms)
|
||||
types' :: [(Reference, [HQ'.HashQualified Name])]
|
||||
types' = map (\r -> (r, PPE.allTypeNames unsuffixifiedPPE r)) (Set.toList types)
|
||||
Cli.respond $ ListNames global hqLength types' terms'
|
||||
let unsuffixifiedPPE = PPED.unsuffixifiedPPE pped
|
||||
terms = Names.lookupHQTerm Names.IncludeSuffixes query names
|
||||
types = Names.lookupHQType Names.IncludeSuffixes query names
|
||||
terms' :: [(Referent, [HQ'.HashQualified Name])]
|
||||
terms' = map (\r -> (r, PPE.allTermNames unsuffixifiedPPE r)) (Set.toList terms)
|
||||
types' :: [(Reference, [HQ'.HashQualified Name])]
|
||||
types' = map (\r -> (r, PPE.allTypeNames unsuffixifiedPPE r)) (Set.toList types)
|
||||
pure (terms', types')
|
||||
if global
|
||||
then do
|
||||
Global.forAllProjectBranches \(projBranchNames, _ids) branch -> do
|
||||
let names = Branch.toNames . Branch.head $ branch
|
||||
(terms, types) <- searchNames names
|
||||
when (not (null terms) || not (null types)) do
|
||||
Cli.respond $ GlobalListNames projBranchNames hqLength types terms
|
||||
else do
|
||||
names <- Cli.currentNames
|
||||
(terms, types) <- searchNames names
|
||||
Cli.respond $ ListNames hqLength types terms
|
||||
DocsI srcs -> do
|
||||
for_ srcs docsI
|
||||
CreateAuthorI authorNameSegment authorFullName -> do
|
||||
@ -1089,7 +1093,7 @@ handleFindI ::
|
||||
Cli ()
|
||||
handleFindI isVerbose fscope ws input = do
|
||||
Cli.Env {codebase} <- ask
|
||||
(pped, names, searchRoot, branch0) <- case fscope of
|
||||
case fscope of
|
||||
FindLocal p -> do
|
||||
searchRoot <- Cli.resolvePath' p
|
||||
branch0 <- Cli.getBranch0FromProjectPath searchRoot
|
||||
@ -1097,7 +1101,21 @@ handleFindI isVerbose fscope ws input = do
|
||||
-- Don't exclude anything from the pretty printer, since the type signatures we print for
|
||||
-- results may contain things in lib.
|
||||
pped <- Cli.currentPrettyPrintEnvDecl
|
||||
pure (pped, names, Just p, branch0)
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
results <- searchBranch0 codebase branch0 names
|
||||
if (null results)
|
||||
then do
|
||||
Cli.respond FindNoLocalMatches
|
||||
-- We've already searched everything else, so now we search JUST the
|
||||
-- names in lib.
|
||||
let mayOnlyLibBranch = branch0 & Branch.children %%~ \cs -> Map.singleton NameSegment.libSegment <$> Map.lookup NameSegment.libSegment cs
|
||||
case mayOnlyLibBranch of
|
||||
Nothing -> respondResults codebase suffixifiedPPE (Just p) []
|
||||
Just onlyLibBranch -> do
|
||||
let onlyLibNames = Branch.toNames onlyLibBranch
|
||||
results <- searchBranch0 codebase branch0 onlyLibNames
|
||||
respondResults codebase suffixifiedPPE (Just p) results
|
||||
else respondResults codebase suffixifiedPPE (Just p) results
|
||||
FindLocalAndDeps p -> do
|
||||
searchRoot <- Cli.resolvePath' p
|
||||
branch0 <- Cli.getBranch0FromProjectPath searchRoot
|
||||
@ -1105,64 +1123,57 @@ handleFindI isVerbose fscope ws input = do
|
||||
-- Don't exclude anything from the pretty printer, since the type signatures we print for
|
||||
-- results may contain things in lib.
|
||||
pped <- Cli.currentPrettyPrintEnvDecl
|
||||
pure (pped, names, Just p, branch0)
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
results <- searchBranch0 codebase branch0 names
|
||||
respondResults codebase suffixifiedPPE (Just p) results
|
||||
FindGlobal -> do
|
||||
-- TODO: Rewrite to be properly global again
|
||||
projectRootNames <- Names.makeAbsolute . Branch.toNames <$> Cli.getCurrentProjectRoot0
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames projectRootNames
|
||||
currentBranch0 <- Cli.getCurrentBranch0
|
||||
pure (pped, projectRootNames, Nothing, currentBranch0)
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
let getResults :: Names -> Cli [SearchResult]
|
||||
getResults names =
|
||||
case ws of
|
||||
[] -> pure (List.sortBy SR.compareByName (SR.fromNames names))
|
||||
-- type query
|
||||
":" : ws -> do
|
||||
typ <- parseSearchType (show input) (unwords ws)
|
||||
let keepNamed = Set.intersection (Branch.deepReferents branch0)
|
||||
(noExactTypeMatches, matches) <- do
|
||||
Cli.runTransaction do
|
||||
matches <- keepNamed <$> Codebase.termsOfType codebase typ
|
||||
if null matches
|
||||
then (True,) . keepNamed <$> Codebase.termsMentioningType codebase typ
|
||||
else pure (False, matches)
|
||||
when noExactTypeMatches (Cli.respond NoExactTypeMatches)
|
||||
pure $
|
||||
-- in verbose mode, aliases are shown, so we collapse all
|
||||
-- aliases to a single search result; in non-verbose mode,
|
||||
-- a separate result may be shown for each alias
|
||||
(if isVerbose then uniqueBy SR.toReferent else id) $
|
||||
searchResultsFor names (Set.toList matches) []
|
||||
Global.forAllProjectBranches \(projAndBranchNames, _ids) branch -> do
|
||||
let branch0 = Branch.head branch
|
||||
let projectRootNames = Names.makeAbsolute . Branch.toNames $ branch0
|
||||
pped <- Cli.prettyPrintEnvDeclFromNames projectRootNames
|
||||
results <- searchBranch0 codebase branch0 projectRootNames
|
||||
when (not $ null results) do
|
||||
Cli.setNumberedArgs $ fmap (SA.SearchResult Nothing) results
|
||||
results' <- Cli.runTransaction (Backend.loadSearchResults codebase results)
|
||||
Cli.respond $ GlobalFindBranchResults projAndBranchNames (PPED.suffixifiedPPE pped) isVerbose results'
|
||||
where
|
||||
searchBranch0 :: Codebase.Codebase m Symbol Ann -> Branch0 IO -> Names -> Cli [SearchResult]
|
||||
searchBranch0 codebase branch0 names =
|
||||
case ws of
|
||||
[] -> pure (List.sortBy SR.compareByName (SR.fromNames names))
|
||||
-- type query
|
||||
":" : ws -> do
|
||||
typ <- parseSearchType (show input) (unwords ws)
|
||||
let keepNamed = Set.intersection (Branch.deepReferents branch0)
|
||||
(noExactTypeMatches, matches) <- do
|
||||
Cli.runTransaction do
|
||||
matches <- keepNamed <$> Codebase.termsOfType codebase typ
|
||||
if null matches
|
||||
then (True,) . keepNamed <$> Codebase.termsMentioningType codebase typ
|
||||
else pure (False, matches)
|
||||
when noExactTypeMatches (Cli.respond NoExactTypeMatches)
|
||||
pure $
|
||||
-- in verbose mode, aliases are shown, so we collapse all
|
||||
-- aliases to a single search result; in non-verbose mode,
|
||||
-- a separate result may be shown for each alias
|
||||
(if isVerbose then uniqueBy SR.toReferent else id) $
|
||||
searchResultsFor names (Set.toList matches) []
|
||||
|
||||
-- name query
|
||||
qs -> do
|
||||
let anythingBeforeHash :: Megaparsec.Parsec (Lexer.Token Text) [Char] Text
|
||||
anythingBeforeHash = Text.pack <$> Megaparsec.takeWhileP Nothing (/= '#')
|
||||
let srs =
|
||||
searchBranchScored
|
||||
names
|
||||
Find.simpleFuzzyScore
|
||||
(mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs)
|
||||
pure $ uniqueBy SR.toReferent srs
|
||||
let respondResults results = do
|
||||
Cli.setNumberedArgs $ fmap (SA.SearchResult searchRoot) results
|
||||
results' <- Cli.runTransaction (Backend.loadSearchResults codebase results)
|
||||
Cli.respond $ ListOfDefinitions fscope suffixifiedPPE isVerbose results'
|
||||
results <- getResults names
|
||||
case (results, fscope) of
|
||||
([], FindLocal {}) -> do
|
||||
Cli.respond FindNoLocalMatches
|
||||
-- We've already searched everything else, so now we search JUST the
|
||||
-- names in lib.
|
||||
let mayOnlyLibBranch = branch0 & Branch.children %%~ \cs -> Map.singleton NameSegment.libSegment <$> Map.lookup NameSegment.libSegment cs
|
||||
case mayOnlyLibBranch of
|
||||
Nothing -> respondResults []
|
||||
Just onlyLibBranch -> do
|
||||
let onlyLibNames = Branch.toNames onlyLibBranch
|
||||
results <- getResults onlyLibNames
|
||||
respondResults results
|
||||
_ -> respondResults results
|
||||
-- name query
|
||||
qs -> do
|
||||
let anythingBeforeHash :: Megaparsec.Parsec (L.Token Text) [Char] Text
|
||||
anythingBeforeHash = Text.pack <$> Megaparsec.takeWhileP Nothing (/= '#')
|
||||
let srs =
|
||||
searchBranchScored
|
||||
names
|
||||
Find.simpleFuzzyScore
|
||||
(mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs)
|
||||
pure $ uniqueBy SR.toReferent srs
|
||||
respondResults :: Codebase.Codebase m Symbol Ann -> PPE.PrettyPrintEnv -> Maybe Path' -> [SearchResult] -> Cli ()
|
||||
respondResults codebase ppe searchRoot results = do
|
||||
Cli.setNumberedArgs $ fmap (SA.SearchResult searchRoot) results
|
||||
results' <- Cli.runTransaction (Backend.loadSearchResults codebase results)
|
||||
Cli.respond $ ListOfDefinitions fscope ppe isVerbose results'
|
||||
|
||||
handleDependencies :: HQ.HashQualified Name -> Cli ()
|
||||
handleDependencies hq = do
|
||||
|
22
unison-cli/src/Unison/Codebase/Editor/HandleInput/Global.hs
Normal file
22
unison-cli/src/Unison/Codebase/Editor/HandleInput/Global.hs
Normal file
@ -0,0 +1,22 @@
|
||||
module Unison.Codebase.Editor.HandleInput.Global (forAllProjectBranches) where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Core.Project
|
||||
import Unison.Prelude
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
|
||||
-- | Map over ALL project branches in the codebase.
|
||||
-- This is a _very_ big hammer, that you should basically never use, except for things like debugging or migrations.
|
||||
forAllProjectBranches :: (Monoid r) => ((ProjectAndBranch ProjectName ProjectBranchName, ProjectAndBranch ProjectId ProjectBranchId) -> Branch IO -> Cli r) -> Cli r
|
||||
forAllProjectBranches f = do
|
||||
Cli.Env {codebase} <- ask
|
||||
projectBranches <- Cli.runTransaction Q.loadAllProjectBranchNamePairs
|
||||
projectBranches & foldMapM \(names, ids@(ProjectAndBranch projId branchId)) -> do
|
||||
b <- liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId
|
||||
f (names, ids) b
|
@ -179,9 +179,9 @@ makePrettyUnisonFile originalFile dependents =
|
||||
originalFile
|
||||
<> Pretty.newline
|
||||
<> Pretty.newline
|
||||
<> "-- The definitions below are not compatible with the updated definitions above."
|
||||
<> "-- The definitions below no longer typecheck with the changes above."
|
||||
<> Pretty.newline
|
||||
<> "-- Please fix the errors and run `update` again."
|
||||
<> "-- Please fix the errors and try `update` again."
|
||||
<> Pretty.newline
|
||||
<> Pretty.newline
|
||||
<> ( dependents
|
||||
|
@ -127,8 +127,8 @@ data Input
|
||||
| PushRemoteBranchI PushRemoteBranchInput
|
||||
| ResetI (BranchId2 {- namespace to reset it to -}) (Maybe UnresolvedProjectBranch {- ProjectBranch to reset -})
|
||||
-- todo: Q: Does it make sense to publish to not-the-root of a Github repo?
|
||||
-- Does it make sense to fork from not-the-root of a Github repo?
|
||||
| -- used in Welcome module to give directions to user
|
||||
| -- Does it make sense to fork from not-the-root of a Github repo?
|
||||
-- used in Welcome module to give directions to user
|
||||
CreateMessage (P.Pretty P.ColorText)
|
||||
| -- Change directory.
|
||||
SwitchBranchI Path'
|
||||
|
@ -263,7 +263,11 @@ data Output
|
||||
| MovedOverExistingBranch Path'
|
||||
| DeletedEverything
|
||||
| ListNames
|
||||
IsGlobal
|
||||
Int -- hq length to print References
|
||||
[(Reference, [HQ'.HashQualified Name])] -- type match, type names
|
||||
[(Referent, [HQ'.HashQualified Name])] -- term match, term names
|
||||
| GlobalListNames
|
||||
(ProjectAndBranch ProjectName ProjectBranchName)
|
||||
Int -- hq length to print References
|
||||
[(Reference, [HQ'.HashQualified Name])] -- type match, type names
|
||||
[(Referent, [HQ'.HashQualified Name])] -- term match, term names
|
||||
@ -271,6 +275,7 @@ data Output
|
||||
| ListOfDefinitions FindScope PPE.PrettyPrintEnv ListDetailed [SearchResult' Symbol Ann]
|
||||
| ListShallow (IO PPE.PrettyPrintEnv) [ShallowListEntry Symbol Ann]
|
||||
| ListStructuredFind [HQ.HashQualified Name]
|
||||
| GlobalFindBranchResults (ProjectAndBranch ProjectName ProjectBranchName) PPE.PrettyPrintEnv ListDetailed [SearchResult' Symbol Ann]
|
||||
| -- ListStructuredFind patternMatchingUsages termBodyUsages
|
||||
-- show the result of add/update
|
||||
SlurpOutput Input PPE.PrettyPrintEnv SlurpResult
|
||||
@ -542,8 +547,10 @@ isFailure o = case o of
|
||||
MoveRootBranchConfirmation -> False
|
||||
MovedOverExistingBranch {} -> False
|
||||
DeletedEverything -> False
|
||||
ListNames _ _ tys tms -> null tms && null tys
|
||||
ListNames _ tys tms -> null tms && null tys
|
||||
GlobalListNames {} -> False
|
||||
ListOfDefinitions _ _ _ ds -> null ds
|
||||
GlobalFindBranchResults _ _ _ _ -> False
|
||||
ListStructuredFind tms -> null tms
|
||||
SlurpOutput _ _ sr -> not $ SR.isOk sr
|
||||
ParseErrors {} -> True
|
||||
|
@ -24,11 +24,10 @@ where
|
||||
import CMark qualified
|
||||
import Data.Char qualified as Char
|
||||
import Data.Text qualified as Text
|
||||
import Data.These (These (..))
|
||||
import Text.Megaparsec qualified as P
|
||||
import Unison.Codebase.Transcript
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (ProjectAndBranch))
|
||||
import Unison.Project (fullyQualifiedProjectAndBranchNamesParser)
|
||||
|
||||
formatAPIRequest :: APIRequest -> Text
|
||||
formatAPIRequest = \case
|
||||
@ -72,24 +71,16 @@ ucmLine :: P UcmLine
|
||||
ucmLine = ucmCommand <|> ucmComment
|
||||
where
|
||||
ucmCommand :: P UcmLine
|
||||
ucmCommand = do
|
||||
context <-
|
||||
P.try do
|
||||
contextString <- P.takeWhile1P Nothing (/= '>')
|
||||
context <-
|
||||
case (tryFrom @Text contextString) of
|
||||
(Right (These project branch)) -> pure (UcmContextProject (ProjectAndBranch project branch))
|
||||
_ -> fail "expected project/branch or absolute path"
|
||||
void $ lineToken $ word ">"
|
||||
pure context
|
||||
line <- P.takeWhileP Nothing (/= '\n') <* spaces
|
||||
pure $ UcmCommand context line
|
||||
ucmCommand =
|
||||
UcmCommand
|
||||
<$> fmap UcmContextProject (P.try $ fullyQualifiedProjectAndBranchNamesParser <* lineToken (word ">"))
|
||||
<*> P.takeWhileP Nothing (/= '\n')
|
||||
<* spaces
|
||||
|
||||
ucmComment :: P UcmLine
|
||||
ucmComment = do
|
||||
word "--"
|
||||
line <- P.takeWhileP Nothing (/= '\n') <* spaces
|
||||
pure $ UcmComment line
|
||||
ucmComment =
|
||||
P.label "comment (delimited with “--”)" $
|
||||
UcmComment <$> (word "--" *> P.takeWhileP Nothing (/= '\n')) <* spaces
|
||||
|
||||
apiRequest :: P APIRequest
|
||||
apiRequest = do
|
||||
@ -118,7 +109,7 @@ fenced info = do
|
||||
hide <- hidden
|
||||
err <- expectingError
|
||||
P.setInput body
|
||||
pure . Ucm hide err <$> (spaces *> many ucmLine)
|
||||
pure . Ucm hide err <$> (spaces *> P.manyTill ucmLine P.eof)
|
||||
"unison" ->
|
||||
do
|
||||
-- todo: this has to be more interesting
|
||||
@ -132,7 +123,7 @@ fenced info = do
|
||||
pure . Unison hide err fileName <$> (spaces *> P.getInput)
|
||||
"api" -> do
|
||||
P.setInput body
|
||||
pure . API <$> (spaces *> many apiRequest)
|
||||
pure . API <$> (spaces *> P.manyTill apiRequest P.eof)
|
||||
_ -> pure Nothing
|
||||
|
||||
word :: Text -> P Text
|
||||
|
@ -1149,7 +1149,7 @@ findAll :: InputPattern
|
||||
findAll = find' "find.all" (Input.FindLocalAndDeps Path.relativeEmpty')
|
||||
|
||||
findGlobal :: InputPattern
|
||||
findGlobal = find' "find.global" Input.FindGlobal
|
||||
findGlobal = find' "debug.find.global" Input.FindGlobal
|
||||
|
||||
findIn, findInAll :: InputPattern
|
||||
findIn = findIn' "find-in" Input.FindLocal
|
||||
@ -1197,8 +1197,8 @@ findHelp =
|
||||
"lists all definitions with a name similar to 'foo' or 'bar' in the "
|
||||
<> "specified subnamespace (including one level of its 'lib')."
|
||||
),
|
||||
( "find.global foo",
|
||||
"lists all definitions with a name similar to 'foo' in any namespace"
|
||||
( "debug.find.global foo",
|
||||
"Iteratively searches all projects and branches and lists all definitions with a name similar to 'foo'. Note that this is a very slow operation."
|
||||
)
|
||||
]
|
||||
)
|
||||
@ -2611,12 +2611,15 @@ names isGlobal =
|
||||
[]
|
||||
I.Visible
|
||||
[("name or hash", Required, definitionQueryArg)]
|
||||
(P.wrap $ makeExample (names isGlobal) ["foo"] <> " shows the hash and all known names for `foo`.")
|
||||
(P.wrap $ makeExample (names isGlobal) ["foo"] <> description)
|
||||
$ \case
|
||||
[thing] -> Input.NamesI isGlobal <$> handleHashQualifiedNameArg thing
|
||||
args -> wrongArgsLength "exactly one argument" args
|
||||
where
|
||||
cmdName = if isGlobal then "names.global" else "names"
|
||||
description
|
||||
| isGlobal = "Iteratively search across all projects and branches for names matching `foo`. Note that this is expected to be quite slow and is primarily for debugging issues with your codebase."
|
||||
| otherwise = "List all known names for `foo` in the current branch."
|
||||
cmdName = if isGlobal then "debug.names.global" else "names"
|
||||
|
||||
dependents, dependencies :: InputPattern
|
||||
dependents =
|
||||
@ -3456,7 +3459,7 @@ validInputs =
|
||||
mergeInputPattern,
|
||||
mergeCommitInputPattern,
|
||||
names False, -- names
|
||||
names True, -- names.global
|
||||
names True, -- debug.names.global
|
||||
namespaceDependencies,
|
||||
previewAdd,
|
||||
previewUpdate,
|
||||
|
@ -857,49 +857,24 @@ notifyUser dir = \case
|
||||
]
|
||||
ListOfDefinitions fscope ppe detailed results ->
|
||||
listOfDefinitions fscope ppe detailed results
|
||||
ListNames global len types terms ->
|
||||
if null types && null terms
|
||||
then
|
||||
pure . P.callout "😶" $
|
||||
P.sepNonEmpty "\n\n" $
|
||||
[ P.wrap "I couldn't find anything by that name.",
|
||||
globalTip
|
||||
]
|
||||
else
|
||||
pure . P.sepNonEmpty "\n\n" $
|
||||
[ formatTypes types,
|
||||
formatTerms terms,
|
||||
globalTip
|
||||
]
|
||||
where
|
||||
globalTip =
|
||||
if global
|
||||
then mempty
|
||||
else (tip $ "Use " <> IP.makeExample (IP.names True) [] <> " to see more results.")
|
||||
formatTerms tms =
|
||||
P.lines . P.nonEmpty $ P.plural tms (P.blue "Term") : List.intersperse "" (go <$> tms)
|
||||
where
|
||||
go (ref, hqs) =
|
||||
P.column2
|
||||
[ ("Hash:", P.syntaxToColor (prettyReferent len ref)),
|
||||
( "Names: ",
|
||||
P.group $
|
||||
P.spaced $
|
||||
P.bold . P.syntaxToColor . prettyHashQualified' <$> List.sortBy Name.compareAlphabetical hqs
|
||||
)
|
||||
]
|
||||
formatTypes types =
|
||||
P.lines . P.nonEmpty $ P.plural types (P.blue "Type") : List.intersperse "" (go <$> types)
|
||||
where
|
||||
go (ref, hqs) =
|
||||
P.column2
|
||||
[ ("Hash:", P.syntaxToColor (prettyReference len ref)),
|
||||
( "Names:",
|
||||
P.group $
|
||||
P.spaced $
|
||||
P.bold . P.syntaxToColor . prettyHashQualified' <$> List.sortBy Name.compareAlphabetical hqs
|
||||
)
|
||||
]
|
||||
GlobalFindBranchResults projBranchName ppe detailed results -> do
|
||||
output <- listOfDefinitions Input.FindGlobal ppe detailed results
|
||||
pure $
|
||||
P.lines
|
||||
[ P.wrap $ "Found results in " <> P.text (into @Text projBranchName),
|
||||
"",
|
||||
output
|
||||
]
|
||||
ListNames len types terms ->
|
||||
listOfNames len types terms
|
||||
GlobalListNames projectBranchName len types terms -> do
|
||||
output <- listOfNames len types terms
|
||||
pure $
|
||||
P.lines
|
||||
[ P.wrap $ "Found results in " <> P.text (into @Text projectBranchName),
|
||||
"",
|
||||
output
|
||||
]
|
||||
-- > names foo
|
||||
-- Terms:
|
||||
-- Hash: #asdflkjasdflkjasdf
|
||||
@ -2102,11 +2077,12 @@ notifyUser dir = \case
|
||||
<> P.text filename
|
||||
ConflictedDefn operation defn ->
|
||||
pure . P.wrap $
|
||||
( case defn of
|
||||
TermDefn (Conflicted name _refs) -> "The term name" <> prettyName name <> "is ambiguous."
|
||||
TypeDefn (Conflicted name _refs) -> "The type name" <> prettyName name <> "is ambiguous."
|
||||
( "This branch has more than one" <> case defn of
|
||||
TermDefn (Conflicted name _refs) -> "term with the name" <> P.group (P.backticked (prettyName name) <> ".")
|
||||
TypeDefn (Conflicted name _refs) -> "type with the name" <> P.group (P.backticked (prettyName name) <> ".")
|
||||
)
|
||||
<> "Please resolve the ambiguity, then try to"
|
||||
<> P.newline
|
||||
<> "Please delete or rename all but one of them, then try the"
|
||||
<> P.text operation
|
||||
<> "again."
|
||||
IncoherentDeclDuringMerge aliceOrBob reason ->
|
||||
@ -2621,7 +2597,7 @@ renderNameConflicts hashLen conflictedNames = do
|
||||
prettyConflictedTerms <- showConflictedNames "term" conflictedTermNames
|
||||
pure $
|
||||
Monoid.unlessM (null allConflictedNames) $
|
||||
P.callout "❓" . P.sep "\n\n" . P.nonEmpty $
|
||||
P.callout "❓" . P.linesSpaced . P.nonEmpty $
|
||||
[ prettyConflictedTypes,
|
||||
prettyConflictedTerms,
|
||||
tip $
|
||||
@ -2642,7 +2618,7 @@ renderNameConflicts hashLen conflictedNames = do
|
||||
where
|
||||
showConflictedNames :: Pretty -> Map Name [HQ.HashQualified Name] -> Numbered Pretty
|
||||
showConflictedNames thingKind conflictedNames =
|
||||
P.lines <$> do
|
||||
P.linesSpaced <$> do
|
||||
for (Map.toList conflictedNames) \(name, hashes) -> do
|
||||
prettyConflicts <- for hashes \hash -> do
|
||||
n <- addNumberedArg $ SA.HashQualified hash
|
||||
@ -2888,6 +2864,45 @@ listOfDefinitions ::
|
||||
listOfDefinitions fscope ppe detailed results =
|
||||
pure $ listOfDefinitions' fscope ppe detailed results
|
||||
|
||||
listOfNames :: Int -> [(Reference, [HQ'.HashQualified Name])] -> [(Referent, [HQ'.HashQualified Name])] -> IO Pretty
|
||||
listOfNames len types terms = do
|
||||
if null types && null terms
|
||||
then
|
||||
pure . P.callout "😶" $
|
||||
P.sepNonEmpty "\n\n" $
|
||||
[ P.wrap "I couldn't find anything by that name."
|
||||
]
|
||||
else
|
||||
pure . P.sepNonEmpty "\n\n" $
|
||||
[ formatTypes types,
|
||||
formatTerms terms
|
||||
]
|
||||
where
|
||||
formatTerms tms =
|
||||
P.lines . P.nonEmpty $ P.plural tms (P.blue "Term") : List.intersperse "" (go <$> tms)
|
||||
where
|
||||
go (ref, hqs) =
|
||||
P.column2
|
||||
[ ("Hash:", P.syntaxToColor (prettyReferent len ref)),
|
||||
( "Names: ",
|
||||
P.group $
|
||||
P.spaced $
|
||||
P.bold . P.syntaxToColor . prettyHashQualified' <$> List.sortBy Name.compareAlphabetical hqs
|
||||
)
|
||||
]
|
||||
formatTypes types =
|
||||
P.lines . P.nonEmpty $ P.plural types (P.blue "Type") : List.intersperse "" (go <$> types)
|
||||
where
|
||||
go (ref, hqs) =
|
||||
P.column2
|
||||
[ ("Hash:", P.syntaxToColor (prettyReference len ref)),
|
||||
( "Names:",
|
||||
P.group $
|
||||
P.spaced $
|
||||
P.bold . P.syntaxToColor . prettyHashQualified' <$> List.sortBy Name.compareAlphabetical hqs
|
||||
)
|
||||
]
|
||||
|
||||
data ShowNumbers = ShowNumbers | HideNumbers
|
||||
|
||||
-- | `ppe` is just for rendering type signatures
|
||||
|
@ -57,7 +57,7 @@ import Unison.Result (Note)
|
||||
import Unison.Result qualified as Result
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.HashQualifiedPrime qualified as HQ' (toText)
|
||||
import Unison.Syntax.Lexer qualified as L
|
||||
import Unison.Syntax.Lexer.Unison qualified as L
|
||||
import Unison.Syntax.Name qualified as Name
|
||||
import Unison.Syntax.Parser qualified as Parser
|
||||
import Unison.Syntax.TypePrinter qualified as TypePrinter
|
||||
|
@ -14,20 +14,42 @@ import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.Symbol (Symbol (..))
|
||||
import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Util.List qualified as ListUtils
|
||||
import Unison.Util.Range qualified as Range
|
||||
import Unison.Var qualified as Var
|
||||
|
||||
data VarUsages
|
||||
= VarUsages
|
||||
{ unusedVars :: Map Symbol (Set Ann),
|
||||
usedVars :: Set Symbol,
|
||||
-- This is generally a copy of usedVars, except that we _don't_ remove variables when they go out of scope.
|
||||
-- This is solely so we have the information to handle an edge case in pattern guards where vars are independently
|
||||
-- brought into scope in BOTH the guards and the body of a match case, and we want to count a var as used if it
|
||||
-- appears in _either_.
|
||||
allUsedVars :: Set Symbol
|
||||
}
|
||||
|
||||
instance Semigroup VarUsages where
|
||||
VarUsages a b c <> VarUsages a' b' c' =
|
||||
VarUsages (Map.unionWith (<>) a a') (b <> b') (c <> c')
|
||||
|
||||
instance Monoid VarUsages where
|
||||
mempty = VarUsages mempty mempty mempty
|
||||
|
||||
analyseTerm :: Lsp.Uri -> Term Symbol Ann -> [Diagnostic]
|
||||
analyseTerm fileUri tm =
|
||||
let (unusedVars, _) = ABT.cata alg tm
|
||||
let (VarUsages {unusedVars}) = ABT.cata alg tm
|
||||
vars =
|
||||
Map.toList unusedVars & mapMaybe \(v, ann) -> do
|
||||
(,ann) <$> getRelevantVarName v
|
||||
diagnostics =
|
||||
vars & mapMaybe \(varName, ann) -> do
|
||||
vars & foldMap \(varName, anns) -> do
|
||||
ann <- Set.toList anns
|
||||
range <- maybeToList $ Cv.annToURange ann
|
||||
-- Limit the range to the first line of the binding to not be too annoying.
|
||||
-- Maybe in the future we can get the actual annotation of the variable name.
|
||||
lspRange <- Cv.uToLspRange . Range.startingLine <$> Cv.annToURange ann
|
||||
let lspRange = Cv.uToLspRange . Range.startingLine $ range
|
||||
pure $ Diagnostic.mkDiagnostic fileUri lspRange Diagnostic.DiagnosticSeverity_Warning [Lsp.DiagnosticTag_Unnecessary] ("Unused binding " <> tShow varName <> ". Use the binding, or prefix it with an _ to dismiss this warning.") []
|
||||
in diagnostics
|
||||
where
|
||||
@ -41,12 +63,39 @@ analyseTerm fileUri tm =
|
||||
guard (not (Text.isPrefixOf "_" n))
|
||||
Just n
|
||||
_ -> Nothing
|
||||
alg :: (Foldable f, Ord v) => Ann -> ABT f v (Map v Ann, Set v) -> (Map v Ann, Set v)
|
||||
alg ::
|
||||
Ann ->
|
||||
(ABT (Term.F Symbol Ann Ann) Symbol VarUsages -> VarUsages)
|
||||
alg ann abt = case abt of
|
||||
Var v -> (mempty, Set.singleton v)
|
||||
Var v -> VarUsages {unusedVars = mempty, usedVars = Set.singleton v, allUsedVars = Set.singleton v}
|
||||
Cycle x -> x
|
||||
Abs v (unusedBindings, usedVars) ->
|
||||
Abs v (VarUsages {unusedVars, usedVars, allUsedVars}) ->
|
||||
if v `Set.member` usedVars
|
||||
then (unusedBindings, Set.delete v usedVars)
|
||||
else (Map.insert v ann unusedBindings, usedVars)
|
||||
Tm fx -> Foldable.fold fx
|
||||
then VarUsages {unusedVars, usedVars = Set.delete v usedVars, allUsedVars}
|
||||
else VarUsages {unusedVars = Map.insert v (Set.singleton ann) unusedVars, usedVars, allUsedVars}
|
||||
Tm fx ->
|
||||
case fx of
|
||||
-- We need to special-case pattern guards because the pattern, guard, and body treat each of their vars in
|
||||
-- their own independent scopes, even though the vars created in the pattern are the same ones used in the
|
||||
-- guards and bindings :shrug:
|
||||
Term.Match scrutinee cases ->
|
||||
let -- There's a separate case for every guard on a single pattern, so we first do our best to group up cases with the same pattern.
|
||||
-- Otherwise, a var may be reported unused in one branch of a guard even though it's used in another branch.
|
||||
groupedCases = ListUtils.groupBy (\(Term.MatchCase pat _ _) -> pat) cases
|
||||
caseVars =
|
||||
groupedCases & foldMap \singlePatCases ->
|
||||
let (VarUsages {unusedVars = unused, usedVars = used, allUsedVars = allUsed}) =
|
||||
singlePatCases
|
||||
& foldMap
|
||||
( \(Term.MatchCase pat guard body) ->
|
||||
-- This is imprecise, but it's quite annoying to get the actual ann of the unused bindings, so
|
||||
-- we just use the FULL span of the pattern for now. We could fix this with a bit
|
||||
-- of elbow grease.
|
||||
let patSpanAnn = fold pat
|
||||
combindedVarUsages = fold guard <> body
|
||||
in combindedVarUsages {unusedVars = (unusedVars combindedVarUsages) $> (Set.singleton patSpanAnn)}
|
||||
)
|
||||
actuallyUnusedVars = unused & Map.filterWithKey \k _ -> k `Set.notMember` allUsed
|
||||
in VarUsages {unusedVars = actuallyUnusedVars, usedVars = used, allUsedVars = allUsed}
|
||||
in scrutinee <> caseVars
|
||||
_ -> Foldable.fold fx
|
||||
|
@ -41,7 +41,7 @@ import Unison.Server.Backend qualified as Backend
|
||||
import Unison.Server.NameSearch (NameSearch)
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Symbol
|
||||
import Unison.Syntax.Lexer qualified as Lexer
|
||||
import Unison.Syntax.Lexer.Unison qualified as Lexer
|
||||
import Unison.Type (Type)
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import Unison.UnisonFile.Summary (FileSummary (..))
|
||||
|
@ -416,21 +416,24 @@ withTestCodebase action = do
|
||||
|
||||
makeDiagnosticRangeTest :: (String, Text) -> Test ()
|
||||
makeDiagnosticRangeTest (testName, testSrc) = scope testName $ do
|
||||
(ann, _block, cleanSrc) <- case extractDelimitedBlock ('«', '»') testSrc of
|
||||
Nothing -> crash "expected exactly one delimited block"
|
||||
Just r -> pure r
|
||||
let (cleanSrc, mayExpectedDiagnostic) = case extractDelimitedBlock ('«', '»') testSrc of
|
||||
Nothing -> (testSrc, Nothing)
|
||||
Just (ann, block, clean) -> (clean, Just (ann, block))
|
||||
(pf, _mayTypecheckedFile) <- typecheckSrc testName cleanSrc
|
||||
UF.terms pf
|
||||
& Map.elems
|
||||
& \case
|
||||
[(_a, trm)] -> do
|
||||
case UnusedBindings.analyseTerm (LSP.Uri "test") trm of
|
||||
[diag] -> do
|
||||
case (mayExpectedDiagnostic, UnusedBindings.analyseTerm (LSP.Uri "test") trm) of
|
||||
(Just (ann, _block), [diag]) -> do
|
||||
let expectedRange = Cv.annToRange ann
|
||||
let actualRange = Just (diag ^. LSP.range)
|
||||
when (expectedRange /= actualRange) do
|
||||
crash $ "Expected diagnostic at range: " <> show expectedRange <> ", got: " <> show actualRange
|
||||
_ -> crash "Expected exactly one diagnostic"
|
||||
(Nothing, []) -> pure ()
|
||||
(expected, actual) -> case expected of
|
||||
Nothing -> crash $ "Expected no diagnostics, got: " <> show actual
|
||||
Just _ -> crash $ "Expected exactly one diagnostic, but got " <> show actual
|
||||
_ -> crash "Expected exactly one term"
|
||||
|
||||
unusedBindingLocations :: Test ()
|
||||
@ -446,5 +449,18 @@ unusedBindingLocations =
|
||||
),
|
||||
( "Unused argument",
|
||||
[here|term «unused» = 1|]
|
||||
),
|
||||
( "Unused binding in cases block",
|
||||
[here|term = cases
|
||||
-- Note: the diagnostic _should_ only wrap the unused bindings, but right now it just wraps the whole pattern.
|
||||
(«unused, used»)
|
||||
| used > 0 -> true
|
||||
| otherwise -> false
|
||||
|]
|
||||
),
|
||||
( "Ignored unused binding in cases block shouldn't error",
|
||||
[here|term = cases
|
||||
(used, _ignored) -> used
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
@ -65,6 +65,7 @@ library
|
||||
Unison.Codebase.Editor.HandleInput.EditNamespace
|
||||
Unison.Codebase.Editor.HandleInput.FindAndReplace
|
||||
Unison.Codebase.Editor.HandleInput.FormatFile
|
||||
Unison.Codebase.Editor.HandleInput.Global
|
||||
Unison.Codebase.Editor.HandleInput.InstallLib
|
||||
Unison.Codebase.Editor.HandleInput.Load
|
||||
Unison.Codebase.Editor.HandleInput.Ls
|
||||
|
@ -155,6 +155,15 @@ instance (ToJSON b, ToJSON a) => ToJSON (DisplayObject b a) where
|
||||
MissingObject sh -> object ["tag" Aeson..= String "MissingObject", "contents" Aeson..= sh]
|
||||
UserObject a -> object ["tag" Aeson..= String "UserObject", "contents" Aeson..= a]
|
||||
|
||||
instance (FromJSON a, FromJSON b) => FromJSON (DisplayObject b a) where
|
||||
parseJSON = withObject "DisplayObject" \o -> do
|
||||
tag <- o .: "tag"
|
||||
case tag of
|
||||
"BuiltinObject" -> BuiltinObject <$> o .: "contents"
|
||||
"MissingObject" -> MissingObject <$> o .: "contents"
|
||||
"UserObject" -> UserObject <$> o .: "contents"
|
||||
_ -> fail $ "Invalid tag: " <> Text.unpack tag
|
||||
|
||||
deriving instance (ToSchema b, ToSchema a) => ToSchema (DisplayObject b a)
|
||||
|
||||
-- [21/10/07] Hello, this is Mitchell. Name refactor in progress. Changing internal representation from a flat text to a
|
||||
|
@ -20,12 +20,11 @@ complement of unison libraries for a given combination of ucm version
|
||||
and @unison/internal version.
|
||||
|
||||
To set up racket to use these files, we need to create a package with
|
||||
them. This is accomplished by running.
|
||||
them. This is accomplished by running:
|
||||
|
||||
raco pkg install -t dir unison
|
||||
raco pkg install -t dir scheme-libs/racket/unison
|
||||
|
||||
in the directory where the `unison` directory is located. Then the
|
||||
runtime executable can be built with
|
||||
After, the runtime executable can be built with
|
||||
|
||||
raco exe scheme-libs/racket/unison-runtime.rkt
|
||||
|
||||
|
@ -1,22 +1,21 @@
|
||||
|
||||
When we start out, `./scheme-libs/racket` contains a bunch of library files that we'll need. They define the Unison builtins for Racket.
|
||||
|
||||
Next, we'll download the jit project and generate a few Racket files from it.
|
||||
|
||||
```ucm
|
||||
``` ucm
|
||||
jit-setup/main> lib.install @unison/internal/releases/0.0.18
|
||||
|
||||
Downloaded 14917 entities.
|
||||
Downloaded 14949 entities.
|
||||
|
||||
I installed @unison/internal/releases/0.0.18 as
|
||||
unison_internal_0_0_18.
|
||||
|
||||
```
|
||||
```unison
|
||||
``` unison
|
||||
go = generateSchemeBoot "scheme-libs/racket"
|
||||
```
|
||||
|
||||
```ucm
|
||||
``` ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
@ -29,7 +28,7 @@ go = generateSchemeBoot "scheme-libs/racket"
|
||||
go : '{IO, Exception} ()
|
||||
|
||||
```
|
||||
```ucm
|
||||
``` ucm
|
||||
jit-setup/main> run go
|
||||
|
||||
()
|
||||
@ -42,16 +41,23 @@ and @unison/internal version.
|
||||
To set up racket to use these files, we need to create a package with
|
||||
them. This is accomplished by running.
|
||||
|
||||
raco pkg install -t dir unison
|
||||
```
|
||||
raco pkg install -t dir unison
|
||||
```
|
||||
|
||||
in the directory where the `unison directory is located. Then the
|
||||
in the directory where the `unison` directory is located. Then the
|
||||
runtime executable can be built with
|
||||
|
||||
raco exe scheme-libs/racket/unison-runtime.rkt
|
||||
```
|
||||
raco exe scheme-libs/racket/unison-runtime.rkt
|
||||
```
|
||||
|
||||
and a distributable directory can be produced with:
|
||||
|
||||
raco distribute <output-dir> scheme-libs/racket/unison-runtime
|
||||
```
|
||||
raco distribute <output-dir> scheme-libs/racket/unison-runtime
|
||||
```
|
||||
|
||||
At that point, <output-dir> should contain the executable and all
|
||||
dependencies necessary to run it.
|
||||
|
||||
|
@ -542,7 +542,7 @@ fix_4384d = {{ {{ docExampleBlock 0 '[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,
|
||||
fix_4384e =
|
||||
id : x -> x
|
||||
id x = x
|
||||
{{ {{ docExampleBlock 0 (id id id id id id id id id id id id id id id id id id id id id (x -> 0) }} }}
|
||||
{{ {{ docExampleBlock 0 (id id id id id id id id id id id id id id id id id id id id id (x -> 0)) }} }}
|
||||
|
||||
fnApplicationSyntax =
|
||||
Environment.default = do 1 + 1
|
||||
|
@ -45,7 +45,5 @@ scratch/main> names term1
|
||||
Term
|
||||
Hash: #8hum58rlih
|
||||
Names: term1 term2
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
```
|
||||
|
@ -48,16 +48,12 @@ scratch/app1> names a
|
||||
Term
|
||||
Hash: #gjmq673r1v
|
||||
Names: lib.text_v1.a lib.text_v2.a
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
scratch/app1> names x
|
||||
|
||||
Term
|
||||
Hash: #nsmc4p1ra4
|
||||
Names: lib.http_v3.x lib.http_v4.x
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
```
|
||||
Our `app2` project includes the `http` library twice as direct dependencies, and once as an indirect dependency via `webutil`.
|
||||
@ -102,15 +98,11 @@ scratch/app2> names a
|
||||
Term
|
||||
Hash: #gjmq673r1v
|
||||
Names: lib.webutil.lib.text_v1.a
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
scratch/app2> names x
|
||||
|
||||
Term
|
||||
Hash: #nsmc4p1ra4
|
||||
Names: lib.http_v1.x lib.http_v2.x
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
```
|
||||
|
@ -25,7 +25,7 @@ scratch/main> find.verbose
|
||||
No results. Check your spelling, or try using tab completion
|
||||
to supply command arguments.
|
||||
|
||||
`find.global` can be used to search outside the current
|
||||
`debug.find.global` can be used to search outside the current
|
||||
namespace.
|
||||
|
||||
```
|
||||
@ -42,7 +42,7 @@ scratch/main> find mynamespace
|
||||
No results. Check your spelling, or try using tab completion
|
||||
to supply command arguments.
|
||||
|
||||
`find.global` can be used to search outside the current
|
||||
`debug.find.global` can be used to search outside the current
|
||||
namespace.
|
||||
|
||||
```
|
||||
|
@ -290,6 +290,7 @@ x = match Some a with
|
||||
I was surprised to find a -> here.
|
||||
I was expecting one of these instead:
|
||||
|
||||
* end of input
|
||||
* newline or semicolon
|
||||
|
||||
```
|
||||
@ -312,6 +313,7 @@ x = match Some a with
|
||||
I was surprised to find a '|' here.
|
||||
I was expecting one of these instead:
|
||||
|
||||
* end of input
|
||||
* newline or semicolon
|
||||
|
||||
```
|
||||
|
3
unison-src/transcripts/errors/invalid-api-requests.md
Normal file
3
unison-src/transcripts/errors/invalid-api-requests.md
Normal file
@ -0,0 +1,3 @@
|
||||
``` api:error
|
||||
DELETE /something/important
|
||||
```
|
5
unison-src/transcripts/errors/no-abspath-in-ucm.md
Normal file
5
unison-src/transcripts/errors/no-abspath-in-ucm.md
Normal file
@ -0,0 +1,5 @@
|
||||
``` ucm:error
|
||||
scratch/main> builtins.merge
|
||||
-- As of 0.5.25, we no longer allow loose code paths for UCM commands.
|
||||
.> ls
|
||||
```
|
@ -34,15 +34,10 @@ Finding within a namespace
|
||||
|
||||
```ucm
|
||||
scratch/main> find bar
|
||||
-- Shows UUIDs
|
||||
-- scratch/main> find.global bar
|
||||
scratch/other> debug.find.global bar
|
||||
scratch/main> find-in somewhere bar
|
||||
```
|
||||
|
||||
```ucm:error
|
||||
scratch/main> find baz
|
||||
```
|
||||
|
||||
```ucm:error
|
||||
scratch/main> find.global notHere
|
||||
```
|
||||
|
@ -65,8 +65,15 @@ scratch/main> find bar
|
||||
1. somewhere.bar : Nat
|
||||
|
||||
|
||||
-- Shows UUIDs
|
||||
-- scratch/main> find.global bar
|
||||
scratch/other> debug.find.global bar
|
||||
|
||||
Found results in scratch/main
|
||||
|
||||
1. .cat.lib.bar : Nat
|
||||
2. .lib.bar : Nat
|
||||
3. .somewhere.bar : Nat
|
||||
|
||||
|
||||
scratch/main> find-in somewhere bar
|
||||
|
||||
1. bar : Nat
|
||||
@ -86,17 +93,7 @@ scratch/main> find baz
|
||||
No results. Check your spelling, or try using tab completion
|
||||
to supply command arguments.
|
||||
|
||||
`find.global` can be used to search outside the current
|
||||
`debug.find.global` can be used to search outside the current
|
||||
namespace.
|
||||
|
||||
```
|
||||
``` ucm
|
||||
scratch/main> find.global notHere
|
||||
|
||||
😶
|
||||
|
||||
No results. Check your spelling, or try using tab completion
|
||||
to supply command arguments.
|
||||
|
||||
|
||||
```
|
||||
|
15
unison-src/transcripts/fix1327.md
Normal file
15
unison-src/transcripts/fix1327.md
Normal file
@ -0,0 +1,15 @@
|
||||
```unison
|
||||
foo = 4
|
||||
|
||||
bar = 5
|
||||
```
|
||||
|
||||
`alias.many` should be able to consume the numbered args produced by `ls`. Previously, `ls` would produce absolute paths, but `alias.many` required relative ones.
|
||||
|
||||
Now `ls` returns a pair of the absolute search directory and the result relative to that search directory, so it can be used in both absolute and relative contexts.
|
||||
|
||||
```ucm
|
||||
scratch/main> add
|
||||
scratch/main> ls
|
||||
scratch/main> alias.many 1-2 .ns1_nohistory
|
||||
```
|
50
unison-src/transcripts/fix1327.output.md
Normal file
50
unison-src/transcripts/fix1327.output.md
Normal file
@ -0,0 +1,50 @@
|
||||
``` unison
|
||||
foo = 4
|
||||
|
||||
bar = 5
|
||||
```
|
||||
|
||||
``` ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
I found and typechecked these definitions in scratch.u. If you
|
||||
do an `add` or `update`, here's how your codebase would
|
||||
change:
|
||||
|
||||
⍟ These new definitions are ok to `add`:
|
||||
|
||||
bar : ##Nat
|
||||
foo : ##Nat
|
||||
|
||||
```
|
||||
`alias.many` should be able to consume the numbered args produced by `ls`. Previously, `ls` would produce absolute paths, but `alias.many` required relative ones.
|
||||
|
||||
Now `ls` returns a pair of the absolute search directory and the result relative to that search directory, so it can be used in both absolute and relative contexts.
|
||||
|
||||
``` ucm
|
||||
scratch/main> add
|
||||
|
||||
⍟ I've added these definitions:
|
||||
|
||||
bar : ##Nat
|
||||
foo : ##Nat
|
||||
|
||||
scratch/main> ls
|
||||
|
||||
1. bar (##Nat)
|
||||
2. foo (##Nat)
|
||||
|
||||
scratch/main> alias.many 1-2 .ns1_nohistory
|
||||
|
||||
Here's what changed in .ns1_nohistory :
|
||||
|
||||
Added definitions:
|
||||
|
||||
1. bar : ##Nat
|
||||
2. foo : ##Nat
|
||||
|
||||
Tip: You can use `undo` or use a hash from `reflog` to undo
|
||||
this change.
|
||||
|
||||
```
|
17
unison-src/transcripts/fix3977.md
Normal file
17
unison-src/transcripts/fix3977.md
Normal file
@ -0,0 +1,17 @@
|
||||
```ucm:hide
|
||||
scratch/main> builtins.merge
|
||||
```
|
||||
|
||||
Pretty-printing previously didn’t compensate for extra characters on a line that was about to be wrapped, resulting in a line-break without sufficient indentation. Now pretty-printing indents based on the starting column of the wrapped expression, not simply “prevIndent + 2”.
|
||||
|
||||
```unison:hide
|
||||
failure msg context = Failure (typeLink Unit) msg (Any context)
|
||||
|
||||
foo = Left (failure ("a loooooooooooooooooooooooooooooooooong" ++ "message with concatenation") ())
|
||||
```
|
||||
|
||||
```ucm
|
||||
scratch/main> add
|
||||
scratch/main> edit foo
|
||||
scratch/main> load scratch.u
|
||||
```
|
44
unison-src/transcripts/fix3977.output.md
Normal file
44
unison-src/transcripts/fix3977.output.md
Normal file
@ -0,0 +1,44 @@
|
||||
Pretty-printing previously didn’t compensate for extra characters on a line that was about to be wrapped, resulting in a line-break without sufficient indentation. Now pretty-printing indents based on the starting column of the wrapped expression, not simply “prevIndent + 2”.
|
||||
|
||||
``` unison
|
||||
failure msg context = Failure (typeLink Unit) msg (Any context)
|
||||
|
||||
foo = Left (failure ("a loooooooooooooooooooooooooooooooooong" ++ "message with concatenation") ())
|
||||
```
|
||||
|
||||
``` ucm
|
||||
scratch/main> add
|
||||
|
||||
⍟ I've added these definitions:
|
||||
|
||||
failure : Text -> context -> Failure
|
||||
foo : Either Failure b
|
||||
|
||||
scratch/main> edit foo
|
||||
|
||||
☝️
|
||||
|
||||
I added 1 definitions to the top of scratch.u
|
||||
|
||||
You can edit them there, then run `update` to replace the
|
||||
definitions currently in this namespace.
|
||||
|
||||
scratch/main> load scratch.u
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
I found and typechecked the definitions in scratch.u. This
|
||||
file has been previously added to the codebase.
|
||||
|
||||
```
|
||||
``` unison:added-by-ucm scratch.u
|
||||
foo : Either Failure b
|
||||
foo =
|
||||
use Text ++
|
||||
Left
|
||||
(failure
|
||||
("a loooooooooooooooooooooooooooooooooong"
|
||||
++ "message with concatenation")
|
||||
())
|
||||
```
|
||||
|
12
unison-src/transcripts/fix5076.md
Normal file
12
unison-src/transcripts/fix5076.md
Normal file
@ -0,0 +1,12 @@
|
||||
```ucm:hide
|
||||
scratch/main> builtins.mergeio
|
||||
```
|
||||
|
||||
Nested call to code lexer wasn’t terminating inline examples containing blocks properly.
|
||||
|
||||
```unison
|
||||
x = {{
|
||||
``let "me"`` live
|
||||
``do "me"`` in
|
||||
}}
|
||||
```
|
22
unison-src/transcripts/fix5076.output.md
Normal file
22
unison-src/transcripts/fix5076.output.md
Normal file
@ -0,0 +1,22 @@
|
||||
Nested call to code lexer wasn’t terminating inline examples containing blocks properly.
|
||||
|
||||
``` unison
|
||||
x = {{
|
||||
``let "me"`` live
|
||||
``do "me"`` in
|
||||
}}
|
||||
```
|
||||
|
||||
``` ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
I found and typechecked these definitions in scratch.u. If you
|
||||
do an `add` or `update`, here's how your codebase would
|
||||
change:
|
||||
|
||||
⍟ These new definitions are ok to `add`:
|
||||
|
||||
x : Doc2
|
||||
|
||||
```
|
@ -113,6 +113,50 @@ scratch/main> help
|
||||
debug.file
|
||||
View details about the most recent successfully typechecked file.
|
||||
|
||||
debug.find.global
|
||||
`find` lists all definitions in the
|
||||
current namespace.
|
||||
`find foo` lists all definitions with a
|
||||
name similar to 'foo' in the
|
||||
current namespace (excluding
|
||||
those under 'lib').
|
||||
`find foo bar` lists all definitions with a
|
||||
name similar to 'foo' or
|
||||
'bar' in the current
|
||||
namespace (excluding those
|
||||
under 'lib').
|
||||
`find-in namespace` lists all definitions in the
|
||||
specified subnamespace.
|
||||
`find-in namespace foo bar` lists all definitions with a
|
||||
name similar to 'foo' or
|
||||
'bar' in the specified
|
||||
subnamespace.
|
||||
find.all foo lists all definitions with a
|
||||
name similar to 'foo' in the
|
||||
current namespace (including
|
||||
one level of 'lib').
|
||||
`find-in.all namespace` lists all definitions in the
|
||||
specified subnamespace
|
||||
(including one level of its
|
||||
'lib').
|
||||
`find-in.all namespace foo bar` lists all definitions with a
|
||||
name similar to 'foo' or
|
||||
'bar' in the specified
|
||||
subnamespace (including one
|
||||
level of its 'lib').
|
||||
debug.find.global foo Iteratively searches all
|
||||
projects and branches and
|
||||
lists all definitions with a
|
||||
name similar to 'foo'. Note
|
||||
that this is a very slow
|
||||
operation.
|
||||
|
||||
debug.names.global
|
||||
`debug.names.global foo` Iteratively search across all
|
||||
projects and branches for names matching `foo`. Note that this
|
||||
is expected to be quite slow and is primarily for debugging
|
||||
issues with your codebase.
|
||||
|
||||
debug.numberedArgs
|
||||
Dump the contents of the numbered args state.
|
||||
|
||||
@ -269,9 +313,12 @@ scratch/main> help
|
||||
'bar' in the specified
|
||||
subnamespace (including one
|
||||
level of its 'lib').
|
||||
find.global foo lists all definitions with a
|
||||
name similar to 'foo' in any
|
||||
namespace
|
||||
debug.find.global foo Iteratively searches all
|
||||
projects and branches and
|
||||
lists all definitions with a
|
||||
name similar to 'foo'. Note
|
||||
that this is a very slow
|
||||
operation.
|
||||
|
||||
find-in
|
||||
`find` lists all definitions in the
|
||||
@ -304,9 +351,12 @@ scratch/main> help
|
||||
'bar' in the specified
|
||||
subnamespace (including one
|
||||
level of its 'lib').
|
||||
find.global foo lists all definitions with a
|
||||
name similar to 'foo' in any
|
||||
namespace
|
||||
debug.find.global foo Iteratively searches all
|
||||
projects and branches and
|
||||
lists all definitions with a
|
||||
name similar to 'foo'. Note
|
||||
that this is a very slow
|
||||
operation.
|
||||
|
||||
find-in.all
|
||||
`find` lists all definitions in the
|
||||
@ -339,9 +389,12 @@ scratch/main> help
|
||||
'bar' in the specified
|
||||
subnamespace (including one
|
||||
level of its 'lib').
|
||||
find.global foo lists all definitions with a
|
||||
name similar to 'foo' in any
|
||||
namespace
|
||||
debug.find.global foo Iteratively searches all
|
||||
projects and branches and
|
||||
lists all definitions with a
|
||||
name similar to 'foo'. Note
|
||||
that this is a very slow
|
||||
operation.
|
||||
|
||||
find.all
|
||||
`find` lists all definitions in the
|
||||
@ -374,48 +427,16 @@ scratch/main> help
|
||||
'bar' in the specified
|
||||
subnamespace (including one
|
||||
level of its 'lib').
|
||||
find.global foo lists all definitions with a
|
||||
name similar to 'foo' in any
|
||||
namespace
|
||||
debug.find.global foo Iteratively searches all
|
||||
projects and branches and
|
||||
lists all definitions with a
|
||||
name similar to 'foo'. Note
|
||||
that this is a very slow
|
||||
operation.
|
||||
|
||||
find.all.verbose
|
||||
`find.all.verbose` searches for definitions like `find.all`, but includes hashes and aliases in the results.
|
||||
|
||||
find.global
|
||||
`find` lists all definitions in the
|
||||
current namespace.
|
||||
`find foo` lists all definitions with a
|
||||
name similar to 'foo' in the
|
||||
current namespace (excluding
|
||||
those under 'lib').
|
||||
`find foo bar` lists all definitions with a
|
||||
name similar to 'foo' or
|
||||
'bar' in the current
|
||||
namespace (excluding those
|
||||
under 'lib').
|
||||
`find-in namespace` lists all definitions in the
|
||||
specified subnamespace.
|
||||
`find-in namespace foo bar` lists all definitions with a
|
||||
name similar to 'foo' or
|
||||
'bar' in the specified
|
||||
subnamespace.
|
||||
find.all foo lists all definitions with a
|
||||
name similar to 'foo' in the
|
||||
current namespace (including
|
||||
one level of 'lib').
|
||||
`find-in.all namespace` lists all definitions in the
|
||||
specified subnamespace
|
||||
(including one level of its
|
||||
'lib').
|
||||
`find-in.all namespace foo bar` lists all definitions with a
|
||||
name similar to 'foo' or
|
||||
'bar' in the specified
|
||||
subnamespace (including one
|
||||
level of its 'lib').
|
||||
find.global foo lists all definitions with a
|
||||
name similar to 'foo' in any
|
||||
namespace
|
||||
|
||||
find.verbose
|
||||
`find.verbose` searches for definitions like `find`, but includes hashes and aliases in the results.
|
||||
|
||||
@ -526,11 +547,8 @@ scratch/main> help
|
||||
`move.type foo bar` renames `foo` to `bar`.
|
||||
|
||||
names
|
||||
`names foo` shows the hash and all known names for `foo`.
|
||||
|
||||
names.global
|
||||
`names.global foo` shows the hash and all known names for
|
||||
`foo`.
|
||||
`names foo` List all known names for `foo` in the current
|
||||
branch.
|
||||
|
||||
namespace.dependencies
|
||||
List the external dependencies of the specified namespace.
|
||||
|
@ -1435,8 +1435,6 @@ project/alice> names A
|
||||
Type
|
||||
Hash: #65mdg7015r
|
||||
Names: A A.inner.X
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
```
|
||||
Bob's branch:
|
||||
|
@ -32,16 +32,13 @@ scratch/main> names #gjmq673r1v
|
||||
scratch/main> names .some.place.x
|
||||
```
|
||||
|
||||
`names.global` searches from the root, and absolutely qualifies results
|
||||
`debug.names.global` searches from the root, and absolutely qualifies results
|
||||
|
||||
|
||||
TODO: swap this back to a 'ucm' block when names.global is re-implemented
|
||||
|
||||
```
|
||||
```ucm
|
||||
-- We can search from a different branch and find all names in the codebase named 'x', and each of their aliases respectively.
|
||||
scratch/other> names.global x
|
||||
scratch/other> debug.names.global x
|
||||
-- We can search by hash, and see all aliases of that hash in the codebase
|
||||
scratch/other> names.global #gjmq673r1v
|
||||
scratch/other> debug.names.global #gjmq673r1v
|
||||
-- We can search using an absolute name
|
||||
scratch/other> names.global .some.place.x
|
||||
scratch/other> debug.names.global .some.place.x
|
||||
```
|
||||
|
@ -59,8 +59,6 @@ scratch/main> names x
|
||||
|
||||
Hash: #pi25gcdv0o
|
||||
Names: some.otherplace.x
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
-- We can search by hash, and see all aliases of that hash
|
||||
scratch/main> names #gjmq673r1v
|
||||
@ -68,8 +66,6 @@ scratch/main> names #gjmq673r1v
|
||||
Term
|
||||
Hash: #gjmq673r1v
|
||||
Names: some.otherplace.y some.place.x somewhere.z
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
-- Works with absolute names too
|
||||
scratch/main> names .some.place.x
|
||||
@ -77,20 +73,39 @@ scratch/main> names .some.place.x
|
||||
Term
|
||||
Hash: #gjmq673r1v
|
||||
Names: some.otherplace.y some.place.x somewhere.z
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
```
|
||||
`names.global` searches from the root, and absolutely qualifies results
|
||||
`debug.names.global` searches from the root, and absolutely qualifies results
|
||||
|
||||
TODO: swap this back to a 'ucm' block when names.global is re-implemented
|
||||
|
||||
```
|
||||
``` ucm
|
||||
-- We can search from a different branch and find all names in the codebase named 'x', and each of their aliases respectively.
|
||||
scratch/other> names.global x
|
||||
-- We can search by hash, and see all aliases of that hash in the codebase
|
||||
scratch/other> names.global #gjmq673r1v
|
||||
-- We can search using an absolute name
|
||||
scratch/other> names.global .some.place.x
|
||||
```
|
||||
scratch/other> debug.names.global x
|
||||
|
||||
Found results in scratch/main
|
||||
|
||||
Terms
|
||||
Hash: #gjmq673r1v
|
||||
Names: some.otherplace.y some.place.x somewhere.z
|
||||
|
||||
Hash: #pi25gcdv0o
|
||||
Names: some.otherplace.x
|
||||
|
||||
-- We can search by hash, and see all aliases of that hash in the codebase
|
||||
scratch/other> debug.names.global #gjmq673r1v
|
||||
|
||||
Found results in scratch/main
|
||||
|
||||
Term
|
||||
Hash: #gjmq673r1v
|
||||
Names: some.otherplace.y some.place.x somewhere.z
|
||||
|
||||
-- We can search using an absolute name
|
||||
scratch/other> debug.names.global .some.place.x
|
||||
|
||||
Found results in scratch/main
|
||||
|
||||
Term
|
||||
Hash: #gjmq673r1v
|
||||
Names: some.otherplace.y some.place.x somewhere.z
|
||||
|
||||
```
|
||||
|
@ -165,8 +165,6 @@ scratch/main> names distributed.lib.baz.qux
|
||||
Term
|
||||
Hash: #nhup096n2s
|
||||
Names: lib.distributed.lib.baz.qux
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
```
|
||||
## Corner cases
|
||||
|
@ -60,8 +60,6 @@ scratch/main> names A
|
||||
Term
|
||||
Hash: #uj8oalgadr#0
|
||||
Names: A.A
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
```
|
||||
``` unison
|
||||
@ -99,8 +97,6 @@ scratch/main> names A
|
||||
Term
|
||||
Hash: #ufo5tuc7ho#0
|
||||
Names: A.A
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
```
|
||||
``` unison
|
||||
@ -140,7 +136,5 @@ scratch/main> names A
|
||||
Term
|
||||
Hash: #uj8oalgadr#0
|
||||
Names: A.A
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
```
|
||||
|
@ -62,7 +62,5 @@ scratch/main> names foo
|
||||
Term
|
||||
Hash: #9ntnotdp87
|
||||
Names: foo
|
||||
|
||||
Tip: Use `names.global` to see more results.
|
||||
|
||||
```
|
||||
|
@ -59,7 +59,8 @@ x = 3
|
||||
``` ucm
|
||||
scratch/main> update
|
||||
|
||||
The term name x is ambiguous. Please resolve the ambiguity,
|
||||
then try to update again.
|
||||
This branch has more than one term with the name `x`. Please
|
||||
delete or rename all but one of them, then try the update
|
||||
again.
|
||||
|
||||
```
|
||||
|
@ -72,8 +72,8 @@ myproject/main> update
|
||||
``` unison:added-by-ucm scratch.u
|
||||
foo = +30
|
||||
|
||||
-- The definitions below are not compatible with the updated definitions above.
|
||||
-- Please fix the errors and run `update` again.
|
||||
-- The definitions below no longer typecheck with the changes above.
|
||||
-- Please fix the errors and try `update` again.
|
||||
|
||||
bar : Nat
|
||||
bar =
|
||||
|
@ -71,8 +71,8 @@ scratch/main> update
|
||||
foo : Int
|
||||
foo = +5
|
||||
|
||||
-- The definitions below are not compatible with the updated definitions above.
|
||||
-- Please fix the errors and run `update` again.
|
||||
-- The definitions below no longer typecheck with the changes above.
|
||||
-- Please fix the errors and try `update` again.
|
||||
|
||||
bar : Nat
|
||||
bar =
|
||||
|
@ -53,8 +53,8 @@ scratch/main> update
|
||||
``` unison:added-by-ucm scratch.u
|
||||
foo n = "hello, world!"
|
||||
|
||||
-- The definitions below are not compatible with the updated definitions above.
|
||||
-- Please fix the errors and run `update` again.
|
||||
-- The definitions below no longer typecheck with the changes above.
|
||||
-- Please fix the errors and try `update` again.
|
||||
|
||||
test> mynamespace.foo.test =
|
||||
n = 2
|
||||
|
@ -67,8 +67,8 @@ scratch/main> update
|
||||
``` unison:added-by-ucm scratch.u
|
||||
type Foo = Bar Nat
|
||||
|
||||
-- The definitions below are not compatible with the updated definitions above.
|
||||
-- Please fix the errors and run `update` again.
|
||||
-- The definitions below no longer typecheck with the changes above.
|
||||
-- Please fix the errors and try `update` again.
|
||||
|
||||
foo : Foo -> Nat
|
||||
foo = cases
|
||||
|
@ -106,8 +106,8 @@ scratch/main> find.verbose
|
||||
``` unison:added-by-ucm scratch.u
|
||||
type Foo = { bar : Nat }
|
||||
|
||||
-- The definitions below are not compatible with the updated definitions above.
|
||||
-- Please fix the errors and run `update` again.
|
||||
-- The definitions below no longer typecheck with the changes above.
|
||||
-- Please fix the errors and try `update` again.
|
||||
|
||||
Foo.baz : Foo -> Int
|
||||
Foo.baz = cases Foo _ baz -> baz
|
||||
|
@ -62,8 +62,8 @@ scratch/main> update
|
||||
``` unison:added-by-ucm scratch.u
|
||||
type Foo = Bar Nat Nat
|
||||
|
||||
-- The definitions below are not compatible with the updated definitions above.
|
||||
-- Please fix the errors and run `update` again.
|
||||
-- The definitions below no longer typecheck with the changes above.
|
||||
-- Please fix the errors and try `update` again.
|
||||
|
||||
incrFoo : Foo -> Foo
|
||||
incrFoo = cases Bar n -> Bar (n Nat.+ 1)
|
||||
|
@ -60,8 +60,8 @@ scratch/main> update
|
||||
``` unison:added-by-ucm scratch.u
|
||||
type Foo a = Bar Nat a
|
||||
|
||||
-- The definitions below are not compatible with the updated definitions above.
|
||||
-- Please fix the errors and run `update` again.
|
||||
-- The definitions below no longer typecheck with the changes above.
|
||||
-- Please fix the errors and try `update` again.
|
||||
|
||||
type Baz = Qux Foo
|
||||
|
||||
|
@ -9,7 +9,9 @@ dependencies:
|
||||
- bytes
|
||||
- containers
|
||||
- cryptonite
|
||||
- deriving-compat
|
||||
- extra
|
||||
- free
|
||||
- lens
|
||||
- megaparsec
|
||||
- mtl
|
||||
|
@ -4,7 +4,11 @@
|
||||
|
||||
module Unison.Parser.Ann where
|
||||
|
||||
import Control.Comonad.Cofree (Cofree ((:<)))
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Void (absurd)
|
||||
import Unison.Lexer.Pos qualified as L
|
||||
import Unison.Prelude
|
||||
|
||||
data Ann
|
||||
= -- Used for things like Builtins which don't have a source position.
|
||||
@ -79,3 +83,24 @@ encompasses (GeneratedFrom ann) other = encompasses ann other
|
||||
encompasses ann (GeneratedFrom other) = encompasses ann other
|
||||
encompasses (Ann start1 end1) (Ann start2 end2) =
|
||||
Just $ start1 <= start2 && end1 >= end2
|
||||
|
||||
class Annotated a where
|
||||
ann :: a -> Ann
|
||||
|
||||
instance Annotated Ann where
|
||||
ann = id
|
||||
|
||||
instance (Annotated a) => Annotated [a] where
|
||||
ann = foldMap ann
|
||||
|
||||
instance (Annotated a) => Annotated (NonEmpty a) where
|
||||
ann = foldMap ann
|
||||
|
||||
instance (Annotated a) => Annotated (Maybe a) where
|
||||
ann = foldMap ann
|
||||
|
||||
instance Annotated Void where
|
||||
ann = absurd
|
||||
|
||||
instance (Annotated a) => Annotated (Cofree f a) where
|
||||
ann (a :< _) = ann a
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -6,9 +6,10 @@ module Unison.Syntax.Lexer.Token
|
||||
where
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Text.Megaparsec (ParsecT, TraversableStream)
|
||||
import Text.Megaparsec (MonadParsec, TraversableStream)
|
||||
import Text.Megaparsec qualified as P
|
||||
import Unison.Lexer.Pos (Pos (Pos))
|
||||
import Unison.Parser.Ann (Ann (Ann), Annotated (..))
|
||||
import Unison.Prelude
|
||||
|
||||
data Token a = Token
|
||||
@ -18,6 +19,9 @@ data Token a = Token
|
||||
}
|
||||
deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
|
||||
|
||||
instance Annotated (Token a) where
|
||||
ann (Token _ s e) = Ann s e
|
||||
|
||||
instance Applicative Token where
|
||||
pure a = Token a (Pos 0 0) (Pos 0 0)
|
||||
Token f start _ <*> Token a _ end = Token (f a) start end
|
||||
@ -39,14 +43,14 @@ instance Applicative Token where
|
||||
instance P.ShowErrorComponent (Token Text) where
|
||||
showErrorComponent = Text.unpack . payload
|
||||
|
||||
tokenP :: (Ord e, TraversableStream s) => ParsecT e s m a -> ParsecT e s m (Token a)
|
||||
tokenP :: (Ord e, TraversableStream s, MonadParsec e s m) => m a -> m (Token a)
|
||||
tokenP p = do
|
||||
start <- posP
|
||||
payload <- p
|
||||
end <- posP
|
||||
pure Token {payload, start, end}
|
||||
|
||||
posP :: (Ord e, TraversableStream s) => ParsecT e s m Pos
|
||||
posP :: (Ord e, TraversableStream s, MonadParsec e s m) => m Pos
|
||||
posP = do
|
||||
p <- P.getSourcePos
|
||||
pure (Pos (P.unPos (P.sourceLine p)) (P.unPos (P.sourceColumn p)))
|
||||
|
1005
unison-syntax/src/Unison/Syntax/Lexer/Unison.hs
Normal file
1005
unison-syntax/src/Unison/Syntax/Lexer/Unison.hs
Normal file
File diff suppressed because it is too large
Load Diff
@ -1,10 +1,12 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Unison.Syntax.Parser
|
||||
( Annotated (..),
|
||||
Err,
|
||||
Error (..),
|
||||
Input,
|
||||
-- FIXME: Don’t export the data constructor
|
||||
Input (..),
|
||||
P,
|
||||
ParsingEnv (..),
|
||||
UniqueName,
|
||||
@ -15,6 +17,8 @@ module Unison.Syntax.Parser
|
||||
chainr1,
|
||||
character,
|
||||
closeBlock,
|
||||
optionalCloseBlock,
|
||||
doc,
|
||||
failCommitted,
|
||||
failureIf,
|
||||
hqInfixId,
|
||||
@ -57,6 +61,7 @@ where
|
||||
import Control.Monad.Reader (ReaderT (..))
|
||||
import Control.Monad.Reader.Class (asks)
|
||||
import Crypto.Random qualified as Random
|
||||
import Data.Bool (bool)
|
||||
import Data.Bytes.Put (runPutS)
|
||||
import Data.Bytes.Serial (serialize)
|
||||
import Data.Bytes.VarInt (VarInt (..))
|
||||
@ -67,6 +72,7 @@ import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Text.Megaparsec (runParserT)
|
||||
import Text.Megaparsec qualified as P
|
||||
import U.Codebase.Reference (ReferenceType (..))
|
||||
import U.Util.Base32Hex qualified as Base32Hex
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.ConstructorReference (ConstructorReference)
|
||||
@ -77,14 +83,16 @@ import Unison.Hashable qualified as Hashable
|
||||
import Unison.Name as Name
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names.ResolutionResult qualified as Names
|
||||
import Unison.Parser.Ann (Ann (..))
|
||||
import Unison.Parser.Ann (Ann (..), Annotated (..))
|
||||
import Unison.Pattern (Pattern)
|
||||
import Unison.Pattern qualified as Pattern
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Syntax.Lexer qualified as L
|
||||
import Unison.Syntax.Lexer.Unison qualified as L
|
||||
import Unison.Syntax.Name qualified as Name (toVar, unsafeParseText)
|
||||
import Unison.Syntax.Parser.Doc qualified as Doc
|
||||
import Unison.Syntax.Parser.Doc.Data qualified as Doc
|
||||
import Unison.Term (MatchCase (..))
|
||||
import Unison.UnisonFile.Error qualified as UF
|
||||
import Unison.Util.Bytes (Bytes)
|
||||
@ -154,19 +162,22 @@ data Error v
|
||||
| UnknownType (L.Token (HQ.HashQualified Name)) (Set Reference)
|
||||
| UnknownId (L.Token (HQ.HashQualified Name)) (Set Referent) (Set Reference)
|
||||
| ExpectedBlockOpen String (L.Token L.Lexeme)
|
||||
| -- Indicates a cases or match/with which doesn't have any patterns
|
||||
| -- | Indicates a cases or match/with which doesn't have any patterns
|
||||
EmptyMatch (L.Token ())
|
||||
| EmptyWatch Ann
|
||||
| UseInvalidPrefixSuffix (Either (L.Token Name) (L.Token Name)) (Maybe [L.Token Name])
|
||||
| UseEmpty (L.Token String) -- an empty `use` statement
|
||||
| DidntExpectExpression (L.Token L.Lexeme) (Maybe (L.Token L.Lexeme))
|
||||
| TypeDeclarationErrors [UF.Error v Ann]
|
||||
| -- MissingTypeModifier (type|ability) name
|
||||
| -- | MissingTypeModifier (type|ability) name
|
||||
MissingTypeModifier (L.Token String) (L.Token v)
|
||||
| -- | A type was found in a position that requires a term
|
||||
TypeNotAllowed (L.Token (HQ.HashQualified Name))
|
||||
| ResolutionFailures [Names.ResolutionFailure v Ann]
|
||||
| DuplicateTypeNames [(v, [Ann])]
|
||||
| DuplicateTermNames [(v, [Ann])]
|
||||
| PatternArityMismatch Int Int Ann -- PatternArityMismatch expectedArity actualArity location
|
||||
| -- | PatternArityMismatch expectedArity actualArity location
|
||||
PatternArityMismatch Int Int Ann
|
||||
| FloatPattern Ann
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
@ -177,25 +188,12 @@ newtype Input = Input {inputStream :: [L.Token L.Lexeme]}
|
||||
deriving stock (Eq, Ord, Show)
|
||||
deriving newtype (P.Stream, P.VisualStream)
|
||||
|
||||
class Annotated a where
|
||||
ann :: a -> Ann
|
||||
|
||||
instance Annotated Ann where
|
||||
ann = id
|
||||
|
||||
instance Annotated (L.Token a) where
|
||||
ann (L.Token _ s e) = Ann s e
|
||||
|
||||
instance (Annotated a) => Annotated (ABT.Term f v a) where
|
||||
ann = ann . ABT.annotation
|
||||
|
||||
instance (Annotated a) => Annotated (Pattern a) where
|
||||
ann = ann . Pattern.loc
|
||||
|
||||
instance (Annotated a) => Annotated [a] where
|
||||
ann [] = mempty
|
||||
ann (h : t) = foldl' (\acc a -> acc <> ann a) (ann h) t
|
||||
|
||||
instance (Annotated a, Annotated b) => Annotated (MatchCase a b) where
|
||||
ann (MatchCase p _ b) = ann p <> ann b
|
||||
|
||||
@ -207,8 +205,7 @@ label = P.label
|
||||
traceRemainingTokens :: (Ord v) => String -> P v m ()
|
||||
traceRemainingTokens label = do
|
||||
remainingTokens <- lookAhead $ many anyToken
|
||||
let _ =
|
||||
trace ("REMAINDER " ++ label ++ ":\n" ++ L.debugLex'' remainingTokens) ()
|
||||
let _ = trace ("REMAINDER " ++ label ++ ":\n" ++ L.debugPreParse (L.preParse remainingTokens)) ()
|
||||
pure ()
|
||||
|
||||
mkAnn :: (Annotated a, Annotated b) => a -> b -> Ann
|
||||
@ -239,23 +236,20 @@ rootFile p = p <* P.eof
|
||||
|
||||
run' :: (Monad m, Ord v) => P v m a -> String -> String -> ParsingEnv m -> m (Either (Err v) a)
|
||||
run' p s name env =
|
||||
let lex =
|
||||
if debug
|
||||
then L.lexer name (trace (L.debugLex''' "lexer receives" s) s)
|
||||
else L.lexer name s
|
||||
let lex = bool id (traceWith L.debugPreParse) debug . L.preParse $ L.lexer name s
|
||||
pTraced = traceRemainingTokens "parser receives" *> p
|
||||
in runReaderT (runParserT pTraced name (Input lex)) env <&> \case
|
||||
in runReaderT (runParserT pTraced name . Input $ toList lex) env <&> \case
|
||||
Left err -> Left (Nel.head (P.bundleErrors err))
|
||||
Right x -> Right x
|
||||
|
||||
run :: (Monad m, Ord v) => P v m a -> String -> ParsingEnv m -> m (Either (Err v) a)
|
||||
run p s = run' p s ""
|
||||
|
||||
-- Virtual pattern match on a lexeme.
|
||||
-- | Virtual pattern match on a lexeme.
|
||||
queryToken :: (Ord v) => (L.Lexeme -> Maybe a) -> P v m (L.Token a)
|
||||
queryToken f = P.token (traverse f) Set.empty
|
||||
|
||||
-- Consume a block opening and return the string that opens the block.
|
||||
-- | Consume a block opening and return the string that opens the block.
|
||||
openBlock :: (Ord v) => P v m (L.Token String)
|
||||
openBlock = queryToken getOpen
|
||||
where
|
||||
@ -265,33 +259,38 @@ openBlock = queryToken getOpen
|
||||
openBlockWith :: (Ord v) => String -> P v m (L.Token ())
|
||||
openBlockWith s = void <$> P.satisfy ((L.Open s ==) . L.payload)
|
||||
|
||||
-- Match a particular lexeme exactly, and consume it.
|
||||
-- | Match a particular lexeme exactly, and consume it.
|
||||
matchToken :: (Ord v) => L.Lexeme -> P v m (L.Token L.Lexeme)
|
||||
matchToken x = P.satisfy ((==) x . L.payload)
|
||||
|
||||
-- Consume a virtual semicolon
|
||||
-- | Consume a virtual semicolon
|
||||
semi :: (Ord v) => P v m (L.Token ())
|
||||
semi = label "newline or semicolon" $ queryToken go
|
||||
where
|
||||
go (L.Semi _) = Just ()
|
||||
go _ = Nothing
|
||||
|
||||
-- Consume the end of a block
|
||||
-- | Consume the end of a block
|
||||
closeBlock :: (Ord v) => P v m (L.Token ())
|
||||
closeBlock = void <$> matchToken L.Close
|
||||
|
||||
-- | With layout, blocks might “close” without an explicit outdent (e.g., not even a newline at the end of a
|
||||
-- `Doc.Transclude`). This allows those blocks to be closed by EOF.
|
||||
optionalCloseBlock :: (Ord v) => P v m (L.Token ())
|
||||
optionalCloseBlock = closeBlock <|> (\() -> L.Token () mempty mempty) <$> P.eof
|
||||
|
||||
wordyPatternName :: (Var v) => P v m (L.Token v)
|
||||
wordyPatternName = queryToken \case
|
||||
L.WordyId (HQ'.NameOnly n) -> Just $ Name.toVar n
|
||||
_ -> Nothing
|
||||
|
||||
-- Parse an prefix identifier e.g. Foo or (+), discarding any hash
|
||||
-- | Parse a prefix identifier e.g. Foo or (+), discarding any hash
|
||||
prefixDefinitionName :: (Var v) => P v m (L.Token v)
|
||||
prefixDefinitionName =
|
||||
wordyDefinitionName <|> parenthesize symbolyDefinitionName
|
||||
|
||||
-- Parse a prefix identifier e.g. Foo or (+), rejecting any hash
|
||||
-- This is useful for term declarations, where type signatures and term names should not have hashes.
|
||||
-- | Parse a prefix identifier e.g. Foo or (+), rejecting any hash
|
||||
-- This is useful for term declarations, where type signatures and term names should not have hashes.
|
||||
prefixTermName :: (Var v) => P v m (L.Token v)
|
||||
prefixTermName = wordyTermName <|> parenthesize symbolyTermName
|
||||
where
|
||||
@ -303,34 +302,34 @@ prefixTermName = wordyTermName <|> parenthesize symbolyTermName
|
||||
L.SymbolyId (HQ'.NameOnly n) -> Just $ Name.toVar n
|
||||
_ -> Nothing
|
||||
|
||||
-- Parse a wordy identifier e.g. Foo, discarding any hash
|
||||
-- | Parse a wordy identifier e.g. Foo, discarding any hash
|
||||
wordyDefinitionName :: (Var v) => P v m (L.Token v)
|
||||
wordyDefinitionName = queryToken $ \case
|
||||
L.WordyId n -> Just $ Name.toVar (HQ'.toName n)
|
||||
L.Blank s -> Just $ Var.nameds ("_" <> s)
|
||||
_ -> Nothing
|
||||
|
||||
-- Parse a wordyId as a Name, rejecting any hash
|
||||
-- | Parse a wordyId as a Name, rejecting any hash
|
||||
importWordyId :: (Ord v) => P v m (L.Token Name)
|
||||
importWordyId = queryToken \case
|
||||
L.WordyId (HQ'.NameOnly n) -> Just n
|
||||
L.Blank s | not (null s) -> Just $ Name.unsafeParseText (Text.pack ("_" <> s))
|
||||
_ -> Nothing
|
||||
|
||||
-- The `+` in: use Foo.bar + as a Name
|
||||
-- | The `+` in: use Foo.bar + as a Name
|
||||
importSymbolyId :: (Ord v) => P v m (L.Token Name)
|
||||
importSymbolyId = queryToken \case
|
||||
L.SymbolyId (HQ'.NameOnly n) -> Just n
|
||||
_ -> Nothing
|
||||
|
||||
-- Parse a symboly ID like >>= or &&, discarding any hash
|
||||
-- | Parse a symboly ID like >>= or &&, discarding any hash
|
||||
symbolyDefinitionName :: (Var v) => P v m (L.Token v)
|
||||
symbolyDefinitionName = queryToken $ \case
|
||||
L.SymbolyId n -> Just $ Name.toVar (HQ'.toName n)
|
||||
_ -> Nothing
|
||||
|
||||
-- | Expect parentheses around a token, includes the parentheses within the start/end
|
||||
-- annotations of the resulting token.
|
||||
-- annotations of the resulting token.
|
||||
parenthesize :: (Ord v) => P v m (L.Token a) -> P v m (L.Token a)
|
||||
parenthesize p = do
|
||||
(start, a) <- P.try do
|
||||
@ -344,7 +343,7 @@ hqPrefixId, hqInfixId :: (Ord v) => P v m (L.Token (HQ.HashQualified Name))
|
||||
hqPrefixId = hqWordyId_ <|> parenthesize hqSymbolyId_
|
||||
hqInfixId = hqSymbolyId_
|
||||
|
||||
-- Parse a hash-qualified alphanumeric identifier
|
||||
-- | Parse a hash-qualified alphanumeric identifier
|
||||
hqWordyId_ :: (Ord v) => P v m (L.Token (HQ.HashQualified Name))
|
||||
hqWordyId_ = queryToken \case
|
||||
L.WordyId n -> Just $ HQ'.toHQ n
|
||||
@ -352,20 +351,20 @@ hqWordyId_ = queryToken \case
|
||||
L.Blank s | not (null s) -> Just $ HQ.NameOnly (Name.unsafeParseText (Text.pack ("_" <> s)))
|
||||
_ -> Nothing
|
||||
|
||||
-- Parse a hash-qualified symboly ID like >>=#foo or &&
|
||||
-- | Parse a hash-qualified symboly ID like >>=#foo or &&
|
||||
hqSymbolyId_ :: (Ord v) => P v m (L.Token (HQ.HashQualified Name))
|
||||
hqSymbolyId_ = queryToken \case
|
||||
L.SymbolyId n -> Just (HQ'.toHQ n)
|
||||
_ -> Nothing
|
||||
|
||||
-- Parse a reserved word
|
||||
-- | Parse a reserved word
|
||||
reserved :: (Ord v) => String -> P v m (L.Token String)
|
||||
reserved w = label w $ queryToken getReserved
|
||||
where
|
||||
getReserved (L.Reserved w') | w == w' = Just w
|
||||
getReserved _ = Nothing
|
||||
|
||||
-- Parse a placeholder or typed hole
|
||||
-- | Parse a placeholder or typed hole
|
||||
blank :: (Ord v) => P v m (L.Token String)
|
||||
blank = label "blank" $ queryToken getBlank
|
||||
where
|
||||
@ -405,6 +404,12 @@ string = queryToken getString
|
||||
getString (L.Textual s) = Just (Text.pack s)
|
||||
getString _ = Nothing
|
||||
|
||||
doc ::
|
||||
(Ord v) => P v m (L.Token (Doc.UntitledSection (Doc.Tree (ReferenceType, HQ'.HashQualified Name) [L.Token L.Lexeme])))
|
||||
doc = queryToken \case
|
||||
L.Doc d -> pure d
|
||||
_ -> Nothing
|
||||
|
||||
-- | Parses a tuple of 'a's, or a single parenthesized 'a'
|
||||
--
|
||||
-- returns the result of combining elements with 'pair', alongside the annotation containing
|
||||
@ -435,12 +440,12 @@ chainr1 p op = go1
|
||||
go1 = p >>= go2
|
||||
go2 hd = do { op <- op; op hd <$> go1 } <|> pure hd
|
||||
|
||||
-- Parse `p` 1+ times, combining with `op`
|
||||
-- | Parse `p` 1+ times, combining with `op`
|
||||
chainl1 :: (Ord v) => P v m a -> P v m (a -> a -> a) -> P v m a
|
||||
chainl1 p op = foldl (flip ($)) <$> p <*> P.many (flip <$> op <*> p)
|
||||
|
||||
-- If `p` would succeed, this fails uncommitted.
|
||||
-- Otherwise, `failIfOk` used to produce the output
|
||||
-- | If `p` would succeed, this fails uncommitted.
|
||||
-- Otherwise, `failIfOk` used to produce the output
|
||||
failureIf :: (Ord v) => P v m (P v m b) -> P v m a -> P v m b
|
||||
failureIf failIfOk p = do
|
||||
dontwant <- P.try . P.lookAhead $ failIfOk
|
||||
@ -448,9 +453,9 @@ failureIf failIfOk p = do
|
||||
when (isJust p) $ fail "failureIf"
|
||||
dontwant
|
||||
|
||||
-- Gives this var an id based on its position - a useful trick to
|
||||
-- obtain a variable whose id won't match any other id in the file
|
||||
-- `positionalVar a Var.missingResult`
|
||||
-- | Gives this var an id based on its position - a useful trick to
|
||||
-- obtain a variable whose id won't match any other id in the file
|
||||
-- `positionalVar a Var.missingResult`
|
||||
positionalVar :: (Annotated a, Var v) => a -> v -> v
|
||||
positionalVar a v =
|
||||
let s = start (ann a)
|
||||
|
624
unison-syntax/src/Unison/Syntax/Parser/Doc.hs
Normal file
624
unison-syntax/src/Unison/Syntax/Parser/Doc.hs
Normal file
@ -0,0 +1,624 @@
|
||||
-- | The parser for Unison’s @Doc@ syntax.
|
||||
--
|
||||
-- This is completely independent of the Unison language, and requires a couple parsers to be passed in to then
|
||||
-- provide a parser for @Doc@ applied to any host language.
|
||||
--
|
||||
-- - an identifer parser
|
||||
-- - a code parser (that accepts a termination parser)
|
||||
-- - a termination parser, for this parser to know when to give up
|
||||
--
|
||||
-- Each of those parsers is expected to satisfy @(`Ord` e, `P.MonadParsec` e `String` m)@.
|
||||
module Unison.Syntax.Parser.Doc
|
||||
( Tree,
|
||||
initialEnv,
|
||||
doc,
|
||||
untitledSection,
|
||||
sectionElem,
|
||||
leaf,
|
||||
|
||||
-- * section elements
|
||||
section,
|
||||
eval,
|
||||
exampleBlock,
|
||||
codeBlock,
|
||||
list,
|
||||
bulletedList,
|
||||
numberedList,
|
||||
paragraph,
|
||||
|
||||
-- * leaves
|
||||
link,
|
||||
namedLink,
|
||||
example,
|
||||
transclude,
|
||||
bold,
|
||||
italic,
|
||||
strikethrough,
|
||||
verbatim,
|
||||
source,
|
||||
foldedSource,
|
||||
evalInline,
|
||||
signatures,
|
||||
signatureInline,
|
||||
group,
|
||||
word,
|
||||
|
||||
-- * other components
|
||||
column',
|
||||
embedLink,
|
||||
embedSignatureLink,
|
||||
join,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Comonad.Cofree (Cofree ((:<)))
|
||||
import Control.Monad.Reader qualified as R
|
||||
import Data.Char (isControl, isSpace)
|
||||
import Data.List qualified as List
|
||||
import Data.List.Extra qualified as List
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
import Text.Megaparsec qualified as P
|
||||
import Text.Megaparsec.Char (char)
|
||||
import Text.Megaparsec.Char qualified as CP
|
||||
import Text.Megaparsec.Char.Lexer qualified as LP
|
||||
import Unison.Parser.Ann (Ann, Annotated (..))
|
||||
import Unison.Prelude hiding (join)
|
||||
import Unison.Syntax.Lexer (column, line, lit, sepBy1', some', someTill', (<+>))
|
||||
import Unison.Syntax.Lexer.Token (Token (Token), posP, tokenP)
|
||||
import Unison.Syntax.Parser.Doc.Data
|
||||
|
||||
type Tree ident code = Cofree (Top ident code) Ann
|
||||
|
||||
data ParsingEnv = ParsingEnv
|
||||
{ -- | Use a stack to remember the parent section and allow docSections within docSections.
|
||||
-- - 1 means we are inside a # Heading 1
|
||||
parentSections :: [Int],
|
||||
-- | 4 means we are inside a list starting at the fourth column
|
||||
parentListColumn :: Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
initialEnv :: ParsingEnv
|
||||
initialEnv = ParsingEnv [0] 0
|
||||
|
||||
doc ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m end ->
|
||||
m (UntitledSection (Tree ident code))
|
||||
doc ident code = flip R.runReaderT initialEnv . untitledSection . sectionElem ident code . void
|
||||
|
||||
-- | This is the actual `Doc` lexer. Unlike `doc2`, it doesn’t do any Unison-side lexing (i.e., it doesn’t know that
|
||||
-- Unison wraps `Doc` literals in `}}`).
|
||||
untitledSection :: (P.MonadParsec e String m) => m a -> m (UntitledSection a)
|
||||
untitledSection a = UntitledSection <$> P.many (a <* CP.space)
|
||||
|
||||
sectionElem ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
R.ReaderT ParsingEnv m (Tree ident code)
|
||||
sectionElem ident code docClose =
|
||||
fmap wrap' $
|
||||
section ident code docClose
|
||||
<|> lift (P.label "block eval (syntax: a fenced code block)" (eval code <|> exampleBlock code <|> codeBlock))
|
||||
<|> list ident code docClose
|
||||
<|> lift (paragraph ident code docClose)
|
||||
|
||||
paragraph ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
m (Top ident code (Tree ident code))
|
||||
paragraph ident code docClose = fmap Paragraph . spaced docClose $ leafy ident code docClose
|
||||
|
||||
word :: (Ord e, P.MonadParsec e String m) => m end -> m (Leaf ident code void)
|
||||
word closing = fmap Word . tokenP . P.try $ do
|
||||
let end = P.lookAhead $ void (P.satisfy isSpace) <|> void closing
|
||||
word <- P.manyTill (P.satisfy (\ch -> not (isSpace ch))) end
|
||||
guard (not $ reserved word || null word)
|
||||
pure word
|
||||
where
|
||||
reserved word = List.isPrefixOf "}}" word || all (== '#') word
|
||||
|
||||
leaf ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
m (Leaf ident code (Tree ident code))
|
||||
leaf ident code closing =
|
||||
link ident
|
||||
<|> namedLink ident code closing
|
||||
<|> example code
|
||||
<|> transclude code
|
||||
<|> bold ident code closing
|
||||
<|> italic ident code closing
|
||||
<|> strikethrough ident code closing
|
||||
<|> verbatim
|
||||
<|> source ident code
|
||||
<|> foldedSource ident code
|
||||
<|> evalInline code
|
||||
<|> signatures ident
|
||||
<|> signatureInline ident
|
||||
<|> word closing
|
||||
|
||||
leafy ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
m (Leaf ident code (Tree ident code))
|
||||
leafy ident code closing = do
|
||||
p <- leaf ident code closing
|
||||
after <- P.optional . P.try $ leafy ident code closing
|
||||
case after of
|
||||
Nothing -> pure p
|
||||
Just after -> group . pure $ p :| pure after
|
||||
|
||||
comma :: (P.MonadParsec e String m) => m String
|
||||
comma = lit "," <* CP.space
|
||||
|
||||
source :: (Ord e, P.MonadParsec e String m) => m ident -> (m () -> m code) -> m (Leaf ident code a)
|
||||
source ident = fmap Source . (lit "@source" *>) . sourceElements ident
|
||||
|
||||
foldedSource :: (Ord e, P.MonadParsec e String m) => m ident -> (m () -> m code) -> m (Leaf ident code a)
|
||||
foldedSource ident = fmap FoldedSource . (lit "@foldedSource" *>) . sourceElements ident
|
||||
|
||||
sourceElements ::
|
||||
(Ord e, P.MonadParsec e String m) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m (NonEmpty (SourceElement ident (Leaf ident code Void)))
|
||||
sourceElements ident code = do
|
||||
_ <- (lit " {" <|> lit "{") *> CP.space
|
||||
s <- sepBy1' srcElem comma
|
||||
_ <- lit "}"
|
||||
pure s
|
||||
where
|
||||
srcElem =
|
||||
SourceElement
|
||||
<$> embedLink ident
|
||||
<*> ( fmap (fromMaybe []) . P.optional $
|
||||
(lit "@") *> (CP.space *> annotations)
|
||||
)
|
||||
where
|
||||
annotation = fmap Left (tokenP ident) <|> fmap Right (transclude code) <* CP.space
|
||||
annotations = P.some (EmbedAnnotation <$> annotation)
|
||||
|
||||
signatures :: (Ord e, P.MonadParsec e String m) => m ident -> m (Leaf ident code a)
|
||||
signatures ident = fmap Signature $ do
|
||||
_ <- (lit "@signatures" <|> lit "@signature") *> (lit " {" <|> lit "{") *> CP.space
|
||||
s <- sepBy1' (embedSignatureLink ident) comma
|
||||
_ <- lit "}"
|
||||
pure s
|
||||
|
||||
signatureInline :: (Ord e, P.MonadParsec e String m) => m ident -> m (Leaf ident code a)
|
||||
signatureInline ident = fmap SignatureInline $ do
|
||||
_ <- lit "@inlineSignature" *> (lit " {" <|> lit "{") *> CP.space
|
||||
s <- embedSignatureLink ident
|
||||
_ <- lit "}"
|
||||
pure s
|
||||
|
||||
evalInline :: (P.MonadParsec e String m) => (m () -> m code) -> m (Leaf ident code a)
|
||||
evalInline code = fmap EvalInline $ do
|
||||
_ <- lit "@eval" *> (lit " {" <|> lit "{") *> CP.space
|
||||
let inlineEvalClose = void $ lit "}"
|
||||
s <- code inlineEvalClose
|
||||
pure s
|
||||
|
||||
-- | Not an actual node, but this pattern is referenced in multiple places
|
||||
embedLink :: (Ord e, P.MonadParsec e s m, P.TraversableStream s) => m ident -> m (EmbedLink ident)
|
||||
embedLink = fmap EmbedLink . tokenP
|
||||
|
||||
embedSignatureLink :: (Ord e, P.MonadParsec e String m) => m ident -> m (EmbedSignatureLink ident)
|
||||
embedSignatureLink ident = EmbedSignatureLink <$> tokenP ident <* CP.space
|
||||
|
||||
verbatim :: (Ord e, P.MonadParsec e String m) => m (Leaf ident code a)
|
||||
verbatim =
|
||||
P.label "code (examples: ''**unformatted**'', `words` or '''_words_''')" $ do
|
||||
Token originalText start stop <- tokenP do
|
||||
-- a single backtick followed by a non-backtick is treated as monospaced
|
||||
let tick = P.try (lit "`" <* P.lookAhead (P.satisfy (/= '`')))
|
||||
-- also two or more ' followed by that number of closing '
|
||||
quotes <- tick <|> (lit "''" <+> P.takeWhileP Nothing (== '\''))
|
||||
P.someTill P.anySingle (lit quotes)
|
||||
let isMultiLine = line start /= line stop
|
||||
pure
|
||||
if isMultiLine
|
||||
then
|
||||
let trimmed = (trimAroundDelimiters originalText)
|
||||
txt = trimIndentFromVerbatimBlock (column start - 1) trimmed
|
||||
in -- If it's a multi-line verbatim block we trim any whitespace representing
|
||||
-- indentation from the pretty-printer. See 'trimIndentFromVerbatimBlock'
|
||||
Verbatim . Word $ Token txt start stop
|
||||
else Code . Word $ Token originalText start stop
|
||||
|
||||
example :: (P.MonadParsec e String m) => (m () -> m code) -> m (Leaf ident code void)
|
||||
example code =
|
||||
P.label "inline code (examples: ``List.map f xs``, ``[1] :+ 2``)" $
|
||||
fmap Example $ do
|
||||
n <- P.try $ do
|
||||
_ <- lit "`"
|
||||
length <$> P.takeWhile1P (Just "backticks") (== '`')
|
||||
let end = void . lit $ replicate (n + 1) '`'
|
||||
CP.space *> code end
|
||||
|
||||
link :: (Ord e, P.MonadParsec e String m) => m ident -> m (Leaf ident code a)
|
||||
link ident = P.label "link (examples: {type List}, {Nat.+})" $ Link <$> P.try (lit "{" *> embedLink ident <* lit "}")
|
||||
|
||||
transclude :: (P.MonadParsec e String m) => (m () -> m code) -> m (Leaf ident code a)
|
||||
transclude code =
|
||||
fmap Transclude . P.label "transclusion (examples: {{ doc2 }}, {{ sepBy s [doc1, doc2] }})" $
|
||||
lit "{{" *> code (void $ lit "}}")
|
||||
|
||||
nonNewlineSpaces :: (P.MonadParsec e String m) => m String
|
||||
nonNewlineSpaces = P.takeWhileP Nothing nonNewlineSpace
|
||||
where
|
||||
nonNewlineSpace ch = isSpace ch && ch /= '\n' && ch /= '\r'
|
||||
|
||||
eval :: (P.MonadParsec e String m, Annotated code) => (m () -> m code) -> m (Top ident code (Tree ident code))
|
||||
eval code =
|
||||
Eval <$> do
|
||||
-- commit after seeing that ``` is on its own line
|
||||
fence <- P.try $ do
|
||||
fence <- lit "```" <+> P.takeWhileP Nothing (== '`')
|
||||
b <- all isSpace <$> P.lookAhead (P.takeWhileP Nothing (/= '\n'))
|
||||
fence <$ guard b
|
||||
CP.space *> code (void $ lit fence)
|
||||
|
||||
exampleBlock :: (P.MonadParsec e String m, Annotated code) => (m () -> m code) -> m (Top ident code (Tree ident code))
|
||||
exampleBlock code =
|
||||
ExampleBlock
|
||||
<$> do
|
||||
void $ lit "@typecheck" <* CP.space
|
||||
fence <- lit "```" <+> P.takeWhileP Nothing (== '`')
|
||||
code . void $ lit fence
|
||||
|
||||
codeBlock :: (Ord e, P.MonadParsec e String m) => m (Top ident code (Tree ident code))
|
||||
codeBlock = do
|
||||
column <- (\x -> x - 1) . toInteger . P.unPos <$> LP.indentLevel
|
||||
let tabWidth = toInteger . P.unPos $ P.defaultTabWidth
|
||||
fence <- lit "```" <+> P.takeWhileP Nothing (== '`')
|
||||
name <-
|
||||
nonNewlineSpaces
|
||||
*> tokenP (P.takeWhile1P Nothing (not . isSpace))
|
||||
<* nonNewlineSpaces
|
||||
_ <- void CP.eol
|
||||
verbatim <-
|
||||
tokenP $
|
||||
uncolumn column tabWidth . trimAroundDelimiters
|
||||
<$> P.someTill P.anySingle ([] <$ lit fence)
|
||||
pure $ CodeBlock name verbatim
|
||||
where
|
||||
uncolumn column tabWidth s =
|
||||
let skip col r | col < 1 = r
|
||||
skip col s@('\t' : _) | col < tabWidth = s
|
||||
skip col ('\t' : r) = skip (col - tabWidth) r
|
||||
skip col (c : r)
|
||||
| isSpace c && (not $ isControl c) =
|
||||
skip (col - 1) r
|
||||
skip _ s = s
|
||||
in List.intercalate "\n" $ skip column <$> lines s
|
||||
|
||||
emphasis ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
Char ->
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
m (Tree ident code)
|
||||
emphasis delimiter ident code closing = do
|
||||
let start = some (P.satisfy (== delimiter))
|
||||
end <- P.try $ do
|
||||
end <- start
|
||||
P.lookAhead (P.satisfy (not . isSpace))
|
||||
pure end
|
||||
wrap' . Paragraph
|
||||
<$> someTill'
|
||||
(leafy ident code (closing <|> (void $ lit end)) <* void whitespaceWithoutParagraphBreak)
|
||||
(lit end)
|
||||
where
|
||||
-- Allows whitespace including up to one newline
|
||||
whitespaceWithoutParagraphBreak = void do
|
||||
void nonNewlineSpaces
|
||||
optional newline >>= \case
|
||||
Just _ -> void nonNewlineSpaces
|
||||
Nothing -> pure ()
|
||||
|
||||
bold ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
m (Leaf ident code (Tree ident code))
|
||||
bold ident code = fmap Bold . emphasis '*' ident code
|
||||
|
||||
italic ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
m (Leaf ident code (Tree ident code))
|
||||
italic ident code = fmap Italic . emphasis '_' ident code
|
||||
|
||||
strikethrough ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
m (Leaf ident code (Tree ident code))
|
||||
strikethrough ident code = fmap Strikethrough . emphasis '~' ident code
|
||||
|
||||
namedLink ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
m (Leaf ident code (Tree ident code))
|
||||
namedLink ident code docClose =
|
||||
P.label "hyperlink (example: [link name](https://destination.com))" do
|
||||
_ <- lit "["
|
||||
p <- spaced docClose . leafy ident code . void $ char ']'
|
||||
_ <- lit "]"
|
||||
_ <- lit "("
|
||||
target <- group $ fmap pure (link ident) <|> some' (transclude code <|> word (docClose <|> void (char ')')))
|
||||
_ <- lit ")"
|
||||
pure $ NamedLink (wrap' $ Paragraph p) target
|
||||
|
||||
sp :: (P.MonadParsec e String m) => m () -> m String
|
||||
sp docClose = P.try $ do
|
||||
spaces <- P.takeWhile1P (Just "space") isSpace
|
||||
close <- P.optional (P.lookAhead docClose)
|
||||
case close of
|
||||
Nothing -> guard $ ok spaces
|
||||
Just _ -> pure ()
|
||||
pure spaces
|
||||
where
|
||||
ok s = length [() | '\n' <- s] < 2
|
||||
|
||||
spaced :: (P.MonadParsec e String m) => m () -> m a -> m (NonEmpty a)
|
||||
spaced docClose p = some' $ p <* P.optional (sp docClose)
|
||||
|
||||
-- | Not an actual node, but this pattern is referenced in multiple places
|
||||
list ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
R.ReaderT ParsingEnv m (Top ident code (Tree ident code))
|
||||
list ident code docClose = bulletedList ident code docClose <|> numberedList ident code docClose
|
||||
|
||||
listSep :: (Ord e, R.MonadReader ParsingEnv m, P.MonadParsec e String m) => m ()
|
||||
listSep = P.try $ newline *> nonNewlineSpaces *> P.lookAhead (void bulletedStart <|> void numberedStart)
|
||||
|
||||
bulletedStart :: (Ord e, R.MonadReader ParsingEnv m, P.MonadParsec e String m) => m (Int, [a])
|
||||
bulletedStart = P.try $ do
|
||||
r <- listItemStart $ [] <$ P.satisfy bulletChar
|
||||
P.lookAhead (P.satisfy isSpace)
|
||||
pure r
|
||||
where
|
||||
bulletChar ch = ch == '*' || ch == '-' || ch == '+'
|
||||
|
||||
listItemStart :: (Ord e, R.MonadReader ParsingEnv m, P.MonadParsec e String m) => m a -> m (Int, a)
|
||||
listItemStart gutter = P.try do
|
||||
nonNewlineSpaces
|
||||
col <- column <$> posP
|
||||
parentCol <- R.asks parentListColumn
|
||||
guard (col > parentCol)
|
||||
(col,) <$> gutter
|
||||
|
||||
numberedStart :: (Ord e, R.MonadReader ParsingEnv m, P.MonadParsec e String m) => m (Int, Token Word64)
|
||||
numberedStart = listItemStart $ P.try (tokenP $ LP.decimal <* lit ".")
|
||||
|
||||
-- | FIXME: This should take a @`P` a@
|
||||
numberedList ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
R.ReaderT ParsingEnv m (Top ident code (Tree ident code))
|
||||
numberedList ident code docClose = NumberedList <$> sepBy1' numberedItem listSep
|
||||
where
|
||||
numberedItem = P.label "numbered list (examples: 1. item1, 8. start numbering at '8')" do
|
||||
(col, s) <- numberedStart
|
||||
(s,) <$> column' ident code docClose col
|
||||
|
||||
-- | FIXME: This should take a @`P` a@
|
||||
bulletedList ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
R.ReaderT ParsingEnv m (Top ident code (Tree ident code))
|
||||
bulletedList ident code docClose = BulletedList <$> sepBy1' bullet listSep
|
||||
where
|
||||
bullet = P.label "bullet (examples: * item1, - item2)" do
|
||||
(col, _) <- bulletedStart
|
||||
column' ident code docClose col
|
||||
|
||||
column' ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
Int ->
|
||||
R.ReaderT ParsingEnv m (Column (Tree ident code))
|
||||
column' ident code docClose col =
|
||||
Column . wrap'
|
||||
<$> (nonNewlineSpaces *> listItemParagraph)
|
||||
<*> R.local (\e -> e {parentListColumn = col}) (P.optional $ listSep *> fmap wrap' (list ident code docClose))
|
||||
where
|
||||
listItemParagraph =
|
||||
Paragraph <$> do
|
||||
col <- column <$> posP
|
||||
some' (lift (leafy ident code docClose) <* sep col)
|
||||
where
|
||||
-- Trickiness here to support hard line breaks inside of
|
||||
-- a bulleted list, so for instance this parses as expected:
|
||||
--
|
||||
-- * uno dos
|
||||
-- tres quatro
|
||||
-- * alice bob
|
||||
-- carol dave eve
|
||||
sep col = do
|
||||
_ <- nonNewlineSpaces
|
||||
_ <-
|
||||
P.optional . P.try $
|
||||
newline
|
||||
*> nonNewlineSpaces
|
||||
*> do
|
||||
col2 <- column <$> posP
|
||||
guard $ col2 >= col
|
||||
(P.notFollowedBy $ void numberedStart <|> void bulletedStart)
|
||||
pure ()
|
||||
|
||||
newline :: (P.MonadParsec e String m) => m String
|
||||
newline = P.label "newline" $ lit "\n" <|> lit "\r\n"
|
||||
|
||||
-- |
|
||||
--
|
||||
-- > ## Section title
|
||||
-- >
|
||||
-- > A paragraph under this section.
|
||||
-- > Part of the same paragraph. Blanklines separate paragraphs.
|
||||
-- >
|
||||
-- > ### A subsection title
|
||||
-- >
|
||||
-- > A paragraph under this subsection.
|
||||
-- >
|
||||
-- > # A section title (not a subsection)
|
||||
section ::
|
||||
(Ord e, P.MonadParsec e String m, Annotated code) =>
|
||||
m ident ->
|
||||
(m () -> m code) ->
|
||||
m () ->
|
||||
R.ReaderT ParsingEnv m (Top ident code (Tree ident code))
|
||||
section ident code docClose = do
|
||||
ns <- R.asks parentSections
|
||||
hashes <- lift $ P.try $ lit (replicate (head ns) '#') *> P.takeWhile1P Nothing (== '#') <* sp docClose
|
||||
title <- lift $ paragraph ident code docClose <* CP.space
|
||||
let m = length hashes + head ns
|
||||
body <-
|
||||
R.local (\env -> env {parentSections = m : tail ns}) $
|
||||
P.many (sectionElem ident code docClose <* CP.space)
|
||||
pure $ Section (wrap' title) body
|
||||
|
||||
-- | FIXME: This should just take a @`P` code@ and @`P` a@.
|
||||
group :: (P.MonadParsec e s m) => m (NonEmpty (Leaf ident code a)) -> m (Leaf ident code a)
|
||||
group = fmap Group . join
|
||||
|
||||
-- | FIXME: This should just take a @`P` a@
|
||||
join :: (P.MonadParsec e s m) => m (NonEmpty a) -> m (Join a)
|
||||
join = fmap Join
|
||||
|
||||
-- * utility functions
|
||||
|
||||
wrap' :: (Annotated code) => Top ident code (Tree ident code) -> Tree ident code
|
||||
wrap' doc = ann doc :< doc
|
||||
|
||||
-- | If it's a multi-line verbatim block we trim any whitespace representing
|
||||
-- indentation from the pretty-printer.
|
||||
--
|
||||
-- E.g.
|
||||
--
|
||||
-- @@
|
||||
-- {{
|
||||
-- # Heading
|
||||
-- '''
|
||||
-- code
|
||||
-- indented
|
||||
-- '''
|
||||
-- }}
|
||||
-- @@
|
||||
--
|
||||
-- Should lex to the text literal "code\n indented".
|
||||
--
|
||||
-- If there's text in the literal that has LESS trailing whitespace than the
|
||||
-- opening delimiters, we don't trim it at all. E.g.
|
||||
--
|
||||
-- @@
|
||||
-- {{
|
||||
-- # Heading
|
||||
-- '''
|
||||
-- code
|
||||
-- '''
|
||||
-- }}
|
||||
-- @@
|
||||
--
|
||||
-- Is parsed as " code".
|
||||
--
|
||||
-- Trim the expected amount of whitespace from a text literal:
|
||||
-- >>> trimIndentFromVerbatimBlock 2 " code\n indented"
|
||||
-- "code\n indented"
|
||||
--
|
||||
-- If the text literal has less leading whitespace than the opening delimiters,
|
||||
-- leave it as-is
|
||||
-- >>> trimIndentFromVerbatimBlock 2 "code\n indented"
|
||||
-- "code\n indented"
|
||||
trimIndentFromVerbatimBlock :: Int -> String -> String
|
||||
trimIndentFromVerbatimBlock leadingSpaces txt = fromMaybe txt $ do
|
||||
List.intercalate "\n" <$> for (lines txt) \line -> do
|
||||
-- If any 'stripPrefix' fails, we fail and return the unaltered text
|
||||
case List.stripPrefix (replicate leadingSpaces ' ') line of
|
||||
Just stripped -> Just stripped
|
||||
Nothing ->
|
||||
-- If it was a line with all white-space, just use an empty line,
|
||||
-- this can happen easily in editors which trim trailing whitespace.
|
||||
if all isSpace line
|
||||
then Just ""
|
||||
else Nothing
|
||||
|
||||
-- | Trim leading/trailing whitespace from around delimiters, e.g.
|
||||
--
|
||||
-- {{
|
||||
-- '''___ <- whitespace here including newline
|
||||
-- text block
|
||||
-- 👇 or here
|
||||
-- __'''
|
||||
-- }}
|
||||
-- >>> trimAroundDelimiters " \n text block \n "
|
||||
-- " text block "
|
||||
--
|
||||
-- Should leave leading and trailing line untouched if it contains non-whitespace, e.g.:
|
||||
--
|
||||
-- ''' leading whitespace
|
||||
-- text block
|
||||
-- trailing whitespace: '''
|
||||
-- >>> trimAroundDelimiters " leading whitespace\n text block \ntrailing whitespace: "
|
||||
-- " leading whitespace\n text block \ntrailing whitespace: "
|
||||
--
|
||||
-- Should keep trailing newline if it's the only thing on the line, e.g.:
|
||||
--
|
||||
-- '''
|
||||
-- newline below
|
||||
--
|
||||
-- '''
|
||||
-- >>> trimAroundDelimiters "\nnewline below\n\n"
|
||||
-- "newline below\n\n"
|
||||
trimAroundDelimiters :: String -> String
|
||||
trimAroundDelimiters txt =
|
||||
txt
|
||||
& ( \s ->
|
||||
List.breakOn "\n" s
|
||||
& \case
|
||||
(prefix, suffix)
|
||||
| all isSpace prefix -> drop 1 suffix
|
||||
| otherwise -> prefix <> suffix
|
||||
)
|
||||
& ( \s ->
|
||||
List.breakOnEnd "\n" s
|
||||
& \case
|
||||
(_prefix, "") -> s
|
||||
(prefix, suffix)
|
||||
| all isSpace suffix -> dropTrailingNewline prefix
|
||||
| otherwise -> prefix <> suffix
|
||||
)
|
||||
where
|
||||
dropTrailingNewline = \case
|
||||
[] -> []
|
||||
(x : xs) -> NonEmpty.init (x NonEmpty.:| xs)
|
194
unison-syntax/src/Unison/Syntax/Parser/Doc/Data.hs
Normal file
194
unison-syntax/src/Unison/Syntax/Parser/Doc/Data.hs
Normal file
@ -0,0 +1,194 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
-- | Haskell parallel to @unison/base.Doc@.
|
||||
--
|
||||
-- These types have two significant parameters: @ident@ and @code@ that are expected to be parameterized by some
|
||||
-- representation of identifiers and source code of the host language.
|
||||
--
|
||||
-- This is much more restricted than @unison/base.Doc@, but it covers everything we can parse from Haskell. The
|
||||
-- mismatch with Unison is a problem, as someone can create a Unison Doc with explicit constructors or function calls,
|
||||
-- have it rendered to a scratch file, and then we can’t parse it. Changing the types here to match Unison wouldn’t
|
||||
-- fix the issue. We have to modify the types and parser in concert (in both Haskell and Unison) to bring them in
|
||||
-- line.
|
||||
module Unison.Syntax.Parser.Doc.Data where
|
||||
|
||||
import Data.Eq.Deriving (deriveEq1, deriveEq2)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Ord.Deriving (deriveOrd1, deriveOrd2)
|
||||
import Text.Show.Deriving (deriveShow1, deriveShow2)
|
||||
import Unison.Parser.Ann (Annotated (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Syntax.Lexer.Token (Token (..))
|
||||
|
||||
newtype UntitledSection a = UntitledSection [a]
|
||||
deriving (Eq, Ord, Show, Foldable, Functor, Traversable)
|
||||
|
||||
data Top ident code a
|
||||
= -- | The first argument is always a `Paragraph`
|
||||
Section a [a]
|
||||
| Eval code
|
||||
| ExampleBlock code
|
||||
| CodeBlock (Token String) (Token String)
|
||||
| BulletedList (NonEmpty (Column a))
|
||||
| NumberedList (NonEmpty (Token Word64, Column a))
|
||||
| Paragraph (NonEmpty (Leaf ident code a))
|
||||
deriving (Eq, Ord, Show, Foldable, Functor, Traversable)
|
||||
|
||||
data Column a
|
||||
= -- | The first is always a `Paragraph`, and the second a `BulletedList` or `NumberedList`
|
||||
Column a (Maybe a)
|
||||
deriving (Eq, Ord, Show, Foldable, Functor, Traversable)
|
||||
|
||||
data Leaf ident code a
|
||||
= Link (EmbedLink ident)
|
||||
| -- | first is a Paragraph, second is always a Group (which contains either a single Term/Type link or list of
|
||||
-- `Transclude`s & `Word`s)
|
||||
NamedLink a (Leaf ident code Void)
|
||||
| Example code
|
||||
| Transclude code
|
||||
| -- | Always a Paragraph
|
||||
Bold a
|
||||
| -- | Always a Paragraph
|
||||
Italic a
|
||||
| -- | Always a Paragraph
|
||||
Strikethrough a
|
||||
| -- | Always a Word
|
||||
Verbatim (Leaf ident Void Void)
|
||||
| -- | Always a Word
|
||||
Code (Leaf ident Void Void)
|
||||
| -- | Always a Transclude
|
||||
Source (NonEmpty (SourceElement ident (Leaf ident code Void)))
|
||||
| -- | Always a Transclude
|
||||
FoldedSource (NonEmpty (SourceElement ident (Leaf ident code Void)))
|
||||
| EvalInline code
|
||||
| Signature (NonEmpty (EmbedSignatureLink ident))
|
||||
| SignatureInline (EmbedSignatureLink ident)
|
||||
| Word (Token String)
|
||||
| Group (Join (Leaf ident code a))
|
||||
deriving (Eq, Ord, Show, Foldable, Functor, Traversable)
|
||||
|
||||
instance Bifunctor (Leaf ident) where
|
||||
bimap f g = \case
|
||||
Link x -> Link x
|
||||
NamedLink a leaf -> NamedLink (g a) $ first f leaf
|
||||
Example code -> Example $ f code
|
||||
Transclude code -> Transclude $ f code
|
||||
Bold a -> Bold $ g a
|
||||
Italic a -> Italic $ g a
|
||||
Strikethrough a -> Strikethrough $ g a
|
||||
Verbatim leaf -> Verbatim leaf
|
||||
Code leaf -> Code leaf
|
||||
Source elems -> Source $ fmap (first f) <$> elems
|
||||
FoldedSource elems -> FoldedSource $ fmap (first f) <$> elems
|
||||
EvalInline code -> EvalInline $ f code
|
||||
Signature x -> Signature x
|
||||
SignatureInline x -> SignatureInline x
|
||||
Word x -> Word x
|
||||
Group join -> Group $ bimap f g <$> join
|
||||
|
||||
-- | This is a deviation from the Unison Doc data model – in Unison, Doc distinguishes between type and term links, but
|
||||
-- here Doc knows nothing about what namespaces may exist.
|
||||
data EmbedLink ident = EmbedLink (Token ident)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data SourceElement ident a = SourceElement (EmbedLink ident) [EmbedAnnotation ident a]
|
||||
deriving (Eq, Ord, Show, Foldable, Functor, Traversable)
|
||||
|
||||
newtype EmbedSignatureLink ident = EmbedSignatureLink (Token ident)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
newtype Join a = Join (NonEmpty a)
|
||||
deriving (Eq, Ord, Show, Foldable, Functor, Traversable)
|
||||
|
||||
newtype EmbedAnnotation ident a
|
||||
= EmbedAnnotation (Either (Token ident) a)
|
||||
deriving (Eq, Ord, Show, Foldable, Functor, Traversable)
|
||||
|
||||
instance (Annotated code, Annotated a) => Annotated (Top ident code a) where
|
||||
ann = \case
|
||||
Section title body -> ann title <> ann body
|
||||
Eval code -> ann code
|
||||
ExampleBlock code -> ann code
|
||||
CodeBlock label body -> ann label <> ann body
|
||||
BulletedList items -> ann items
|
||||
NumberedList items -> ann $ snd <$> items
|
||||
Paragraph leaves -> ann leaves
|
||||
|
||||
instance (Annotated a) => Annotated (Column a) where
|
||||
ann (Column para list) = ann para <> ann list
|
||||
|
||||
instance (Annotated code, Annotated a) => Annotated (Leaf ident code a) where
|
||||
ann = \case
|
||||
Link link -> ann link
|
||||
NamedLink label target -> ann label <> ann target
|
||||
Example code -> ann code
|
||||
Transclude code -> ann code
|
||||
Bold para -> ann para
|
||||
Italic para -> ann para
|
||||
Strikethrough para -> ann para
|
||||
Verbatim word -> ann word
|
||||
Code word -> ann word
|
||||
Source elems -> ann elems
|
||||
FoldedSource elems -> ann elems
|
||||
EvalInline code -> ann code
|
||||
Signature links -> ann links
|
||||
SignatureInline link -> ann link
|
||||
Word text -> ann text
|
||||
Group (Join leaves) -> ann leaves
|
||||
|
||||
instance Annotated (EmbedLink ident) where
|
||||
ann (EmbedLink name) = ann name
|
||||
|
||||
instance (Annotated code) => Annotated (SourceElement ident code) where
|
||||
ann (SourceElement link target) = ann link <> ann target
|
||||
|
||||
instance Annotated (EmbedSignatureLink ident) where
|
||||
ann (EmbedSignatureLink name) = ann name
|
||||
|
||||
instance (Annotated code) => Annotated (EmbedAnnotation ident code) where
|
||||
ann (EmbedAnnotation a) = either ann ann a
|
||||
|
||||
$(deriveEq1 ''Column)
|
||||
$(deriveOrd1 ''Column)
|
||||
$(deriveShow1 ''Column)
|
||||
|
||||
$(deriveEq1 ''Token)
|
||||
$(deriveOrd1 ''Token)
|
||||
$(deriveShow1 ''Token)
|
||||
|
||||
$(deriveEq1 ''EmbedAnnotation)
|
||||
$(deriveOrd1 ''EmbedAnnotation)
|
||||
$(deriveShow1 ''EmbedAnnotation)
|
||||
$(deriveEq2 ''EmbedAnnotation)
|
||||
$(deriveOrd2 ''EmbedAnnotation)
|
||||
$(deriveShow2 ''EmbedAnnotation)
|
||||
|
||||
$(deriveEq1 ''EmbedLink)
|
||||
$(deriveOrd1 ''EmbedLink)
|
||||
$(deriveShow1 ''EmbedLink)
|
||||
|
||||
$(deriveEq1 ''SourceElement)
|
||||
$(deriveOrd1 ''SourceElement)
|
||||
$(deriveShow1 ''SourceElement)
|
||||
$(deriveEq2 ''SourceElement)
|
||||
$(deriveOrd2 ''SourceElement)
|
||||
$(deriveShow2 ''SourceElement)
|
||||
|
||||
$(deriveEq1 ''Join)
|
||||
$(deriveOrd1 ''Join)
|
||||
$(deriveShow1 ''Join)
|
||||
|
||||
$(deriveEq1 ''Leaf)
|
||||
$(deriveOrd1 ''Leaf)
|
||||
$(deriveShow1 ''Leaf)
|
||||
$(deriveEq2 ''Leaf)
|
||||
$(deriveOrd2 ''Leaf)
|
||||
$(deriveShow2 ''Leaf)
|
||||
|
||||
$(deriveEq1 ''Top)
|
||||
$(deriveOrd1 ''Top)
|
||||
$(deriveShow1 ''Top)
|
||||
$(deriveEq2 ''Top)
|
||||
$(deriveOrd2 ''Top)
|
||||
$(deriveShow2 ''Top)
|
@ -10,7 +10,7 @@ import Unison.Prelude
|
||||
import Unison.ShortHash (ShortHash)
|
||||
import Unison.ShortHash qualified as ShortHash
|
||||
import Unison.Syntax.HashQualifiedPrime qualified as HQ' (unsafeParseText)
|
||||
import Unison.Syntax.Lexer
|
||||
import Unison.Syntax.Lexer.Unison
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
@ -221,8 +221,8 @@ test =
|
||||
|
||||
t :: String -> [Lexeme] -> Test ()
|
||||
t s expected =
|
||||
let actual0 = payload <$> lexer "ignored filename" s
|
||||
actual = take (length actual0 - 2) . drop 1 $ actual0
|
||||
let actual0 = payload <$> preParse (lexer "ignored filename" s)
|
||||
actual = take (length actual0 - 2) . drop 1 $ toList actual0
|
||||
in scope s $
|
||||
if actual == expected
|
||||
then ok
|
||||
|
@ -23,9 +23,12 @@ library
|
||||
Unison.Syntax.HashQualifiedPrime
|
||||
Unison.Syntax.Lexer
|
||||
Unison.Syntax.Lexer.Token
|
||||
Unison.Syntax.Lexer.Unison
|
||||
Unison.Syntax.Name
|
||||
Unison.Syntax.NameSegment
|
||||
Unison.Syntax.Parser
|
||||
Unison.Syntax.Parser.Doc
|
||||
Unison.Syntax.Parser.Doc.Data
|
||||
Unison.Syntax.ReservedWords
|
||||
Unison.Syntax.ShortHash
|
||||
Unison.Syntax.Var
|
||||
@ -68,7 +71,9 @@ library
|
||||
, bytes
|
||||
, containers
|
||||
, cryptonite
|
||||
, deriving-compat
|
||||
, extra
|
||||
, free
|
||||
, lens
|
||||
, megaparsec
|
||||
, mtl
|
||||
@ -125,8 +130,10 @@ test-suite syntax-tests
|
||||
, code-page
|
||||
, containers
|
||||
, cryptonite
|
||||
, deriving-compat
|
||||
, easytest
|
||||
, extra
|
||||
, free
|
||||
, lens
|
||||
, megaparsec
|
||||
, mtl
|
||||
|
Loading…
Reference in New Issue
Block a user