unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 02:25:39 +03:00
Code Issues Projects Releases Wiki Activity

⅄ trunk → 24-08-01-merge-api

Browse Source
This commit is contained in:
Mitchell Rosen 2024-08-05 10:38:38 -04:00
commit b94698057d
66 changed files with 2864 additions and 2019 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.github/workflows/nix-dev-cache.yaml vendored
View File

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

6
development.markdown
View File

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

23
parser-typechecker/src/Unison/PatternMatchCoverage.hs
View File

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

9
parser-typechecker/src/Unison/PatternMatchCoverage/Desugar.hs
View File

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

12
parser-typechecker/src/Unison/PrintError.hs
View File

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

339
parser-typechecker/src/Unison/Syntax/TermParser.hs
View File

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

2
parser-typechecker/src/Unison/Syntax/TermPrinter.hs
View File

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

2
parser-typechecker/src/Unison/Typechecker/Context.hs
View File

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

@ -0,0 +1,6 @@
compiled/
boot-generated.ss
builtin-generated.ss
compound-wrappers.ss
data-info.ss
simple-wrappers.ss

65
scheme-libs/racket/unison/Readme.md
View File

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

163
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

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

4
unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs
View File

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

4
unison-cli/src/Unison/Codebase/Editor/Input.hs
View File

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

11
unison-cli/src/Unison/Codebase/Editor/Output.hs
View File

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

31
unison-cli/src/Unison/Codebase/Transcript/Parser.hs
View File

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

15
unison-cli/src/Unison/CommandLine/InputPatterns.hs
View File

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

113
unison-cli/src/Unison/CommandLine/OutputMessages.hs
View File

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

2
unison-cli/src/Unison/LSP/FileAnalysis.hs
View File

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

67
unison-cli/src/Unison/LSP/FileAnalysis/UnusedBindings.hs
View File

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

2
unison-cli/src/Unison/LSP/Types.hs
View File

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

28
unison-cli/tests/Unison/Test/LSP.hs
View File

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

1
unison-cli/unison-cli.cabal
View File

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

9
unison-share-api/src/Unison/Server/Orphans.hs
View File

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

7
unison-src/transcripts-manual/gen-racket-libs.md
View File

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

26
unison-src/transcripts-manual/gen-racket-libs.output.md
View File

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

2
unison-src/transcripts-round-trip/reparses-with-same-hash.u
View File

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

2
unison-src/transcripts/ability-order-doesnt-affect-hash.output.md
View File

@ -45,7 +45,5 @@ scratch/main> names term1
Term
Hash: #8hum58rlih
Names: term1 term2
Tip: Use `names.global` to see more results.
```

8
unison-src/transcripts/deep-names.output.md
View File

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

4
unison-src/transcripts/empty-namespaces.output.md
View File

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

2
unison-src/transcripts/error-messages.output.md
View File

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

@ -0,0 +1,3 @@
``` api:error
DELETE /something/important
```

5
unison-src/transcripts/errors/no-abspath-in-ucm.md Normal file
View 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
```

7
unison-src/transcripts/find-command.md
View File

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

23
unison-src/transcripts/find-command.output.md
View File

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

122
unison-src/transcripts/help.output.md
View File

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

2
unison-src/transcripts/merge.output.md
View File

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

13
unison-src/transcripts/names.md
View File

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

47
unison-src/transcripts/names.output.md
View File

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

2
unison-src/transcripts/suffixes.output.md
View File

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

6
unison-src/transcripts/unique-type-churn.output.md
View File

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

2
unison-src/transcripts/update-ignores-lib-namespace.output.md
View File

@ -62,7 +62,5 @@ scratch/main> names foo
Term
Hash: #9ntnotdp87
Names: foo
Tip: Use `names.global` to see more results.
```

5
unison-src/transcripts/update-on-conflict.output.md
View File

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

4
unison-src/transcripts/update-suffixifies-properly.output.md
View File

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

4
unison-src/transcripts/update-term-with-dependent-to-different-type.output.md
View File

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

4
unison-src/transcripts/update-test-watch-roundtrip.output.md
View File

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

4
unison-src/transcripts/update-type-delete-constructor-with-dependent.output.md
View File

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

4
unison-src/transcripts/update-type-delete-record-field.output.md
View File

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

4
unison-src/transcripts/update-type-with-dependent-term.output.md
View File

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

4
unison-src/transcripts/update-type-with-dependent-type-to-different-kind.output.md
View File

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

2
unison-syntax/package.yaml
View File

@ -9,7 +9,9 @@ dependencies:
- bytes
- containers
- cryptonite
- deriving-compat
- extra
- free
- lens
- megaparsec
- mtl

25
unison-syntax/src/Unison/Parser/Ann.hs
View File

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

1487
unison-syntax/src/Unison/Syntax/Lexer.hs
View File

File diff suppressed because it is too large Load Diff

10
unison-syntax/src/Unison/Syntax/Lexer/Token.hs
View File

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

File diff suppressed because it is too large Load Diff

103
unison-syntax/src/Unison/Syntax/Parser.hs
View File

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

6
unison-syntax/test/Main.hs
View File

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

7
unison-syntax/unison-syntax.cabal
View File

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