From 4fda3cc3ec63318d85c0babab8aea7fe512cd6d3 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 19 Oct 2022 11:19:04 -0400 Subject: [PATCH 01/41] delete unused Backticks lexeme --- unison-syntax/src/Unison/Syntax/Lexer.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 68f6ded234..1467cb3aee 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} module Unison.Syntax.Lexer ( Token (..), @@ -128,7 +124,6 @@ data Lexeme | Reserved String -- reserved tokens such as `{`, `(`, `type`, `of`, etc | Textual String -- text literals, `"foo bar"` | Character Char -- character literals, `?X` - | Backticks String (Maybe ShortHash) -- an identifier in backticks | WordyId String (Maybe ShortHash) -- a (non-infix) identifier | SymbolyId String (Maybe ShortHash) -- an infix identifier | Blank String -- a typed hole or placeholder @@ -1373,8 +1368,6 @@ instance P.VisualStream [Token Lexeme] where case showEscapeChar c of Just c -> "?\\" ++ [c] Nothing -> '?' : [c] - pretty (Backticks n h) = - '`' : n ++ (toList h >>= SH.toString) ++ ['`'] pretty (WordyId n h) = n ++ (toList h >>= SH.toString) pretty (SymbolyId n h) = n ++ (toList h >>= SH.toString) pretty (Blank s) = "_" ++ s From 90f515e48d40926cfbe3beb7309ab0e9c975dabd Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 19 Oct 2022 13:51:01 -0400 Subject: [PATCH 02/41] Require backticks to parse a symbol with a "." anywhere in it --- .../src/Unison/Syntax/TypeParser.hs | 2 +- unison-syntax/package.yaml | 1 + unison-syntax/src/Unison/Syntax/Lexer.hs | 124 ++++++++++++------ unison-syntax/test/Main.hs | 7 +- unison-syntax/unison-syntax.cabal | 2 + 5 files changed, 92 insertions(+), 44 deletions(-) diff --git a/parser-typechecker/src/Unison/Syntax/TypeParser.hs b/parser-typechecker/src/Unison/Syntax/TypeParser.hs index 04a769909d..6fe706baf0 100644 --- a/parser-typechecker/src/Unison/Syntax/TypeParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TypeParser.hs @@ -112,6 +112,6 @@ forall :: Var v => TypeP v -> TypeP v forall rec = do kw <- reserved "forall" <|> reserved "∀" vars <- fmap (fmap L.payload) . some $ prefixDefinitionName - _ <- matchToken $ L.SymbolyId "." Nothing + _ <- reserved "." t <- rec pure $ Type.foralls (ann kw <> ann t) vars t diff --git a/unison-syntax/package.yaml b/unison-syntax/package.yaml index 59b67674bb..693a7ec53b 100644 --- a/unison-syntax/package.yaml +++ b/unison-syntax/package.yaml @@ -12,6 +12,7 @@ dependencies: - lens - megaparsec - mtl + - parser-combinators - text - unison-core1 - unison-prelude diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 1467cb3aee..cf42c62757 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -33,6 +33,7 @@ module Unison.Syntax.Lexer where import Control.Lens.TH (makePrisms) +import qualified Control.Monad.Combinators as Monad import qualified Control.Monad.State as S import Data.Char import Data.List @@ -314,7 +315,7 @@ lexemes :: P [Token Lexeme] lexemes = lexemes' eof where eof :: P [Token Lexeme] - eof = P.try $ do + eof = P.try do p <- P.eof >> pos n <- maybe 0 (const 1) <$> S.gets opening l <- S.gets layout @@ -343,11 +344,15 @@ lexemes' eof = tl <- eof pure $ hd <> tl where + toks :: P [Token Lexeme] toks = - doc2 <|> doc <|> token numeric <|> token character <|> reserved - <|> token symbolyId + doc2 + <|> doc + <|> token numeric + <|> token character + <|> reserved <|> token blank - <|> token wordyId + <|> token identifier <|> (asum . map token) [semi, textual, hash] wordySep c = isSpace c || not (wordyIdChar c) @@ -434,7 +439,7 @@ lexemes' eof = (tok (Reserved <$> lit "@") <+> (CP.space *> annotations)) ) where - annotation = tok (symbolyId <|> wordyId) <|> expr <* CP.space + annotation = tok identifier <|> expr <* CP.space annotations = join <$> P.some (wrap "syntax.docEmbedAnnotation" annotation) src' name atName = wrap name $ do @@ -460,15 +465,15 @@ lexemes' eof = typeLink = wrap "syntax.docEmbedTypeLink" $ do _ <- typeOrAbilityAlt wordyKw <* CP.space - tok (symbolyId <|> wordyId) <* CP.space + tok identifier <* CP.space termLink = wrap "syntax.docEmbedTermLink" $ - tok (symbolyId <|> wordyId) <* CP.space + tok identifier <* CP.space signatureLink = wrap "syntax.docEmbedSignatureLink" $ - tok (symbolyId <|> wordyId) <* CP.space + tok identifier <* CP.space groupy closing p = do (start, p, stop) <- positioned p @@ -488,7 +493,7 @@ lexemes' eof = verbatim = P.label "code (examples: ''**unformatted**'', '''_words_''')" $ do (start, txt, stop) <- positioned $ do - quotes <- lit "''" <+> many (P.satisfy (== '\'')) + quotes <- lit "''" <+> P.takeWhileP Nothing (== '\'') P.someTill P.anySingle (lit quotes) if all isSpace $ takeWhile (/= '\n') txt then @@ -540,7 +545,7 @@ lexemes' eof = evalUnison = wrap "syntax.docEval" $ do -- commit after seeing that ``` is on its own line fence <- P.try $ do - fence <- lit "```" <+> P.many (P.satisfy (== '`')) + fence <- lit "```" <+> P.takeWhileP Nothing (== '`') b <- all isSpace <$> P.lookAhead (P.takeWhileP Nothing (/= '\n')) fence <$ guard b CP.space @@ -550,7 +555,7 @@ lexemes' eof = exampleBlock = wrap "syntax.docExampleBlock" $ do void $ lit "@typecheck" <* CP.space - fence <- lit "```" <+> P.many (P.satisfy (== '`')) + fence <- lit "```" <+> P.takeWhileP Nothing (== '`') local (\env -> env {inLayout = True, opening = Just "docExampleBlock"}) (restoreStack "docExampleBlock" $ lexemes' ([] <$ lit fence)) @@ -568,11 +573,11 @@ lexemes' eof = other = wrap "syntax.docCodeBlock" $ do column <- (\x -> x - 1) . toInteger . P.unPos <$> LP.indentLevel let tabWidth = toInteger . P.unPos $ P.defaultTabWidth - fence <- lit "```" <+> P.many (P.satisfy (== '`')) + fence <- lit "```" <+> P.takeWhileP Nothing (== '`') name <- - P.many (P.satisfy nonNewlineSpace) + P.takeWhileP Nothing nonNewlineSpace *> tok (Textual <$> P.takeWhile1P Nothing (not . isSpace)) - <* P.many (P.satisfy nonNewlineSpace) + <* P.takeWhileP Nothing nonNewlineSpace _ <- void CP.eol verbatim <- tok $ @@ -753,13 +758,13 @@ lexemes' eof = ch = (":]" <$ lit "\\:]") <|> ("@" <$ lit "\\@") <|> (pure <$> P.anySingle) txt = tok (Textual . join <$> P.manyTill ch (P.lookAhead sep)) sep = void at <|> void close - ref = at *> (tok wordyId <|> tok symbolyId <|> docTyp) + ref = at *> (tok identifier <|> docTyp) atk = (ref <|> docTyp) <+> body docTyp = do _ <- lit "[" typ <- tok (P.manyTill P.anySingle (P.lookAhead (lit "]"))) _ <- lit "]" *> CP.space - t <- tok wordyId <|> tok symbolyId + t <- tok identifier pure $ (fmap Reserved <$> typ) <> t blank = @@ -774,50 +779,78 @@ lexemes' eof = character = Character <$> (char '?' *> (spEsc <|> LP.charLiteral)) where spEsc = P.try (char '\\' *> char 's' $> ' ') - wordyId :: P Lexeme - wordyId = P.label wordyMsg . P.try $ do - dot <- P.optional (lit ".") - segs <- P.sepBy1 wordyIdSeg (P.try (char '.' <* P.lookAhead (P.satisfy wordyIdChar))) - shorthash <- P.optional shorthash - pure $ WordyId (fromMaybe "" dot <> intercalate "." segs) shorthash - where - wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" - symbolyId :: P Lexeme - symbolyId = P.label symbolMsg . P.try $ do - dot <- P.optional (lit ".") - segs <- P.optional segs - shorthash <- P.optional shorthash - case (dot, segs) of - (_, Just segs) -> pure $ SymbolyId (fromMaybe "" dot <> segs) shorthash - -- a single . or .#somehash is parsed as a symboly id - (Just dot, Nothing) -> pure $ SymbolyId dot shorthash - (Nothing, Nothing) -> fail symbolMsg + -- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is + -- symboly (comprised of only symbols) or wordy (comprised of only alphanums). + -- + -- Examples: + -- + -- foo + -- .foo.++.doc + -- `.`.`..` (This is a two-segment identifier without a leading dot: "." then "..") + identifier :: P Lexeme + identifier = do + identifier_ <&> \case + (False, ident, shorthash) -> WordyId ident shorthash + (True, ident, shorthash) -> SymbolyId ident shorthash + + -- internal identifier helper that returns (isSymboly, identifier, shorthash) + identifier_ :: P (Bool, String, Maybe ShortHash) + identifier_ = do + P.label "identifier (ex: abba1, snake_case, .foo.++#xyz, or 🌻)" do + P.try do + emptyOrDot <- fromMaybe "" <$> P.optional (lit ".") + segments <- Monad.sepBy1 (symbolyIdSeg <|> wordyIdSeg) (lit ".") + shorthash <- P.optional shorthash + pure (isSymbolyId (last segments), emptyOrDot ++ concat (intersperse "." segments), shorthash) where - segs = symbolyIdSeg <|> (wordyIdSeg <+> lit "." <+> segs) + isSymbolyId :: String -> Bool + isSymbolyId = \case + c : _ -> not (wordyIdStartChar c) + _ -> False - symbolMsg = "operator (examples: +, Float./, List.++#xyz)" + -- Like 'identifier', but the returned lexeme is always a WordyId, never SymbolyId (i.e. the last segment is wordy). + wordyId :: P Lexeme + wordyId = do + start <- pos + (isSymboly, ident, shorthash) <- identifier_ + if isSymboly + then do + stop <- pos + P.customFailure (Token (InvalidSymbolyId ident) start stop) + else pure (WordyId ident shorthash) symbolyIdSeg :: P String symbolyIdSeg = do start <- pos - id <- P.takeWhile1P (Just symbolMsg) symbolyIdChar + id <- + let unescaped = P.takeWhile1P (Just symbolMsg) symbolyIdChar + escaped = do + _ <- lit "`" + s <- P.takeWhile1P (Just symbolMsg) escapedSymbolyIdChar + _ <- lit "`" + pure ("`" ++ s ++ "`") + in unescaped <|> escaped when (Set.member id reservedOperators) $ do stop <- pos P.customFailure (Token (ReservedSymbolyId id) start stop) pure id + where + symbolMsg = "operator (examples: +, Float./, List.++#xyz)" wordyIdSeg :: P String -- wordyIdSeg = litSeg <|> (P.try do -- todo wordyIdSeg = P.try $ do start <- pos ch <- P.satisfy wordyIdStartChar - rest <- P.many (P.satisfy wordyIdChar) + rest <- P.takeWhileP (Just wordyMsg) wordyIdChar let word = ch : rest when (Set.member word keywords) $ do stop <- pos P.customFailure (Token (ReservedWordyId word) start stop) pure (ch : rest) + where + wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" {- -- ``an-identifier-with-dashes`` @@ -899,7 +932,8 @@ lexemes' eof = <|> layoutKeywords where keywords = - symbolyKw ":" + symbolyKw "." + <|> symbolyKw ":" <|> symbolyKw "@" <|> symbolyKw "||" <|> symbolyKw "|" @@ -1250,15 +1284,23 @@ wordyId' s = case wordyId0 s of -- Returns either an error or an id and a remainder symbolyId0 :: String -> Either Err (String, String) -symbolyId0 s = span' symbolyIdChar s $ \case +symbolyId0 s = span' symbolyIdChar s \case (id@(_ : _), rem) | not (Set.member id reservedOperators) -> Right (id, rem) (id, _rem) -> Left (InvalidSymbolyId id) symbolyIdChar :: Char -> Bool symbolyIdChar ch = Set.member ch symbolyIdChars +-- | The set of characters allowed in an unescaped symboly identifier. symbolyIdChars :: Set Char -symbolyIdChars = Set.fromList "!$%^&*-=+<>.~\\/|:" +symbolyIdChars = Set.fromList "!$%^&*-=+<>~\\/|:" + +escapedSymbolyIdChar :: Char -> Bool +escapedSymbolyIdChar = (`Set.member` escapedSymbolyIdChars) + +-- | The set of characters allowed in an escaped symboly identifier. +escapedSymbolyIdChars :: Set Char +escapedSymbolyIdChars = Set.insert '.' symbolyIdChars keywords :: Set String keywords = diff --git a/unison-syntax/test/Main.hs b/unison-syntax/test/Main.hs index 1efd851aaa..191424141a 100644 --- a/unison-syntax/test/Main.hs +++ b/unison-syntax/test/Main.hs @@ -73,13 +73,16 @@ test = t "0:Int" [Numeric "0", Reserved ":", simpleWordyId "Int"], t "0 : Int" [Numeric "0", Reserved ":", simpleWordyId "Int"], t - ".Foo Foo . .foo.bar.baz" + ".Foo Foo `.` .foo.bar.baz" [ simpleWordyId ".Foo", simpleWordyId "Foo", - simpleSymbolyId ".", + simpleSymbolyId "`.`", simpleWordyId ".foo.bar.baz" ], t ".Foo.Bar.+" [simpleSymbolyId ".Foo.Bar.+"], + t ".Foo.++.+" [simpleSymbolyId ".Foo.++.+"], + t ".Foo.`++`.+" [simpleSymbolyId ".Foo.`++`.+"], + t ".Foo.`+.+`.+" [simpleSymbolyId ".Foo.`+.+`.+"], -- idents with hashes t "foo#bar" [WordyId "foo" (Just (ShortHash.unsafeFromText "#bar"))], t "+#bar" [SymbolyId "+" (Just (ShortHash.unsafeFromText "#bar"))], diff --git a/unison-syntax/unison-syntax.cabal b/unison-syntax/unison-syntax.cabal index af96209f8d..e062e0bbce 100644 --- a/unison-syntax/unison-syntax.cabal +++ b/unison-syntax/unison-syntax.cabal @@ -61,6 +61,7 @@ library , lens , megaparsec , mtl + , parser-combinators , text , unison-core1 , unison-prelude @@ -114,6 +115,7 @@ test-suite syntax-tests , lens , megaparsec , mtl + , parser-combinators , text , unison-core1 , unison-prelude From 9cea1f7a34051236578d097e2fcb525775fe5b34 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 19 Oct 2022 14:19:37 -0400 Subject: [PATCH 03/41] move some lexers to the top level --- unison-syntax/src/Unison/Syntax/Lexer.hs | 188 +++++++++++------------ 1 file changed, 91 insertions(+), 97 deletions(-) diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index cf42c62757..bac4cb77e2 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -352,11 +352,10 @@ lexemes' eof = <|> token character <|> reserved <|> token blank - <|> token identifier + <|> token identifierP <|> (asum . map token) [semi, textual, hash] wordySep c = isSpace c || not (wordyIdChar c) - positioned p = do start <- pos; a <- p; stop <- pos; pure (start, a, stop) tok :: P a -> P [Token a] tok p = do @@ -439,7 +438,7 @@ lexemes' eof = (tok (Reserved <$> lit "@") <+> (CP.space *> annotations)) ) where - annotation = tok identifier <|> expr <* CP.space + annotation = tok identifierP <|> expr <* CP.space annotations = join <$> P.some (wrap "syntax.docEmbedAnnotation" annotation) src' name atName = wrap name $ do @@ -465,15 +464,15 @@ lexemes' eof = typeLink = wrap "syntax.docEmbedTypeLink" $ do _ <- typeOrAbilityAlt wordyKw <* CP.space - tok identifier <* CP.space + tok identifierP <* CP.space termLink = wrap "syntax.docEmbedTermLink" $ - tok identifier <* CP.space + tok identifierP <* CP.space signatureLink = wrap "syntax.docEmbedSignatureLink" $ - tok identifier <* CP.space + tok identifierP <* CP.space groupy closing p = do (start, p, stop) <- positioned p @@ -758,18 +757,18 @@ lexemes' eof = ch = (":]" <$ lit "\\:]") <|> ("@" <$ lit "\\@") <|> (pure <$> P.anySingle) txt = tok (Textual . join <$> P.manyTill ch (P.lookAhead sep)) sep = void at <|> void close - ref = at *> (tok identifier <|> docTyp) + ref = at *> (tok identifierP <|> docTyp) atk = (ref <|> docTyp) <+> body docTyp = do _ <- lit "[" typ <- tok (P.manyTill P.anySingle (P.lookAhead (lit "]"))) _ <- lit "]" *> CP.space - t <- tok identifier + t <- tok identifierP pure $ (fmap Reserved <$> typ) <> t blank = separated wordySep $ - char '_' *> P.optional wordyIdSeg <&> (Blank . fromMaybe "") + char '_' *> P.optional wordyIdSegP <&> (Blank . fromMaybe "") semi = char ';' $> Semi False textual = Textual <$> quoted @@ -780,99 +779,14 @@ lexemes' eof = where spEsc = P.try (char '\\' *> char 's' $> ' ') - -- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is - -- symboly (comprised of only symbols) or wordy (comprised of only alphanums). - -- - -- Examples: - -- - -- foo - -- .foo.++.doc - -- `.`.`..` (This is a two-segment identifier without a leading dot: "." then "..") - identifier :: P Lexeme - identifier = do - identifier_ <&> \case - (False, ident, shorthash) -> WordyId ident shorthash - (True, ident, shorthash) -> SymbolyId ident shorthash - - -- internal identifier helper that returns (isSymboly, identifier, shorthash) - identifier_ :: P (Bool, String, Maybe ShortHash) - identifier_ = do - P.label "identifier (ex: abba1, snake_case, .foo.++#xyz, or 🌻)" do - P.try do - emptyOrDot <- fromMaybe "" <$> P.optional (lit ".") - segments <- Monad.sepBy1 (symbolyIdSeg <|> wordyIdSeg) (lit ".") - shorthash <- P.optional shorthash - pure (isSymbolyId (last segments), emptyOrDot ++ concat (intersperse "." segments), shorthash) - where - isSymbolyId :: String -> Bool - isSymbolyId = \case - c : _ -> not (wordyIdStartChar c) - _ -> False - -- Like 'identifier', but the returned lexeme is always a WordyId, never SymbolyId (i.e. the last segment is wordy). wordyId :: P Lexeme wordyId = do - start <- pos - (isSymboly, ident, shorthash) <- identifier_ + (start, (isSymboly, ident, shorthash), stop) <- positioned identifierP_ if isSymboly - then do - stop <- pos - P.customFailure (Token (InvalidSymbolyId ident) start stop) + then P.customFailure (Token (InvalidSymbolyId ident) start stop) else pure (WordyId ident shorthash) - symbolyIdSeg :: P String - symbolyIdSeg = do - start <- pos - id <- - let unescaped = P.takeWhile1P (Just symbolMsg) symbolyIdChar - escaped = do - _ <- lit "`" - s <- P.takeWhile1P (Just symbolMsg) escapedSymbolyIdChar - _ <- lit "`" - pure ("`" ++ s ++ "`") - in unescaped <|> escaped - when (Set.member id reservedOperators) $ do - stop <- pos - P.customFailure (Token (ReservedSymbolyId id) start stop) - pure id - where - symbolMsg = "operator (examples: +, Float./, List.++#xyz)" - - wordyIdSeg :: P String - -- wordyIdSeg = litSeg <|> (P.try do -- todo - wordyIdSeg = P.try $ do - start <- pos - ch <- P.satisfy wordyIdStartChar - rest <- P.takeWhileP (Just wordyMsg) wordyIdChar - let word = ch : rest - when (Set.member word keywords) $ do - stop <- pos - P.customFailure (Token (ReservedWordyId word) start stop) - pure (ch : rest) - where - wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" - - {- - -- ``an-identifier-with-dashes`` - -- ```an identifier with spaces``` - litSeg :: P String - litSeg = P.try $ do - ticks1 <- lit "``" - ticks2 <- P.many (char '`') - let ticks = ticks1 <> ticks2 - let escTick = lit "\\`" $> '`' - P.manyTill (LP.charLiteral <|> escTick) (lit ticks) - -} - - hashMsg = "hash (ex: #af3sj3)" - shorthash = P.label hashMsg $ do - P.lookAhead (char '#') - -- `foo#xyz` should parse - (start, potentialHash, _) <- positioned $ P.takeWhile1P (Just hashMsg) (\ch -> not (isSep ch) && ch /= '`') - case SH.fromString potentialHash of - Nothing -> err start (InvalidShortHash potentialHash) - Just sh -> pure sh - separated :: (Char -> Bool) -> P a -> P a separated ok p = P.try $ p <* P.lookAhead (void (P.satisfy ok) <|> P.eof) @@ -917,7 +831,7 @@ lexemes' eof = num sign n = Numeric (fromMaybe "" sign <> show n) sign = P.optional (lit "+" <|> lit "-") - hash = Hash <$> P.try shorthash + hash = Hash <$> P.try shorthashP reserved :: P [Token Lexeme] reserved = @@ -1104,6 +1018,86 @@ lexemes' eof = findClose _ [] = Nothing findClose s ((h, _) : tl) = if h `elem` s then Just (h, 1) else fmap (1 +) <$> findClose s tl +-- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is +-- symboly (comprised of only symbols) or wordy (comprised of only alphanums). +-- +-- Examples: +-- +-- foo +-- .foo.++.doc +-- `.`.`..` (This is a two-segment identifier without a leading dot: "." then "..") +identifierP :: P Lexeme +identifierP = do + identifierP_ <&> \case + (False, ident, shorthash) -> WordyId ident shorthash + (True, ident, shorthash) -> SymbolyId ident shorthash + +-- internal identifier helper that returns (isSymboly, identifier, shorthash) +identifierP_ :: P (Bool, String, Maybe ShortHash) +identifierP_ = do + P.label "identifier (ex: abba1, snake_case, .foo.++#xyz, or 🌻)" do + P.try do + emptyOrDot <- fromMaybe "" <$> P.optional (lit ".") + segments <- Monad.sepBy1 (symbolyIdSegP <|> wordyIdSegP) (lit ".") + shorthash <- P.optional shorthashP + pure (isSymbolyId (last segments), emptyOrDot ++ concat (intersperse "." segments), shorthash) + where + isSymbolyId :: String -> Bool + isSymbolyId = \case + c : _ -> not (wordyIdStartChar c) + _ -> False + +symbolyIdSegP :: P String +symbolyIdSegP = do + start <- pos + id <- + let unescaped = P.takeWhile1P (Just symbolMsg) symbolyIdChar + escaped = do + _ <- lit "`" + s <- P.takeWhile1P (Just symbolMsg) escapedSymbolyIdChar + _ <- lit "`" + pure ("`" ++ s ++ "`") + in unescaped <|> escaped + when (Set.member id reservedOperators) $ do + stop <- pos + P.customFailure (Token (ReservedSymbolyId id) start stop) + pure id + where + symbolMsg = "operator (examples: +, Float./, List.++#xyz)" + +wordyIdSegP :: P String +wordyIdSegP = + P.try do + start <- pos + ch <- P.satisfy wordyIdStartChar + rest <- P.takeWhileP (Just wordyMsg) wordyIdChar + let word = ch : rest + when (Set.member word keywords) $ do + stop <- pos + P.customFailure (Token (ReservedWordyId word) start stop) + pure (ch : rest) + where + wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" + +shorthashP :: P ShortHash +shorthashP = + P.label hashMsg do + P.lookAhead (char '#') + -- `foo#xyz` should parse + (start, potentialHash, _) <- positioned $ P.takeWhile1P (Just hashMsg) (\ch -> not (isSep ch) && ch /= '`') + case SH.fromString potentialHash of + Nothing -> err start (InvalidShortHash potentialHash) + Just sh -> pure sh + where + hashMsg = "hash (ex: #af3sj3)" + +positioned :: P a -> P (Pos, a, Pos) +positioned p = do + start <- pos + a <- p + stop <- pos + pure (start, a, stop) + simpleWordyId :: String -> Lexeme simpleWordyId = flip WordyId Nothing From 64206020c511ed37e124289379fd65951879331a Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 20 Oct 2022 10:21:10 -0400 Subject: [PATCH 04/41] begin fixing type errors --- unison-syntax/package.yaml | 1 + unison-syntax/src/Unison/Syntax/Identifier.hs | 51 ++++++++ unison-syntax/src/Unison/Syntax/Lexer.hs | 118 +++++++++++------- unison-syntax/src/Unison/Syntax/Parser.hs | 41 ++---- unison-syntax/unison-syntax.cabal | 3 + 5 files changed, 138 insertions(+), 76 deletions(-) create mode 100644 unison-syntax/src/Unison/Syntax/Identifier.hs diff --git a/unison-syntax/package.yaml b/unison-syntax/package.yaml index 693a7ec53b..41665800f8 100644 --- a/unison-syntax/package.yaml +++ b/unison-syntax/package.yaml @@ -14,6 +14,7 @@ dependencies: - mtl - parser-combinators - text + - text-builder - unison-core1 - unison-prelude - unison-pretty-printer diff --git a/unison-syntax/src/Unison/Syntax/Identifier.hs b/unison-syntax/src/Unison/Syntax/Identifier.hs new file mode 100644 index 0000000000..2cea90b119 --- /dev/null +++ b/unison-syntax/src/Unison/Syntax/Identifier.hs @@ -0,0 +1,51 @@ +-- | An identifer, as seen by the default syntax. +module Unison.Syntax.Identifier + ( Identifier (..), + + -- * Basic manipulation + appendSegment, + + -- * String conversions + toText, + ) +where + +import qualified Data.List.NonEmpty as List (NonEmpty) +import qualified Data.List.NonEmpty as List.NonEmpty +import qualified Data.Text as Text +import qualified Text.Builder +import Unison.Prelude +import Unison.Util.Alphabetical (Alphabetical (..)) + +-- | An identifier is a non-empty list of segments, plus a bit tracking whether or not there was a leading dot. +data Identifier = Identifier + { leadingDot :: Bool, + segments :: List.NonEmpty Text + } + deriving stock (Eq, Show, Ord) + +instance Alphabetical Identifier where + compareAlphabetical x y = + compareAlphabetical (toText x) (toText y) + +-- | Append a segment to an identifier. +appendSegment :: Identifier -> Text -> Identifier +appendSegment Identifier {leadingDot, segments} seg = + Identifier + { leadingDot, + segments = segments <> (seg List.NonEmpty.:| []) + } + +-- | Render an identifier as text, escaping all segments that contain '.' +toText :: Identifier -> Text +toText Identifier {leadingDot, segments} = + Text.Builder.run (foldl' (\xs x -> xs <> segmentToText x) (if leadingDot then "." else mempty) segments) + where + segmentToText :: Text -> Text.Builder.Builder + segmentToText seg = + if isJust (Text.find (== '.') seg) + then backtick <> Text.Builder.text seg <> backtick + else Text.Builder.text seg + backtick :: Text.Builder.Builder + backtick = + "`" diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index bac4cb77e2..bbd66a94a1 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -33,7 +33,7 @@ module Unison.Syntax.Lexer where import Control.Lens.TH (makePrisms) -import qualified Control.Monad.Combinators as Monad +import qualified Control.Monad.Combinators.NonEmpty as Monad import qualified Control.Monad.State as S import Data.Char import Data.List @@ -48,10 +48,13 @@ import qualified Text.Megaparsec.Char as CP import qualified Text.Megaparsec.Char.Lexer as LP import qualified Text.Megaparsec.Error as EP import qualified Text.Megaparsec.Internal as PI +import qualified Unison.HashQualified' as HQ' import Unison.Lexer.Pos (Column, Line, Pos (Pos), column, line) import Unison.Prelude import Unison.ShortHash (ShortHash) import qualified Unison.ShortHash as SH +import Unison.Syntax.Identifier (Identifier (..)) +import qualified Unison.Syntax.Identifier as Identifier import qualified Unison.Util.Bytes as Bytes import Unison.Util.Monoid (intercalateMap) @@ -112,7 +115,7 @@ data Err | Opaque String -- Catch-all failure type, generally these will be -- automatically generated errors coming from megaparsec -- Try to avoid this for common errors a user is likely to see. - deriving (Eq, Ord, Show) -- richer algebra + deriving stock (Eq, Ord, Show) -- richer algebra -- Design principle: -- `[Lexeme]` should be sufficient information for parsing without @@ -125,14 +128,14 @@ data Lexeme | Reserved String -- reserved tokens such as `{`, `(`, `type`, `of`, etc | Textual String -- text literals, `"foo bar"` | Character Char -- character literals, `?X` - | WordyId String (Maybe ShortHash) -- a (non-infix) identifier - | SymbolyId String (Maybe ShortHash) -- an infix identifier + | WordyId (HQ'.HashQualified Identifier) -- a (non-infix) identifier. invariant: last segment is wordy + | SymbolyId (HQ'.HashQualified Identifier) -- an infix identifier. invariant: last segment is symboly | Blank String -- a typed hole or placeholder | Numeric String -- numeric literals, left unparsed | Bytes Bytes.Bytes -- bytes literals | Hash ShortHash -- hash literals | Err Err - deriving (Eq, Show, Ord) + deriving stock (Eq, Show, Ord) type IsVirtual = Bool -- is it a virtual semi or an actual semi? @@ -298,7 +301,14 @@ lexer0' scope rem = | notLayout t1 && touches t1 t2 && isSigned num = t1 : Token - (SymbolyId (take 1 num) Nothing) + ( SymbolyId + ( HQ'.fromName + Identifier + { leadingDot = False, + segments = Text.pack (take 1 num) Nel.:| [] + } + ) + ) (start t2) (inc $ start t2) : Token (Numeric (drop 1 num)) (inc $ start t2) (end t2) : @@ -352,7 +362,7 @@ lexemes' eof = <|> token character <|> reserved <|> token blank - <|> token identifierP + <|> token identifierLexemeP <|> (asum . map token) [semi, textual, hash] wordySep c = isSpace c || not (wordyIdChar c) @@ -377,10 +387,12 @@ lexemes' eof = -- ability Foo where => ability Foo where tn <- subsequentTypeName pure $ case (tn, docToks) of - (Just (WordyId tname _), ht : _) + (Just (WordyId ident), ht : _) | isTopLevel -> startToks - <> [WordyId (tname <> ".doc") Nothing <$ ht, Open "=" <$ ht] + <> [ WordyId (HQ'.fromName (Identifier.appendSegment (HQ'.toName ident) "doc")) <$ ht, + Open "=" <$ ht + ] <> docToks0 <> [Close <$ last docToks] <> endToks @@ -394,7 +406,12 @@ lexemes' eof = let modifier = typeModifiersAlt lit' let typeOrAbility' = typeOrAbilityAlt wordyKw _ <- modifier <* typeOrAbility' *> sp - wordyId + (start, ident, stop) <- positioned identifierP + if isSymbolyIdentifier ident + then + P.customFailure + (Token (InvalidSymbolyId (Text.unpack (HQ'.toTextWith Identifier.toText ident))) start stop) + else pure (WordyId ident) ignore _ _ _ = [] body = join <$> P.many (sectionElem <* CP.space) sectionElem = section <|> fencedBlock <|> list <|> paragraph @@ -438,7 +455,7 @@ lexemes' eof = (tok (Reserved <$> lit "@") <+> (CP.space *> annotations)) ) where - annotation = tok identifierP <|> expr <* CP.space + annotation = tok identifierLexemeP <|> expr <* CP.space annotations = join <$> P.some (wrap "syntax.docEmbedAnnotation" annotation) src' name atName = wrap name $ do @@ -464,15 +481,15 @@ lexemes' eof = typeLink = wrap "syntax.docEmbedTypeLink" $ do _ <- typeOrAbilityAlt wordyKw <* CP.space - tok identifierP <* CP.space + tok identifierLexemeP <* CP.space termLink = wrap "syntax.docEmbedTermLink" $ - tok identifierP <* CP.space + tok identifierLexemeP <* CP.space signatureLink = wrap "syntax.docEmbedSignatureLink" $ - tok identifierP <* CP.space + tok identifierLexemeP <* CP.space groupy closing p = do (start, p, stop) <- positioned p @@ -757,13 +774,13 @@ lexemes' eof = ch = (":]" <$ lit "\\:]") <|> ("@" <$ lit "\\@") <|> (pure <$> P.anySingle) txt = tok (Textual . join <$> P.manyTill ch (P.lookAhead sep)) sep = void at <|> void close - ref = at *> (tok identifierP <|> docTyp) + ref = at *> (tok identifierLexemeP <|> docTyp) atk = (ref <|> docTyp) <+> body docTyp = do _ <- lit "[" typ <- tok (P.manyTill P.anySingle (P.lookAhead (lit "]"))) _ <- lit "]" *> CP.space - t <- tok identifierP + t <- tok identifierLexemeP pure $ (fmap Reserved <$> typ) <> t blank = @@ -779,14 +796,6 @@ lexemes' eof = where spEsc = P.try (char '\\' *> char 's' $> ' ') - -- Like 'identifier', but the returned lexeme is always a WordyId, never SymbolyId (i.e. the last segment is wordy). - wordyId :: P Lexeme - wordyId = do - (start, (isSymboly, ident, shorthash), stop) <- positioned identifierP_ - if isSymboly - then P.customFailure (Token (InvalidSymbolyId ident) start stop) - else pure (WordyId ident shorthash) - separated :: (Char -> Bool) -> P a -> P a separated ok p = P.try $ p <* P.lookAhead (void (P.satisfy ok) <|> P.eof) @@ -1026,26 +1035,39 @@ lexemes' eof = -- foo -- .foo.++.doc -- `.`.`..` (This is a two-segment identifier without a leading dot: "." then "..") -identifierP :: P Lexeme +identifierP :: P (HQ'.HashQualified Identifier) identifierP = do - identifierP_ <&> \case - (False, ident, shorthash) -> WordyId ident shorthash - (True, ident, shorthash) -> SymbolyId ident shorthash - --- internal identifier helper that returns (isSymboly, identifier, shorthash) -identifierP_ :: P (Bool, String, Maybe ShortHash) -identifierP_ = do + -- identifierP_ <&> \case + -- (False, ident, shorthash) -> WordyId ident shorthash + -- (True, ident, shorthash) -> SymbolyId ident shorthash P.label "identifier (ex: abba1, snake_case, .foo.++#xyz, or 🌻)" do P.try do - emptyOrDot <- fromMaybe "" <$> P.optional (lit ".") - segments <- Monad.sepBy1 (symbolyIdSegP <|> wordyIdSegP) (lit ".") - shorthash <- P.optional shorthashP - pure (isSymbolyId (last segments), emptyOrDot ++ concat (intersperse "." segments), shorthash) - where - isSymbolyId :: String -> Bool - isSymbolyId = \case - c : _ -> not (wordyIdStartChar c) - _ -> False + maybeDot <- P.optional (lit ".") + segments <- fmap Text.pack <$> Monad.sepBy1 (symbolyIdSegP <|> wordyIdSegP) (lit ".") + let ident = Identifier {leadingDot = isJust maybeDot, segments} + P.optional shorthashP <&> \case + Nothing -> HQ'.fromName ident + Just shorthash -> HQ'.HashQualified ident shorthash + +-- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is +-- symboly (comprised of only symbols) or wordy (comprised of only alphanums). +-- +-- Examples: +-- +-- foo +-- .foo.++.doc +-- `.`.`..` (This is a two-segment identifier without a leading dot: "." then "..") +identifierLexemeP :: P Lexeme +identifierLexemeP = do + ident <- identifierP + pure + if isSymbolyIdSeg (Nel.last (Identifier.segments (HQ'.toName ident))) + then SymbolyId ident + else WordyId ident + +isSymbolyIdentifier :: HQ'.HashQualified Identifier -> Bool +isSymbolyIdentifier = + isSymbolyIdSeg . Nel.last . Identifier.segments . HQ'.toName symbolyIdSegP :: P String symbolyIdSegP = do @@ -1056,7 +1078,7 @@ symbolyIdSegP = do _ <- lit "`" s <- P.takeWhile1P (Just symbolMsg) escapedSymbolyIdChar _ <- lit "`" - pure ("`" ++ s ++ "`") + pure s in unescaped <|> escaped when (Set.member id reservedOperators) $ do stop <- pos @@ -1099,10 +1121,10 @@ positioned p = do pure (start, a, stop) simpleWordyId :: String -> Lexeme -simpleWordyId = flip WordyId Nothing +simpleWordyId = undefined -- flip WordyId Nothing simpleSymbolyId :: String -> Lexeme -simpleSymbolyId = flip SymbolyId Nothing +simpleSymbolyId = undefined -- flip SymbolyId Nothing notLayout :: Token Lexeme -> Bool notLayout t = case payload t of @@ -1296,6 +1318,10 @@ escapedSymbolyIdChar = (`Set.member` escapedSymbolyIdChars) escapedSymbolyIdChars :: Set Char escapedSymbolyIdChars = Set.insert '.' symbolyIdChars +isSymbolyIdSeg :: Text -> Bool +isSymbolyIdSeg = + not . wordyIdStartChar . Text.head + keywords :: Set String keywords = Set.fromList @@ -1404,8 +1430,8 @@ instance P.VisualStream [Token Lexeme] where case showEscapeChar c of Just c -> "?\\" ++ [c] Nothing -> '?' : [c] - pretty (WordyId n h) = n ++ (toList h >>= SH.toString) - pretty (SymbolyId n h) = n ++ (toList h >>= SH.toString) + pretty (WordyId n) = Text.unpack (HQ'.toTextWith Identifier.toText n) + pretty (SymbolyId n) = Text.unpack (HQ'.toTextWith Identifier.toText n) pretty (Blank s) = "_" ++ s pretty (Numeric n) = n pretty (Hash sh) = show sh diff --git a/unison-syntax/src/Unison/Syntax/Parser.hs b/unison-syntax/src/Unison/Syntax/Parser.hs index 3dcbc6cd97..336c665b33 100644 --- a/unison-syntax/src/Unison/Syntax/Parser.hs +++ b/unison-syntax/src/Unison/Syntax/Parser.hs @@ -26,6 +26,7 @@ import qualified Unison.ABT as ABT import Unison.ConstructorReference (ConstructorReference) import qualified Unison.Hash as Hash import qualified Unison.HashQualified as HQ +import qualified Unison.HashQualified' as HQ' import qualified Unison.Hashable as Hashable import Unison.Name as Name import qualified Unison.Names.ResolutionResult as Names @@ -34,20 +35,9 @@ import Unison.Parser.Ann (Ann (..)) import Unison.Pattern (Pattern) import qualified Unison.Pattern as Pattern import Unison.Prelude - ( Alternative (many, (<|>)), - Set, - Text, - encodeUtf8, - foldl', - fromMaybe, - isJust, - optional, - trace, - void, - when, - ) import Unison.Reference (Reference) import Unison.Referent (Referent) +import qualified Unison.Syntax.Identifier as Identifier import qualified Unison.Syntax.Lexer as L import Unison.Term (MatchCase (..)) import qualified Unison.UnisonFile.Error as UF @@ -237,13 +227,6 @@ openBlockWith s = void <$> P.satisfy ((L.Open s ==) . L.payload) matchToken :: Ord v => L.Lexeme -> P v (L.Token L.Lexeme) matchToken x = P.satisfy ((==) x . L.payload) --- The package name that refers to the root, literally just `.` -importDotId :: Ord v => P v (L.Token Name) -importDotId = queryToken go - where - go (L.SymbolyId "." Nothing) = Just (Name.unsafeFromString ".") - go _ = Nothing - -- Consume a virtual semicolon semi :: Ord v => P v (L.Token ()) semi = queryToken go @@ -256,9 +239,8 @@ closeBlock :: Ord v => P v (L.Token ()) closeBlock = void <$> matchToken L.Close wordyPatternName :: Var v => P v (L.Token v) -wordyPatternName = queryToken $ \case - L.WordyId s Nothing -> Just $ Var.nameds s - _ -> Nothing +wordyPatternName = + fmap Var.nameds <$> wordyIdString -- Parse an prefix identifier e.g. Foo or (+), discarding any hash prefixDefinitionName :: Var v => P v (L.Token v) @@ -268,14 +250,14 @@ prefixDefinitionName = -- Parse a wordy identifier e.g. Foo, discarding any hash wordyDefinitionName :: Var v => P v (L.Token v) wordyDefinitionName = queryToken $ \case - L.WordyId s _ -> Just $ Var.nameds s + L.WordyId ident -> Just $ Var.nameds (Identifier.toText (HQ'.toName ident)) L.Blank s -> Just $ Var.nameds ("_" <> s) _ -> Nothing -- Parse a wordyId as a String, rejecting any hash wordyIdString :: Ord v => P v (L.Token String) wordyIdString = queryToken $ \case - L.WordyId s Nothing -> Just s + L.WordyId ident | isNothing (HQ'.toHash ident) -> Just (Text.unpack (Identifier.toText (HQ'.toName ident))) _ -> Nothing -- Parse a wordyId as a Name, rejecting any hash @@ -288,8 +270,8 @@ importSymbolyId = (fmap . fmap) Name.unsafeFromString symbolyIdString -- Parse a symbolyId as a String, rejecting any hash symbolyIdString :: Ord v => P v (L.Token String) -symbolyIdString = queryToken $ \case - L.SymbolyId s Nothing -> Just s +symbolyIdString = queryToken \case + L.SymbolyId ident | isNothing (HQ'.toHash ident) -> Just (Text.unpack (Identifier.toText (HQ'.toName ident))) _ -> Nothing -- Parse an infix id e.g. + or Docs.++, discarding any hash @@ -299,7 +281,7 @@ infixDefinitionName = symbolyDefinitionName -- Parse a symboly ID like >>= or &&, discarding any hash symbolyDefinitionName :: Var v => P v (L.Token v) symbolyDefinitionName = queryToken $ \case - L.SymbolyId s _ -> Just $ Var.nameds s + L.SymbolyId ident -> Just $ Var.nameds (Identifier.toText (HQ'.toName ident)) _ -> Nothing parenthesize :: Ord v => P v a -> P v a @@ -311,8 +293,7 @@ hqInfixId = hqSymbolyId_ -- Parse a hash-qualified alphanumeric identifier hqWordyId_ :: Ord v => P v (L.Token (HQ.HashQualified Name)) -hqWordyId_ = queryToken $ \case - L.WordyId "" (Just h) -> Just $ HQ.HashOnly h +hqWordyId_ = queryToken \case L.WordyId s (Just h) -> Just $ HQ.HashQualified (Name.unsafeFromString s) h L.WordyId s Nothing -> Just $ HQ.NameOnly (Name.unsafeFromString s) L.Hash h -> Just $ HQ.HashOnly h @@ -321,7 +302,7 @@ hqWordyId_ = queryToken $ \case -- Parse a hash-qualified symboly ID like >>=#foo or && hqSymbolyId_ :: Ord v => P v (L.Token (HQ.HashQualified Name)) -hqSymbolyId_ = queryToken $ \case +hqSymbolyId_ = queryToken \case L.SymbolyId "" (Just h) -> Just $ HQ.HashOnly h L.SymbolyId s (Just h) -> Just $ HQ.HashQualified (Name.unsafeFromString s) h L.SymbolyId s Nothing -> Just $ HQ.NameOnly (Name.unsafeFromString s) diff --git a/unison-syntax/unison-syntax.cabal b/unison-syntax/unison-syntax.cabal index e062e0bbce..06f32130af 100644 --- a/unison-syntax/unison-syntax.cabal +++ b/unison-syntax/unison-syntax.cabal @@ -18,6 +18,7 @@ source-repository head library exposed-modules: Unison.Parser.Ann + Unison.Syntax.Identifier Unison.Syntax.Lexer Unison.Syntax.Parser Unison.UnisonFile.Error @@ -63,6 +64,7 @@ library , mtl , parser-combinators , text + , text-builder , unison-core1 , unison-prelude , unison-pretty-printer @@ -117,6 +119,7 @@ test-suite syntax-tests , mtl , parser-combinators , text + , text-builder , unison-core1 , unison-prelude , unison-pretty-printer From d679b4d59d16759429d55845f5ce9290149558ed Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 17 Jan 2024 14:14:39 -0500 Subject: [PATCH 05/41] remove unused prisms --- unison-syntax/src/Unison/Syntax/Lexer.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 782e504131..b53ae1158b 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -34,7 +34,6 @@ module Unison.Syntax.Lexer ) where -import Control.Lens.TH (makePrisms) import Control.Monad.Combinators.NonEmpty qualified as Monad import Control.Monad.State qualified as S import Data.Char @@ -146,8 +145,6 @@ data Lexeme type IsVirtual = Bool -- is it a virtual semi or an actual semi? -makePrisms ''Lexeme - lexemeToHQName :: Lexeme -> Maybe (HQ.HashQualified Name) lexemeToHQName = \case WordyId n -> Just (HQ'.toHQ n) From 886295134caf3693d743b2f20ea25cbba7cc1e62 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 17 Jan 2024 20:11:20 -0500 Subject: [PATCH 06/41] begin building out a Unison.Syntax.NameSegment module --- unison-syntax/src/Unison/Syntax/Lexer.hs | 77 +++++-------- .../src/Unison/Syntax/NameSegment.hs | 104 ++++++++++++++++++ unison-syntax/unison-syntax.cabal | 1 + 3 files changed, 131 insertions(+), 51 deletions(-) create mode 100644 unison-syntax/src/Unison/Syntax/NameSegment.hs diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index b53ae1158b..2d5588608a 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -36,8 +36,8 @@ where import Control.Monad.Combinators.NonEmpty qualified as Monad import Control.Monad.State qualified as S -import Data.Char -import Data.List +import Data.Char (isAlpha, isAlphaNum, isControl, isDigit, isSpace, ord, toLower) +import Data.List (intercalate, isPrefixOf) import Data.List.NonEmpty qualified as Nel import Data.Map.Strict qualified as Map import Data.Set qualified as Set @@ -61,6 +61,8 @@ import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH import Unison.Syntax.HashQualified' qualified as HQ' (toString) import Unison.Syntax.Name qualified as Name (toText, unsafeFromString) +import Unison.Syntax.NameSegment (reservedSymbolySegments, symbolyIdChar) +import Unison.Syntax.NameSegment qualified as NameSegment (symbolyP) import Unison.Util.Bytes qualified as Bytes import Unison.Util.Monoid (intercalateMap) @@ -259,20 +261,21 @@ token'' tok p = do name `elem` ["{", "(", "[", "handle", "match", "if", "then"] showErrorFancy :: (P.ShowErrorComponent e) => P.ErrorFancy e -> String -showErrorFancy (P.ErrorFail msg) = msg -showErrorFancy (P.ErrorIndentation ord ref actual) = - "incorrect indentation (got " - <> show (P.unPos actual) - <> ", should be " - <> p - <> show (P.unPos ref) - <> ")" - where - p = case ord of - LT -> "less than " - EQ -> "equal to " - GT -> "greater than " -showErrorFancy (P.ErrorCustom a) = P.showErrorComponent a +showErrorFancy = \case + P.ErrorFail msg -> msg + P.ErrorIndentation ord ref actual -> + "incorrect indentation (got " + <> show (P.unPos actual) + <> ", should be " + <> p + <> show (P.unPos ref) + <> ")" + where + p = case ord of + LT -> "less than " + EQ -> "equal to " + GT -> "greater than " + P.ErrorCustom a -> P.showErrorComponent a lexer0' :: String -> String -> [Token Lexeme] lexer0' scope rem = @@ -410,9 +413,7 @@ lexemes' eof = body = join <$> P.many (sectionElem <* CP.space) sectionElem = section <|> fencedBlock <|> list <|> paragraph paragraph = wrap "syntax.docParagraph" $ join <$> spaced leaf - reserved word = - isPrefixOf "}}" word - || all (== '#') word + reserved word = isPrefixOf "}}" word || all (== '#') word wordy closing = wrap "syntax.docWord" . tok . fmap Textual . P.try $ do let end = @@ -1095,20 +1096,11 @@ isSymbolyIdentifier = symbolyIdSegP :: P NameSegment symbolyIdSegP = do start <- pos - segment <- - let unescaped = P.takeWhile1P (Just symbolMsg) symbolyIdChar - escaped = do - _ <- lit "`" - s <- P.takeWhile1P (Just symbolMsg) escapedSymbolyIdChar - _ <- lit "`" - pure s - in unescaped <|> escaped - when (Set.member segment reservedOperators) do - stop <- pos - P.customFailure (Token (ReservedSymbolyId segment) start stop) - pure (NameSegment (Text.pack segment)) - where - symbolMsg = "operator (examples: +, Float./, List.++#xyz)" + NameSegment.symbolyP >>= \case + Left segment -> do + stop <- pos + P.customFailure (Token (ReservedSymbolyId (Text.unpack segment)) start stop) + Right segment -> pure segment wordyIdSegP :: P NameSegment wordyIdSegP = @@ -1364,23 +1356,9 @@ wordyId' s = case wordyId0 s of -- Returns either an error or an id and a remainder symbolyId0 :: String -> Either Err (String, String) symbolyId0 s = span' symbolyIdChar s \case - (id@(_ : _), rem) | not (Set.member id reservedOperators) -> Right (id, rem) + (id@(_ : _), rem) | not (Set.member (Text.pack id) reservedSymbolySegments) -> Right (id, rem) (id, _rem) -> Left (InvalidSymbolyId id) -symbolyIdChar :: Char -> Bool -symbolyIdChar ch = Set.member ch symbolyIdChars - --- | The set of characters allowed in an unescaped symboly identifier. -symbolyIdChars :: Set Char -symbolyIdChars = Set.fromList "!$%^&*-=+<>~\\/|:" - -escapedSymbolyIdChar :: Char -> Bool -escapedSymbolyIdChar = (`Set.member` escapedSymbolyIdChars) - --- | The set of characters allowed in an escaped symboly identifier. -escapedSymbolyIdChars :: Set Char -escapedSymbolyIdChars = Set.insert '.' symbolyIdChars - isSymbolyIdSeg :: NameSegment -> Bool isSymbolyIdSeg = not . wordyIdStartChar . Text.head . NameSegment.toText @@ -1432,9 +1410,6 @@ delimiters = Set.fromList "()[]{},?;" isDelimiter :: Char -> Bool isDelimiter ch = Set.member ch delimiters -reservedOperators :: Set String -reservedOperators = Set.fromList ["=", "->", ":", "&&", "||", "|", "!", "'", "==>"] - inc :: Pos -> Pos inc (Pos line col) = Pos line (col + 1) diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs new file mode 100644 index 0000000000..b05d78fcc4 --- /dev/null +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -0,0 +1,104 @@ +-- | Utilities related to the parsing and printing of name segments using the default syntax. +module Unison.Syntax.NameSegment + ( -- * String conversions + unsafeFromText, + + -- * Name segment parsers + symbolyP, + + -- * Character classifiers + symbolyIdChar, + reservedSymbolySegments, + ) +where + +import Data.Set qualified as Set +import Data.Text qualified as Text +import Text.Megaparsec (ParsecT) +import Text.Megaparsec qualified as P +import Text.Megaparsec.Char qualified as P +import Unison.NameSegment (NameSegment (..)) +import Unison.Prelude + +------------------------------------------------------------------------------------------------------------------------ +-- String conversions + +-- | Convert a text to a name segment, when the text is known to be a valid name segment. +unsafeFromText :: Text -> NameSegment +unsafeFromText = + NameSegment + +------------------------------------------------------------------------------------------------------------------------ +-- Name segment parsers + +-- type P = P.ParsecT (Token Err) String (S.State ParsingEnv) + +-- | A symboly name segment parser, which consists only of symboly characters. +-- +-- A symboly name segment can optionally be escaped by surrounding it with backticks. Thus, there are two different +-- syntaxes for the ++ operator, for example: +-- +-- 1. ++ +-- 2. `++` +-- +-- The only difference is that the literal dot character (.) is allowed in escaped segments, but not unescaped segments. +-- Thus, there is only one syntax for the .~ operator: +-- +-- 1. `.~` +-- +-- The backticks of escaped symboly segments are not present in the data itself, i.e. the string "`.~`" corresponds +-- to the data NameSegment ".~". +-- +-- Returns @Left@ if the symboly name segment is reserved, e.g. "=" +symbolyP :: Ord e => ParsecT e [Char] s (Either Text NameSegment) +symbolyP = do + string <- unescaped <|> escaped + let text = Text.pack string + pure + if Set.member text reservedSymbolySegments + then Left text + else Right (NameSegment text) + where + unescaped = + P.takeWhile1P (Just (description symbolyIdChars)) symbolyIdChar + + escaped = do + _ <- P.char '`' + s <- P.takeWhile1P (Just (description escapedSymbolyIdChars)) escapedSymbolyIdChar + _ <- P.char '`' + pure s + + description valid = + "operator (valid characters: " ++ Set.toList valid ++ ")" + +------------------------------------------------------------------------------------------------------------------------ +-- Character classifiers + +symbolyIdChar :: Char -> Bool +symbolyIdChar = + (`Set.member` symbolyIdChars) + +-- | The set of characters allowed in an unescaped symboly identifier. +symbolyIdChars :: Set Char +symbolyIdChars = Set.fromList "!$%^&*-=+<>~\\/|:" + +escapedSymbolyIdChar :: Char -> Bool +escapedSymbolyIdChar = (`Set.member` escapedSymbolyIdChars) + +-- | The set of characters allowed in an escaped symboly identifier. +escapedSymbolyIdChars :: Set Char +escapedSymbolyIdChars = Set.insert '.' symbolyIdChars + +reservedSymbolySegments :: Set Text +reservedSymbolySegments = + Set.fromList + [ "=", + "->", + ":", + "&&", + "||", + "|", + "!", + "'", + "==>" + ] diff --git a/unison-syntax/unison-syntax.cabal b/unison-syntax/unison-syntax.cabal index 4bd090dc04..ebfd6cab67 100644 --- a/unison-syntax/unison-syntax.cabal +++ b/unison-syntax/unison-syntax.cabal @@ -23,6 +23,7 @@ library Unison.Syntax.HashQualified' Unison.Syntax.Lexer Unison.Syntax.Name + Unison.Syntax.NameSegment Unison.Syntax.Parser Unison.UnisonFile.Error hs-source-dirs: From dd6c0d69b8156f8ab4213efa0ea979841a135281 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 17 Jan 2024 20:45:17 -0500 Subject: [PATCH 07/41] fix a bug in identifier parser --- unison-syntax/src/Unison/Syntax/Lexer.hs | 33 ++++++++++--------- .../src/Unison/Syntax/NameSegment.hs | 20 +++++++++++ 2 files changed, 38 insertions(+), 15 deletions(-) diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 2d5588608a..4698e35437 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -36,7 +36,7 @@ where import Control.Monad.Combinators.NonEmpty qualified as Monad import Control.Monad.State qualified as S -import Data.Char (isAlpha, isAlphaNum, isControl, isDigit, isSpace, ord, toLower) +import Data.Char (isAlphaNum, isControl, isDigit, isSpace, ord, toLower) import Data.List (intercalate, isPrefixOf) import Data.List.NonEmpty qualified as Nel import Data.Map.Strict qualified as Map @@ -61,7 +61,7 @@ import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH import Unison.Syntax.HashQualified' qualified as HQ' (toString) import Unison.Syntax.Name qualified as Name (toText, unsafeFromString) -import Unison.Syntax.NameSegment (reservedSymbolySegments, symbolyIdChar) +import Unison.Syntax.NameSegment (reservedSymbolySegments, segmentStartChar, symbolyIdChar, wordyIdChar, wordyIdStartChar) import Unison.Syntax.NameSegment qualified as NameSegment (symbolyP) import Unison.Util.Bytes qualified as Bytes import Unison.Util.Monoid (intercalateMap) @@ -1066,12 +1066,25 @@ identifierP :: P (HQ'.HashQualified Name) identifierP = do P.label "identifier (ex: abba1, snake_case, .foo.++#xyz, or 🌻)" do P.try do - maybeDot <- P.optional (lit ".") - segments <- Monad.sepBy1 (symbolyIdSegP <|> wordyIdSegP) (lit ".") - let name = (if isJust maybeDot then Name.makeAbsolute else id) (Name.fromSegments segments) + leadingDot <- isJust <$> P.optional (char '.') + segments <- Monad.sepBy1 (symbolyIdSegP <|> wordyIdSegP) separatorP + let name = (if leadingDot then Name.makeAbsolute else id) (Name.fromSegments segments) P.optional shorthashP <&> \case Nothing -> HQ'.fromName name Just shorthash -> HQ'.HashQualified name shorthash + where + -- The separator between segments is just a dot, but we don't want to commit to parsing another segment unless the + -- character after the dot can begin a segment. + -- + -- This allows (for example) the "a." in "forall a. a -> a" to successfully parse as an identifier "a" followed by + -- the reserved symbol ".", rathern than fail to parse as an identifier, because it looks like the prefix of some + -- "a.b" that stops in the middle. + separatorP :: P Char + separatorP = + P.try do + c <- char '.' + P.lookAhead (P.satisfy segmentStartChar) + pure c -- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is -- symboly (comprised of only symbols) or wordy (comprised of only alphanums). @@ -1313,16 +1326,6 @@ wordyId0 s = span' wordyIdChar s $ \case Right (id, rem) (id, _rem) -> Left (InvalidWordyId id) -wordyIdStartChar :: Char -> Bool -wordyIdStartChar ch = isAlpha ch || isEmoji ch || ch == '_' - -wordyIdChar :: Char -> Bool -wordyIdChar ch = - isAlphaNum ch || isEmoji ch || ch `elem` ['_', '!', '\''] - -isEmoji :: Char -> Bool -isEmoji c = c >= '\x1F300' && c <= '\x1FAFF' - symbolyId :: String -> Either Err (String, String) symbolyId r@('.' : s) | s == "" = symbolyId0 r -- diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index b05d78fcc4..e16191e5b0 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -7,11 +7,15 @@ module Unison.Syntax.NameSegment symbolyP, -- * Character classifiers + segmentStartChar, symbolyIdChar, + wordyIdStartChar, + wordyIdChar, reservedSymbolySegments, ) where +import Data.Char qualified as Char import Data.Set qualified as Set import Data.Text qualified as Text import Text.Megaparsec (ParsecT) @@ -74,6 +78,10 @@ symbolyP = do ------------------------------------------------------------------------------------------------------------------------ -- Character classifiers +segmentStartChar :: Char -> Bool +segmentStartChar c = + wordyIdStartChar c || symbolyIdChar c || c == '`' -- backtick starts an escaped symboly segment + symbolyIdChar :: Char -> Bool symbolyIdChar = (`Set.member` symbolyIdChars) @@ -102,3 +110,15 @@ reservedSymbolySegments = "'", "==>" ] + +wordyIdStartChar :: Char -> Bool +wordyIdStartChar ch = + Char.isAlpha ch || isEmoji ch || ch == '_' + +wordyIdChar :: Char -> Bool +wordyIdChar ch = + Char.isAlphaNum ch || isEmoji ch || ch == '_' || ch == '!' || ch == '\'' + +isEmoji :: Char -> Bool +isEmoji c = + c >= '\x1F300' && c <= '\x1FAFF' From 768df76668a3fa45d0a962eb6e0319abde00bd50 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 18 Jan 2024 12:30:12 -0500 Subject: [PATCH 08/41] extract name parser out to share among lexer and path parser --- unison-syntax/src/Unison/Syntax/Lexer.hs | 227 +++++------------- .../src/Unison/Syntax/Lexer/Token.hs | 33 +++ unison-syntax/src/Unison/Syntax/Name.hs | 76 +++++- .../src/Unison/Syntax/NameSegment.hs | 61 +++-- .../src/Unison/Syntax/ReservedWords.hs | 59 +++++ unison-syntax/unison-syntax.cabal | 2 + 6 files changed, 262 insertions(+), 196 deletions(-) create mode 100644 unison-syntax/src/Unison/Syntax/Lexer/Token.hs create mode 100644 unison-syntax/src/Unison/Syntax/ReservedWords.hs diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 4698e35437..41ba07e502 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -7,7 +7,6 @@ module Unison.Syntax.Lexer Err (..), Pos (..), Lexeme (..), - lexemeToHQName, lexer, simpleWordyId, simpleSymbolyId, @@ -20,9 +19,6 @@ module Unison.Syntax.Lexer debugLex''', showEscapeChar, touches, - typeModifiers, - typeOrAbilityAlt, - typeModifiersAlt, -- todo: these probably don't belong here wordyIdChar, wordyIdStartChar, @@ -34,7 +30,6 @@ module Unison.Syntax.Lexer ) where -import Control.Monad.Combinators.NonEmpty qualified as Monad import Control.Monad.State qualified as S import Data.Char (isAlphaNum, isControl, isDigit, isSpace, ord, toLower) import Data.List (intercalate, isPrefixOf) @@ -49,7 +44,6 @@ import Text.Megaparsec.Char qualified as CP import Text.Megaparsec.Char.Lexer qualified as LP import Text.Megaparsec.Error qualified as EP import Text.Megaparsec.Internal qualified as PI -import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Lexer.Pos (Column, Line, Pos (Pos), column, line) import Unison.Name (Name) @@ -60,9 +54,11 @@ import Unison.Prelude import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH import Unison.Syntax.HashQualified' qualified as HQ' (toString) -import Unison.Syntax.Name qualified as Name (toText, unsafeFromString) -import Unison.Syntax.NameSegment (reservedSymbolySegments, segmentStartChar, symbolyIdChar, wordyIdChar, wordyIdStartChar) -import Unison.Syntax.NameSegment qualified as NameSegment (symbolyP) +import Unison.Syntax.Lexer.Token (Token (..), posP, tokenP) +import Unison.Syntax.Name qualified as Name (ParseErr (..), isSymboly, nameP, toText, unsafeFromString) +import Unison.Syntax.NameSegment (symbolyIdChar, wordyIdChar, wordyIdStartChar) +import Unison.Syntax.NameSegment qualified as NameSegment (wordyP) +import Unison.Syntax.ReservedWords (keywords, reservedOperators, typeModifiers, typeOrAbility) import Unison.Util.Bytes qualified as Bytes import Unison.Util.Monoid (intercalateMap) @@ -70,13 +66,6 @@ type BlockName = String type Layout = [(BlockName, Column)] -data Token a = Token - { payload :: a, - start :: !Pos, - end :: !Pos - } - deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) - data ParsingEnv = ParsingEnv { layout :: !Layout, -- layout stack opening :: Maybe BlockName, -- `Just b` if a block of type `b` is being opened @@ -147,13 +136,6 @@ data Lexeme type IsVirtual = Bool -- is it a virtual semi or an actual semi? -lexemeToHQName :: Lexeme -> Maybe (HQ.HashQualified Name) -lexemeToHQName = \case - WordyId n -> Just (HQ'.toHQ n) - SymbolyId n -> Just (HQ'.toHQ n) - Hash sh -> Just (HQ.HashOnly sh) - _ -> Nothing - space :: P () space = LP.space @@ -169,11 +151,6 @@ lit = P.try . LP.symbol (pure ()) token :: P Lexeme -> P [Token Lexeme] token = token' (\a start end -> [Token a start end]) -pos :: P Pos -pos = do - p <- P.getSourcePos - pure $ Pos (P.unPos (P.sourceLine p)) (P.unPos (P.sourceColumn p)) - -- Token parser: strips trailing whitespace and comments after a -- successful parse, and also takes care of emitting layout tokens -- (such as virtual semicolons and closing tokens). @@ -183,7 +160,7 @@ token' tok p = LP.lexeme space (token'' tok p) -- Committed failure err :: Pos -> Err -> P x err start t = do - stop <- pos + stop <- posP -- This consumes a character and therefore produces committed failure, -- so `err s t <|> p2` won't try `p2` _ <- void P.anySingle <|> P.eof @@ -205,7 +182,7 @@ commitAfter2 a b f = do -- but does emit layout tokens such as virtual semicolons and closing tokens. token'' :: (a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme] token'' tok p = do - start <- pos + start <- posP -- We save the current state so we can backtrack the state if `p` fails. env <- S.get layoutToks <- case opening env of @@ -238,7 +215,7 @@ token'' tok p = do -- the layout stack and/or emit virtual semicolons. Nothing -> if inLayout env then pops start else pure [] a <- p <|> (S.put env >> fail "resetting state") - end <- pos + end <- posP pure $ layoutToks ++ tok a start end where pops :: Pos -> P [Token Lexeme] @@ -334,7 +311,7 @@ lexemes = lexemes' eof where eof :: P [Token Lexeme] eof = P.try do - p <- P.eof >> pos + p <- P.eof >> posP n <- maybe 0 (const 1) <$> S.gets opening l <- S.gets layout pure $ replicate (length l + n) (Token Close p p) @@ -402,11 +379,11 @@ lexemes' eof = wordyKw kw = separated wordySep (lit kw) subsequentTypeName = P.lookAhead . P.optional $ do let lit' s = lit s <* sp - let modifier = typeModifiersAlt lit' - let typeOrAbility' = typeOrAbilityAlt wordyKw + let modifier = typeModifiersAlt (lit' . Text.unpack) + let typeOrAbility' = typeOrAbilityAlt (wordyKw . Text.unpack) _ <- modifier <* typeOrAbility' *> sp - (start, name, stop) <- positioned identifierP - if isSymbolyIdentifier name + Token name start stop <- tokenP identifierP + if Name.isSymboly (HQ'.toName name) then P.customFailure (Token (InvalidSymbolyId (Text.unpack (HQ'.toTextWith Name.toText name))) start stop) else pure (WordyId name) ignore _ _ _ = [] @@ -477,8 +454,8 @@ lexemes' eof = s <- lexemes' inlineEvalClose pure s - typeLink = wrap "syntax.docEmbedTypeLink" $ do - _ <- typeOrAbilityAlt wordyKw <* CP.space + typeLink = wrap "syntax.docEmbedTypeLink" do + _ <- typeOrAbilityAlt (wordyKw . Text.unpack) <* CP.space tok identifierLexemeP <* CP.space termLink = @@ -490,7 +467,7 @@ lexemes' eof = tok identifierLexemeP <* CP.space groupy closing p = do - (start, p, stop) <- positioned p + Token p start stop <- tokenP p after <- P.optional . P.try $ leafy closing pure $ case after of Nothing -> p @@ -506,7 +483,7 @@ lexemes' eof = verbatim = P.label "code (examples: ''**unformatted**'', `words` or '''_words_''')" $ do - (start, txt, stop) <- positioned $ do + Token txt 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 ' @@ -679,7 +656,7 @@ lexemes' eof = listItemStart' gutter = P.try $ do nonNewlineSpaces - col <- column <$> pos + col <- column <$> posP parentCol <- S.gets parentListColumn guard (col > parentCol) (col,) <$> gutter @@ -691,7 +668,7 @@ lexemes' eof = num n = Numeric (show n) listItemParagraph = wrap "syntax.docParagraph" $ do - col <- column <$> pos + col <- column <$> posP join <$> P.some (leaf <* sep col) where -- Trickiness here to support hard line breaks inside of @@ -708,7 +685,7 @@ lexemes' eof = newline *> nonNewlineSpaces *> do - col2 <- column <$> pos + col2 <- column <$> posP guard $ col2 >= col (P.notFollowedBy $ numberedStart <|> bulletedStart) pure () @@ -759,7 +736,7 @@ lexemes' eof = wrap :: String -> P [Token Lexeme] -> P [Token Lexeme] wrap o p = do - start <- pos + start <- posP lexemes <- p pure $ go start lexemes where @@ -812,7 +789,7 @@ lexemes' eof = n <- many (char '"') _ <- optional (char '\n') -- initial newline is skipped s <- P.manyTill P.anySingle (lit (replicate (length n + 3) '"')) - col0 <- column <$> pos + col0 <- column <$> posP let col = col0 - (length n) - 3 -- this gets us first col of closing quotes let leading = replicate (max 0 (col - 1)) ' ' -- a last line that's equal to `leading` is ignored, since leading @@ -839,7 +816,7 @@ lexemes' eof = intOrNat = P.try $ num <$> sign <*> LP.decimal float = do _ <- P.try (P.lookAhead (sign >> (LP.decimal :: P Int) >> (char '.' <|> char 'e' <|> char 'E'))) -- commit after this - start <- pos + start <- posP sign <- fromMaybe "" <$> sign base <- P.takeWhile1P (Just "base") isDigit decimals <- @@ -855,7 +832,7 @@ lexemes' eof = pure $ Numeric (sign <> base <> fromMaybe "" decimals <> fromMaybe "" exp) bytes = do - start <- pos + start <- posP _ <- lit "0xs" s <- map toLower <$> P.takeWhileP (Just "hexidecimal character") isAlphaNum case Bytes.fromBase16 $ Bytes.fromWord8s (fromIntegral . ord <$> s) of @@ -863,11 +840,11 @@ lexemes' eof = Right bs -> pure (Bytes bs) otherbase = octal <|> hex octal = do - start <- pos + start <- posP commitAfter2 sign (lit "0o") $ \sign _ -> fmap (num sign) LP.octal <|> err start InvalidOctalLiteral hex = do - start <- pos + start <- posP commitAfter2 sign (lit "0x") $ \sign _ -> fmap (num sign) LP.hexadecimal <|> err start InvalidHexLiteral @@ -909,7 +886,7 @@ lexemes' eof = symbolyKw s = separated (not . symbolyIdChar) (kw s) kw :: String -> P [Token Lexeme] - kw s = positioned (lit s) <&> \(pos1, s, pos2) -> [Token (Reserved s) pos1 pos2] + kw s = tokenP (lit s) <&> \token -> [Reserved <$> token] layoutKeywords :: P [Token Lexeme] layoutKeywords = @@ -930,8 +907,8 @@ lexemes' eof = openKw "if" <|> closeKw' (Just "then") ["if"] (lit "then") <|> closeKw' (Just "else") ["then"] (lit "else") - modKw = typeModifiersAlt (openKw1 wordySep) - typeOrAbilityKw = typeOrAbilityAlt openTypeKw1 + modKw = typeModifiersAlt (openKw1 wordySep . Text.unpack) + typeOrAbilityKw = typeOrAbilityAlt (openTypeKw1 . Text.unpack) typ = modKw <|> typeOrAbilityKw withKw = do @@ -954,14 +931,14 @@ lexemes' eof = openTypeKw1 t = do b <- S.gets (topBlockName . layout) case b of - Just mod | Set.member mod typeModifiers -> wordyKw t + Just mod | Set.member (Text.pack mod) typeModifiers -> wordyKw t _ -> openKw1 wordySep t -- layout keyword which bumps the layout column by 1, rather than looking ahead -- to the next token to determine the layout column openKw1 :: (Char -> Bool) -> String -> P [Token Lexeme] openKw1 sep kw = do - (pos0, kw, pos1) <- positioned $ separated sep (lit kw) + Token kw pos0 pos1 <- tokenP $ separated sep (lit kw) S.modify (\env -> env {layout = (kw, column $ inc pos0) : layout env}) pure [Token (Open kw) pos0 pos1] @@ -970,7 +947,7 @@ lexemes' eof = env <- S.get case topBlockName (layout env) of -- '=' does not open a layout block if within a type declaration - Just t | t == "type" || Set.member t typeModifiers -> pure [Token (Reserved "=") start end] + Just t | t == "type" || Set.member (Text.pack t) typeModifiers -> pure [Token (Reserved "=") start end] Just _ -> S.put (env {opening = Just "="}) >> pure [Token (Open "=") start end] _ -> err start LayoutError @@ -1017,12 +994,12 @@ lexemes' eof = delim = P.try $ do ch <- P.satisfy (\ch -> ch /= ';' && Set.member ch delimiters) - pos <- pos + pos <- posP pure [Token (Reserved [ch]) pos (inc pos)] delayOrForce = separated ok $ do - (start, op, end) <- positioned $ P.satisfy isDelayOrForce - pure [Token (Reserved [op]) start end] + token <- tokenP $ P.satisfy isDelayOrForce + pure [token <&> \op -> Reserved [op]] where ok c = isDelayOrForce c || isSpace c || isAlphaNum c || Set.member c delimiters || c == '\"' @@ -1034,25 +1011,25 @@ open b = openAs b b openAs :: String -> String -> P [Token Lexeme] openAs syntax b = do - (start, _, end) <- positioned $ lit syntax + token <- tokenP $ lit syntax env <- S.get S.put (env {opening = Just b}) - pure [Token (Open b) start end] + pure [Open b <$ token] openKw :: String -> P [Token Lexeme] openKw s = separated wordySep $ do - (pos1, s, pos2) <- positioned $ lit s + token <- tokenP $ lit s env <- S.get S.put (env {opening = Just s}) - pure [Token (Open s) pos1 pos2] + pure [Open <$> token] wordySep :: Char -> Bool wordySep c = isSpace c || not (wordyIdChar c) tok :: P a -> P [Token a] tok p = do - (start, a, stop) <- positioned p - pure [Token a start stop] + token <- tokenP p + pure [token] -- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is -- symboly (comprised of only symbols) or wordy (comprised of only alphanums). @@ -1065,26 +1042,15 @@ tok p = do identifierP :: P (HQ'.HashQualified Name) identifierP = do P.label "identifier (ex: abba1, snake_case, .foo.++#xyz, or 🌻)" do - P.try do - leadingDot <- isJust <$> P.optional (char '.') - segments <- Monad.sepBy1 (symbolyIdSegP <|> wordyIdSegP) separatorP - let name = (if leadingDot then Name.makeAbsolute else id) (Name.fromSegments segments) - P.optional shorthashP <&> \case - Nothing -> HQ'.fromName name - Just shorthash -> HQ'.HashQualified name shorthash + name <- PI.withParsecT (fmap nameParseErrToErr) Name.nameP + P.optional shorthashP <&> \case + Nothing -> HQ'.fromName name + Just shorthash -> HQ'.HashQualified name shorthash where - -- The separator between segments is just a dot, but we don't want to commit to parsing another segment unless the - -- character after the dot can begin a segment. - -- - -- This allows (for example) the "a." in "forall a. a -> a" to successfully parse as an identifier "a" followed by - -- the reserved symbol ".", rathern than fail to parse as an identifier, because it looks like the prefix of some - -- "a.b" that stops in the middle. - separatorP :: P Char - separatorP = - P.try do - c <- char '.' - P.lookAhead (P.satisfy segmentStartChar) - pure c + nameParseErrToErr :: Name.ParseErr -> Err + nameParseErrToErr = \case + Name.ReservedOperator s -> ReservedSymbolyId (Text.unpack s) + Name.ReservedWord s -> ReservedWordyId (Text.unpack s) -- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is -- symboly (comprised of only symbols) or wordy (comprised of only alphanums). @@ -1098,59 +1064,29 @@ identifierLexemeP :: P Lexeme identifierLexemeP = do name <- identifierP pure - if isSymbolyIdSeg (Name.lastSegment (HQ'.toName name)) + if Name.isSymboly (HQ'.toName name) then SymbolyId name else WordyId name -isSymbolyIdentifier :: HQ'.HashQualified Name -> Bool -isSymbolyIdentifier = - isSymbolyIdSeg . Name.lastSegment . HQ'.toName - -symbolyIdSegP :: P NameSegment -symbolyIdSegP = do - start <- pos - NameSegment.symbolyP >>= \case - Left segment -> do - stop <- pos - P.customFailure (Token (ReservedSymbolyId (Text.unpack segment)) start stop) - Right segment -> pure segment - wordyIdSegP :: P NameSegment wordyIdSegP = - P.try do - start <- pos - ch <- P.satisfy wordyIdStartChar - rest <- P.takeWhileP (Just wordyMsg) wordyIdChar - let word = ch : rest - when (Set.member word keywords) $ do - stop <- pos - P.customFailure (Token (ReservedWordyId word) start stop) - pure (NameSegment (Text.pack (ch : rest))) - where - wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" + PI.withParsecT (fmap (ReservedWordyId . Text.unpack)) NameSegment.wordyP shorthashP :: P ShortHash shorthashP = P.label hashMsg do P.lookAhead (char '#') -- `foo#xyz` should parse - (start, potentialHash, _) <- positioned $ P.takeWhile1P (Just hashMsg) (\ch -> not (isSep ch) && ch /= '`') + Token potentialHash start _ <- tokenP $ P.takeWhile1P (Just hashMsg) (\ch -> not (isSep ch) && ch /= '`') case SH.fromText (Text.pack potentialHash) of Nothing -> err start (InvalidShortHash potentialHash) Just sh -> pure sh where hashMsg = "hash (ex: #af3sj3)" -positioned :: P a -> P (Pos, a, Pos) -positioned p = do - start <- pos - a <- p - stop <- pos - pure (start, a, stop) - blockDelimiter :: [String] -> P String -> P [Token Lexeme] blockDelimiter open closeP = do - (pos1, close, pos2) <- positioned $ closeP + Token close pos1 pos2 <- tokenP closeP env <- S.get case findClose open (layout env) of Nothing -> err pos1 (UnexpectedDelimiter (quote close)) @@ -1169,7 +1105,7 @@ closeKw' reopenBlockname open closeP = close' reopenBlockname open (separated wo close' :: Maybe String -> [String] -> P String -> P [Token Lexeme] close' reopenBlockname open closeP = do - (pos1, close, pos2) <- positioned $ closeP + Token close pos1 pos2 <- tokenP closeP env <- S.get case findClose open (layout env) of Nothing -> err pos1 (CloseWithoutMatchingOpen msgOpen (quote close)) @@ -1273,8 +1209,8 @@ reorder = join . sortWith f . stanzas where f [] = 3 :: Int f (t0 : _) = case payload $ headToken t0 of - Open mod | Set.member mod typeModifiers -> 1 - Open typOrA | Set.member typOrA typeOrAbility -> 1 + Open mod | Set.member (Text.pack mod) typeModifiers -> 1 + Open typOrA | Set.member (Text.pack typOrA) typeOrAbility -> 1 Reserved "use" -> 0 _ -> 3 :: Int @@ -1319,9 +1255,9 @@ isSep c = isSpace c || Set.member c delimiters -- Not a keyword, '.' delimited list of wordyId0 (should not include a trailing '.') wordyId0 :: String -> Either Err (String, String) -wordyId0 s = span' wordyIdChar s $ \case +wordyId0 s = span' wordyIdChar s \case (id@(ch : _), rem) - | not (Set.member id keywords) + | not (Set.member (Text.pack id) keywords) && wordyIdStartChar ch -> Right (id, rem) (id, _rem) -> Left (InvalidWordyId id) @@ -1359,51 +1295,14 @@ wordyId' s = case wordyId0 s of -- Returns either an error or an id and a remainder symbolyId0 :: String -> Either Err (String, String) symbolyId0 s = span' symbolyIdChar s \case - (id@(_ : _), rem) | not (Set.member (Text.pack id) reservedSymbolySegments) -> Right (id, rem) + (id@(_ : _), rem) | not (Set.member (Text.pack id) reservedOperators) -> Right (id, rem) (id, _rem) -> Left (InvalidSymbolyId id) -isSymbolyIdSeg :: NameSegment -> Bool -isSymbolyIdSeg = - not . wordyIdStartChar . Text.head . NameSegment.toText - -keywords :: Set String -keywords = - Set.fromList - [ "if", - "then", - "else", - "do", - "forall", - "∀", - "handle", - "with", - "where", - "use", - "true", - "false", - "alias", - "typeLink", - "termLink", - "let", - "namespace", - "match", - "cases", - "@rewrite" - ] - <> typeModifiers - <> typeOrAbility - -typeOrAbility :: Set String -typeOrAbility = Set.fromList ["type", "ability"] - -typeOrAbilityAlt :: (Alternative f) => (String -> f a) -> f a +typeOrAbilityAlt :: (Alternative f) => (Text -> f a) -> f a typeOrAbilityAlt f = asum $ map f (toList typeOrAbility) -typeModifiers :: Set String -typeModifiers = Set.fromList ["structural", "unique"] - -typeModifiersAlt :: (Alternative f) => (String -> f a) -> f a +typeModifiersAlt :: (Alternative f) => (Text -> f a) -> f a typeModifiersAlt f = asum $ map f (toList typeModifiers) @@ -1489,7 +1388,3 @@ instance P.VisualStream [Token Lexeme] where if line1 == line2 then replicate (col2 - col1) ' ' else replicate (line2 - line1) '\n' ++ replicate col2 ' ' - -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 diff --git a/unison-syntax/src/Unison/Syntax/Lexer/Token.hs b/unison-syntax/src/Unison/Syntax/Lexer/Token.hs new file mode 100644 index 0000000000..91c1787f46 --- /dev/null +++ b/unison-syntax/src/Unison/Syntax/Lexer/Token.hs @@ -0,0 +1,33 @@ +module Unison.Syntax.Lexer.Token + ( Token (..), + tokenP, + posP, + ) +where + +import Text.Megaparsec (ParsecT, TraversableStream) +import Text.Megaparsec qualified as P +import Unison.Lexer.Pos (Pos (Pos)) + +data Token a = Token + { payload :: a, + start :: !Pos, + end :: !Pos + } + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +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 + +tokenP :: (Ord e, TraversableStream s) => ParsecT e s m a -> ParsecT e s 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 = do + p <- P.getSourcePos + pure (Pos (P.unPos (P.sourceLine p)) (P.unPos (P.sourceColumn p))) diff --git a/unison-syntax/src/Unison/Syntax/Name.hs b/unison-syntax/src/Unison/Syntax/Name.hs index c298e74afb..fb80cefafa 100644 --- a/unison-syntax/src/Unison/Syntax/Name.hs +++ b/unison-syntax/src/Unison/Syntax/Name.hs @@ -1,32 +1,52 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} --- | Syntax-related combinators for Name (to/from string types). +-- | Utilities related to the parsing and printing of names using the default syntax. module Unison.Syntax.Name - ( fromText, - fromTextEither, + ( -- * String conversions unsafeFromString, - unsafeFromText, - unsafeFromVar, toString, + fromText, + fromTextEither, + unsafeFromText, toText, + unsafeFromVar, toVar, + + -- * Name parsers + ParseErr (..), + nameP, + + -- * Name classifiers + isSymboly, ) where +import Control.Monad.Combinators.NonEmpty qualified as Monad import Data.List.NonEmpty (pattern (:|)) import Data.List.NonEmpty qualified as List (NonEmpty) import Data.Text qualified as Text import Data.Text.Lazy qualified as Text.Lazy import Data.Text.Lazy.Builder qualified as Text (Builder) import Data.Text.Lazy.Builder qualified as Text.Builder +import Text.Megaparsec (ParsecT) +import Text.Megaparsec qualified as P +import Text.Megaparsec.Char qualified as P +import Text.Megaparsec.Internal qualified as P (withParsecT) +import Unison.Name qualified as Name (fromSegments, lastSegment, makeAbsolute) import Unison.Name.Internal (Name (Name)) import Unison.NameSegment (NameSegment (NameSegment)) import Unison.NameSegment qualified as NameSegment import Unison.Position (Position (..)) import Unison.Prelude +import Unison.Syntax.Lexer.Token (Token) +import Unison.Syntax.NameSegment (segmentStartChar) +import Unison.Syntax.NameSegment qualified as NameSegment (isSymboly, symbolyP, wordyP) import Unison.Var (Var) import Unison.Var qualified as Var +------------------------------------------------------------------------------------------------------------------------ +-- String conversions + instance IsString Name where fromString = unsafeFromString @@ -64,7 +84,8 @@ toVar = -- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes -- no attempt at rejecting bogus names like "foo...bar...baz". fromText :: Text -> Maybe Name -fromText = eitherToMaybe . fromTextEither +fromText = + eitherToMaybe . fromTextEither -- | Parse a name from a string literal. -- @@ -103,7 +124,8 @@ unsafeFromString = -- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes -- no attempt at rejecting bogus names like "foo...bar...baz". unsafeFromText :: (HasCallStack) => Text -> Name -unsafeFromText = either (error . Text.unpack) id . fromTextEither +unsafeFromText = + either (error . Text.unpack) id . fromTextEither -- | Unsafely parse a name from a var, by first rendering the var as a string. -- @@ -111,3 +133,43 @@ unsafeFromText = either (error . Text.unpack) id . fromTextEither unsafeFromVar :: (Var v) => v -> Name unsafeFromVar = unsafeFromText . Var.name + +------------------------------------------------------------------------------------------------------------------------ +-- Name parsers + +data ParseErr + = ReservedOperator !Text + | ReservedWord !Text + deriving stock (Eq, Ord) + +nameP :: forall m. Monad m => ParsecT (Token ParseErr) [Char] m Name +nameP = + P.try do + leadingDot <- isJust <$> P.optional (P.char '.') + name <- Name.fromSegments <$> Monad.sepBy1 segmentP separatorP + pure (if leadingDot then Name.makeAbsolute name else name) + where + segmentP :: ParsecT (Token ParseErr) [Char] m NameSegment + segmentP = + P.withParsecT (fmap ReservedOperator) NameSegment.symbolyP + <|> P.withParsecT (fmap ReservedWord) NameSegment.wordyP + + -- The separator between segments is just a dot, but we don't want to commit to parsing another segment unless the + -- character after the dot can begin a segment. + -- + -- This allows (for example) the "a." in "forall a. a -> a" to successfully parse as an identifier "a" followed by + -- the reserved symbol ".", rathern than fail to parse as an identifier, because it looks like the prefix of some + -- "a.b" that stops in the middle. + separatorP :: Ord e => ParsecT e [Char] m Char + separatorP = + P.try do + c <- P.char '.' + P.lookAhead (P.satisfy segmentStartChar) + pure c + +------------------------------------------------------------------------------------------------------------------------ +-- Name classifiers + +isSymboly :: Name -> Bool +isSymboly = + NameSegment.isSymboly . Name.lastSegment diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index e16191e5b0..ad36415952 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -4,14 +4,17 @@ module Unison.Syntax.NameSegment unsafeFromText, -- * Name segment parsers + isSymboly, + + -- * Name segment classifiers symbolyP, + wordyP, -- * Character classifiers segmentStartChar, symbolyIdChar, wordyIdStartChar, wordyIdChar, - reservedSymbolySegments, ) where @@ -23,6 +26,8 @@ import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P import Unison.NameSegment (NameSegment (..)) import Unison.Prelude +import Unison.Syntax.Lexer.Token (Token (..), posP) +import Unison.Syntax.ReservedWords (keywords, reservedOperators) ------------------------------------------------------------------------------------------------------------------------ -- String conversions @@ -35,8 +40,6 @@ unsafeFromText = ------------------------------------------------------------------------------------------------------------------------ -- Name segment parsers --- type P = P.ParsecT (Token Err) String (S.State ParsingEnv) - -- | A symboly name segment parser, which consists only of symboly characters. -- -- A symboly name segment can optionally be escaped by surrounding it with backticks. Thus, there are two different @@ -53,15 +56,17 @@ unsafeFromText = -- The backticks of escaped symboly segments are not present in the data itself, i.e. the string "`.~`" corresponds -- to the data NameSegment ".~". -- --- Returns @Left@ if the symboly name segment is reserved, e.g. "=" -symbolyP :: Ord e => ParsecT e [Char] s (Either Text NameSegment) +-- Throws the parsed name segment as an error if it's reserved, e.g. "=". +symbolyP :: ParsecT (Token Text) [Char] m NameSegment symbolyP = do + start <- posP string <- unescaped <|> escaped let text = Text.pack string - pure - if Set.member text reservedSymbolySegments - then Left text - else Right (NameSegment text) + if Set.member text reservedOperators + then do + end <- posP + P.customFailure (Token text start end) + else pure (NameSegment text) where unescaped = P.takeWhile1P (Just (description symbolyIdChars)) symbolyIdChar @@ -75,6 +80,30 @@ symbolyP = do description valid = "operator (valid characters: " ++ Set.toList valid ++ ")" +-- | A wordy name segment parser, which consists only of wordy characters. +-- +-- Throws the parsed name segment as an error if it's a keyword, e.g. "match". +wordyP :: ParsecT (Token Text) [Char] m NameSegment +wordyP = do + start <- posP + ch <- P.satisfy wordyIdStartChar + rest <- P.takeWhileP (Just wordyMsg) wordyIdChar + let word = Text.pack (ch : rest) + if Set.member word keywords + then do + end <- posP + P.customFailure (Token word start end) + else pure (NameSegment word) + where + wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" + +------------------------------------------------------------------------------------------------------------------------ +-- Character classifiers + +isSymboly :: NameSegment -> Bool +isSymboly = + not . wordyIdStartChar . Text.head . toText + ------------------------------------------------------------------------------------------------------------------------ -- Character classifiers @@ -97,20 +126,6 @@ escapedSymbolyIdChar = (`Set.member` escapedSymbolyIdChars) escapedSymbolyIdChars :: Set Char escapedSymbolyIdChars = Set.insert '.' symbolyIdChars -reservedSymbolySegments :: Set Text -reservedSymbolySegments = - Set.fromList - [ "=", - "->", - ":", - "&&", - "||", - "|", - "!", - "'", - "==>" - ] - wordyIdStartChar :: Char -> Bool wordyIdStartChar ch = Char.isAlpha ch || isEmoji ch || ch == '_' diff --git a/unison-syntax/src/Unison/Syntax/ReservedWords.hs b/unison-syntax/src/Unison/Syntax/ReservedWords.hs new file mode 100644 index 0000000000..e6072f1b57 --- /dev/null +++ b/unison-syntax/src/Unison/Syntax/ReservedWords.hs @@ -0,0 +1,59 @@ +module Unison.Syntax.ReservedWords + ( keywords, + typeModifiers, + typeOrAbility, + reservedOperators, + ) +where + +import Data.Set qualified as Set +import Unison.Prelude + +keywords :: Set Text +keywords = + Set.fromList + [ "@rewrite", + "alias", + "cases", + "do", + "else", + "false", + "forall", + "handle", + "if", + "let", + "match", + "namespace", + "termLink", + "then", + "true", + "typeLink", + "use", + "where", + "with", + "∀" + ] + <> typeModifiers + <> typeOrAbility + +typeModifiers :: Set Text +typeModifiers = + Set.fromList ["structural", "unique"] + +typeOrAbility :: Set Text +typeOrAbility = + Set.fromList ["type", "ability"] + +reservedOperators :: Set Text +reservedOperators = + Set.fromList + [ "=", + "->", + ":", + "&&", + "||", + "|", + "!", + "'", + "==>" + ] diff --git a/unison-syntax/unison-syntax.cabal b/unison-syntax/unison-syntax.cabal index ebfd6cab67..aa607ee77c 100644 --- a/unison-syntax/unison-syntax.cabal +++ b/unison-syntax/unison-syntax.cabal @@ -22,9 +22,11 @@ library Unison.Syntax.HashQualified Unison.Syntax.HashQualified' Unison.Syntax.Lexer + Unison.Syntax.Lexer.Token Unison.Syntax.Name Unison.Syntax.NameSegment Unison.Syntax.Parser + Unison.Syntax.ReservedWords Unison.UnisonFile.Error hs-source-dirs: src From 81e4ebe013ca0074b0bb876a8642045d5c29b971 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 18 Jan 2024 13:12:04 -0500 Subject: [PATCH 09/41] begin unifying name and path parsers --- .../src/Unison/Codebase/Path.hs | 7 +++--- .../src/Unison/Codebase/Path/Parse.hs | 25 +++++++++---------- .../tests/Unison/Test/Codebase/Path.hs | 15 ++--------- unison-syntax/src/Unison/Syntax/Name.hs | 8 ++++++ 4 files changed, 25 insertions(+), 30 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index a3c84bfa4b..f46934be24 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -302,12 +302,11 @@ fromName :: Name -> Path fromName = fromList . List.NonEmpty.toList . Name.segments fromName' :: Name -> Path' -fromName' n = case take 1 (Name.toString n) of - "." -> AbsolutePath' . Absolute $ Path seq - _ -> RelativePath' $ Relative path +fromName' n + | Name.isAbsolute n = AbsolutePath' (Absolute path) + | otherwise = RelativePath' (Relative path) where path = fromName n - seq = toSeq path unsafeToName :: Path -> Name unsafeToName = Name.unsafeFromText . toText diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs index 3a180c328c..83782c5682 100644 --- a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} module Unison.Codebase.Path.Parse ( parsePath', - parsePathImpl', parseSplit', definitionNameSegment, parseHQSplit, @@ -19,7 +14,9 @@ where import Control.Lens (over, _1) import Control.Lens qualified as Lens import Data.List.Extra (stripPrefix) +import Data.List.NonEmpty qualified as List.NonEmpty import Data.Text qualified as Text +import Text.Megaparsec qualified as P import Unison.Codebase.Path import Unison.HashQualified' qualified as HQ' import Unison.NameSegment (NameSegment (NameSegment)) @@ -28,19 +25,21 @@ import Unison.Prelude hiding (empty, toList) import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH import Unison.Syntax.Lexer qualified as Lexer +import Unison.Syntax.Name qualified as Name -- .libs.blah.poo is Absolute -- libs.blah.poo is Relative -- Left is some parse error tbd parsePath' :: String -> Either String Path' -parsePath' p = case parsePathImpl' p of - Left e -> Left e - Right (p, "") -> Right p - Right (p, rem) -> case parseSegment rem of - Right (seg, "") -> Right (unsplit' (p, NameSegment . Text.pack $ seg)) - Right (_, rem) -> - Left ("extra characters after " <> show p <> ": " <> show rem) - Left e -> Left e +parsePath' = \case + "." -> Right absoluteEmpty' + path -> + case P.runParser (Name.nameP <* P.eof) "" path of + Left err -> Left (renderErr err) + Right name -> Right (fromName' name) + where + renderErr = + P.parseErrorTextPretty . P.mapParseError Lexer.payload . List.NonEmpty.head . P.bundleErrors -- implementation detail of parsePath' and parseSplit' -- foo.bar.baz.34 becomes `Right (foo.bar.baz, "34") diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs index 2ecab3dcd6..fea1b787d1 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs @@ -1,31 +1,20 @@ {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} module Unison.Test.Codebase.Path where -import Data.Either import Data.Maybe (fromJust) -import Data.Sequence -import Data.Text import EasyTest import Unison.Codebase.Path import Unison.Codebase.Path.Parse import Unison.HashQualified' qualified as HQ' import Unison.NameSegment +import Unison.Prelude import Unison.ShortHash qualified as SH test :: Test () test = scope "path" . tests $ - [ scope "parsePathImpl'" . tests $ - [ let s = "foo.bar.baz.34" in scope s . expect $ parsePathImpl' s == Right (relative ["foo", "bar", "baz"], "34"), - let s = "foo.bar.baz" in scope s . expect $ parsePathImpl' s == Right (relative ["foo", "bar"], "baz"), - let s = "baz" in scope s . expect $ parsePathImpl' s == Right (relative [], "baz"), - let s = "-" in scope s . expect $ parsePathImpl' s == Right (relative [], "-"), - let s = "34" in scope s . pending . expect $ parsePathImpl' s == Right (relative [], "34"), - let s = "foo.bar.baz#a8fj" in scope s . expect $ isLeft $ parsePathImpl' s - ], - scope "parseSplit'" . tests $ + [ scope "parseSplit'" . tests $ [ scope "wordyNameSegment" . tests $ [ let s = "foo.bar.baz" in scope s . expect $ diff --git a/unison-syntax/src/Unison/Syntax/Name.hs b/unison-syntax/src/Unison/Syntax/Name.hs index fb80cefafa..ed17a9bc26 100644 --- a/unison-syntax/src/Unison/Syntax/Name.hs +++ b/unison-syntax/src/Unison/Syntax/Name.hs @@ -142,6 +142,14 @@ data ParseErr | ReservedWord !Text deriving stock (Eq, Ord) +instance P.ShowErrorComponent ParseErr where + showErrorComponent = \case + ReservedOperator s -> Text.unpack ("reserved operator: " <> s) + ReservedWord s -> Text.unpack ("reserved word: " <> s) + errorComponentLen = \case + ReservedOperator s -> Text.length s + ReservedWord s -> Text.length s + nameP :: forall m. Monad m => ParsecT (Token ParseErr) [Char] m Name nameP = P.try do From 3677c6bfbb20e9662450c3bd1b1a620bd4baba8b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 18 Jan 2024 13:55:25 -0500 Subject: [PATCH 10/41] use name parser in parseSplit' --- .../src/Unison/Codebase/Path.hs | 18 +- .../src/Unison/Codebase/Path/Parse.hs | 33 +-- .../tests/Unison/Test/Codebase/Path.hs | 25 +-- .../src/Unison/Codebase/Editor/Input.hs | 8 +- .../Unison/CommandLine/BranchRelativePath.hs | 5 +- .../src/Unison/CommandLine/InputPatterns.hs | 196 ++++++++---------- unison-cli/unison/ArgParse.hs | 6 +- unison-share-api/src/Unison/Server/Orphans.hs | 8 +- unison-syntax/src/Unison/Syntax/Lexer.hs | 14 +- unison-syntax/src/Unison/Syntax/Name.hs | 26 +-- .../src/Unison/Syntax/NameSegment.hs | 28 +++ 11 files changed, 169 insertions(+), 198 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index f46934be24..47fc227da2 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -65,6 +65,7 @@ module Unison.Codebase.Path -- * things that could be replaced with `Parse` instances splitFromName, + splitFromName', hqSplitFromName', -- * things that could be replaced with `Cons` instances @@ -256,9 +257,19 @@ hqSplitFromName' = fmap (fmap HQ'.fromName) . Lens.unsnoc . fromName' -- >>> splitFromName "foo" -- (,foo) splitFromName :: Name -> Split -splitFromName name = +splitFromName = + over _1 fromPath' . splitFromName' + +splitFromName' :: Name -> Split' +splitFromName' name = case Name.reverseSegments name of - (seg :| pathSegments) -> (fromList $ reverse pathSegments, seg) + (seg :| pathSegments) -> + let path = fromList (reverse pathSegments) + in ( if Name.isAbsolute name + then AbsolutePath' (Absolute path) + else RelativePath' (Relative path), + seg + ) -- | Remove a path prefix from a name. -- Returns 'Nothing' if there are no remaining segments to construct the name from. @@ -522,7 +533,8 @@ instance Convert HQSplit (HQ'.HashQualified Path) where convert = unsplitHQ instance Convert HQSplit' (HQ'.HashQualified Path') where convert = unsplitHQ' -instance Convert Name Split where convert = splitFromName +instance Convert Name Split where + convert = splitFromName instance Convert (path, NameSegment) (path, HQ'.HQSegment) where convert (path, name) = diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs index 83782c5682..1a88b95e5a 100644 --- a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -3,18 +3,15 @@ module Unison.Codebase.Path.Parse ( parsePath', parseSplit', - definitionNameSegment, parseHQSplit, parseHQSplit', parseShortHashOrHQSplit', - wordyNameSegment, ) where import Control.Lens (over, _1) import Control.Lens qualified as Lens import Data.List.Extra (stripPrefix) -import Data.List.NonEmpty qualified as List.NonEmpty import Data.Text qualified as Text import Text.Megaparsec qualified as P import Unison.Codebase.Path @@ -26,20 +23,12 @@ import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH import Unison.Syntax.Lexer qualified as Lexer import Unison.Syntax.Name qualified as Name +import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr) --- .libs.blah.poo is Absolute --- libs.blah.poo is Relative --- Left is some parse error tbd -parsePath' :: String -> Either String Path' +parsePath' :: String -> Either Text Path' parsePath' = \case "." -> Right absoluteEmpty' - path -> - case P.runParser (Name.nameP <* P.eof) "" path of - Left err -> Left (renderErr err) - Right name -> Right (fromName' name) - where - renderErr = - P.parseErrorTextPretty . P.mapParseError Lexer.payload . List.NonEmpty.head . P.bundleErrors + path -> unsplit' <$> parseSplit' path -- implementation detail of parsePath' and parseSplit' -- foo.bar.baz.34 becomes `Right (foo.bar.baz, "34") @@ -100,17 +89,11 @@ definitionNameSegment s = wordyNameSegment s <> symbolyNameSegment s <> unit s Right (a, rem) -> Left $ "trailing characters after " <> show a <> ": " <> show rem --- parseSplit' wordyNameSegment "foo.bar.baz" returns Right (foo.bar, baz) --- parseSplit' wordyNameSegment "foo.bar.+" returns Left err --- parseSplit' definitionNameSegment "foo.bar.+" returns Right (foo.bar, +) -parseSplit' :: - (String -> Either String NameSegment) -> - String -> - Either String Split' -parseSplit' lastSegment p = do - (p', rem) <- parsePathImpl' p - seg <- lastSegment rem - pure (p', seg) +parseSplit' :: String -> Either Text Split' +parseSplit' path = do + case P.runParser (Name.nameP <* P.eof) "" path of + Left err -> Left (NameSegment.renderParseErr err) + Right name -> Right (splitFromName' name) parseShortHashOrHQSplit' :: String -> Either String (Either ShortHash HQSplit') parseShortHashOrHQSplit' s = diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs index fea1b787d1..a79ceb2aed 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs @@ -4,34 +4,17 @@ module Unison.Test.Codebase.Path where import Data.Maybe (fromJust) import EasyTest -import Unison.Codebase.Path -import Unison.Codebase.Path.Parse +import Unison.Codebase.Path (Path (..), Path' (..), Relative (..)) +import Unison.Codebase.Path.Parse (parseHQSplit', parseShortHashOrHQSplit') import Unison.HashQualified' qualified as HQ' -import Unison.NameSegment +import Unison.NameSegment (NameSegment (..)) import Unison.Prelude import Unison.ShortHash qualified as SH test :: Test () test = scope "path" . tests $ - [ scope "parseSplit'" . tests $ - [ scope "wordyNameSegment" . tests $ - [ let s = "foo.bar.baz" - in scope s . expect $ - parseSplit' wordyNameSegment s == Right (relative ["foo", "bar"], NameSegment "baz"), - let s = "foo.bar.baz#abc" in scope s . expect $ isLeft $ parseSplit' wordyNameSegment s, - let s = "foo.bar.+" - in scope s . expect $ - isLeft $ - parseSplit' wordyNameSegment s - ], - scope "definitionNameSegment" . tests $ - [ let s = "foo.bar.+" - in scope s . expect $ - parseSplit' definitionNameSegment s == Right (relative ["foo", "bar"], NameSegment "+") - ] - ], - scope "parseShortHashOrHQSplit'" . tests $ + [ scope "parseShortHashOrHQSplit'" . tests $ [ let s = "foo.bar#34" in scope s . expect $ parseShortHashOrHQSplit' s diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index c851d20e30..4fc74cf42f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -34,7 +34,7 @@ import Data.Text qualified as Text import Data.These (These) import U.Codebase.HashTags (CausalHash) import Unison.Codebase.Branch.Merge qualified as Branch -import Unison.Codebase.Editor.RemoteRepo +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace) import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path @@ -42,8 +42,8 @@ import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.SyncMode (SyncMode) -import Unison.Codebase.Verbosity -import Unison.CommandLine.BranchRelativePath +import Unison.Codebase.Verbosity (Verbosity) +import Unison.CommandLine.BranchRelativePath (BranchRelativePath, parseBranchRelativePath) import Unison.HashQualified qualified as HQ import Unison.Name (Name) import Unison.NameSegment (NameSegment) @@ -82,7 +82,7 @@ type HashOrHQSplit' = Either ShortHash Path.HQSplit' data Insistence = Force | Try deriving (Show, Eq) -parseBranchId :: String -> Either String BranchId +parseBranchId :: String -> Either Text BranchId parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of Nothing -> Left "Invalid hash, expected a base32hex string." Just h -> pure $ Left h diff --git a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs index cbdfb3403f..0bd113d29b 100644 --- a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs +++ b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs @@ -131,5 +131,6 @@ branchRelativePathParser = _ <- Megaparsec.char ':' That <$> relPath - failureAt :: forall a. Int -> String -> Megaparsec.Parsec Void Text a - failureAt offset str = Megaparsec.parseError (Megaparsec.FancyError offset (Set.singleton (Megaparsec.ErrorFail str))) + failureAt :: forall a. Int -> Text -> Megaparsec.Parsec Void Text a + failureAt offset str = + Megaparsec.parseError (Megaparsec.FancyError offset (Set.singleton (Megaparsec.ErrorFail (Text.unpack str)))) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 8e55778ede..3b9d22d4b1 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -61,6 +61,7 @@ import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), Projec import Unison.Project.Util (ProjectContext (..), projectContextFromPath) import Unison.Syntax.HashQualified qualified as HQ (fromString) import Unison.Syntax.Name qualified as Name (fromText, unsafeFromString) +import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr, segmentP) import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (intercalateMap) import Unison.Util.Pretty qualified as P @@ -152,8 +153,8 @@ todo = ] ) ( \case - patchStr : ws -> mapLeft (warn . fromString) $ do - patch <- Path.parseSplit' Path.definitionNameSegment patchStr + patchStr : ws -> mapLeft (warn . P.text) $ do + patch <- Path.parseSplit' patchStr branch <- case ws of [] -> pure Path.relativeEmpty' [pathStr] -> Path.parsePath' pathStr @@ -315,9 +316,7 @@ updateOld = ) \case patchStr : ws -> do - patch <- - first fromString $ - Path.parseSplit' Path.definitionNameSegment patchStr + patch <- first P.text $ Path.parseSplit' patchStr pure $ Input.UpdateI (Input.UsePatch patch) @@ -365,8 +364,8 @@ patch = ] ) \case - patchStr : ws -> first fromString $ do - patch <- Path.parseSplit' Path.definitionNameSegment patchStr + patchStr : ws -> first P.text do + patch <- Path.parseSplit' patchStr branch <- case ws of [pathStr] -> Path.parsePath' pathStr _ -> pure Path.relativeEmpty' @@ -500,7 +499,7 @@ ui = help = P.wrap "`ui` opens the Local UI in the default browser.", parse = \case [] -> pure $ Input.UiI Path.relativeEmpty' - [path] -> first fromString $ do + [path] -> first P.text $ do p <- Path.parsePath' path pure $ Input.UiI p _ -> Left (I.help ui) @@ -641,7 +640,7 @@ findShallow = ) ( \case [] -> pure $ Input.FindShallowI Path.relativeEmpty' - [path] -> first fromString $ do + [path] -> first P.text $ do p <- Path.parsePath' path pure $ Input.FindShallowI p _ -> Left (I.help findShallow) @@ -694,9 +693,9 @@ renameTerm = ] "`move.term foo bar` renames `foo` to `bar`." ( \case - [oldName, newName] -> first fromString $ do - src <- Path.parseHQSplit' oldName - target <- Path.parseSplit' Path.definitionNameSegment newName + [oldName, newName] -> first P.text do + src <- mapLeft Text.pack (Path.parseHQSplit' oldName) + target <- Path.parseSplit' newName pure $ Input.MoveTermI src target _ -> Left . P.warnCallout $ @@ -715,7 +714,7 @@ moveAll = ] "`move foo bar` renames the term, type, and namespace foo to bar." ( \case - [oldName, newName] -> first fromString $ do + [oldName, newName] -> first P.text $ do src <- Path.parsePath' oldName target <- Path.parsePath' newName pure $ Input.MoveAllI src target @@ -736,9 +735,9 @@ renameType = ] "`move.type foo bar` renames `foo` to `bar`." ( \case - [oldName, newName] -> first fromString $ do - src <- Path.parseHQSplit' oldName - target <- Path.parseSplit' Path.definitionNameSegment newName + [oldName, newName] -> first P.text do + src <- mapLeft Text.pack (Path.parseHQSplit' oldName) + target <- Path.parseSplit' newName pure $ Input.MoveTypeI src target _ -> Left . P.warnCallout $ @@ -833,10 +832,7 @@ deleteReplacement isTerm = ) ( \case query : patch -> do - patch <- - first fromString - . traverse (Path.parseSplit' Path.definitionNameSegment) - $ listToMaybe patch + patch <- first P.text . traverse Path.parseSplit' $ listToMaybe patch q <- parseHashQualifiedName query pure $ input q patch _ -> @@ -919,9 +915,9 @@ aliasTerm = [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)] "`alias.term foo bar` introduces `bar` with the same definition as `foo`." ( \case - [oldName, newName] -> first fromString $ do - source <- Path.parseShortHashOrHQSplit' oldName - target <- Path.parseSplit' Path.definitionNameSegment newName + [oldName, newName] -> first P.text do + source <- mapLeft Text.pack (Path.parseShortHashOrHQSplit' oldName) + target <- Path.parseSplit' newName pure $ Input.AliasTermI source target _ -> Left . warn $ @@ -938,9 +934,9 @@ aliasType = [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)] "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`." ( \case - [oldName, newName] -> first fromString $ do - source <- Path.parseShortHashOrHQSplit' oldName - target <- Path.parseSplit' Path.definitionNameSegment newName + [oldName, newName] -> first P.text do + source <- mapLeft Text.pack (Path.parseShortHashOrHQSplit' oldName) + target <- Path.parseSplit' newName pure $ Input.AliasTypeI source target _ -> Left . warn $ @@ -965,8 +961,8 @@ aliasMany = ] ) ( \case - srcs@(_ : _) Cons.:> dest -> first fromString $ do - sourceDefinitions <- traverse Path.parseHQSplit srcs + srcs@(_ : _) Cons.:> dest -> first P.text do + sourceDefinitions <- mapLeft Text.pack (traverse Path.parseHQSplit srcs) destNamespace <- Path.parsePath' dest pure $ Input.AliasManyI sourceDefinitions destNamespace _ -> Left (I.help aliasMany) @@ -1013,7 +1009,7 @@ cd = ) ( \case [".."] -> Right Input.UpI - [p] -> first fromString $ do + [p] -> first P.text do p <- Path.parsePath' p pure . Input.SwitchBranchI $ p _ -> Left (I.help cd) @@ -1066,8 +1062,8 @@ deleteNamespaceParser helpText insistence = first fromString . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) - [p] -> first fromString $ do - p <- Path.parseSplit' Path.definitionNameSegment p + [p] -> first P.text do + p <- Path.parseSplit' p pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p)) _ -> Left helpText ) @@ -1081,22 +1077,22 @@ deletePatch = [("patch to delete", Required, patchArg)] "`delete.patch ` deletes the patch `foo`" ( \case - [p] -> first fromString $ do - p <- Path.parseSplit' Path.definitionNameSegment p + [p] -> first P.text do + p <- Path.parseSplit' p pure . Input.DeleteI $ DeleteTarget'Patch p _ -> Left (I.help deletePatch) ) movePatch :: String -> String -> Either (P.Pretty CT.ColorText) Input -movePatch src dest = first fromString $ do - src <- Path.parseSplit' Path.definitionNameSegment src - dest <- Path.parseSplit' Path.definitionNameSegment dest +movePatch src dest = first P.text do + src <- Path.parseSplit' src + dest <- Path.parseSplit' dest pure $ Input.MovePatchI src dest copyPatch' :: String -> String -> Either (P.Pretty CT.ColorText) Input -copyPatch' src dest = first fromString $ do - src <- Path.parseSplit' Path.definitionNameSegment src - dest <- Path.parseSplit' Path.definitionNameSegment dest +copyPatch' src dest = first P.text do + src <- Path.parseSplit' src + dest <- Path.parseSplit' dest pure $ Input.CopyPatchI src dest copyPatch :: InputPattern @@ -1134,7 +1130,7 @@ renameBranch = [("namespace to move", Required, namespaceArg), ("new location", Required, newNameArg)] "`move.namespace foo bar` renames the path `foo` to `bar`." ( \case - [src, dest] -> first fromString $ do + [src, dest] -> first P.text do src <- Path.parsePath' src dest <- Path.parsePath' dest pure $ Input.MoveBranchI src dest @@ -1158,7 +1154,7 @@ history = ] ) ( \case - [src] -> first fromString $ do + [src] -> first P.text do p <- Input.parseBranchId src pure $ Input.HistoryI (Just 10) (Just 10) p [] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath) @@ -1262,7 +1258,7 @@ resetRoot = ] ) ( \case - [src] -> first fromString $ do + [src] -> first P.text $ do src <- Input.parseBranchId src pure $ Input.ResetRootI src _ -> Left (I.help resetRoot) @@ -1732,11 +1728,11 @@ diffNamespace = ] ) ( \case - [before, after] -> first fromString $ do + [before, after] -> first P.text do before <- Input.parseBranchId before after <- Input.parseBranchId after pure $ Input.DiffNamespaceI before after - [before] -> first fromString $ do + [before] -> first P.text do before <- Input.parseBranchId before pure $ Input.DiffNamespaceI before (Right Path.currentPath) _ -> Left $ I.help diffNamespace @@ -1812,10 +1808,7 @@ replaceEdit f = self ) ( \case source : target : patch -> do - patch <- - first fromString - <$> traverse (Path.parseSplit' Path.definitionNameSegment) - $ listToMaybe patch + patch <- first P.text <$> traverse Path.parseSplit' $ listToMaybe patch sourcehq <- parseHashQualifiedName source targethq <- parseHashQualifiedName target pure $ f sourcehq targethq patch @@ -2136,8 +2129,8 @@ viewPatch = ) ( \case [] -> Right $ Input.ListEditsI Nothing - [patchStr] -> mapLeft fromString $ do - patch <- Path.parseSplit' Path.definitionNameSegment patchStr + [patchStr] -> mapLeft P.text do + patch <- Path.parseSplit' patchStr Right $ Input.ListEditsI (Just patch) _ -> Left $ warn "`view.patch` takes a patch and that's it." ) @@ -2195,7 +2188,7 @@ namespaceDependencies = [("namespace", Optional, namespaceArg)] "List the external dependencies of the specified namespace." ( \case - [p] -> first fromString $ do + [p] -> first P.text do p <- Path.parsePath' p pure $ Input.NamespaceDependenciesI (Just p) [] -> pure (Input.NamespaceDependenciesI Nothing) @@ -2334,12 +2327,11 @@ docsToHtml = ) ] ) - ( \case - [namespacePath, destinationFilePath] -> first fromString $ do - np <- Path.parsePath' namespacePath - pure $ Input.DocsToHtmlI np destinationFilePath - _ -> Left $ showPatternHelp docsToHtml - ) + \case + [namespacePath, destinationFilePath] -> first P.text do + np <- Path.parsePath' namespacePath + pure $ Input.DocsToHtmlI np destinationFilePath + _ -> Left $ showPatternHelp docsToHtml docToMarkdown :: InputPattern docToMarkdown = @@ -2354,12 +2346,11 @@ docToMarkdown = ) ] ) - ( \case - [docNameText] -> first fromString $ do - docName <- maybeToEither "Invalid name" . Name.fromText . Text.pack $ docNameText - pure $ Input.DocToMarkdownI docName - _ -> Left $ showPatternHelp docToMarkdown - ) + \case + [docNameText] -> first fromString $ do + docName <- maybeToEither "Invalid name" . Name.fromText . Text.pack $ docNameText + pure $ Input.DocToMarkdownI docName + _ -> Left $ showPatternHelp docToMarkdown execute :: InputPattern execute = @@ -2377,11 +2368,10 @@ execute = ) ] ) - ( \case - [w] -> pure $ Input.ExecuteI w [] - (w : ws) -> pure $ Input.ExecuteI w ws - _ -> Left $ showPatternHelp execute - ) + \case + [w] -> pure $ Input.ExecuteI w [] + (w : ws) -> pure $ Input.ExecuteI w ws + _ -> Left $ showPatternHelp execute saveExecuteResult :: InputPattern saveExecuteResult = @@ -2393,10 +2383,9 @@ saveExecuteResult = ( "`add.run name` adds to the codebase the result of the most recent `run` command" <> "as `name`." ) - ( \case - [w] -> pure $ Input.SaveExecuteResultI (Name.unsafeFromString w) - _ -> Left $ showPatternHelp saveExecuteResult - ) + \case + [w] -> pure $ Input.SaveExecuteResultI (Name.unsafeFromString w) + _ -> Left $ showPatternHelp saveExecuteResult ioTest :: InputPattern ioTest = @@ -2449,11 +2438,10 @@ makeStandalone = ) ] ) - ( \case - [main, file] -> - Input.MakeStandaloneI file <$> parseHashQualifiedName main - _ -> Left $ showPatternHelp makeStandalone - ) + \case + [main, file] -> + Input.MakeStandaloneI file <$> parseHashQualifiedName main + _ -> Left $ showPatternHelp makeStandalone runScheme :: InputPattern runScheme = @@ -2468,10 +2456,9 @@ runScheme = ) ] ) - ( \case - (main : args) -> Right $ Input.ExecuteSchemeI main args - _ -> Left $ showPatternHelp runScheme - ) + \case + (main : args) -> Right $ Input.ExecuteSchemeI main args + _ -> Left $ showPatternHelp runScheme compileScheme :: InputPattern compileScheme = @@ -2488,11 +2475,10 @@ compileScheme = ) ] ) - ( \case - [main, file] -> - Input.CompileSchemeI file <$> parseHashQualifiedName main - _ -> Left $ showPatternHelp compileScheme - ) + \case + [main, file] -> + Input.CompileSchemeI file <$> parseHashQualifiedName main + _ -> Left $ showPatternHelp compileScheme schemeLibgen :: InputPattern schemeLibgen = @@ -2515,11 +2501,10 @@ schemeLibgen = ) ] ) - ( \case - [] -> pure $ Input.GenSchemeLibsI Nothing - [dir] -> pure . Input.GenSchemeLibsI $ Just dir - _ -> Left $ showPatternHelp schemeLibgen - ) + \case + [] -> pure $ Input.GenSchemeLibsI Nothing + [dir] -> pure . Input.GenSchemeLibsI $ Just dir + _ -> Left $ showPatternHelp schemeLibgen fetchScheme :: InputPattern fetchScheme = @@ -2552,16 +2537,15 @@ fetchScheme = ) ] ) - ( \case - [] -> pure (Input.FetchSchemeCompilerI "unison" JitInfo.currentRelease) - [name] -> pure (Input.FetchSchemeCompilerI name branch) - where - branch - | name == "unison" = JitInfo.currentRelease - | otherwise = "main" - [name, branch] -> pure (Input.FetchSchemeCompilerI name branch) - _ -> Left $ showPatternHelp fetchScheme - ) + \case + [] -> pure (Input.FetchSchemeCompilerI "unison" JitInfo.currentRelease) + [name] -> pure (Input.FetchSchemeCompilerI name branch) + where + branch + | name == "unison" = JitInfo.currentRelease + | otherwise = "main" + [name, branch] -> pure (Input.FetchSchemeCompilerI name branch) + _ -> Left $ showPatternHelp fetchScheme createAuthor :: InputPattern createAuthor = @@ -2582,8 +2566,10 @@ createAuthor = ) ) ( \case - symbolStr : authorStr@(_ : _) -> first fromString $ do - symbol <- Path.definitionNameSegment symbolStr + symbolStr : authorStr@(_ : _) -> first fromString do + symbol <- + Megaparsec.runParser (NameSegment.segmentP <* Megaparsec.eof) "" symbolStr + & mapLeft (Text.unpack . NameSegment.renderParseErr) -- let's have a real parser in not too long let author :: Text author = Text.pack $ case (unwords authorStr) of @@ -2663,10 +2649,10 @@ diffNamespaceToPatch = help = P.wrap "Create a patch from a namespace diff.", parse = \case [branchId1, branchId2, patch] -> - mapLeft fromString do + mapLeft P.text do branchId1 <- Input.parseBranchId branchId1 branchId2 <- Input.parseBranchId branchId2 - patch <- Path.parseSplit' Path.definitionNameSegment patch + patch <- Path.parseSplit' patch pure (Input.DiffNamespaceToPatchI Input.DiffNamespaceToPatchInput {branchId1, branchId2, patch}) _ -> Left (showPatternHelp diffNamespaceToPatch) } diff --git a/unison-cli/unison/ArgParse.hs b/unison-cli/unison/ArgParse.hs index 971e289ec5..43def809b8 100644 --- a/unison-cli/unison/ArgParse.hs +++ b/unison-cli/unison/ArgParse.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -- | This module handles parsing CLI arguments into 'Command's. -- See the excellent documentation at https://hackage.haskell.org/package/optparse-applicative @@ -13,6 +10,7 @@ import Data.Functor ((<&>)) import Data.List qualified as List import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE +import Data.Text qualified as Text import Options.Applicative ( CommandFields, Mod, @@ -450,7 +448,7 @@ readPath' :: ReadM Path.Path' readPath' = do strPath <- OptParse.str case Path.parsePath' strPath of - Left err -> OptParse.readerError err + Left err -> OptParse.readerError (Text.unpack err) Right path' -> pure path' fileArgument :: String -> Parser FilePath diff --git a/unison-share-api/src/Unison/Server/Orphans.hs b/unison-share-api/src/Unison/Server/Orphans.hs index 8455e265f8..3478e650a8 100644 --- a/unison-share-api/src/Unison/Server/Orphans.hs +++ b/unison-share-api/src/Unison/Server/Orphans.hs @@ -234,7 +234,7 @@ instance ToJSON ConstructorType where instance FromHttpApiData Path.Relative where parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of - Left s -> Left (Text.pack s) + Left s -> Left s Right (Path.RelativePath' p) -> Right p Right (Path.AbsolutePath' _) -> Left $ "Expected relative path, but " <> txt <> " was absolute." @@ -243,7 +243,7 @@ instance ToHttpApiData Path.Relative where instance FromHttpApiData Path.Absolute where parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of - Left s -> Left (Text.pack s) + Left s -> Left s Right (Path.RelativePath' _) -> Left $ "Expected absolute path, but " <> txt <> " was relative." Right (Path.AbsolutePath' p) -> Right p @@ -251,14 +251,14 @@ instance ToHttpApiData Path.Absolute where toUrlPiece = tShow instance FromHttpApiData Path.Path' where - parseUrlPiece txt = mapLeft Text.pack $ Path.parsePath' (Text.unpack txt) + parseUrlPiece txt = Path.parsePath' (Text.unpack txt) instance ToHttpApiData Path.Path' where toUrlPiece = tShow instance FromHttpApiData Path.Path where parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of - Left s -> Left (Text.pack s) + Left s -> Left s Right (Path.RelativePath' p) -> Right (Path.unrelative p) Right (Path.AbsolutePath' _) -> Left $ "Expected relative path, but " <> txt <> " was absolute." diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 41ba07e502..b5646cb964 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -55,9 +55,9 @@ import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH import Unison.Syntax.HashQualified' qualified as HQ' (toString) import Unison.Syntax.Lexer.Token (Token (..), posP, tokenP) -import Unison.Syntax.Name qualified as Name (ParseErr (..), isSymboly, nameP, toText, unsafeFromString) +import Unison.Syntax.Name qualified as Name (isSymboly, nameP, toText, unsafeFromString) import Unison.Syntax.NameSegment (symbolyIdChar, wordyIdChar, wordyIdStartChar) -import Unison.Syntax.NameSegment qualified as NameSegment (wordyP) +import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr(..), wordyP) import Unison.Syntax.ReservedWords (keywords, reservedOperators, typeModifiers, typeOrAbility) import Unison.Util.Bytes qualified as Bytes import Unison.Util.Monoid (intercalateMap) @@ -1042,15 +1042,15 @@ tok p = do identifierP :: P (HQ'.HashQualified Name) identifierP = do P.label "identifier (ex: abba1, snake_case, .foo.++#xyz, or 🌻)" do - name <- PI.withParsecT (fmap nameParseErrToErr) Name.nameP + name <- PI.withParsecT (fmap nameSegmentParseErrToErr) Name.nameP P.optional shorthashP <&> \case Nothing -> HQ'.fromName name Just shorthash -> HQ'.HashQualified name shorthash where - nameParseErrToErr :: Name.ParseErr -> Err - nameParseErrToErr = \case - Name.ReservedOperator s -> ReservedSymbolyId (Text.unpack s) - Name.ReservedWord s -> ReservedWordyId (Text.unpack s) + nameSegmentParseErrToErr :: NameSegment.ParseErr -> Err + nameSegmentParseErrToErr = \case + NameSegment.ReservedOperator s -> ReservedSymbolyId (Text.unpack s) + NameSegment.ReservedWord s -> ReservedWordyId (Text.unpack s) -- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is -- symboly (comprised of only symbols) or wordy (comprised of only alphanums). diff --git a/unison-syntax/src/Unison/Syntax/Name.hs b/unison-syntax/src/Unison/Syntax/Name.hs index ed17a9bc26..2d9742a789 100644 --- a/unison-syntax/src/Unison/Syntax/Name.hs +++ b/unison-syntax/src/Unison/Syntax/Name.hs @@ -13,7 +13,6 @@ module Unison.Syntax.Name toVar, -- * Name parsers - ParseErr (..), nameP, -- * Name classifiers @@ -31,7 +30,6 @@ import Data.Text.Lazy.Builder qualified as Text.Builder import Text.Megaparsec (ParsecT) import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P -import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.Name qualified as Name (fromSegments, lastSegment, makeAbsolute) import Unison.Name.Internal (Name (Name)) import Unison.NameSegment (NameSegment (NameSegment)) @@ -40,7 +38,7 @@ import Unison.Position (Position (..)) import Unison.Prelude import Unison.Syntax.Lexer.Token (Token) import Unison.Syntax.NameSegment (segmentStartChar) -import Unison.Syntax.NameSegment qualified as NameSegment (isSymboly, symbolyP, wordyP) +import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr, isSymboly, segmentP) import Unison.Var (Var) import Unison.Var qualified as Var @@ -137,31 +135,13 @@ unsafeFromVar = ------------------------------------------------------------------------------------------------------------------------ -- Name parsers -data ParseErr - = ReservedOperator !Text - | ReservedWord !Text - deriving stock (Eq, Ord) - -instance P.ShowErrorComponent ParseErr where - showErrorComponent = \case - ReservedOperator s -> Text.unpack ("reserved operator: " <> s) - ReservedWord s -> Text.unpack ("reserved word: " <> s) - errorComponentLen = \case - ReservedOperator s -> Text.length s - ReservedWord s -> Text.length s - -nameP :: forall m. Monad m => ParsecT (Token ParseErr) [Char] m Name +nameP :: forall m. Monad m => ParsecT (Token NameSegment.ParseErr) [Char] m Name nameP = P.try do leadingDot <- isJust <$> P.optional (P.char '.') - name <- Name.fromSegments <$> Monad.sepBy1 segmentP separatorP + name <- Name.fromSegments <$> Monad.sepBy1 NameSegment.segmentP separatorP pure (if leadingDot then Name.makeAbsolute name else name) where - segmentP :: ParsecT (Token ParseErr) [Char] m NameSegment - segmentP = - P.withParsecT (fmap ReservedOperator) NameSegment.symbolyP - <|> P.withParsecT (fmap ReservedWord) NameSegment.wordyP - -- The separator between segments is just a dot, but we don't want to commit to parsing another segment unless the -- character after the dot can begin a segment. -- diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index ad36415952..c0e4191944 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -7,8 +7,11 @@ module Unison.Syntax.NameSegment isSymboly, -- * Name segment classifiers + segmentP, symbolyP, wordyP, + ParseErr (..), + renderParseErr, -- * Character classifiers segmentStartChar, @@ -19,11 +22,13 @@ module Unison.Syntax.NameSegment where import Data.Char qualified as Char +import Data.List.NonEmpty qualified as List.NonEmpty import Data.Set qualified as Set import Data.Text qualified as Text import Text.Megaparsec (ParsecT) import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P +import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.NameSegment (NameSegment (..)) import Unison.Prelude import Unison.Syntax.Lexer.Token (Token (..), posP) @@ -40,6 +45,11 @@ unsafeFromText = ------------------------------------------------------------------------------------------------------------------------ -- Name segment parsers +segmentP :: Monad m => ParsecT (Token ParseErr) [Char] m NameSegment +segmentP = + P.withParsecT (fmap ReservedOperator) symbolyP + <|> P.withParsecT (fmap ReservedWord) wordyP + -- | A symboly name segment parser, which consists only of symboly characters. -- -- A symboly name segment can optionally be escaped by surrounding it with backticks. Thus, there are two different @@ -97,6 +107,24 @@ wordyP = do where wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" +data ParseErr + = ReservedOperator !Text + | ReservedWord !Text + deriving stock (Eq, Ord) + +instance P.ShowErrorComponent ParseErr where + showErrorComponent = \case + ReservedOperator s -> Text.unpack ("reserved operator: " <> s) + ReservedWord s -> Text.unpack ("reserved word: " <> s) + errorComponentLen = \case + ReservedOperator s -> Text.length s + ReservedWord s -> Text.length s + +-- | A convenience function for rendering a name segment parse error, because it's so weird and verbose to do so. +renderParseErr :: P.ParseErrorBundle [Char] (Token ParseErr) -> Text +renderParseErr = + Text.pack . P.parseErrorTextPretty . P.mapParseError payload . List.NonEmpty.head . P.bundleErrors + ------------------------------------------------------------------------------------------------------------------------ -- Character classifiers From 51b650ba129d432a4bb0fd0baaece2aaa931978e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 18 Jan 2024 22:15:54 -0500 Subject: [PATCH 11/41] unify name and path parsers --- codebase2/core/Unison/ShortHash.hs | 2 - .../src/Unison/Codebase/Path.hs | 2 +- .../src/Unison/Codebase/Path/Parse.hs | 155 +++------ .../src/Unison/Syntax/TermPrinter.hs | 25 +- .../src/Unison/CommandLine/InputPatterns.hs | 309 ++++++++---------- unison-syntax/src/Unison/Syntax/Lexer.hs | 94 +----- .../src/Unison/Syntax/Lexer/Token.hs | 19 ++ unison-syntax/src/Unison/Syntax/Name.hs | 32 +- .../src/Unison/Syntax/NameSegment.hs | 33 +- .../src/Unison/Syntax/ReservedWords.hs | 5 + unison-syntax/src/Unison/Syntax/ShortHash.hs | 38 +++ unison-syntax/unison-syntax.cabal | 1 + 12 files changed, 284 insertions(+), 431 deletions(-) create mode 100644 unison-syntax/src/Unison/Syntax/ShortHash.hs diff --git a/codebase2/core/Unison/ShortHash.hs b/codebase2/core/Unison/ShortHash.hs index 98532cb928..70dce9de9e 100644 --- a/codebase2/core/Unison/ShortHash.hs +++ b/codebase2/core/Unison/ShortHash.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Unison.ShortHash diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index 47fc227da2..672877b2e5 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -95,7 +95,7 @@ import Unison.Name qualified as Name import Unison.NameSegment (NameSegment (NameSegment)) import Unison.NameSegment qualified as NameSegment import Unison.Prelude hiding (empty, toList) -import Unison.Syntax.Name qualified as Name (toString, unsafeFromText) +import Unison.Syntax.Name qualified as Name (unsafeFromText) import Unison.Util.List qualified as List import Unison.Util.Monoid (intercalateMap) diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs index 1a88b95e5a..443b73f70e 100644 --- a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedLists #-} - module Unison.Codebase.Path.Parse ( parsePath', parseSplit', @@ -9,141 +7,64 @@ module Unison.Codebase.Path.Parse ) where -import Control.Lens (over, _1) -import Control.Lens qualified as Lens -import Data.List.Extra (stripPrefix) import Data.Text qualified as Text +import Text.Megaparsec (Parsec) import Text.Megaparsec qualified as P +import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.Codebase.Path import Unison.HashQualified' qualified as HQ' -import Unison.NameSegment (NameSegment (NameSegment)) -import Unison.NameSegment qualified as NameSegment import Unison.Prelude hiding (empty, toList) import Unison.ShortHash (ShortHash) -import Unison.ShortHash qualified as SH import Unison.Syntax.Lexer qualified as Lexer import Unison.Syntax.Name qualified as Name import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr) +import Unison.Syntax.ShortHash qualified as ShortHash + +------------------------------------------------------------------------------------------------------------------------ +-- Path parsing functions parsePath' :: String -> Either Text Path' parsePath' = \case "." -> Right absoluteEmpty' path -> unsplit' <$> parseSplit' path --- implementation detail of parsePath' and parseSplit' --- foo.bar.baz.34 becomes `Right (foo.bar.baz, "34") --- foo.bar.baz becomes `Right (foo.bar, "baz") --- baz becomes `Right (, "baz") --- foo.bar.baz#a8fj becomes `Left`; we don't hash-qualify paths. --- TODO: Get rid of this thing. -parsePathImpl' :: String -> Either String (Path', String) -parsePathImpl' p = case p of - "." -> Right (Path' . Left $ absoluteEmpty, "") - '.' : p -> over _1 (Path' . Left . Absolute . fromList) <$> segs p - p -> over _1 (Path' . Right . Relative . fromList) <$> segs p - where - go f p = case f p of - Right (a, "") -> case Lens.unsnoc (NameSegment.segments' $ Text.pack a) of - Nothing -> Left "empty path" - Just (segs, last) -> Right (NameSegment <$> segs, Text.unpack last) - Right (segs, '.' : rem) -> - let segs' = NameSegment.segments' (Text.pack segs) - in Right (NameSegment <$> segs', rem) - Right (segs, rem) -> - Left $ "extra characters after " <> segs <> ": " <> show rem - Left e -> Left e - segs p = go parseSegment p - -parseSegment :: String -> Either String (String, String) -parseSegment s = - first show - . (Lexer.wordyId <> Lexer.symbolyId) - <> unit' - <> const (Left ("I expected an identifier but found " <> s)) - $ s +parseSplit' :: String -> Either Text Split' +parseSplit' = + runParser splitP' -wordyNameSegment, definitionNameSegment :: String -> Either String NameSegment -wordyNameSegment s = case Lexer.wordyId0 s of - Left e -> Left (show e) - Right (a, "") -> Right (NameSegment (Text.pack a)) - Right (a, rem) -> - Left $ "trailing characters after " <> show a <> ": " <> show rem +parseShortHashOrHQSplit' :: String -> Either Text (Either ShortHash HQSplit') +parseShortHashOrHQSplit' = + runParser shortHashOrHqSplitP' --- Parse a name segment like "()" -unit' :: String -> Either String (String, String) -unit' s = case stripPrefix "()" s of - Nothing -> Left $ "Expected () but found: " <> s - Just rem -> Right ("()", rem) +parseHQSplit :: String -> Either Text HQSplit +parseHQSplit s = + parseHQSplit' s >>= \case + (RelativePath' (Relative p), hqseg) -> Right (p, hqseg) + _ -> Left $ "Sorry, you can't use an absolute name like " <> Text.pack s <> " here." -unit :: String -> Either String NameSegment -unit s = case unit' s of - Right (_, "") -> Right $ NameSegment "()" - Right (_, rem) -> Left $ "trailing characters after (): " <> show rem - Left _ -> Left $ "I don't know how to parse " <> s +parseHQSplit' :: String -> Either Text HQSplit' +parseHQSplit' = + runParser hqSplitP' -definitionNameSegment s = wordyNameSegment s <> symbolyNameSegment s <> unit s - where - symbolyNameSegment s = case Lexer.symbolyId0 s of - Left e -> Left (show e) - Right (a, "") -> Right (NameSegment (Text.pack a)) - Right (a, rem) -> - Left $ "trailing characters after " <> show a <> ": " <> show rem +runParser :: Parsec (Lexer.Token Text) [Char] a -> String -> Either Text a +runParser p = + mapLeft (Text.pack . P.errorBundlePretty) + . P.runParser (p <* P.eof) "" -parseSplit' :: String -> Either Text Split' -parseSplit' path = do - case P.runParser (Name.nameP <* P.eof) "" path of - Left err -> Left (NameSegment.renderParseErr err) - Right name -> Right (splitFromName' name) +------------------------------------------------------------------------------------------------------------------------ +-- Path parsers -parseShortHashOrHQSplit' :: String -> Either String (Either ShortHash HQSplit') -parseShortHashOrHQSplit' s = - case Text.breakOn "#" $ Text.pack s of - ("", "") -> error $ "encountered empty string parsing '" <> s <> "'" - (n, "") -> do - (p, rem) <- parsePathImpl' (Text.unpack n) - seg <- definitionNameSegment rem - pure $ Right (p, HQ'.NameOnly seg) - ("", sh) -> do - sh <- maybeToRight (shError s) . SH.fromText $ sh - pure $ Left sh - (n, sh) -> do - (p, rem) <- parsePathImpl' (Text.unpack n) - seg <- definitionNameSegment rem - hq <- - maybeToRight (shError s) - . fmap (\sh -> (p, HQ'.HashQualified seg sh)) - . SH.fromText - $ sh - pure $ Right hq - where - shError s = "couldn't parse shorthash from " <> s +splitP' :: Parsec (Lexer.Token Text) [Char] Split' +splitP' = + splitFromName' <$> P.withParsecT (fmap NameSegment.renderParseErr) Name.nameP -parseHQSplit :: String -> Either String HQSplit -parseHQSplit s = case parseHQSplit' s of - Right (Path' (Right (Relative p)), hqseg) -> Right (p, hqseg) - Right (Path' Left {}, _) -> - Left $ "Sorry, you can't use an absolute name like " <> s <> " here." - Left e -> Left e +shortHashOrHqSplitP' :: Parsec (Lexer.Token Text) [Char] (Either ShortHash HQSplit') +shortHashOrHqSplitP' = + Left <$> ShortHash.shortHashP <|> Right <$> hqSplitP' -parseHQSplit' :: String -> Either String HQSplit' -parseHQSplit' s = case Text.breakOn "#" $ Text.pack s of - ("", "") -> error $ "encountered empty string parsing '" <> s <> "'" - ("", _) -> Left "Sorry, you can't use a hash-only reference here." - (n, "") -> do - (p, rem) <- parsePath n - seg <- definitionNameSegment rem - pure (p, HQ'.NameOnly seg) - (n, sh) -> do - (p, rem) <- parsePath n - seg <- definitionNameSegment rem - maybeToRight (shError s) - . fmap (\sh -> (p, HQ'.HashQualified seg sh)) - . SH.fromText - $ sh - where - shError s = "couldn't parse shorthash from " <> s - parsePath n = do - x <- parsePathImpl' $ Text.unpack n - pure $ case x of - (Path' (Left e), "") | e == absoluteEmpty -> (relativeEmpty', ".") - x -> x +hqSplitP' :: Parsec (Lexer.Token Text) [Char] HQSplit' +hqSplitP' = do + (segs, seg) <- splitP' + P.optional (P.withParsecT (fmap ("invalid hash: " <>)) ShortHash.shortHashP) <&> \case + Nothing -> (segs, HQ'.fromName seg) + Just hash -> (segs, HQ'.HashQualified seg hash) diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index be9d64fd16..6a1a28e572 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -52,8 +52,8 @@ 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, symbolyId) -import Unison.Syntax.Name qualified as Name (fromText, toString, toText, unsafeFromText) +import Unison.Syntax.Lexer (showEscapeChar) +import Unison.Syntax.Name qualified as Name (fromText, fromTextEither, isSymboly, toText, unsafeFromText) import Unison.Syntax.NamePrinter (styleHashQualified'') import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Term @@ -206,7 +206,7 @@ pretty0 elideUnit = elideUnit } term = - specialCases term $ \case + specialCases term \case Var' v -> pure . parenIfInfix name ic $ styleHashQualified'' (fmt S.Var) name where -- OK since all term vars are user specified, any freshening was just added during typechecking @@ -298,7 +298,7 @@ pretty0 `PP.hang` pb <> PP.softbreak <> fmt S.ControlKeyword "with" - `hangHandler` ph + `hangHandler` ph ] Delay' x | isLet x || p < 0 -> do @@ -1078,14 +1078,8 @@ l :: (IsString s) => String -> Pretty s l = fromString isSymbolic :: HQ.HashQualified Name -> Bool -isSymbolic (HQ.NameOnly name) = isSymbolic' name -isSymbolic (HQ.HashQualified name _) = isSymbolic' name -isSymbolic (HQ.HashOnly _) = False - -isSymbolic' :: Name -> Bool -isSymbolic' name = case symbolyId . Name.toString $ name of - Right _ -> True - _ -> False +isSymbolic = + maybe False Name.isSymboly . HQ.toName emptyAc :: AmbientContext emptyAc = ac (-1) Normal Map.empty MaybeDoc @@ -1395,8 +1389,7 @@ calcImports im tm = (im', render $ getUses result) |> filter ( \s -> let (p, i) = lookupOrDie s m - in (i > 1 || isRight (symbolyId (unpack s))) - && not (null p) + in (i > 1 || isRight (Name.fromTextEither s)) && not (null p) ) |> map (\s -> (s, lookupOrDie s m)) |> Map.fromList @@ -1741,9 +1734,7 @@ prettyDoc2 ac tm = do <> PP.softbreak <> p <> PP.softbreak - <> fmt - S.DocDelimiter - "}}" + <> fmt S.DocDelimiter "}}" bail tm = brace <$> pretty0 ac tm -- Finds the longest run of a character and return one bigger than that longestRun c s = diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 3b9d22d4b1..f9820a6042 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -20,6 +20,7 @@ import System.Console.Haskeline.Completion (Completion (Completion)) import System.Console.Haskeline.Completion qualified as Haskeline import System.Console.Haskeline.Completion qualified as Line import Text.Megaparsec qualified as Megaparsec +import Text.Megaparsec.Internal qualified as Megaparsec (withParsecT) import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries @@ -472,10 +473,10 @@ docs = ] ) ( \case - (x : xs) -> + x : xs -> (x NE.:| xs) & traverse Path.parseHQSplit' - & bimap fromString Input.DocsI + & bimap P.text Input.DocsI _ -> Left (I.help docs) ) @@ -694,7 +695,7 @@ renameTerm = "`move.term foo bar` renames `foo` to `bar`." ( \case [oldName, newName] -> first P.text do - src <- mapLeft Text.pack (Path.parseHQSplit' oldName) + src <- Path.parseHQSplit' oldName target <- Path.parseSplit' newName pure $ Input.MoveTermI src target _ -> @@ -736,7 +737,7 @@ renameType = "`move.type foo bar` renames `foo` to `bar`." ( \case [oldName, newName] -> first P.text do - src <- mapLeft Text.pack (Path.parseHQSplit' oldName) + src <- Path.parseHQSplit' oldName target <- Path.parseSplit' newName pure $ Input.MoveTypeI src target _ -> @@ -784,7 +785,7 @@ deleteGen suffix queryCompletionArg target mkTarget = info ( \case [] -> Left . P.warnCallout $ P.wrap warn - queries -> first fromString $ do + queries -> first P.text do paths <- traverse Path.parseHQSplit' queries pure $ Input.DeleteI (mkTarget paths) ) @@ -914,16 +915,15 @@ aliasTerm = I.Visible [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)] "`alias.term foo bar` introduces `bar` with the same definition as `foo`." - ( \case - [oldName, newName] -> first P.text do - source <- mapLeft Text.pack (Path.parseShortHashOrHQSplit' oldName) - target <- Path.parseSplit' newName - pure $ Input.AliasTermI source target - _ -> - Left . warn $ - P.wrap - "`alias.term` takes two arguments, like `alias.term oldname newname`." - ) + \case + [oldName, newName] -> first P.text do + source <- Path.parseShortHashOrHQSplit' oldName + target <- Path.parseSplit' newName + pure $ Input.AliasTermI source target + _ -> + Left . warn $ + P.wrap + "`alias.term` takes two arguments, like `alias.term oldname newname`." aliasType :: InputPattern aliasType = @@ -933,16 +933,15 @@ aliasType = I.Visible [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)] "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`." - ( \case - [oldName, newName] -> first P.text do - source <- mapLeft Text.pack (Path.parseShortHashOrHQSplit' oldName) - target <- Path.parseSplit' newName - pure $ Input.AliasTypeI source target - _ -> - Left . warn $ - P.wrap - "`alias.type` takes two arguments, like `alias.type oldname newname`." - ) + \case + [oldName, newName] -> first P.text do + source <- Path.parseShortHashOrHQSplit' oldName + target <- Path.parseSplit' newName + pure $ Input.AliasTypeI source target + _ -> + Left . warn $ + P.wrap + "`alias.type` takes two arguments, like `alias.type oldname newname`." aliasMany :: InputPattern aliasMany = @@ -960,13 +959,12 @@ aliasMany = <> "creates aliases `.quux.foo.foo` and `.quux.bar.bar`." ] ) - ( \case - srcs@(_ : _) Cons.:> dest -> first P.text do - sourceDefinitions <- mapLeft Text.pack (traverse Path.parseHQSplit srcs) - destNamespace <- Path.parsePath' dest - pure $ Input.AliasManyI sourceDefinitions destNamespace - _ -> Left (I.help aliasMany) - ) + \case + srcs@(_ : _) Cons.:> dest -> first P.text do + sourceDefinitions <- traverse Path.parseHQSplit srcs + destNamespace <- Path.parsePath' dest + pure $ Input.AliasManyI sourceDefinitions destNamespace + _ -> Left (I.help aliasMany) up :: InputPattern up = @@ -1007,13 +1005,12 @@ cd = ] ] ) - ( \case - [".."] -> Right Input.UpI - [p] -> first P.text do - p <- Path.parsePath' p - pure . Input.SwitchBranchI $ p - _ -> Left (I.help cd) - ) + \case + [".."] -> Right Input.UpI + [p] -> first P.text do + p <- Path.parsePath' p + pure . Input.SwitchBranchI $ p + _ -> Left (I.help cd) back :: InputPattern back = @@ -1028,10 +1025,9 @@ back = ) ] ) - ( \case - [] -> pure Input.PopBranchI - _ -> Left (I.help cd) - ) + \case + [] -> pure Input.PopBranchI + _ -> Left (I.help cd) deleteNamespace :: InputPattern deleteNamespace = @@ -1056,17 +1052,15 @@ deleteNamespaceForce = (deleteNamespaceParser (I.help deleteNamespaceForce) Input.Force) deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> [String] -> Either (P.Pretty CT.ColorText) Input -deleteNamespaceParser helpText insistence = - ( \case - ["."] -> - first fromString - . pure - $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) - [p] -> first P.text do - p <- Path.parseSplit' p - pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p)) - _ -> Left helpText - ) +deleteNamespaceParser helpText insistence = \case + ["."] -> + first fromString + . pure + $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) + [p] -> first P.text do + p <- Path.parseSplit' p + pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p)) + _ -> Left helpText deletePatch :: InputPattern deletePatch = @@ -1076,12 +1070,11 @@ deletePatch = I.Visible [("patch to delete", Required, patchArg)] "`delete.patch ` deletes the patch `foo`" - ( \case - [p] -> first P.text do - p <- Path.parseSplit' p - pure . Input.DeleteI $ DeleteTarget'Patch p - _ -> Left (I.help deletePatch) - ) + \case + [p] -> first P.text do + p <- Path.parseSplit' p + pure . Input.DeleteI $ DeleteTarget'Patch p + _ -> Left (I.help deletePatch) movePatch :: String -> String -> Either (P.Pretty CT.ColorText) Input movePatch src dest = first P.text do @@ -1103,10 +1096,9 @@ copyPatch = I.Visible [("patch to copy", Required, patchArg), ("copy destination", Required, newNameArg)] "`copy.patch foo bar` copies the patch `foo` to `bar`." - ( \case - [src, dest] -> copyPatch' src dest - _ -> Left (I.help copyPatch) - ) + \case + [src, dest] -> copyPatch' src dest + _ -> Left (I.help copyPatch) renamePatch :: InputPattern renamePatch = @@ -1116,10 +1108,9 @@ renamePatch = I.Visible [("patch", Required, patchArg), ("new location", Required, newNameArg)] "`move.patch foo bar` renames the patch `foo` to `bar`." - ( \case - [src, dest] -> movePatch src dest - _ -> Left (I.help renamePatch) - ) + \case + [src, dest] -> movePatch src dest + _ -> Left (I.help renamePatch) renameBranch :: InputPattern renameBranch = @@ -1129,13 +1120,12 @@ renameBranch = I.Visible [("namespace to move", Required, namespaceArg), ("new location", Required, newNameArg)] "`move.namespace foo bar` renames the path `foo` to `bar`." - ( \case - [src, dest] -> first P.text do - src <- Path.parsePath' src - dest <- Path.parsePath' dest - pure $ Input.MoveBranchI src dest - _ -> Left (I.help renameBranch) - ) + \case + [src, dest] -> first P.text do + src <- Path.parsePath' src + dest <- Path.parsePath' dest + pure $ Input.MoveBranchI src dest + _ -> Left (I.help renameBranch) history :: InputPattern history = @@ -1153,13 +1143,12 @@ history = ) ] ) - ( \case - [src] -> first P.text do - p <- Input.parseBranchId src - pure $ Input.HistoryI (Just 10) (Just 10) p - [] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath) - _ -> Left (I.help history) - ) + \case + [src] -> first P.text do + p <- Input.parseBranchId src + pure $ Input.HistoryI (Just 10) (Just 10) p + [] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath) + _ -> Left (I.help history) forkLocal :: InputPattern forkLocal = @@ -1182,13 +1171,12 @@ forkLocal = ) ] ) - ( \case - [src, dest] -> do - src <- Input.parseBranchId2 src - dest <- parseBranchRelativePath dest - pure $ Input.ForkLocalBranchI src dest - _ -> Left (I.help forkLocal) - ) + \case + [src, dest] -> do + src <- Input.parseBranchId2 src + dest <- parseBranchRelativePath dest + pure $ Input.ForkLocalBranchI src dest + _ -> Left (I.help forkLocal) reset :: InputPattern reset = @@ -1257,12 +1245,11 @@ resetRoot = ) ] ) - ( \case - [src] -> first P.text $ do - src <- Input.parseBranchId src - pure $ Input.ResetRootI src - _ -> Left (I.help resetRoot) - ) + \case + [src] -> first P.text $ do + src <- Input.parseBranchId src + pure $ Input.ResetRootI src + _ -> Left (I.help resetRoot) pull :: InputPattern pull = @@ -1420,11 +1407,10 @@ debugFuzzyOptions = P.wrap $ "or `debug.fuzzy-options merge - _`" ] ) - ( \case - (cmd : args) -> - Right $ Input.DebugFuzzyOptionsI cmd args - _ -> Left (I.help debugFuzzyOptions) - ) + \case + (cmd : args) -> + Right $ Input.DebugFuzzyOptionsI cmd args + _ -> Left (I.help debugFuzzyOptions) push :: InputPattern push = @@ -2063,33 +2049,32 @@ help = I.Visible [("command", Optional, commandNameArg)] "`help` shows general help and `help ` shows help for one command." - ( \case - [] -> - Left $ - intercalateMap - "\n\n" - showPatternHelp - visibleInputs - [cmd] -> - case (Map.lookup cmd commandsByName, isHelp cmd) of - (Nothing, Just msg) -> Left msg - (Nothing, Nothing) -> Left . warn $ "I don't know of that command. Try `help`." - (Just pat, Nothing) -> Left $ showPatternHelp pat - -- If we have a command and a help topic with the same name (like "projects"), then append a tip to the - -- command's help that suggests running `help-topic command` - (Just pat, Just _) -> - Left $ - showPatternHelp pat - <> P.newline - <> P.newline - <> ( tip $ - "To read more about" - <> P.group (P.string cmd <> ",") - <> "use" - <> makeExample helpTopics [P.string cmd] - ) - _ -> Left $ warn "Use `help ` or `help`." - ) + \case + [] -> + Left $ + intercalateMap + "\n\n" + showPatternHelp + visibleInputs + [cmd] -> + case (Map.lookup cmd commandsByName, isHelp cmd) of + (Nothing, Just msg) -> Left msg + (Nothing, Nothing) -> Left . warn $ "I don't know of that command. Try `help`." + (Just pat, Nothing) -> Left $ showPatternHelp pat + -- If we have a command and a help topic with the same name (like "projects"), then append a tip to the + -- command's help that suggests running `help-topic command` + (Just pat, Just _) -> + Left $ + showPatternHelp pat + <> P.newline + <> P.newline + <> ( tip $ + "To read more about" + <> P.group (P.string cmd <> ",") + <> "use" + <> makeExample helpTopics [P.string cmd] + ) + _ -> Left $ warn "Use `help ` or `help`." where commandsByName = Map.fromList $ do @@ -2106,10 +2091,9 @@ quit = I.Visible [] "Exits the Unison command line interface." - ( \case - [] -> pure Input.QuitI - _ -> Left "Use `quit`, `exit`, or to quit." - ) + \case + [] -> pure Input.QuitI + _ -> Left "Use `quit`, `exit`, or to quit." viewPatch :: InputPattern viewPatch = @@ -2127,13 +2111,12 @@ viewPatch = ) ] ) - ( \case - [] -> Right $ Input.ListEditsI Nothing - [patchStr] -> mapLeft P.text do - patch <- Path.parseSplit' patchStr - Right $ Input.ListEditsI (Just patch) - _ -> Left $ warn "`view.patch` takes a patch and that's it." - ) + \case + [] -> Right $ Input.ListEditsI Nothing + [patchStr] -> mapLeft P.text do + patch <- Path.parseSplit' patchStr + Right $ Input.ListEditsI (Just patch) + _ -> Left $ warn "`view.patch` takes a patch and that's it." names :: Input.IsGlobal -> InputPattern names isGlobal = @@ -2143,15 +2126,14 @@ names isGlobal = I.Visible [("name or hash", Required, definitionQueryArg)] (P.wrap $ makeExample (names isGlobal) ["foo"] <> " shows the hash and all known names for `foo`.") - ( \case - [thing] -> case HQ.fromString thing of - Just hq -> Right $ Input.NamesI isGlobal hq - Nothing -> - Left $ - "I was looking for one of these forms: " - <> P.blue "foo .foo.bar foo#abc #abcde .foo.bar#asdf" - _ -> Left (I.help (names isGlobal)) - ) + \case + [thing] -> case HQ.fromString thing of + Just hq -> Right $ Input.NamesI isGlobal hq + Nothing -> + Left $ + "I was looking for one of these forms: " + <> P.blue "foo .foo.bar foo#abc #abcde .foo.bar#asdf" + _ -> Left (I.help (names isGlobal)) where cmdName = if isGlobal then "names.global" else "names" @@ -2163,10 +2145,9 @@ dependents = I.Visible [("definition", Required, definitionQueryArg)] "List the named dependents of the specified definition." - ( \case - [thing] -> fmap Input.ListDependentsI $ parseHashQualifiedName thing - _ -> Left (I.help dependents) - ) + \case + [thing] -> fmap Input.ListDependentsI $ parseHashQualifiedName thing + _ -> Left (I.help dependents) dependencies = InputPattern "dependencies" @@ -2174,10 +2155,9 @@ dependencies = I.Visible [("definition", Required, definitionQueryArg)] "List the dependencies of the specified definition." - ( \case - [thing] -> fmap Input.ListDependenciesI $ parseHashQualifiedName thing - _ -> Left (I.help dependencies) - ) + \case + [thing] -> fmap Input.ListDependenciesI $ parseHashQualifiedName thing + _ -> Left (I.help dependencies) namespaceDependencies :: InputPattern namespaceDependencies = @@ -2187,13 +2167,12 @@ namespaceDependencies = I.Visible [("namespace", Optional, namespaceArg)] "List the external dependencies of the specified namespace." - ( \case - [p] -> first P.text do - p <- Path.parsePath' p - pure $ Input.NamespaceDependenciesI (Just p) - [] -> pure (Input.NamespaceDependenciesI Nothing) - _ -> Left (I.help namespaceDependencies) - ) + \case + [p] -> first P.text do + p <- Path.parsePath' p + pure $ Input.NamespaceDependenciesI (Just p) + [] -> pure (Input.NamespaceDependenciesI Nothing) + _ -> Left (I.help namespaceDependencies) debugNumberedArgs :: InputPattern debugNumberedArgs = @@ -2566,10 +2545,10 @@ createAuthor = ) ) ( \case - symbolStr : authorStr@(_ : _) -> first fromString do + symbolStr : authorStr@(_ : _) -> first P.text do symbol <- - Megaparsec.runParser (NameSegment.segmentP <* Megaparsec.eof) "" symbolStr - & mapLeft (Text.unpack . NameSegment.renderParseErr) + Megaparsec.runParser (Megaparsec.withParsecT (fmap NameSegment.renderParseErr) NameSegment.segmentP <* Megaparsec.eof) "" symbolStr + & mapLeft (Text.pack . Megaparsec.errorBundlePretty) -- let's have a real parser in not too long let author :: Text author = Text.pack $ case (unwords authorStr) of diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index b5646cb964..afd846b397 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -19,14 +19,11 @@ module Unison.Syntax.Lexer debugLex''', showEscapeChar, touches, - -- todo: these probably don't belong here + + -- * Character classifiers wordyIdChar, wordyIdStartChar, - wordyId, - symbolyId, symbolyIdChar, - wordyId0, - symbolyId0, ) where @@ -52,13 +49,13 @@ import Unison.NameSegment (NameSegment (NameSegment)) import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.ShortHash (ShortHash) -import Unison.ShortHash qualified as SH import Unison.Syntax.HashQualified' qualified as HQ' (toString) import Unison.Syntax.Lexer.Token (Token (..), posP, tokenP) import Unison.Syntax.Name qualified as Name (isSymboly, nameP, toText, unsafeFromString) import Unison.Syntax.NameSegment (symbolyIdChar, wordyIdChar, wordyIdStartChar) -import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr(..), wordyP) -import Unison.Syntax.ReservedWords (keywords, reservedOperators, typeModifiers, typeOrAbility) +import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr (..), wordyP) +import Unison.Syntax.ReservedWords (delimiters, typeModifiers, typeOrAbility) +import Unison.Syntax.ShortHash qualified as ShortHash (shortHashP) import Unison.Util.Bytes qualified as Bytes import Unison.Util.Monoid (intercalateMap) @@ -71,8 +68,7 @@ data ParsingEnv = ParsingEnv opening :: Maybe BlockName, -- `Just b` if a block of type `b` is being opened inLayout :: Bool, -- are we inside a construct that uses layout? parentSection :: Int, -- 1 means we are inside a # Heading 1 - parentListColumn :: Int -- 4 means we are inside a list starting - -- at the fourth column + parentListColumn :: Int -- 4 means we are inside a list starting at the fourth column } deriving (Show) @@ -852,7 +848,7 @@ lexemes' eof = num sign n = Numeric (fromMaybe "" sign <> show n) sign = P.optional (lit "+" <|> lit "-") - hash = Hash <$> P.try shorthashP + hash = Hash <$> P.try shortHashP reserved :: P [Token Lexeme] reserved = @@ -1043,7 +1039,7 @@ identifierP :: P (HQ'.HashQualified Name) identifierP = do P.label "identifier (ex: abba1, snake_case, .foo.++#xyz, or 🌻)" do name <- PI.withParsecT (fmap nameSegmentParseErrToErr) Name.nameP - P.optional shorthashP <&> \case + P.optional shortHashP <&> \case Nothing -> HQ'.fromName name Just shorthash -> HQ'.HashQualified name shorthash where @@ -1072,17 +1068,9 @@ wordyIdSegP :: P NameSegment wordyIdSegP = PI.withParsecT (fmap (ReservedWordyId . Text.unpack)) NameSegment.wordyP -shorthashP :: P ShortHash -shorthashP = - P.label hashMsg do - P.lookAhead (char '#') - -- `foo#xyz` should parse - Token potentialHash start _ <- tokenP $ P.takeWhile1P (Just hashMsg) (\ch -> not (isSep ch) && ch /= '`') - case SH.fromText (Text.pack potentialHash) of - Nothing -> err start (InvalidShortHash potentialHash) - Just sh -> pure sh - where - hashMsg = "hash (ex: #af3sj3)" +shortHashP :: P ShortHash +shortHashP = + PI.withParsecT (fmap (InvalidShortHash . Text.unpack)) ShortHash.shortHashP blockDelimiter :: [String] -> P String -> P [Token Lexeme] blockDelimiter open closeP = do @@ -1227,8 +1215,7 @@ lexer scope rem = isDelayOrForce :: Char -> Bool isDelayOrForce op = op == '\'' || op == '!' --- Mapping between characters and their escape codes. Use parse/showEscapeChar --- to convert. +-- Mapping between characters and their escape codes. Use parse/showEscapeChar to convert. escapeChars :: [(Char, Char)] escapeChars = [ ('0', '\0'), @@ -1250,54 +1237,6 @@ showEscapeChar :: Char -> Maybe Char showEscapeChar c = Map.lookup c (Map.fromList [(x, y) | (y, x) <- escapeChars]) -isSep :: Char -> Bool -isSep c = isSpace c || Set.member c delimiters - --- Not a keyword, '.' delimited list of wordyId0 (should not include a trailing '.') -wordyId0 :: String -> Either Err (String, String) -wordyId0 s = span' wordyIdChar s \case - (id@(ch : _), rem) - | not (Set.member (Text.pack id) keywords) - && wordyIdStartChar ch -> - Right (id, rem) - (id, _rem) -> Left (InvalidWordyId id) - -symbolyId :: String -> Either Err (String, String) -symbolyId r@('.' : s) - | s == "" = symbolyId0 r -- - | isSpace (head s) = symbolyId0 r -- lone dot treated as an operator - | isDelimiter (head s) = symbolyId0 r -- - | otherwise = (\(s, rem) -> ('.' : s, rem)) <$> symbolyId' s -symbolyId s = symbolyId' s - --- Is a '.' delimited list of wordyId, with a final segment of `symbolyId0` -symbolyId' :: String -> Either Err (String, String) -symbolyId' s = case wordyId0 s of - Left _ -> symbolyId0 s - Right (wid, '.' : rem) -> case symbolyId rem of - Left e -> Left e - Right (rest, rem) -> Right (wid <> "." <> rest, rem) - Right (w, _) -> Left (InvalidSymbolyId w) - -wordyId :: String -> Either Err (String, String) -wordyId ('.' : s) = (\(s, rem) -> ('.' : s, rem)) <$> wordyId' s -wordyId s = wordyId' s - --- Is a '.' delimited list of wordyId -wordyId' :: String -> Either Err (String, String) -wordyId' s = case wordyId0 s of - Left e -> Left e - Right (wid, '.' : rem@(ch : _)) | wordyIdStartChar ch -> case wordyId rem of - Left e -> Left e - Right (rest, rem) -> Right (wid <> "." <> rest, rem) - Right (w, rem) -> Right (w, rem) - --- Returns either an error or an id and a remainder -symbolyId0 :: String -> Either Err (String, String) -symbolyId0 s = span' symbolyIdChar s \case - (id@(_ : _), rem) | not (Set.member (Text.pack id) reservedOperators) -> Right (id, rem) - (id, _rem) -> Left (InvalidSymbolyId id) - typeOrAbilityAlt :: (Alternative f) => (Text -> f a) -> f a typeOrAbilityAlt f = asum $ map f (toList typeOrAbility) @@ -1306,12 +1245,6 @@ typeModifiersAlt :: (Alternative f) => (Text -> f a) -> f a typeModifiersAlt f = asum $ map f (toList typeModifiers) -delimiters :: Set Char -delimiters = Set.fromList "()[]{},?;" - -isDelimiter :: Char -> Bool -isDelimiter ch = Set.member ch delimiters - inc :: Pos -> Pos inc (Pos line col) = Pos line (col + 1) @@ -1343,9 +1276,6 @@ debugLex' = debugLex'' . lexer "debugLex" debugLex''' :: String -> String -> String debugLex''' s = debugLex'' . lexer s -span' :: (a -> Bool) -> [a] -> (([a], [a]) -> r) -> r -span' f a k = k (span f a) - instance EP.ShowErrorComponent (Token Err) where showErrorComponent (Token err _ _) = go err where diff --git a/unison-syntax/src/Unison/Syntax/Lexer/Token.hs b/unison-syntax/src/Unison/Syntax/Lexer/Token.hs index 91c1787f46..81842c409e 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer/Token.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer/Token.hs @@ -5,9 +5,11 @@ module Unison.Syntax.Lexer.Token ) where +import Data.Text qualified as Text import Text.Megaparsec (ParsecT, TraversableStream) import Text.Megaparsec qualified as P import Unison.Lexer.Pos (Pos (Pos)) +import Unison.Prelude data Token a = Token { payload :: a, @@ -20,6 +22,23 @@ 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 +-- This instance is odd, but useful. +-- +-- The lexer prefers to throw custom errors as `Token Err`. It also calls out to other parsers (like the name segment +-- parser) that don't know about `Err`, but throw custom errors as `Token Something` for the lexer to inject into +-- `Token Err`. +-- +-- ...then there are yet more callers of these other parsers that don't want an annoying `Token Something`, they just +-- want a simple string error message. +-- +-- So, the flow aided by this instance is roughly: +-- +-- 1. Run some parser, using `withParsecT` as necessary to unify the potentially-different `Token Something` errors +-- as a `Token Text`. +-- 2. `prettyErrorBundle` that thing. +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 p = do start <- posP diff --git a/unison-syntax/src/Unison/Syntax/Name.hs b/unison-syntax/src/Unison/Syntax/Name.hs index 2d9742a789..87db9a90ff 100644 --- a/unison-syntax/src/Unison/Syntax/Name.hs +++ b/unison-syntax/src/Unison/Syntax/Name.hs @@ -22,7 +22,6 @@ where import Control.Monad.Combinators.NonEmpty qualified as Monad import Data.List.NonEmpty (pattern (:|)) -import Data.List.NonEmpty qualified as List (NonEmpty) import Data.Text qualified as Text import Data.Text.Lazy qualified as Text.Lazy import Data.Text.Lazy.Builder qualified as Text (Builder) @@ -30,15 +29,16 @@ import Data.Text.Lazy.Builder qualified as Text.Builder import Text.Megaparsec (ParsecT) import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P +import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.Name qualified as Name (fromSegments, lastSegment, makeAbsolute) import Unison.Name.Internal (Name (Name)) -import Unison.NameSegment (NameSegment (NameSegment)) +import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment import Unison.Position (Position (..)) import Unison.Prelude import Unison.Syntax.Lexer.Token (Token) import Unison.Syntax.NameSegment (segmentStartChar) -import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr, isSymboly, segmentP) +import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr, isSymboly, renderParseErr, segmentP) import Unison.Var (Var) import Unison.Var qualified as Var @@ -86,30 +86,10 @@ fromText = eitherToMaybe . fromTextEither -- | Parse a name from a string literal. --- --- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes --- no attempt at rejecting bogus names like "foo...bar...baz". fromTextEither :: Text -> Either Text Name -fromTextEither = \case - "" -> Left "empty name" - "." -> Right $ Name Relative ("." :| []) - ".." -> Right $ Name Absolute ("." :| []) - name - | Text.any (== '#') name -> Left ("not a name: " <> tShow name) - | Text.head name == '.' -> Name Absolute <$> (go (Text.tail name)) - | otherwise -> Name Relative <$> go name - where - go :: Text -> Either Text (List.NonEmpty NameSegment) - go name = - if ".." `Text.isSuffixOf` name - then Right $ "." :| split (Text.dropEnd 2 name) - else case split name of - [] -> Left "empty name" - s : ss -> Right $ s :| ss - - split :: Text -> [NameSegment] - split = - reverse . map NameSegment . Text.split (== '.') +fromTextEither s = + P.runParser (P.withParsecT (fmap NameSegment.renderParseErr) nameP <* P.eof) "" (Text.unpack s) + & mapLeft (Text.pack . P.errorBundlePretty) -- | Unsafely parse a name from a string literal. -- See 'unsafeFromText'. diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index c0e4191944..daf3a34f03 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -7,11 +7,11 @@ module Unison.Syntax.NameSegment isSymboly, -- * Name segment classifiers + ParseErr (..), + renderParseErr, segmentP, symbolyP, wordyP, - ParseErr (..), - renderParseErr, -- * Character classifiers segmentStartChar, @@ -22,7 +22,6 @@ module Unison.Syntax.NameSegment where import Data.Char qualified as Char -import Data.List.NonEmpty qualified as List.NonEmpty import Data.Set qualified as Set import Data.Text qualified as Text import Text.Megaparsec (ParsecT) @@ -45,6 +44,16 @@ unsafeFromText = ------------------------------------------------------------------------------------------------------------------------ -- Name segment parsers +data ParseErr + = ReservedOperator !Text + | ReservedWord !Text + deriving stock (Eq, Ord) + +renderParseErr :: ParseErr -> Text +renderParseErr = \case + ReservedOperator s -> "reserved operator: " <> s + ReservedWord s -> "reserved word: " <> s + segmentP :: Monad m => ParsecT (Token ParseErr) [Char] m NameSegment segmentP = P.withParsecT (fmap ReservedOperator) symbolyP @@ -107,24 +116,6 @@ wordyP = do where wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" -data ParseErr - = ReservedOperator !Text - | ReservedWord !Text - deriving stock (Eq, Ord) - -instance P.ShowErrorComponent ParseErr where - showErrorComponent = \case - ReservedOperator s -> Text.unpack ("reserved operator: " <> s) - ReservedWord s -> Text.unpack ("reserved word: " <> s) - errorComponentLen = \case - ReservedOperator s -> Text.length s - ReservedWord s -> Text.length s - --- | A convenience function for rendering a name segment parse error, because it's so weird and verbose to do so. -renderParseErr :: P.ParseErrorBundle [Char] (Token ParseErr) -> Text -renderParseErr = - Text.pack . P.parseErrorTextPretty . P.mapParseError payload . List.NonEmpty.head . P.bundleErrors - ------------------------------------------------------------------------------------------------------------------------ -- Character classifiers diff --git a/unison-syntax/src/Unison/Syntax/ReservedWords.hs b/unison-syntax/src/Unison/Syntax/ReservedWords.hs index e6072f1b57..c9b9cce59f 100644 --- a/unison-syntax/src/Unison/Syntax/ReservedWords.hs +++ b/unison-syntax/src/Unison/Syntax/ReservedWords.hs @@ -3,6 +3,7 @@ module Unison.Syntax.ReservedWords typeModifiers, typeOrAbility, reservedOperators, + delimiters, ) where @@ -57,3 +58,7 @@ reservedOperators = "'", "==>" ] + +delimiters :: Set Char +delimiters = + Set.fromList "()[]{},?;" diff --git a/unison-syntax/src/Unison/Syntax/ShortHash.hs b/unison-syntax/src/Unison/Syntax/ShortHash.hs new file mode 100644 index 0000000000..9d6cfba4e8 --- /dev/null +++ b/unison-syntax/src/Unison/Syntax/ShortHash.hs @@ -0,0 +1,38 @@ +-- | Utilities related to the parsing and printing of short hashes using the default syntax. +module Unison.Syntax.ShortHash + ( -- * Short hash parsers + shortHashP, + ) +where + +import Data.Char qualified as Char +import Data.Set qualified as Set +import Data.Text qualified as Text +import Text.Megaparsec (ParsecT) +import Text.Megaparsec qualified as P +import Text.Megaparsec.Char qualified as P +import Unison.Prelude +import Unison.ShortHash (ShortHash) +import Unison.ShortHash qualified as ShortHash +import Unison.Syntax.Lexer.Token (Token (..), tokenP) +import Unison.Syntax.ReservedWords (delimiters) + +-- | A short hash parser. +-- +-- Throws the parsed hash as an error if it's invalid. +shortHashP :: ParsecT (Token Text) [Char] m ShortHash +shortHashP = + P.label hashMsg do + P.lookAhead (P.char '#') + token <- + tokenP do + Text.pack <$> P.takeWhile1P (Just hashMsg) (\ch -> not (isSep ch) && ch /= '`') + case ShortHash.fromText (payload token) of + Nothing -> P.customFailure token + Just sh -> pure sh + where + hashMsg = "hash (ex: #af3sj3)" + + isSep :: Char -> Bool + isSep c = + Char.isSpace c || Set.member c delimiters diff --git a/unison-syntax/unison-syntax.cabal b/unison-syntax/unison-syntax.cabal index aa607ee77c..48f5d0dd24 100644 --- a/unison-syntax/unison-syntax.cabal +++ b/unison-syntax/unison-syntax.cabal @@ -27,6 +27,7 @@ library Unison.Syntax.NameSegment Unison.Syntax.Parser Unison.Syntax.ReservedWords + Unison.Syntax.ShortHash Unison.UnisonFile.Error hs-source-dirs: src From 8871927c6ef963322678f018dfa8f3f224bcb7af Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 24 Jan 2024 11:01:22 -0500 Subject: [PATCH 12/41] more path, name, and name segment work (doesn't build yet) --- .../U/Codebase/Sqlite/Operations.hs | 28 +++---- .../U/Codebase/Sqlite/Queries.hs | 14 ++++ codebase2/core/Unison/NameSegment.hs | 42 ++++++---- parser-typechecker/src/U/Codebase/Projects.hs | 2 +- .../src/Unison/Codebase/Branch.hs | 7 +- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 3 +- .../src/Unison/Codebase/Path.hs | 36 ++++----- .../src/Unison/Codebase/Path/Parse.hs | 23 +++++- .../src/Unison/Hashing/V2/Convert.hs | 3 +- parser-typechecker/src/Unison/PrintError.hs | 8 +- parser-typechecker/src/Unison/Project/Util.hs | 46 ++++++++--- .../src/Unison/Syntax/FileParser.hs | 4 +- .../src/Unison/Syntax/TermParser.hs | 10 +-- .../src/Unison/Syntax/TermPrinter.hs | 4 +- .../tests/Unison/Core/Test/Name.hs | 33 ++++---- .../src/Unison/CommandLine/Completion.hs | 79 ++++++++++--------- unison-core/src/Unison/Name.hs | 13 +-- unison-share-api/src/Unison/Server/Backend.hs | 19 ++--- .../src/Unison/Server/CodebaseServer.hs | 9 +-- unison-share-api/src/Unison/Server/Local.hs | 18 ++++- .../Unison/Server/Local/Endpoints/Current.hs | 11 +-- .../Server/Local/Endpoints/FuzzyFind.hs | 12 +-- .../Local/Endpoints/NamespaceDetails.hs | 15 ++-- .../Local/Endpoints/NamespaceListing.hs | 11 ++- unison-share-api/src/Unison/Server/Orphans.hs | 10 +-- unison-share-api/src/Unison/Server/Syntax.hs | 4 +- unison-share-api/src/Unison/Server/Types.hs | 6 +- unison-src/tests/imports.u | 2 - unison-src/tests/methodical/dots.u | 14 ++-- unison-syntax/src/Unison/Syntax/Lexer.hs | 8 +- unison-syntax/src/Unison/Syntax/Name.hs | 9 ++- .../src/Unison/Syntax/NameSegment.hs | 29 +++++-- 32 files changed, 312 insertions(+), 220 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 723f760334..5088899990 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -200,8 +200,7 @@ import U.Util.Base32Hex qualified as Base32Hex import U.Util.Serialization qualified as S import Unison.Hash qualified as H import Unison.Hash32 qualified as Hash32 -import Unison.NameSegment (NameSegment (NameSegment)) -import Unison.NameSegment qualified as NameSegment +import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.ShortHash (ShortCausalHash (..), ShortNamespaceHash (..)) import Unison.Sqlite @@ -577,7 +576,7 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = Transaction (Map NameSegment (Map C.Referent (Transaction C.Branch.MdValues))) doTerms = Map.bitraverse - (fmap NameSegment . Q.expectText) + Q.expectNameSegment ( Map.bitraverse s2cReferent \case S.MetadataSet.Inline rs -> pure $ C.Branch.MdValues <$> loadTypesForMetadata rs @@ -587,7 +586,7 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = Transaction (Map NameSegment (Map C.Reference (Transaction C.Branch.MdValues))) doTypes = Map.bitraverse - (fmap NameSegment . Q.expectText) + Q.expectNameSegment ( Map.bitraverse s2cReference \case S.MetadataSet.Inline rs -> pure $ C.Branch.MdValues <$> loadTypesForMetadata rs @@ -595,14 +594,14 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = doPatches :: Map Db.TextId Db.PatchObjectId -> Transaction (Map NameSegment (PatchHash, Transaction C.Branch.Patch)) - doPatches = Map.bitraverse (fmap NameSegment . Q.expectText) \patchId -> do + doPatches = Map.bitraverse Q.expectNameSegment \patchId -> do h <- PatchHash <$> (Q.expectPrimaryHashByObjectId . Db.unPatchObjectId) patchId pure (h, expectPatch patchId) doChildren :: Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) -> Transaction (Map NameSegment (C.Branch.CausalBranch Transaction)) - doChildren = Map.bitraverse (fmap NameSegment . Q.expectText) \(boId, chId) -> + doChildren = Map.bitraverse Q.expectNameSegment \(boId, chId) -> C.Causal <$> Q.expectCausalHash chId <*> expectValueHashByCausalHashId chId @@ -718,15 +717,15 @@ saveNamespace hh bhId me = do c2sBranch :: BranchV Transaction -> Transaction DbBranchV c2sBranch = \case BranchV2 branch -> do - terms <- Map.bitraverse saveNameSegment (Map.bitraverse c2sReferent c2sMetadata) (branch ^. #terms) - types <- Map.bitraverse saveNameSegment (Map.bitraverse c2sReference c2sMetadata) (branch ^. #types) - patches <- Map.bitraverse saveNameSegment savePatchObjectId (branch ^. #patches) - children <- Map.bitraverse saveNameSegment (saveBranch hh) (branch ^. #children) + terms <- Map.bitraverse Q.saveNameSegment (Map.bitraverse c2sReferent c2sMetadata) (branch ^. #terms) + types <- Map.bitraverse Q.saveNameSegment (Map.bitraverse c2sReference c2sMetadata) (branch ^. #types) + patches <- Map.bitraverse Q.saveNameSegment savePatchObjectId (branch ^. #patches) + children <- Map.bitraverse Q.saveNameSegment (saveBranch hh) (branch ^. #children) pure (DbBranchV2 S.Branch {terms, types, patches, children}) BranchV3 branch -> do - children <- Map.bitraverse saveNameSegment (saveBranchV3 hh) (branch ^. #children) - terms <- Map.bitraverse saveNameSegment c2sReferent (branch ^. #terms) - types <- Map.bitraverse saveNameSegment c2sReference (branch ^. #types) + children <- Map.bitraverse Q.saveNameSegment (saveBranchV3 hh) (branch ^. #children) + terms <- Map.bitraverse Q.saveNameSegment c2sReferent (branch ^. #terms) + types <- Map.bitraverse Q.saveNameSegment c2sReference (branch ^. #types) pure (DbBranchV3 S.BranchV3 {children, terms, types}) c2sMetadata :: Transaction C.Branch.MdValues -> Transaction S.Branch.Full.DbMetadataSet @@ -740,9 +739,6 @@ saveNamespace hh bhId me = do patch <- mp savePatch hh h patch - saveNameSegment :: NameSegment -> Transaction Db.TextId - saveNameSegment = Q.saveText . NameSegment.toText - -- Save just the causal object (i.e. the `causal` row and its associated `causal_parents`). Internal helper shared by -- `saveBranch` and `saveBranchV3`. saveCausalObject :: diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index ab44fa29ef..cb8cfc6008 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -16,6 +16,10 @@ module U.Codebase.Sqlite.Queries expectText, expectTextCheck, + -- ** name segments + saveNameSegment, + expectNameSegment, + -- * hash table saveHash, saveHashes, @@ -388,6 +392,8 @@ import Unison.Hash qualified as Hash import Unison.Hash32 (Hash32) import Unison.Hash32 qualified as Hash32 import Unison.Hash32.Orphans.Sqlite () +import Unison.NameSegment (NameSegment) +import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Sqlite import Unison.Util.Alternative qualified as Alternative @@ -645,6 +651,14 @@ loadTextSql h = WHERE id = :h |] +saveNameSegment :: NameSegment -> Transaction TextId +saveNameSegment = + saveText . NameSegment.toUnescapedText + +expectNameSegment :: TextId -> Transaction NameSegment +expectNameSegment = + fmap NameSegment.unsafeFromUnescapedText . expectText + saveHashObject :: HashId -> ObjectId -> HashVersion -> Transaction () saveHashObject hId oId version = execute diff --git a/codebase2/core/Unison/NameSegment.hs b/codebase2/core/Unison/NameSegment.hs index 615d687166..9270625359 100644 --- a/codebase2/core/Unison/NameSegment.hs +++ b/codebase2/core/Unison/NameSegment.hs @@ -4,14 +4,31 @@ import Data.Text qualified as Text import Data.Text.Lazy.Builder qualified as Text (Builder) import Data.Text.Lazy.Builder qualified as Text.Builder import Unison.Prelude -import Unison.Util.Alphabetical (Alphabetical, compareAlphabetical) +import Unison.Util.Alphabetical (Alphabetical) -- Represents the parts of a name between the `.`s -newtype NameSegment = NameSegment {toText :: Text} +newtype NameSegment + = UnsafeNameSegment Text deriving stock (Eq, Ord, Generic) + deriving newtype (Alphabetical) -instance Alphabetical NameSegment where - compareAlphabetical n1 n2 = compareAlphabetical (toText n1) (toText n2) +instance Show NameSegment where + show = show . toUnescapedText + +-- | Convert a text to a name segment, when the text is known to be a valid name segment. +-- +-- For example, to make a name segment containing the text ".~", use @unsafeFromUnescapedText ".~"@, even if that +-- operator would need to be escaped (e.g. "`.~`") when written by a user. +unsafeFromUnescapedText :: Text -> NameSegment +unsafeFromUnescapedText = + UnsafeNameSegment + +-- | Convert a name segment to unescaped text. +-- +-- > toUnescapedText (unsafeFromText ".~") = ".~" +toUnescapedText :: NameSegment -> Text +toUnescapedText = + coerce -- Split text into segments. A smarter version of `Text.splitOn` that handles -- the name `.` properly. @@ -44,20 +61,17 @@ reverseSegments' = go in seg : go rem isEmpty :: NameSegment -> Bool -isEmpty ns = toText ns == mempty +isEmpty = + coerce Text.null isPrefixOf :: NameSegment -> NameSegment -> Bool -isPrefixOf n1 n2 = Text.isPrefixOf (toText n1) (toText n2) - -toString :: NameSegment -> String -toString = Text.unpack . toText +isPrefixOf = + coerce Text.isPrefixOf toTextBuilder :: NameSegment -> Text.Builder toTextBuilder = coerce Text.Builder.fromText -instance IsString NameSegment where - fromString = NameSegment . Text.pack - -instance Show NameSegment where - show = show . toText +libSegment :: NameSegment +libSegment = + unsafeFromUnescapedText "lib" diff --git a/parser-typechecker/src/U/Codebase/Projects.hs b/parser-typechecker/src/U/Codebase/Projects.hs index b3a8fd53e1..387da9c737 100644 --- a/parser-typechecker/src/U/Codebase/Projects.hs +++ b/parser-typechecker/src/U/Codebase/Projects.hs @@ -11,7 +11,7 @@ import U.Codebase.Causal qualified as Causal import U.Codebase.HashTags (BranchHash (..)) import Unison.Codebase.Path import Unison.Codebase.Path qualified as Path -import Unison.Name (libSegment) +import Unison.NameSegment (libSegment) import Unison.Prelude import Unison.Sqlite qualified as Sqlite import Unison.Util.Monoid (ifoldMapM) diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 2c1dd569f7..b6f27682b9 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -120,6 +120,7 @@ import Unison.Hashing.V2.Convert qualified as H import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) +import Unison.NameSegment qualified as NameSegment import Unison.Prelude hiding (empty) import Unison.Reference (TermReference, TypeReference) import Unison.Referent (Referent) @@ -151,7 +152,7 @@ withoutLib Branch0 {..} = _children & imapMaybe ( \nameSegment child -> - if nameSegment == Name.libSegment + if nameSegment == NameSegment.libSegment then Nothing else Just (child & head_ %~ withoutLib) ) @@ -165,7 +166,7 @@ withoutTransitiveLibs Branch0 {..} = _children & imapMaybe ( \nameSegment child -> - if nameSegment == Name.libSegment + if nameSegment == NameSegment.libSegment then Just (child & head_ %~ withoutLib) else Just (child & head_ %~ withoutTransitiveLibs) ) @@ -348,7 +349,7 @@ deepChildrenHelper (reversePrefix, libDepth, b0) = do pure if isShallowDependency || isUnseenNamespace then - let libDepth' = if ns == "lib" then libDepth + 1 else libDepth + let libDepth' = if ns == NameSegment.libSegment then libDepth + 1 else libDepth in Seq.singleton (ns : reversePrefix, libDepth', head b) else Seq.empty State.modify' (Set.insert h) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 1233168378..005be11df1 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -12,6 +12,7 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Share.Types import Unison.Util.Monoid qualified as Monoid +import qualified Unison.NameSegment as NameSegment data ReadRepo = ReadRepoGit ReadGitRepo @@ -131,7 +132,7 @@ data ReadShareLooseCode = ReadShareLooseCode isPublic :: ReadShareLooseCode -> Bool isPublic ReadShareLooseCode {path} = case path of - ("public" Path.:< _) -> True + ((NameSegment.toUnescapedText -> "public") Path.:< _) -> True _ -> False data WriteRemoteNamespace a diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index 672877b2e5..64122cd5fc 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -54,7 +54,6 @@ module Unison.Codebase.Path toName', unsafeToName, unsafeToName', - toPath', toText, toText', unsplit, @@ -92,12 +91,10 @@ import GHC.Exts qualified as GHC import Unison.HashQualified' qualified as HQ' import Unison.Name (Convert (..), Name, Parse) import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment (NameSegment)) -import Unison.NameSegment qualified as NameSegment +import Unison.NameSegment (NameSegment) import Unison.Prelude hiding (empty, toList) -import Unison.Syntax.Name qualified as Name (unsafeFromText) +import Unison.Syntax.Name qualified as Name (toText, unsafeFromText) import Unison.Util.List qualified as List -import Unison.Util.Monoid (intercalateMap) -- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"] newtype Path = Path {toSeq :: Seq NameSegment} @@ -226,12 +223,6 @@ relativeEmpty' = RelativePath' (Relative empty) absoluteEmpty' :: Path' absoluteEmpty' = AbsolutePath' (Absolute empty) --- | Mitchell: this function is bogus, because an empty name segment is bogus -toPath' :: Path -> Path' -toPath' = \case - Path (NameSegment "" :<| tail) -> AbsolutePath' . Absolute . Path $ tail - p -> Path' . Right . Relative $ p - -- Forget whether the path is absolute or relative fromPath' :: Path' -> Path fromPath' = \case @@ -357,12 +348,15 @@ instance Show Path where -- | Note: This treats the path as relative. toText :: Path -> Text -toText (Path nss) = intercalateMap "." NameSegment.toText nss +toText path = + case toName path of + Nothing -> "." + Just name -> Name.toText name fromText :: Text -> Path fromText = \case "" -> empty - t -> fromList $ NameSegment <$> NameSegment.segments' t + text -> fromName (Name.unsafeFromText text) -- | Construct a Path' from a text -- @@ -375,16 +369,16 @@ fromText = \case -- >>> show $ fromText' "" -- "" fromText' :: Text -> Path' -fromText' txt = - case Text.uncons txt of - Nothing -> relativeEmpty' - Just ('.', p) -> AbsolutePath' . Absolute $ fromText p - Just _ -> RelativePath' . Relative $ fromText txt +fromText' = \case + "" -> RelativePath' (Relative mempty) + "." -> AbsolutePath' (Absolute mempty) + text -> fromName' (Name.unsafeFromText text) toText' :: Path' -> Text -toText' = \case - AbsolutePath' (Absolute path) -> Text.cons '.' (toText path) - RelativePath' (Relative path) -> toText path +toText' path = + case toName' path of + Nothing -> if isAbsolute path then "." else "" + Just name -> Name.toText name {-# COMPLETE Empty, (:<) #-} diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs index 443b73f70e..f99d08df83 100644 --- a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -1,9 +1,16 @@ module Unison.Codebase.Path.Parse - ( parsePath', + ( -- * Path parsing functions + parsePath, + parsePath', + parseSplit, parseSplit', parseHQSplit, parseHQSplit', parseShortHashOrHQSplit', + + -- * Path parsers + splitP, + splitP', ) where @@ -23,11 +30,21 @@ import Unison.Syntax.ShortHash qualified as ShortHash ------------------------------------------------------------------------------------------------------------------------ -- Path parsing functions +parsePath :: String -> Either Text Path +parsePath = \case + "" -> Right empty + path -> unsplit <$> parseSplit path + parsePath' :: String -> Either Text Path' parsePath' = \case + "" -> Right relativeEmpty' "." -> Right absoluteEmpty' path -> unsplit' <$> parseSplit' path +parseSplit :: String -> Either Text Split +parseSplit = + runParser splitP + parseSplit' :: String -> Either Text Split' parseSplit' = runParser splitP' @@ -54,6 +71,10 @@ runParser p = ------------------------------------------------------------------------------------------------------------------------ -- Path parsers +splitP :: Parsec (Lexer.Token Text) [Char] Split +splitP = + splitFromName <$> P.withParsecT (fmap NameSegment.renderParseErr) Name.relativeNameP + splitP' :: Parsec (Lexer.Token Text) [Char] Split' splitP' = splitFromName' <$> P.withParsecT (fmap NameSegment.renderParseErr) Name.nameP diff --git a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs index 18880e2d96..09769d43e8 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs @@ -412,4 +412,5 @@ m2hBranch0 b = doChildren = Map.bimap m2hNameSegment (unCausalHash . Memory.Branch.headHash) m2hNameSegment :: Memory.NameSegment.NameSegment -> Hashing.NameSegment -m2hNameSegment (Memory.NameSegment.NameSegment s) = Hashing.NameSegment s +m2hNameSegment = + Hashing.NameSegment . Memory.NameSegment.toUnescapedText diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 3a6c26b664..2a2419b527 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -26,7 +26,7 @@ import Unison.Kind qualified as Kind import Unison.KindInference.Error.Pretty (prettyKindError) import Unison.Name (Name) import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment (..)) +import Unison.NameSegment qualified as NameSegment import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names import Unison.Parser.Ann (Ann (..)) @@ -635,7 +635,7 @@ renderTypeError e env src curPath = case e of C.Exact -> (_1 %~ ((name, typ) :)) . r C.WrongType -> (_2 %~ ((name, typ) :)) . r C.WrongName -> (_3 %~ ((name, typ) :)) . r - libPath = Path.absoluteToPath' curPath Path.:> "lib" + libPath = Path.absoluteToPath' curPath Path.:> NameSegment.libSegment in mconcat [ "I couldn't find any definitions matching the name ", style ErrorSite (Var.nameStr unknownTermV), @@ -653,7 +653,7 @@ renderTypeError e env src curPath = case e of ) <> "\n\n" <> "To add a library to this project use the command: " - <> Pr.backticked ("fork <.path.to.lib> " <> Pr.shown (libPath Path.:> "")), + <> Pr.backticked ("fork <.path.to.lib> " <> Pr.shown libPath <> "."), "\n\n", case expectedType of Type.Var' (TypeVar.Existential {}) -> "There are no constraints on its type." @@ -1632,7 +1632,7 @@ renderParseErrors s = \case else unknownTypesMsg <> "\n\n" <> dupDataAndAbilitiesMsg in (msgs, allRanges) go (Parser.DidntExpectExpression _tok (Just t@(L.payload -> L.SymbolyId (HQ'.NameOnly name)))) - | name == Name.fromSegment (NameSegment "::") = + | name == Name.fromSegment (NameSegment.unsafeFromUnescapedText "::") = let msg = mconcat [ "This looks like the start of an expression here but I was expecting a binding.", diff --git a/parser-typechecker/src/Unison/Project/Util.hs b/parser-typechecker/src/Unison/Project/Util.hs index d82e118acc..f660554e31 100644 --- a/parser-typechecker/src/Unison/Project/Util.hs +++ b/parser-typechecker/src/Unison/Project/Util.hs @@ -8,6 +8,8 @@ module Unison.Project.Util projectContextFromPath, pattern UUIDNameSegment, ProjectContext (..), + pattern ProjectsNameSegment, + pattern BranchesNameSegment, ) where @@ -18,6 +20,7 @@ import Data.UUID qualified as UUID import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..)) import Unison.Codebase.Path qualified as Path import Unison.NameSegment (NameSegment (..)) +import Unison.NameSegment qualified as NameSegment import Unison.Project (ProjectAndBranch (..)) -- | Get the path that a project is stored at. Users aren't supposed to go here. @@ -34,7 +37,7 @@ projectPath projectId = -- .__projects._ABCD.branches projectBranchesPath :: ProjectId -> Path.Absolute projectBranchesPath projectId = - snoc (projectPath projectId) "branches" + snoc (projectPath projectId) BranchesNameSegment -- | Get the path that a branch is stored at. Users aren't supposed to go here. -- @@ -54,9 +57,12 @@ projectBranchSegment (ProjectBranchId branchId) = pattern UUIDNameSegment :: UUID -> NameSegment pattern UUIDNameSegment uuid <- - NameSegment (Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid)) + ( NameSegment.toUnescapedText -> + (Text.uncons -> Just ('_', UUID.fromText . Text.map (\c -> if c == '_' then '-' else c) -> Just uuid)) + ) where - UUIDNameSegment uuid = NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid))) + UUIDNameSegment uuid = + NameSegment.unsafeFromUnescapedText (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid))) -- | The prism between paths like -- @@ -75,16 +81,12 @@ projectPathPrism = where toPath :: ProjectId -> Path.Absolute toPath projectId = - Path.Absolute $ - Path.fromList - [ "__projects", - UUIDNameSegment (unProjectId projectId) - ] + Path.Absolute (Path.fromList [ProjectsNameSegment, UUIDNameSegment (unProjectId projectId)]) toId :: Path.Absolute -> Maybe ProjectId toId path = case Path.toList (Path.unabsolute path) of - ["__projects", UUIDNameSegment projectId] -> Just (ProjectId projectId) + [ProjectsNameSegment, UUIDNameSegment projectId] -> Just (ProjectId projectId) _ -> Nothing -- | The prism between paths like @@ -106,9 +108,9 @@ projectBranchPathPrism = toPath (ProjectAndBranch {project = projectId, branch = branchId}, restPath) = Path.Absolute $ Path.fromList - ( [ "__projects", + ( [ ProjectsNameSegment, UUIDNameSegment (unProjectId projectId), - "branches", + BranchesNameSegment, UUIDNameSegment (unProjectBranchId branchId) ] ++ Path.toList restPath @@ -117,7 +119,7 @@ projectBranchPathPrism = toIds :: Path.Absolute -> Maybe (ProjectAndBranch ProjectId ProjectBranchId, Path.Path) toIds path = case Path.toList (Path.unabsolute path) of - "__projects" : UUIDNameSegment projectId : "branches" : UUIDNameSegment branchId : restPath -> + ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : restPath -> Just (ProjectAndBranch {project = ProjectId projectId, branch = ProjectBranchId branchId}, Path.fromList restPath) _ -> Nothing @@ -136,3 +138,23 @@ projectContextFromPath path = ProjectBranchPath projectId branchId restPath Nothing -> LooseCodePath path + +pattern ProjectsNameSegment :: NameSegment +pattern ProjectsNameSegment <- + ((== projectsNameSegment) -> True) + where + ProjectsNameSegment = projectsNameSegment + +pattern BranchesNameSegment :: NameSegment +pattern BranchesNameSegment <- + ((== branchesNameSegment) -> True) + where + BranchesNameSegment = branchesNameSegment + +projectsNameSegment :: NameSegment +projectsNameSegment = + NameSegment.unsafeFromUnescapedText "__projects" + +branchesNameSegment :: NameSegment +branchesNameSegment = + NameSegment.unsafeFromUnescapedText "branches" diff --git a/parser-typechecker/src/Unison/Syntax/FileParser.hs b/parser-typechecker/src/Unison/Syntax/FileParser.hs index dc812c972b..7f35cadd30 100644 --- a/parser-typechecker/src/Unison/Syntax/FileParser.hs +++ b/parser-typechecker/src/Unison/Syntax/FileParser.hs @@ -9,7 +9,7 @@ import Unison.ABT qualified as ABT import Unison.DataDeclaration (DataDeclaration) import Unison.DataDeclaration qualified as DD import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment (..)) +import Unison.NameSegment qualified as NameSegment import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names import Unison.NamesWithHistory qualified as Names @@ -220,7 +220,7 @@ watched = P.try do kind <- (fmap . fmap . fmap) Name.toString (optional importWordyId) guid <- uniqueName 10 op <- optional (L.payload <$> P.lookAhead importSymbolyId) - guard (op == Just (Name.fromSegment (NameSegment ">"))) + guard (op == Just (Name.fromSegment (NameSegment.unsafeFromUnescapedText ">"))) tok <- anyToken guard $ maybe True (`L.touches` tok) kind pure (maybe UF.RegularWatch L.payload kind, guid, maybe mempty ann kind <> ann tok) diff --git a/parser-typechecker/src/Unison/Syntax/TermParser.hs b/parser-typechecker/src/Unison/Syntax/TermParser.hs index 49fff2ea81..fe62ffa443 100644 --- a/parser-typechecker/src/Unison/Syntax/TermParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TermParser.hs @@ -33,7 +33,6 @@ import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment (..)) import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Names qualified as Names @@ -46,6 +45,7 @@ import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.Syntax.Lexer qualified as L import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeFromVar) +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Syntax.Parser hiding (seq) import Unison.Syntax.Parser qualified as Parser (seq, uniqueName) import Unison.Syntax.TypeParser qualified as TypeParser @@ -418,7 +418,7 @@ symbolyQuasikeyword kw = queryToken \case nameIsKeyword :: Name -> Text -> Bool nameIsKeyword name keyword = case (Name.isRelative name, Name.reverseSegments name) of - (True, segment NonEmpty.:| []) -> NameSegment.toText segment == keyword + (True, segment NonEmpty.:| []) -> NameSegment.toEscapedText segment == keyword _ -> False -- If the hash qualified is name only, it is treated as a var, if it @@ -969,9 +969,9 @@ bang = P.label "bang" do seqOp :: (Ord v) => P v m Pattern.SeqOp seqOp = - Pattern.Snoc <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment ":+")))) - <|> Pattern.Cons <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment "+:")))) - <|> Pattern.Concat <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment "++")))) + Pattern.Snoc <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment.unsafeFromUnescapedText ":+")))) + <|> Pattern.Cons <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment.unsafeFromUnescapedText "+:")))) + <|> Pattern.Concat <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment.unsafeFromUnescapedText "++")))) term4 :: (Monad m, Var v) => TermP v m term4 = f <$> some termLeaf diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index 6a1a28e572..ba22d5ea86 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -39,7 +39,6 @@ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) -import Unison.NameSegment qualified as NameSegment import Unison.Pattern (Pattern) import Unison.Pattern qualified as Pattern import Unison.Prelude @@ -55,6 +54,7 @@ import Unison.Syntax.HashQualified qualified as HQ (unsafeFromVar) import Unison.Syntax.Lexer (showEscapeChar) import Unison.Syntax.Name qualified as Name (fromText, fromTextEither, isSymboly, toText, unsafeFromText) import Unison.Syntax.NamePrinter (styleHashQualified'') +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Term import Unison.Type (Type, pattern ForallsNamed') @@ -1308,7 +1308,7 @@ countName n = { usages = Map.fromList do (p, s) <- Name.splits n - pure (Name.toText s, Map.singleton (map NameSegment.toText p) 1) + pure (Name.toText s, Map.singleton (map NameSegment.toEscapedText p) 1) } joinName :: Prefix -> Suffix -> Name diff --git a/parser-typechecker/tests/Unison/Core/Test/Name.hs b/parser-typechecker/tests/Unison/Core/Test/Name.hs index fbf7cc8205..41413eae58 100644 --- a/parser-typechecker/tests/Unison/Core/Test/Name.hs +++ b/parser-typechecker/tests/Unison/Core/Test/Name.hs @@ -6,6 +6,7 @@ import Data.Set qualified as Set import EasyTest import Unison.Name as Name import Unison.Syntax.Name qualified as Name (unsafeFromText) +import Unison.Syntax.NameSegment qualified as NameSegment (unsafeFromText) import Unison.Util.Relation qualified as R test :: Test () @@ -67,7 +68,7 @@ testSuffixes = expectEqual (suffixes "foo.bar") ["foo.bar", "bar"], scope "multiple namespaces" $ expectEqual (suffixes "foo.bar.baz") ["foo.bar.baz", "bar.baz", "baz"], - scope "terms named `.`" $ expectEqual (suffixes "base..") ["base..", "."] + scope "terms named `.`" $ expectEqual (suffixes "base.`.`") ["base.`.`", "`.`"] ] testSuffixSearch :: [Test ()] @@ -81,11 +82,11 @@ testSuffixSearch = (n "foo.bar.baz", 3), (n "a.b.c", 4), (n "a1.b.c", 5), - (n "..", 6) + (n ".`.`", 6) ] n = Name.unsafeFromText - expectEqual' ("." :| []) (Name.segments (n "..")) - expectEqual' ("." :| []) (Name.reverseSegments (n "..")) + expectEqual' (NameSegment.unsafeFromText "." :| []) (Name.reverseSegments (n ".`.`")) + expectEqual' (NameSegment.unsafeFromText "." :| []) (Name.reverseSegments (n ".`.`")) expectEqual' (Set.fromList [1, 2]) @@ -105,13 +106,13 @@ testSuffixSearch = expectEqual' (n "a1.b.c") (Name.suffixifyByHash (n "a1.b.c") rel) - note . show $ Name.reverseSegments (n ".") - note . show $ Name.reverseSegments (n "..") + note . show $ Name.reverseSegments (n "`.`") + note . show $ Name.reverseSegments (n ".`.`") tests [ scope "(.) shortest unique suffix" $ - expectEqual' (n ".") (Name.suffixifyByHash (n "..") rel), + expectEqual' (n "`.`") (Name.suffixifyByHash (n ".`.`") rel), scope "(.) search by suffix" $ - expectEqual' (Set.fromList [6]) (Name.searchBySuffix (n ".") rel) + expectEqual' (Set.fromList [6]) (Name.searchBySuffix (n "`.`") rel) ] ok ] @@ -119,12 +120,12 @@ testSuffixSearch = testUnsafeFromString :: [Test ()] testUnsafeFromString = [ scope "." do - expectEqual' (isAbsolute ".") False - expectEqual' (segments ".") ("." :| []) + expectEqual' (isAbsolute "`.`") False + expectEqual' (segments "`.`") (NameSegment.unsafeFromText "." :| []) ok, - scope ".." do - expectEqual' (isAbsolute "..") True - expectEqual' (segments "..") ("." :| []) + scope ".`.`" do + expectEqual' (isAbsolute ".`.`") True + expectEqual' (segments ".`.`") (NameSegment.unsafeFromText "." :| []) ok, scope "foo.bar" do expectEqual' (isAbsolute "foo.bar") False @@ -134,8 +135,8 @@ testUnsafeFromString = expectEqual' (isAbsolute ".foo.bar") True expectEqual' (segments ".foo.bar") ("foo" :| ["bar"]) ok, - scope "foo.." do - expectEqual' (isAbsolute "foo..") False - expectEqual' (segments "foo..") ("foo" :| ["."]) + scope "foo.`.`" do + expectEqual' (isAbsolute "foo.`.`") False + expectEqual' (segments "foo.`.`") ("foo" :| [NameSegment.unsafeFromText "."]) ok ] diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index bdaf4a1ddc..2088faeb1f 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -37,6 +37,7 @@ import Network.URI qualified as URI import System.Console.Haskeline qualified as Line import System.Console.Haskeline.Completion (Completion) import System.Console.Haskeline.Completion qualified as Haskeline +import Text.Megaparsec qualified as P import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.Reference qualified as Reference @@ -45,10 +46,11 @@ import Unison.Auth.HTTPClient (AuthenticatedHttpClient (..)) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path +import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.CommandLine.InputPattern qualified as IP import Unison.HashQualified' qualified as HQ' -import Unison.NameSegment (NameSegment (NameSegment)) +import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Server.Local.Endpoints.NamespaceListing (NamespaceListing (NamespaceListing)) @@ -57,6 +59,7 @@ import Unison.Server.Types qualified as Server import Unison.Share.Codeserver qualified as Codeserver import Unison.Share.Types qualified as Share import Unison.Sqlite qualified as Sqlite +import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as P import UnliftIO qualified @@ -144,7 +147,7 @@ completeWithinNamespace compTypes query currentPath = do currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib - & fmap (\(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> NameSegment.NameSegment match)) + & fmap (\(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> NameSegment.unsafeFromText match)) & filter (\(_isFinished, match) -> List.isPrefixOf query match) & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) & pure @@ -173,7 +176,7 @@ completeWithinNamespace compTypes query currentPath = do nib <- namesInBranch shortHashLen childBranch nib & fmap - ( \(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> suffix Lens.:> NameSegment.NameSegment match) + ( \(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> suffix Lens.:> NameSegment.unsafeFromText match) ) & filter (\(_isFinished, match) -> List.isPrefixOf query match) & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) @@ -185,13 +188,13 @@ completeWithinNamespace compTypes query currentPath = do textifyHQ f xs = xs & hashQualifyCompletions f - & fmap (HQ'.toTextWith NameSegment.toText) + & fmap (HQ'.toTextWith NameSegment.toEscapedText) & fmap (True,) pure $ - ((False,) <$> dotifyNamespaces (fmap NameSegment.toText . Map.keys $ nonEmptyChildren)) + ((False,) <$> dotifyNamespaces (fmap NameSegment.toEscapedText . Map.keys $ nonEmptyChildren)) <> Monoid.whenM (NESet.member TermCompletion compTypes) (textifyHQ (hqFromNamedV2Referent hashLen) $ V2Branch.terms b) <> Monoid.whenM (NESet.member TypeCompletion compTypes) (textifyHQ (hqFromNamedV2Reference hashLen) $ V2Branch.types b) - <> Monoid.whenM (NESet.member PatchCompletion compTypes) (fmap ((True,) . NameSegment.toText) . Map.keys $ V2Branch.patches b) + <> Monoid.whenM (NESet.member PatchCompletion compTypes) (fmap ((True,) . NameSegment.toEscapedText) . Map.keys $ V2Branch.patches b) -- Regrettably there'shqFromNamedV2Referencenot a great spot to combinators for V2 references and shorthashes right now. hqFromNamedV2Referent :: Int -> NameSegment -> Referent.Referent -> HQ'.HashQualified NameSegment @@ -205,7 +208,7 @@ completeWithinNamespace compTypes query currentPath = do -- completions. qualifyRefs :: NameSegment -> Map r metadata -> [HQ'.HashQualified NameSegment] qualifyRefs n refs - | ((Text.isInfixOf "#" . NameSegment.toText) querySuffix) || length refs > 1 = refs & Map.keys <&> qualify n + | ((Text.isInfixOf "#" . NameSegment.toEscapedText) querySuffix) || length refs > 1 = refs & Map.keys <&> qualify n | otherwise = [HQ'.NameOnly n] -- If we're not completing namespaces, then all namespace completions should automatically @@ -241,22 +244,24 @@ completeWithinNamespace compTypes query currentPath = do -- -- >>> parseLaxPath'Query "base.List" -- (base,"List") -parseLaxPath'Query :: Text -> (Path.Path', NameSegment) +parseLaxPath'Query :: Text -> (Path.Path', Text) parseLaxPath'Query txt = - case unsnoc (Text.splitOn "." txt) of - -- This case is impossible due to the behaviour of 'splitOn' - Nothing -> - (Path.relativeEmpty', NameSegment "") - -- ".base." - -- ".base.List" - Just ("" : pathPrefix, querySegment) -> (Path.AbsolutePath' . Path.Absolute . Path.fromList . fmap NameSegment $ pathPrefix, NameSegment querySegment) - -- "" - -- "base" - -- "base.List" - Just (pathPrefix, querySegment) -> - ( Path.RelativePath' . Path.Relative . Path.fromList . fmap NameSegment $ pathPrefix, - NameSegment querySegment - ) + case P.runParser (((,) <$> Path.splitP' <*> P.takeRest) "" (Text.unpack txt)) of + _ -> wundefined + +-- case unsnoc (Text.splitOn "." txt) of +-- -- This case is impossible due to the behaviour of 'splitOn' +-- Nothing -> undefined +-- -- ".base." +-- -- ".base.List" +-- Just ("" : pathPrefix, querySegment) -> (Path.AbsolutePath' . Path.Absolute . Path.fromList . fmap NameSegment $ pathPrefix, NameSegment querySegment) +-- -- "" +-- -- "base" +-- -- "base.List" +-- Just (pathPrefix, querySegment) -> +-- ( Path.RelativePath' . Path.Relative . Path.fromList . fmap NameSegment $ pathPrefix, +-- NameSegment querySegment +-- ) -- | Completes a namespace argument by prefix-matching against the query. prefixCompleteNamespace :: @@ -350,19 +355,21 @@ shareCompletion :: m [Completion] shareCompletion completionTypes authHTTPClient str = fromMaybe [] <$> runMaybeT do - case Text.splitOn "." (Text.pack str) of - [] -> empty - [userPrefix] -> do - userHandles <- searchUsers authHTTPClient userPrefix + case Path.toList <$> Path.parsePath str of + Left _err -> empty + Right [] -> empty + Right [userPrefix] -> do + userHandles <- searchUsers authHTTPClient (NameSegment.toEscapedText userPrefix) pure $ userHandles - & filter (userPrefix `Text.isPrefixOf`) - <&> \handle -> prettyCompletionWithQueryPrefix False (Text.unpack userPrefix) (Text.unpack handle) - userHandle : path -> do - (userHandle, path, pathSuffix) <- case unsnoc path of - Just (path, pathSuffix) -> pure (userHandle, Path.fromList (NameSegment <$> path), pathSuffix) - Nothing -> pure (userHandle, Path.empty, "") - NamespaceListing {namespaceListingChildren} <- MaybeT $ fetchShareNamespaceInfo authHTTPClient userHandle path + & filter (\userHandle -> NameSegment.toEscapedText userPrefix `Text.isPrefixOf` userHandle) + <&> \handle -> prettyCompletionWithQueryPrefix False (Text.unpack (NameSegment.toEscapedText userPrefix)) (Text.unpack handle) + Right (userHandle : path0) -> do + let (path, pathSuffix) = + case unsnoc path0 of + Just (path, pathSuffix) -> (Path.fromList path, pathSuffix) + Nothing -> (Path.empty, "") + NamespaceListing {namespaceListingChildren} <- MaybeT $ fetchShareNamespaceInfo authHTTPClient (NameSegment.toEscapedText userHandle) path namespaceListingChildren & fmap ( \case @@ -370,16 +377,16 @@ shareCompletion completionTypes authHTTPClient str = let name = Server.namespaceName nn in (NamespaceCompletion, name) Server.TermObject nt -> - let name = HQ'.toTextWith NameSegment.toText $ Server.termName nt + let name = HQ'.toTextWith NameSegment.toEscapedText $ Server.termName nt in (NamespaceCompletion, name) Server.TypeObject nt -> - let name = HQ'.toTextWith NameSegment.toText $ Server.typeName nt + let name = HQ'.toTextWith NameSegment.toEscapedText $ Server.typeName nt in (TermCompletion, name) Server.PatchObject np -> let name = Server.patchName np in (NamespaceCompletion, name) ) - & filter (\(typ, name) -> typ `NESet.member` completionTypes && pathSuffix `Text.isPrefixOf` name) + & filter (\(typ, name) -> typ `NESet.member` completionTypes && NameSegment.toEscapedText pathSuffix `Text.isPrefixOf` name) & fmap ( \(_, name) -> let queryPath = userHandle : coerce (Path.toList path) diff --git a/unison-core/src/Unison/Name.hs b/unison-core/src/Unison/Name.hs index 58a096fc61..327f60edfb 100644 --- a/unison-core/src/Unison/Name.hs +++ b/unison-core/src/Unison/Name.hs @@ -37,7 +37,6 @@ module Unison.Name -- * To organize later commonPrefix, - libSegment, preferShallowLibDepth, searchByRankedSuffix, searchBySuffix, @@ -67,7 +66,7 @@ import Data.Monoid (Sum (..)) import Data.RFC5051 qualified as RFC5051 import Data.Set qualified as Set import Unison.Name.Internal -import Unison.NameSegment (NameSegment (NameSegment)) +import Unison.NameSegment (NameSegment (..)) import Unison.NameSegment qualified as NameSegment import Unison.Position (Position (..)) import Unison.Prelude @@ -361,16 +360,13 @@ preferShallowLibDepth = \case [x] -> Set.singleton (snd x) rs -> let byDepth = List.multimap (map (first minLibs) rs) - libCount = length . filter (== libSegment) . toList . reverseSegments + libCount = length . filter (== NameSegment.libSegment) . toList . reverseSegments minLibs [] = 0 minLibs ns = minimum (map libCount ns) in case Map.lookup 0 byDepth <|> Map.lookup 1 byDepth of Nothing -> Set.fromList (map snd rs) Just rs -> Set.fromList rs -libSegment :: NameSegment -libSegment = NameSegment "lib" - sortByText :: (a -> Text) -> [a] -> [a] sortByText by as = let as' = [(a, by a) | a <- as] @@ -574,10 +570,5 @@ class Convert a b where class Parse a b where parse :: a -> Maybe b -instance Parse Text NameSegment where - parse txt = case NameSegment.segments' txt of - [n] -> Just (NameSegment.NameSegment n) - _ -> Nothing - instance (Parse a a2, Parse b b2) => Parse (a, b) (a2, b2) where parse (a, b) = (,) <$> parse a <*> parse b diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 3da76b8027..dd96b1109a 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -168,6 +168,7 @@ import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.HashQualified' qualified as HQ' (toText) import Unison.Syntax.Name as Name (toText, unsafeFromText) import Unison.Syntax.NamePrinter qualified as NP +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText, unsafeFromText) import Unison.Syntax.TermPrinter qualified as TermPrinter import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Term (Term) @@ -202,8 +203,8 @@ listEntryName :: ShallowListEntry v a -> Text listEntryName = \case ShallowTermEntry te -> termEntryDisplayName te ShallowTypeEntry te -> typeEntryDisplayName te - ShallowBranchEntry n _ _ -> NameSegment.toText n - ShallowPatchEntry n -> NameSegment.toText n + ShallowBranchEntry n _ _ -> NameSegment.toEscapedText n + ShallowPatchEntry n -> NameSegment.toEscapedText n data BackendError = NoSuchNamespace Path.Absolute @@ -285,7 +286,7 @@ termEntryLabeledDependencies TermEntry {termEntryType, termEntryReferent, termEn _ -> error "termEntryLabeledDependencies: not a constructor, but one was required" termEntryDisplayName :: TermEntry v a -> Text -termEntryDisplayName = HQ'.toTextWith NameSegment.toText . termEntryHQName +termEntryDisplayName = HQ'.toTextWith NameSegment.toEscapedText . termEntryHQName termEntryHQName :: TermEntry v a -> HQ'.HashQualified NameSegment termEntryHQName TermEntry {termEntryName, termEntryConflicted, termEntryHash} = @@ -307,7 +308,7 @@ typeEntryLabeledDependencies TypeEntry {typeEntryReference} = Set.singleton (LD.TypeReference typeEntryReference) typeEntryDisplayName :: TypeEntry -> Text -typeEntryDisplayName = HQ'.toTextWith NameSegment.toText . typeEntryHQName +typeEntryDisplayName = HQ'.toTextWith NameSegment.toEscapedText . typeEntryHQName typeEntryHQName :: TypeEntry -> HQ'.HashQualified NameSegment typeEntryHQName TypeEntry {typeEntryName, typeEntryConflicted, typeEntryReference} = @@ -761,7 +762,7 @@ mkTypeDefinition codebase pped namesRoot rootCausal width r docs tp = do liftIO $ Codebase.runTransaction codebase do causalAtPath <- Codebase.getShallowCausalAtPath namesRoot (Just rootCausal) branchAtPath <- V2Causal.value causalAtPath - typeEntryTag <$> typeListEntry codebase (Just branchAtPath) (ExactName (NameSegment bn) r) + typeEntryTag <$> typeListEntry codebase (Just branchAtPath) (ExactName (NameSegment.unsafeFromText bn) r) pure $ TypeDefinition (HQ'.toText <$> PPE.allTypeNames fqnPPE r) @@ -795,7 +796,7 @@ mkTermDefinition codebase termPPED namesRoot rootCausal width r docs tm = do tag <- lift ( termEntryTag - <$> termListEntry codebase (Just branchAtPath) (ExactName (NameSegment bn) (Cv.referent1to2 referent)) + <$> termListEntry codebase (Just branchAtPath) (ExactName (NameSegment.unsafeFromText bn) (Cv.referent1to2 referent)) ) mk ts bn tag where @@ -873,7 +874,7 @@ docsForDefinitionName :: Name -> IO [TermReference] docsForDefinitionName codebase (NameSearch {termSearch}) searchType name = do - let potentialDocNames = [name, name Cons.:> "doc"] + let potentialDocNames = [name, name Cons.:> NameSegment.unsafeFromUnescapedText "doc"] Codebase.runTransaction codebase do refs <- potentialDocNames & foldMapM \name -> @@ -918,7 +919,7 @@ docsInBranchToHtmlFiles runtime codebase root currentPath directory = do let currentBranch = Branch.getAt' currentPath root let allTerms = (R.toList . Branch.deepTerms . Branch.head) currentBranch -- ignores docs inside lib namespace, recursively - let notLib (_, name) = "lib" `notElem` Name.segments name + let notLib (_, name) = NameSegment.libSegment `notElem` Name.segments name (docTermsWithNames, hqLength) <- Codebase.runTransaction codebase do docTermsWithNames <- filterM (isDoc codebase . fst) (filter notLib allTerms) @@ -948,7 +949,7 @@ docsInBranchToHtmlFiles runtime codebase root currentPath directory = do docFilePath :: FilePath -> Name -> FilePath docFilePath destination docFQN = let (dir, fileName) = - case unsnoc . map NameSegment.toString . toList . Name.segments $ docFQN of + case unsnoc . map (Text.unpack . NameSegment.toUnescapedText) . toList . Name.segments $ docFQN of Just (path, leafName) -> (directoryPath path, docFileName leafName) Nothing -> diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index 1e83d59d3f..edad8053d2 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -91,7 +90,6 @@ import Unison.Codebase.Runtime qualified as Rt import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.HashQualified import Unison.Name as Name (Name, segments) -import Unison.NameSegment qualified as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) @@ -111,6 +109,7 @@ import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer) import Unison.Server.Types (mungeString, setCacheControl) import Unison.ShortHash qualified as ShortHash import Unison.Symbol (Symbol) +import Unison.Syntax.NameSegment qualified as NameSegment -- HTML content type data HTML = HTML @@ -256,7 +255,7 @@ urlFor service baseUrl = namespacePath path = if path == Path.empty then [] - else [DontEscape "namespaces"] <> (EscapeMe . NameSegment.toText <$> Path.toList path) + else [DontEscape "namespaces"] <> (EscapeMe . NameSegment.toEscapedText <$> Path.toList path) definitionPath :: Maybe DefinitionReference -> Maybe [URISegment] definitionPath def = @@ -274,11 +273,11 @@ urlFor service baseUrl = refToUrlText r = case r of NameOnly n -> - n & Name.segments & fmap (EscapeMe . NameSegment.toText) & toList + n & Name.segments & fmap (EscapeMe . NameSegment.toEscapedText) & toList HashOnly h -> [EscapeMe $ ShortHash.toText h] HashQualified n _ -> - n & Name.segments & fmap (EscapeMe . NameSegment.toText) & toList + n & Name.segments & fmap (EscapeMe . NameSegment.toEscapedText) & toList toDefinitionPath :: DefinitionReference -> [URISegment] toDefinitionPath d = diff --git a/unison-share-api/src/Unison/Server/Local.hs b/unison-share-api/src/Unison/Server/Local.hs index b0075557e2..16e00a742a 100644 --- a/unison-share-api/src/Unison/Server/Local.hs +++ b/unison-share-api/src/Unison/Server/Local.hs @@ -13,7 +13,9 @@ import U.Codebase.Causal qualified as Causal import Unison.Codebase.Path import Unison.Codebase.Path qualified as Path import Unison.HashQualified qualified as HQ -import Unison.Name (Name, libSegment) +import Unison.Name (Name) +import Unison.NameSegment (libSegment) +import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Server.Backend import Unison.Sqlite qualified as Sqlite @@ -59,7 +61,19 @@ inferNamesRoot p b | otherwise = getLast <$> execWriterT (runReaderT (go p b) Path.empty) where findBaseProject :: Path -> Maybe Path - findBaseProject ("public" Cons.:< "base" Cons.:< release Cons.:< _rest) = Just (Path.fromList ["public", "base", release]) + findBaseProject + ( (NameSegment.toUnescapedText -> "public") + Cons.:< (NameSegment.toUnescapedText -> "base") + Cons.:< release + Cons.:< _rest + ) = + Just + ( Path.fromList + [ NameSegment.unsafeFromUnescapedText "public", + NameSegment.unsafeFromUnescapedText "base", + release + ] + ) findBaseProject _ = Nothing go :: Path -> Branch Sqlite.Transaction -> ReaderT Path (WriterT (Last Path) Sqlite.Transaction) () go p b = do diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs index c450a7c833..4f622ae215 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs @@ -16,9 +16,10 @@ import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..)) -import Unison.NameSegment (NameSegment (..)) +import Unison.NameSegment (NameSegment) +import Unison.NameSegment qualified as NameSegment import Unison.Prelude -import Unison.Project.Util (pattern UUIDNameSegment) +import Unison.Project.Util (pattern BranchesNameSegment, pattern ProjectsNameSegment, pattern UUIDNameSegment) import Unison.Server.Backend import Unison.Server.Types (APIGet) @@ -58,7 +59,7 @@ serveCurrent = lift . getCurrentProjectBranch getCurrentProjectBranch :: MonadIO m => Codebase m v a -> m Current getCurrentProjectBranch codebase = do namespace <- Codebase.runTransaction codebase Queries.expectMostRecentNamespace - let segments = NameSegment <$> namespace + let segments = NameSegment.unsafeFromUnescapedText <$> namespace let absolutePath = toPath segments case toIds segments of ProjectAndBranch (Just projectId) branchId -> @@ -72,9 +73,9 @@ getCurrentProjectBranch codebase = do toIds :: [NameSegment] -> ProjectAndBranch (Maybe ProjectId) (Maybe ProjectBranchId) toIds segments = case segments of - "__projects" : UUIDNameSegment projectId : "branches" : UUIDNameSegment branchId : _ -> + ProjectsNameSegment : UUIDNameSegment projectId : BranchesNameSegment : UUIDNameSegment branchId : _ -> ProjectAndBranch {project = Just $ ProjectId projectId, branch = Just $ ProjectBranchId branchId} - "__projects" : UUIDNameSegment projectId : _ -> + ProjectsNameSegment : UUIDNameSegment projectId : _ -> ProjectAndBranch {project = Just $ ProjectId projectId, branch = Nothing} _ -> ProjectAndBranch {project = Nothing, branch = Nothing} diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs index 530eaa91c3..85d0f5d762 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs @@ -1,11 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} module Unison.Server.Local.Endpoints.FuzzyFind where @@ -34,7 +28,6 @@ import Unison.Codebase.Editor.DisplayObject import Unison.Codebase.Path qualified as Path import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv -import Unison.NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyPrintEnvDecl qualified as PPE @@ -50,6 +43,7 @@ import Unison.Server.Types mayDefaultWidth, ) import Unison.Symbol (Symbol) +import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.Pretty (Width) type FuzzyFindAPI = @@ -188,10 +182,10 @@ serveFuzzyFind codebase mayRoot relativeTo limit typeWidth query = do $ Backend.termEntryToNamedTerm ppe typeWidth te ) ) - <$> Backend.termListEntry codebase relativeToBranch (ExactName (NameSegment n) (Cv.referent1to2 r)) + <$> Backend.termListEntry codebase relativeToBranch (ExactName (NameSegment.unsafeFromText n) (Cv.referent1to2 r)) Backend.FoundTypeRef r -> Codebase.runTransaction codebase do - te <- Backend.typeListEntry codebase relativeToBranch (ExactName (NameSegment n) r) + te <- Backend.typeListEntry codebase relativeToBranch (ExactName (NameSegment.unsafeFromText n) r) let namedType = Backend.typeEntryToNamedType te let typeName = Backend.bestNameForType @Symbol ppe (mayDefaultWidth typeWidth) r typeHeader <- Backend.typeDeclHeader codebase ppe r diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs index 5edb2ef232..0a12729b71 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs @@ -1,11 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} module Unison.Server.Local.Endpoints.NamespaceDetails where @@ -22,6 +16,7 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path import Unison.Codebase.Runtime qualified as Rt import Unison.Codebase.ShortCausalHash (ShortCausalHash) +import Unison.NameSegment qualified as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Server.Backend @@ -78,4 +73,10 @@ namespaceDetails runtime codebase namespacePath mayRoot _mayWidth = do pure $ NamespaceDetails namespacePath causalHash renderedReadme pure $ namespaceDetails where - readmeNames = Set.fromList ["README", "Readme", "ReadMe", "readme"] + readmeNames = + Set.fromList + [ NameSegment.unsafeFromUnescapedText "README", + NameSegment.unsafeFromUnescapedText "Readme", + NameSegment.unsafeFromUnescapedText "ReadMe", + NameSegment.unsafeFromUnescapedText "readme" + ] diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs index ddbeecbfa9..fe5e5ee06a 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs @@ -26,7 +26,6 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Hash qualified as Hash -import Unison.NameSegment qualified as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE @@ -42,6 +41,7 @@ import Unison.Server.Types v2CausalBranchToUnisonHash, ) import Unison.Symbol (Symbol) +import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.Pretty (Width) import Unison.Var (Var) @@ -183,12 +183,12 @@ backendListEntryToNamespaceObject ppe typeWidth = \case Backend.ShallowBranchEntry name hash (NamespaceStats {numContainedTerms, numContainedTypes, numContainedPatches}) -> Subnamespace $ NamedNamespace - { namespaceName = NameSegment.toText name, + { namespaceName = NameSegment.toEscapedText name, namespaceHash = "#" <> Hash.toBase32HexText (unCausalHash hash), namespaceSize = numContainedTerms + numContainedTypes + numContainedPatches } Backend.ShallowPatchEntry name -> - PatchObject . NamedPatch $ NameSegment.toText name + PatchObject . NamedPatch $ NameSegment.toEscapedText name serve :: Codebase IO Symbol Ann -> @@ -215,10 +215,9 @@ serve codebase maySCH mayRelativeTo mayNamespaceName = do let relativeToPath = fromMaybe Path.empty mayRelativeTo let namespacePath = fromMaybe Path.empty mayNamespaceName let path = relativeToPath <> namespacePath - let path' = Path.toPath' path (listingCausal, listingBranch) <- (lift . Codebase.runTransaction codebase) do - listingCausal <- Codebase.getShallowCausalAtPath (Path.fromPath' path') (Just rootCausal) + listingCausal <- Codebase.getShallowCausalAtPath path (Just rootCausal) listingBranch <- V2Causal.value listingCausal pure (listingCausal, listingBranch) -- TODO: Currently the ppe is just used to render the types returned from the namespace @@ -226,7 +225,7 @@ serve codebase maySCH mayRelativeTo mayNamespaceName = do -- If we ever show types on hover we need to build and use a proper PPE here, but it's not -- shallowPPE <- liftIO $ Backend.shallowPPE codebase listingBranch let shallowPPE = PPE.empty - let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path' + let listingFQN = Path.toText path let listingHash = v2CausalBranchToUnisonHash listingCausal listingEntries <- lift (Backend.lsBranch codebase listingBranch) makeNamespaceListing shallowPPE listingFQN listingHash listingEntries diff --git a/unison-share-api/src/Unison/Server/Orphans.hs b/unison-share-api/src/Unison/Server/Orphans.hs index 3478e650a8..22e9f09fb4 100644 --- a/unison-share-api/src/Unison/Server/Orphans.hs +++ b/unison-share-api/src/Unison/Server/Orphans.hs @@ -18,9 +18,7 @@ import U.Codebase.HashTags import Unison.Codebase.Editor.DisplayObject import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path -import Unison.Codebase.ShortCausalHash - ( ShortCausalHash (..), - ) +import Unison.Codebase.ShortCausalHash (ShortCausalHash (..)) import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.ConstructorType (ConstructorType) import Unison.ConstructorType qualified as CT @@ -32,7 +30,6 @@ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment (..)) -import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Project import Unison.Reference qualified as Reference @@ -42,6 +39,7 @@ import Unison.ShortHash qualified as SH import Unison.Syntax.HashQualified qualified as HQ (fromText) import Unison.Syntax.HashQualified' qualified as HQ' (fromText) import Unison.Syntax.Name qualified as Name (fromTextEither, toText) +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Util.Pretty (Width (..)) instance ToJSON Hash where @@ -308,13 +306,13 @@ instance ToJSON (HQ.HashQualified Name) where toJSON = Aeson.String . HQ.toTextWith Name.toText instance ToJSON (HQ.HashQualified NameSegment) where - toJSON = Aeson.String . HQ.toTextWith NameSegment.toText + toJSON = Aeson.String . HQ.toTextWith NameSegment.toEscapedText instance ToJSON (HQ'.HashQualified Name) where toJSON = Aeson.String . HQ'.toTextWith Name.toText instance ToJSON (HQ'.HashQualified NameSegment) where - toJSON = Aeson.String . HQ'.toTextWith NameSegment.toText + toJSON = Aeson.String . HQ'.toTextWith NameSegment.toEscapedText instance FromJSON (HQ'.HashQualified Name) where parseJSON = Aeson.withText "HashQualified'" \txt -> diff --git a/unison-share-api/src/Unison/Server/Syntax.hs b/unison-share-api/src/Unison/Server/Syntax.hs index 75cada4319..74efcef19d 100644 --- a/unison-share-api/src/Unison/Server/Syntax.hs +++ b/unison-share-api/src/Unison/Server/Syntax.hs @@ -21,7 +21,6 @@ import Lucid import Lucid qualified as L import Unison.Name (Name) import Unison.Name qualified as Name -import Unison.NameSegment qualified as NameSegment import Unison.Pattern (SeqOp (..)) import Unison.Prelude import Unison.Reference (Reference) @@ -29,6 +28,7 @@ import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Syntax.HashQualified qualified as HashQualified (toText) import Unison.Syntax.Name qualified as Name (unsafeFromText) +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Util.AnnotatedText ( AnnotatedText (..), Segment (..), @@ -269,7 +269,7 @@ nameToHtml name = span_ [class_ "fqn"] $ sequence_ parts where segments = - map (segment . L.toHtml . NameSegment.toText) $ List.NonEmpty.toList $ Name.segments name + map (segment . L.toHtml . NameSegment.toEscapedText) $ List.NonEmpty.toList $ Name.segments name segment = span_ [class_ "segment"] diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 3b80c071f0..88dce1f6c2 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -43,7 +43,6 @@ import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.NameSegment (NameSegment) -import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) import Unison.Server.Doc (Doc) @@ -51,6 +50,7 @@ import Unison.Server.Orphans () import Unison.Server.Syntax (SyntaxText) import Unison.ShortHash (ShortHash) import Unison.Syntax.HashQualified qualified as HQ (fromText) +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Util.Pretty (Width (..)) type APIHeaders x = @@ -256,7 +256,7 @@ data NamedTerm = NamedTerm instance ToJSON NamedTerm where toJSON (NamedTerm n h typ tag) = Aeson.object - [ "termName" .= HQ'.toTextWith NameSegment.toText n, + [ "termName" .= HQ'.toTextWith NameSegment.toEscapedText n, "termHash" .= h, "termType" .= typ, "termTag" .= tag @@ -282,7 +282,7 @@ data NamedType = NamedType instance ToJSON NamedType where toJSON (NamedType n h tag) = Aeson.object - [ "typeName" .= HQ'.toTextWith NameSegment.toText n, + [ "typeName" .= HQ'.toTextWith NameSegment.toEscapedText n, "typeHash" .= h, "typeTag" .= tag ] diff --git a/unison-src/tests/imports.u b/unison-src/tests/imports.u index 2647c9f573..9d2b575b6c 100644 --- a/unison-src/tests/imports.u +++ b/unison-src/tests/imports.u @@ -1,5 +1,3 @@ -use . Int -- imports `.Int` from root path and gives it the local name `Int` - -- This brings `None` into scope unqualified use Optional None diff --git a/unison-src/tests/methodical/dots.u b/unison-src/tests/methodical/dots.u index dcd584a560..3e2a214aaa 100644 --- a/unison-src/tests/methodical/dots.u +++ b/unison-src/tests/methodical/dots.u @@ -1,11 +1,11 @@ -- You can define an operator called dot -(.) f g x = f (g x) +(`.`) f g x = f (g x) id : ∀ a. a -> a -- dot still fine in type parser id x = x -id2 = id . id +id2 = id `.` id -- You need a space or delimiter char after the dot, -- otherwise Unison assumes it's a rooted name - this will look for @@ -14,15 +14,15 @@ id2 = id . id -- foo = id .zonk -- You can define qualified functions -(base.function..) f g x = f (g x) +(base.function.`.`) f g x = f (g x) -- looks weird, but consistent syntax with any other infix binding -object oop.syntax.. method = method object +object oop.syntax.`.` method = method object ex = - use base.function . - (id . id) 42 + use base.function `.` + (id `.` id) 42 -ex2 = use oop.syntax .; 42 . id . id +ex2 = use oop.syntax `.`; 42 `.` id `.` id > (ex, ex2) diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index afd846b397..80be836e42 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -45,7 +45,7 @@ import Unison.HashQualified' qualified as HQ' import Unison.Lexer.Pos (Column, Line, Pos (Pos), column, line) import Unison.Name (Name) import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment (NameSegment)) +import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.ShortHash (ShortHash) @@ -364,7 +364,9 @@ lexemes' eof = (Just (WordyId tname), ht : _) | isTopLevel -> startToks - <> [WordyId (HQ'.fromName (Name.snoc (HQ'.toName tname) (NameSegment "doc"))) <$ ht, Open "=" <$ ht] + <> [ WordyId (HQ'.fromName (Name.snoc (HQ'.toName tname) (NameSegment.unsafeFromUnescapedText "doc"))) <$ ht, + Open "=" <$ ht + ] <> docToks0 <> [Close <$ last docToks] <> endToks @@ -775,7 +777,7 @@ lexemes' eof = separated wordySep do _ <- char '_' seg <- P.optional wordyIdSegP - pure (Blank (maybe "" (Text.unpack . NameSegment.toText) seg)) + pure (Blank (maybe "" (Text.unpack . NameSegment.toUnescapedText) seg)) semi = char ';' $> Semi False textual = Textual <$> quoted diff --git a/unison-syntax/src/Unison/Syntax/Name.hs b/unison-syntax/src/Unison/Syntax/Name.hs index 87db9a90ff..b79a78c593 100644 --- a/unison-syntax/src/Unison/Syntax/Name.hs +++ b/unison-syntax/src/Unison/Syntax/Name.hs @@ -14,6 +14,7 @@ module Unison.Syntax.Name -- * Name parsers nameP, + relativeNameP, -- * Name classifiers isSymboly, @@ -115,12 +116,18 @@ unsafeFromVar = ------------------------------------------------------------------------------------------------------------------------ -- Name parsers +-- | A name parser. nameP :: forall m. Monad m => ParsecT (Token NameSegment.ParseErr) [Char] m Name nameP = P.try do leadingDot <- isJust <$> P.optional (P.char '.') - name <- Name.fromSegments <$> Monad.sepBy1 NameSegment.segmentP separatorP + name <- relativeNameP pure (if leadingDot then Name.makeAbsolute name else name) + +-- | A relative name parser. +relativeNameP :: forall m. Monad m => ParsecT (Token NameSegment.ParseErr) [Char] m Name +relativeNameP = do + Name.fromSegments <$> Monad.sepBy1 NameSegment.segmentP separatorP where -- The separator between segments is just a dot, but we don't want to commit to parsing another segment unless the -- character after the dot can begin a segment. diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index daf3a34f03..8b05559726 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -1,6 +1,7 @@ -- | Utilities related to the parsing and printing of name segments using the default syntax. module Unison.Syntax.NameSegment ( -- * String conversions + toEscapedText, unsafeFromText, -- * Name segment parsers @@ -29,6 +30,7 @@ import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.NameSegment (NameSegment (..)) +import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Syntax.Lexer.Token (Token (..), posP) import Unison.Syntax.ReservedWords (keywords, reservedOperators) @@ -36,10 +38,23 @@ import Unison.Syntax.ReservedWords (keywords, reservedOperators) ------------------------------------------------------------------------------------------------------------------------ -- String conversions --- | Convert a text to a name segment, when the text is known to be a valid name segment. +-- | Convert a name segment to escaped text, for display purposes. +-- +-- > toEscapedText (unsafeFromText ".~") = "`.~`" +toEscapedText :: NameSegment -> Text +toEscapedText = + wundefined + +-- | Convert text to a name segment. +-- +-- > unsafeFromText "foo" = NameSegment "foo" +-- > unsafeFromText ".~" = +-- > unsafeFromText "`.~`" = NameSegment ".~" unsafeFromText :: Text -> NameSegment -unsafeFromText = - NameSegment +unsafeFromText text = + case P.runParser (P.withParsecT (fmap renderParseErr) (segmentP <* P.eof)) "" (Text.unpack text) of + Left err -> error (P.errorBundlePretty err) + Right segment -> segment ------------------------------------------------------------------------------------------------------------------------ -- Name segment parsers @@ -79,13 +94,13 @@ segmentP = symbolyP :: ParsecT (Token Text) [Char] m NameSegment symbolyP = do start <- posP - string <- unescaped <|> escaped + string <- escaped <|> unescaped let text = Text.pack string if Set.member text reservedOperators then do end <- posP P.customFailure (Token text start end) - else pure (NameSegment text) + else pure (NameSegment.unsafeFromUnescapedText text) where unescaped = P.takeWhile1P (Just (description symbolyIdChars)) symbolyIdChar @@ -112,7 +127,7 @@ wordyP = do then do end <- posP P.customFailure (Token word start end) - else pure (NameSegment word) + else pure (NameSegment.unsafeFromUnescapedText word) where wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" @@ -121,7 +136,7 @@ wordyP = do isSymboly :: NameSegment -> Bool isSymboly = - not . wordyIdStartChar . Text.head . toText + not . wordyIdStartChar . Text.head . NameSegment.toUnescapedText ------------------------------------------------------------------------------------------------------------------------ -- Character classifiers From e4a2080301c7229eae60dc2410a3e7c919d56e14 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 26 Jan 2024 14:00:16 -0500 Subject: [PATCH 13/41] wip --- .../src/Unison/CommandLine/Completion.hs | 50 +++++++++++-------- .../src/Unison/Syntax/NameSegment.hs | 20 +++++--- 2 files changed, 43 insertions(+), 27 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 2088faeb1f..e02823d514 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -27,6 +27,7 @@ import Data.Aeson qualified as Aeson import Data.List (isPrefixOf) import Data.List qualified as List import Data.List.Extra (nubOrdOn) +import Data.List.NonEmpty qualified as List.NonEmpty import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map import Data.Set.NonEmpty (NESet) @@ -50,6 +51,7 @@ import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.CommandLine.InputPattern qualified as IP import Unison.HashQualified' qualified as HQ' +import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment import Unison.Prelude @@ -59,6 +61,7 @@ import Unison.Server.Types qualified as Server import Unison.Share.Codeserver qualified as Codeserver import Unison.Share.Types qualified as Share import Unison.Sqlite qualified as Sqlite +import Unison.Syntax.Name qualified as Name import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as P @@ -159,28 +162,30 @@ completeWithinNamespace compTypes query currentPath = do pure . nubOrdOn Haskeline.replacement . List.sortOn Haskeline.replacement $ allSuggestions where queryPathPrefix :: Path.Path' - querySuffix :: NameSegment.NameSegment + querySuffix :: Text (queryPathPrefix, querySuffix) = parseLaxPath'Query (Text.pack query) absQueryPath :: Path.Absolute absQueryPath = Path.resolve currentPath queryPathPrefix getChildSuggestions :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [Completion] - getChildSuggestions shortHashLen b = do - nonEmptyChildren <- V2Branch.nonEmptyChildren b - case querySuffix of - "" -> pure [] - suffix -> do - case Map.lookup suffix nonEmptyChildren of - Nothing -> pure [] - Just childCausal -> do - childBranch <- V2Causal.value childCausal - nib <- namesInBranch shortHashLen childBranch - nib - & fmap - ( \(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> suffix Lens.:> NameSegment.unsafeFromText match) - ) - & filter (\(_isFinished, match) -> List.isPrefixOf query match) - & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) - & pure + getChildSuggestions shortHashLen b + | Text.null querySuffix = pure [] + | otherwise = + case NameSegment.fromText querySuffix of + Nothing -> pure Nothing + Just suffix -> do + nonEmptyChildren <- V2Branch.nonEmptyChildren b + case Map.lookup querySuffix nonEmptyChildren of + Nothing -> pure [] + Just childCausal -> do + childBranch <- V2Causal.value childCausal + nib <- namesInBranch shortHashLen childBranch + nib + & fmap + ( \(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> suffix Lens.:> NameSegment.unsafeFromText match) + ) + & filter (\(_isFinished, match) -> List.isPrefixOf query match) + & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) + & pure namesInBranch :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [(Bool, Text)] namesInBranch hashLen b = do nonEmptyChildren <- V2Branch.nonEmptyChildren b @@ -389,8 +394,13 @@ shareCompletion completionTypes authHTTPClient str = & filter (\(typ, name) -> typ `NESet.member` completionTypes && NameSegment.toEscapedText pathSuffix `Text.isPrefixOf` name) & fmap ( \(_, name) -> - let queryPath = userHandle : coerce (Path.toList path) - result = Text.unpack $ Text.intercalate "." (queryPath <> [name]) + let queryPath = userHandle : Path.toList path + result = + (queryPath ++ [NameSegment.unsafeFromText name]) + & List.NonEmpty.fromList + & Name.fromSegments + & Name.toText + & Text.unpack in prettyCompletionWithQueryPrefix False str result ) & pure diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index 8b05559726..eec4c60d16 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -2,6 +2,7 @@ module Unison.Syntax.NameSegment ( -- * String conversions toEscapedText, + fromText, unsafeFromText, -- * Name segment parsers @@ -47,14 +48,19 @@ toEscapedText = -- | Convert text to a name segment. -- --- > unsafeFromText "foo" = NameSegment "foo" --- > unsafeFromText ".~" = --- > unsafeFromText "`.~`" = NameSegment ".~" -unsafeFromText :: Text -> NameSegment -unsafeFromText text = +-- > fromText "foo" = Right (NameSegment "foo") +-- > fromText ".~" = Left ... +-- > fromText "`.~`" = Right (NameSegment ".~") +fromText :: Text -> Either Text NameSegment +fromText text = case P.runParser (P.withParsecT (fmap renderParseErr) (segmentP <* P.eof)) "" (Text.unpack text) of - Left err -> error (P.errorBundlePretty err) - Right segment -> segment + Left err -> Left (Text.pack (P.errorBundlePretty err)) + Right segment -> Right segment + +-- | Convert text to a name segment. +unsafeFromText :: Text -> NameSegment +unsafeFromText = + either (error . Text.unpack) id . fromText ------------------------------------------------------------------------------------------------------------------------ -- Name segment parsers From 374a641fb8c3d2445aa3a7d7cbe9f5c9aa42a203 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 29 Jan 2024 09:59:25 -0500 Subject: [PATCH 14/41] more NameSegment to/from text --- unison-cli/src/Unison/Cli/Monad.hs | 2 +- unison-cli/src/Unison/Cli/MonadUtils.hs | 4 +- unison-cli/src/Unison/Cli/Pretty.hs | 9 +++- .../src/Unison/Cli/UniqueTypeGuidLookup.hs | 2 +- .../src/Unison/Cli/UnisonConfigUtils.hs | 4 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 43 ++++++++++--------- .../Editor/HandleInput/FindAndReplace.hs | 3 +- .../HandleInput/NamespaceDependencies.hs | 4 +- .../Editor/HandleInput/ProjectCreate.hs | 7 ++- .../Codebase/Editor/HandleInput/Update2.hs | 9 ++-- .../Codebase/Editor/HandleInput/Upgrade.hs | 23 +++++----- .../src/Unison/Codebase/Editor/Propagate.hs | 5 ++- .../src/Unison/Codebase/Editor/UriParser.hs | 3 +- .../src/Unison/CommandLine/Completion.hs | 32 ++++---------- .../src/Unison/CommandLine/InputPatterns.hs | 9 +--- .../src/Unison/CommandLine/OutputMessages.hs | 30 ++++++++----- unison-cli/src/Unison/LSP/Completion.hs | 24 +++++------ unison-cli/unison/Main.hs | 3 +- 18 files changed, 110 insertions(+), 106 deletions(-) diff --git a/unison-cli/src/Unison/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index 22d03dfb96..f5271e566c 100644 --- a/unison-cli/src/Unison/Cli/Monad.hs +++ b/unison-cli/src/Unison/Cli/Monad.hs @@ -402,7 +402,7 @@ popd = do setMostRecentNamespace :: Path.Absolute -> Cli () setMostRecentNamespace = - runTransaction . Queries.setMostRecentNamespace . map NameSegment.toText . Path.toList . Path.unabsolute + runTransaction . Queries.setMostRecentNamespace . map NameSegment.toUnescapedText . Path.toList . Path.unabsolute respond :: Output -> Cli () respond output = do diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 551f51c9f4..a3ce9a8b56 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -113,6 +113,7 @@ import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) +import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Parser.Ann (Ann (..)) import Unison.Prelude @@ -499,7 +500,8 @@ getTypesAt path = do -- Getting patches defaultPatchNameSegment :: NameSegment -defaultPatchNameSegment = "patch" +defaultPatchNameSegment = + NameSegment.unsafeFromUnescapedText "patch" -- | The default patch path. defaultPatchPath :: Path.Split' diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index a8773ad4d2..4ec00b02fe 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -17,6 +17,7 @@ module Unison.Cli.Pretty prettyHash32, prettyHumanReadableTime, prettyLabeledDependencies, + prettyPath, prettyPath', prettyProjectAndBranchName, prettyBranchName, @@ -159,7 +160,7 @@ prettyShareLink :: WriteShareRemoteNamespace -> Pretty prettyShareLink WriteShareRemoteNamespace {repo, path} = let encodedPath = Path.toList path - & fmap (URI.encodeText . NameSegment.toText) + & fmap (URI.encodeText . NameSegment.toUnescapedText) & Text.intercalate "/" in P.green . P.text $ shareOrigin <> "/@" <> shareUserHandleToText repo <> "/p/code/latest/namespaces/" <> encodedPath @@ -176,6 +177,12 @@ prettyFilePath :: FilePath -> Pretty prettyFilePath fp = P.blue (P.string fp) +prettyPath :: Path.Path -> Pretty +prettyPath path = + if path == Path.empty + then "the current namespace" + else P.blue (P.shown path) + prettyPath' :: Path.Path' -> Pretty prettyPath' p' = if Path.isCurrentPath p' diff --git a/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs b/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs index 0524e8ae16..337dafac1a 100644 --- a/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs +++ b/unison-cli/src/Unison/Cli/UniqueTypeGuidLookup.hs @@ -38,6 +38,6 @@ loadUniqueTypeGuid currentPath name0 = do -- an appropriate time, such as after the current unison file finishes parsing). let loadBranchAtPath :: [NameSegment] -> Sqlite.Transaction (Maybe (Codebase.Branch.Branch Sqlite.Transaction)) loadBranchAtPath segments = - Operations.loadBranchAtPath Nothing (map NameSegment.toText segments) + Operations.loadBranchAtPath Nothing (map NameSegment.toUnescapedText segments) Codebase.loadUniqueTypeGuid loadBranchAtPath (Foldable.toList @Seq branchPath) name diff --git a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs b/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs index b1dafa02f4..f4d2e870ee 100644 --- a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs +++ b/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs @@ -22,15 +22,15 @@ import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.UriParser qualified as UriParser import Unison.Codebase.Path (Path' (..)) import Unison.Codebase.Path qualified as Path -import Unison.NameSegment qualified as NameSegment import Unison.Prelude +import Unison.Syntax.NameSegment qualified as NameSegment configKey :: Text -> Path.Absolute -> Text configKey k p = Text.intercalate "." . toList $ k :<| fmap - NameSegment.toText + NameSegment.toEscapedText (Path.toSeq $ Path.unabsolute p) gitUrlKey :: Path.Absolute -> Text diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f8c9719b7c..223b8e6e78 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -150,6 +150,7 @@ import Unison.Parser.Ann qualified as Ann import Unison.Parsers qualified as Parsers import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE +import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty) import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED @@ -177,6 +178,7 @@ import Unison.Symbol (Symbol) import Unison.Syntax.HashQualified qualified as HQ (fromString, toString, toText, unsafeFromString) import Unison.Syntax.Lexer qualified as L import Unison.Syntax.Name qualified as Name (toString, toText, toVar, unsafeFromVar) +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Syntax.Parser qualified as Parser import Unison.Syntax.TermPrinter qualified as TP import Unison.Term (Term) @@ -203,7 +205,6 @@ import Unison.Var qualified as Var import Unison.WatchKind qualified as WK import UnliftIO.Directory qualified as Directory import Witch (unsafeFrom) -import qualified Unison.PrettyPrintEnv.Names as PPE ------------------------------------------------------------------------------------------------------------------------ -- Main loop @@ -706,8 +707,8 @@ loop e = do -- add the new definitions to the codebase and to the namespace Cli.runTransaction (traverse_ (uncurry3 (Codebase.putTerm codebase)) [guid, author, copyrightHolder]) authorPath <- Cli.resolveSplit' authorPath' - copyrightHolderPath <- Cli.resolveSplit' (base |> "copyrightHolders" |> authorNameSegment) - guidPath <- Cli.resolveSplit' (authorPath' |> "guid") + copyrightHolderPath <- Cli.resolveSplit' (base |> NameSegment.unsafeFromUnescapedText "copyrightHolders" |> authorNameSegment) + guidPath <- Cli.resolveSplit' (authorPath' |> NameSegment.unsafeFromUnescapedText "guid") Cli.stepManyAt description [ BranchUtil.makeAddTermName (Path.convert authorPath) (d authorRef), @@ -727,8 +728,8 @@ loop e = do where d :: Reference.Id -> Referent d = Referent.Ref . Reference.DerivedId - base :: Path.Split' = (Path.relativeEmpty', "metadata") - authorPath' = base |> "authors" |> authorNameSegment + base :: Path.Split' = (Path.relativeEmpty', NameSegment.unsafeFromUnescapedText "metadata") + authorPath' = base |> NameSegment.unsafeFromUnescapedText "authors" |> authorNameSegment MoveTermI src' dest' -> doMoveTerm src' dest' =<< inputDescription input MoveTypeI src' dest' -> doMoveType src' dest' =<< inputDescription input MoveAllI src' dest' -> do @@ -816,11 +817,11 @@ loop e = do where entryToHQString :: ShallowListEntry v Ann -> String entryToHQString e = - fixup case e of - ShallowTypeEntry te -> Text.unpack $ Backend.typeEntryDisplayName te - ShallowTermEntry te -> Text.unpack $ Backend.termEntryDisplayName te - ShallowBranchEntry ns _ _ -> NameSegment.toString ns - ShallowPatchEntry ns -> NameSegment.toString ns + fixup $ Text.unpack case e of + ShallowTypeEntry te -> Backend.typeEntryDisplayName te + ShallowTermEntry te -> Backend.termEntryDisplayName te + ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns + ShallowPatchEntry ns -> NameSegment.toEscapedText ns where fixup s = case pathArgStr of "" -> s @@ -997,7 +998,7 @@ loop e = do -- due to builtin terms; so we don't just reuse `uf` above. let srcb = BranchUtil.fromNames Builtin.names currentPath <- Cli.getCurrentPath - _ <- Cli.updateAtM description (currentPath `snoc` "builtin") \destb -> + _ <- Cli.updateAtM description (currentPath `snoc` NameSegment.unsafeFromUnescapedText "builtin") \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success MergeIOBuiltinsI -> do @@ -1021,7 +1022,7 @@ loop e = do let names0 = Builtin.names <> UF.typecheckedToNames IOSource.typecheckedFile' let srcb = BranchUtil.fromNames names0 currentPath <- Cli.getCurrentPath - _ <- Cli.updateAtM description (currentPath `snoc` "builtin") \destb -> + _ <- Cli.updateAtM description (currentPath `snoc` NameSegment.unsafeFromUnescapedText "builtin") \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success ListEditsI maybePath -> do @@ -1104,14 +1105,14 @@ loop e = do [ Monoid.unlessM (null causalParents) $ P.lit "Causal Parents:" <> P.newline <> P.indentN 2 (P.lines (map P.shown $ Set.toList causalParents)), Monoid.unlessM (null terms) $ P.lit "Terms:" <> P.newline <> P.indentN 2 (P.lines (map (prettyDefn Referent.toText) $ Map.toList terms)), Monoid.unlessM (null types) $ P.lit "Types:" <> P.newline <> P.indentN 2 (P.lines (map (prettyDefn Reference.toText) $ Map.toList types)), - Monoid.unlessM (null patches) $ P.lit "Patches:" <> P.newline <> P.indentN 2 (P.column2 (map (bimap (P.text . NameSegment.toText) P.shown) $ Map.toList patches)), - Monoid.unlessM (null children) $ P.lit "Children:" <> P.newline <> P.indentN 2 (P.column2 (map (bimap (P.text . NameSegment.toText) P.shown) $ Map.toList children)) + Monoid.unlessM (null patches) $ P.lit "Patches:" <> P.newline <> P.indentN 2 (P.column2 (map (bimap (P.text . NameSegment.toEscapedText) P.shown) $ Map.toList patches)), + Monoid.unlessM (null children) $ P.lit "Children:" <> P.newline <> P.indentN 2 (P.column2 (map (bimap (P.text . NameSegment.toEscapedText) P.shown) $ Map.toList children)) ] ) where prettyRef renderR r = P.indentN 2 $ P.text (renderR r) prettyDefn renderR (r, Foldable.toList -> names) = - P.lines (P.text . NameSegment.toText <$> if null names then [NameSegment ""] else names) <> P.newline <> prettyRef renderR r + P.lines (P.text <$> if null names then [""] else NameSegment.toEscapedText <$> names) <> P.newline <> prettyRef renderR r rootBranch <- Cli.getRootBranch void . liftIO . flip State.execStateT mempty $ goCausal [getCausal rootBranch] DebugDumpNamespaceSimpleI -> do @@ -1307,7 +1308,7 @@ inputDescription input = "compile.native.genlibs" <> Text.pack (maybe "" (" " ++) mdir) FetchSchemeCompilerI name branch -> pure ("compile.native.fetch" <> Text.pack name <> " " <> Text.pack branch) - CreateAuthorI (NameSegment id) name -> pure ("create.author " <> id <> " " <> name) + CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name) RemoveTermReplacementI src p0 -> do p <- opatch p0 pure ("delete.term-replacement" <> HQ.toText src <> " " <> p) @@ -1321,7 +1322,6 @@ inputDescription input = pure (Text.unwords ["diff.namespace.to-patch", branchId1, branchId2, patch]) ClearI {} -> pure "clear" DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name) - UpgradeI old new -> pure (Text.unwords ["upgrade", NameSegment.toText old, NameSegment.toText new]) -- ApiI -> wat AuthLoginI {} -> wat @@ -1378,6 +1378,7 @@ inputDescription input = TodoI {} -> wat UiI {} -> wat UpI {} -> wat + UpgradeI {} -> wat VersionI -> wat where hp' :: Either SCH.ShortCausalHash Path' -> Cli Text @@ -1398,7 +1399,7 @@ inputDescription input = hqs' :: Path.HQSplit' -> Cli Text hqs' (p0, hq) = do p <- if Path.isRoot' p0 then pure mempty else p' p0 - pure (p <> "." <> HQ'.toTextWith NameSegment.toText hq) + pure (p <> "." <> HQ'.toTextWith NameSegment.toEscapedText hq) hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq) ps' = p' . Path.unsplit' looseCodeOrProjectToText :: Input.LooseCodeOrProject -> Cli Text @@ -1471,7 +1472,7 @@ handleFindI isVerbose fscope ws input = do Cli.respond FindNoLocalMatches -- We've already searched everything else, so now we search JUST the -- names in lib. - let mayOnlyLibBranch = currentBranch0 & Branch.children %%~ (\cs -> Map.singleton "lib" <$> Map.lookup "lib" cs) + let mayOnlyLibBranch = currentBranch0 & Branch.children %%~ \cs -> Map.singleton NameSegment.libSegment <$> Map.lookup NameSegment.libSegment cs case mayOnlyLibBranch of Nothing -> respondResults [] Just onlyLibBranch -> do @@ -1548,7 +1549,7 @@ handleDependents hq = do r <- Set.toList dependents Just (isTerm, hq) <- [(True,) <$> PPE.terms fqppe (Referent.Ref r), (False,) <$> PPE.types fqppe r] fullName <- [HQ'.toName hq] - guard (not (Name.beginsWithSegment fullName Name.libSegment)) + guard (not (Name.beginsWithSegment fullName NameSegment.libSegment)) Just shortName <- pure $ PPE.terms ppe (Referent.Ref r) <|> PPE.types ppe r pure (isTerm, HQ'.toHQ shortName, r) pure results @@ -1921,7 +1922,7 @@ searchBranchScored names0 score queries = compilerPath :: Path.Path' compilerPath = Path.Path' {Path.unPath' = Left abs} where - segs = NameSegment <$> ["unison", "internal"] + segs = NameSegment.unsafeFromUnescapedText <$> ["unison", "internal"] rootPath = Path.Path {Path.toSeq = Seq.fromList segs} abs = Path.Absolute {Path.unabsolute = rootPath} diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs index ce81492cbb..83cc5486ea 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs @@ -22,6 +22,7 @@ import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name +import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Names qualified as Names import Unison.NamesWithHistory qualified as Names @@ -76,7 +77,7 @@ handleStructuredFindI rule = do r <- Set.toList (Relation.ran $ Names.terms names) Just hq <- [PPE.terms fqppe r] fullName <- [HQ'.toName hq] - guard (not (Name.beginsWithSegment fullName Name.libSegment)) + guard (not (Name.beginsWithSegment fullName NameSegment.libSegment)) Referent.Ref _ <- pure r Just shortName <- [PPE.terms (PPED.suffixifiedPPE ppe) r] pure (HQ'.toHQ shortName, r) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs index 6760210e3d..f812df39ba 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/NamespaceDependencies.hs @@ -22,7 +22,7 @@ import Unison.DataDeclaration qualified as DD import Unison.LabeledDependency (LabeledDependency) import Unison.LabeledDependency qualified as LD import Unison.Name (Name) -import Unison.Name qualified as Name +import Unison.NameSegment qualified as NameSegment import Unison.Names qualified as Names import Unison.Prelude import Unison.PrettyPrintEnvDecl qualified as PPED @@ -97,4 +97,4 @@ namespaceDependencies codebase branch = do pure onlyExternalDeps where - branchWithoutLibdeps = branch & over Branch.children (Map.delete Name.libSegment) + branchWithoutLibdeps = branch & over Branch.children (Map.delete NameSegment.libSegment) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index 91f79e7609..f710f43dae 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs @@ -23,8 +23,7 @@ import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.HandleInput.Pull qualified as Pull import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path -import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment (NameSegment)) +import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Share.API.Hash qualified as Share.API @@ -137,12 +136,12 @@ projectCreate tryDownloadingBase maybeProjectName = do projectBranchLibBaseObject = over Branch.children - (Map.insert (NameSegment "base") baseLatestReleaseBranchObject) + (Map.insert (NameSegment.unsafeFromUnescapedText "base") baseLatestReleaseBranchObject) Branch.empty0 projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty in over Branch.children - (Map.insert Name.libSegment projectBranchLibObject) + (Map.insert NameSegment.libSegment projectBranchLibObject) Branch.empty0 Cli.stepAt reflogDescription (Path.unabsolute path, const projectBranchObject) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index 69502efc10..7ad598626a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -58,7 +58,8 @@ import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Name.Forward (ForwardName (..)) import Unison.Name.Forward qualified as ForwardName -import Unison.NameSegment (NameSegment (NameSegment)) +import Unison.NameSegment (NameSegment (UnsafeNameSegment)) +import Unison.NameSegment qualified as NameSegment import Unison.Names (Names (Names)) import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) @@ -101,7 +102,7 @@ handleUpdate2 = do currentPath <- Cli.getCurrentPath currentBranch0 <- Cli.getBranch0At currentPath let namesIncludingLibdeps = Branch.toNames currentBranch0 - let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete Name.libSegment)) + let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete NameSegment.libSegment)) let ctorNames = forwardCtorNames namesExcludingLibdeps Cli.respond Output.UpdateLookingForDependents @@ -394,12 +395,12 @@ incrementLastSegmentChar (ForwardName segments) = in ForwardName $ maybe (NonEmpty.singleton incrementedLastSegment) (|> incrementedLastSegment) (NonEmpty.nonEmpty initSegments) where incrementLastCharInSegment :: NameSegment -> NameSegment - incrementLastCharInSegment (NameSegment text) = + incrementLastCharInSegment (UnsafeNameSegment text) = let incrementedText = if Text.null text then text else Text.init text `Text.append` Text.singleton (succ $ Text.last text) - in NameSegment incrementedText + in UnsafeNameSegment incrementedText -- @getTermAndDeclNames file@ returns the names of the terms and decls defined in a typechecked Unison file. getTermAndDeclNames :: (Var v) => TypecheckedUnisonFile v a -> Defns (Set Name) (Set Name) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs index add8c66ca2..4a87b73b47 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs @@ -50,12 +50,14 @@ import Unison.Reference (TermReference, TypeReference) import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Sqlite (Transaction) +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.UnisonFile qualified as UnisonFile import Unison.Util.Pretty qualified as Pretty import Unison.Util.Relation (Relation) import Unison.Util.Relation qualified as Relation import Unison.Util.Set qualified as Set import Witch (unsafeFrom) +import qualified Data.Char as Char handleUpgrade :: NameSegment -> NameSegment -> Cli () handleUpgrade oldDepName newDepName = do @@ -67,14 +69,14 @@ handleUpgrade oldDepName newDepName = do (projectAndBranch, _path) <- Cli.expectCurrentProjectBranch let projectId = projectAndBranch ^. #project . #projectId let projectPath = Cli.projectBranchPath (ProjectAndBranch projectId (projectAndBranch ^. #branch . #branchId)) - let oldDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [Name.libSegment, oldDepName])) - let newDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [Name.libSegment, newDepName])) + let oldDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, oldDepName])) + let newDepPath = Path.resolve projectPath (Path.Relative (Path.fromList [NameSegment.libSegment, newDepName])) currentV1Branch <- Cli.getBranch0At projectPath let currentV1BranchWithoutOldDep = deleteLibdep oldDepName currentV1Branch oldDep <- Cli.expectBranch0AtPath' oldDepPath let oldDepWithoutDeps = deleteLibdeps oldDep - let oldTransitiveDeps = fromMaybe Branch.empty0 $ fmap Branch.head $ Map.lookup Name.libSegment (oldDep ^. Branch.children) + let oldTransitiveDeps = fromMaybe Branch.empty0 $ fmap Branch.head $ Map.lookup NameSegment.libSegment (oldDep ^. Branch.children) newDep <- Cli.expectBranch0AtPath' newDepPath let newDepWithoutDeps = deleteLibdeps newDep @@ -211,7 +213,7 @@ handleUpgrade oldDepName newDepName = do where textualDescriptionOfUpgrade :: Text textualDescriptionOfUpgrade = - Text.unwords ["upgrade", NameSegment.toText oldDepName, NameSegment.toText newDepName] + Text.unwords ["upgrade", NameSegment.toEscapedText oldDepName, NameSegment.toEscapedText newDepName] makeOldDepPPE :: NameSegment -> @@ -256,8 +258,8 @@ makeOldDepPPE oldDepName newDepName namesExcludingOldDep oldDep oldDepWithoutDep } where oldNames = Branch.toNames oldDep - prefixedOldNames = PPE.namer (Names.prefix0 (Name.fromReverseSegments (oldDepName :| [Name.libSegment])) oldNames) - fakeNames = PPE.namer (Names.prefix0 (Name.fromReverseSegments (newDepName :| [Name.libSegment])) oldNames) + prefixedOldNames = PPE.namer (Names.prefix0 (Name.fromReverseSegments (oldDepName :| [NameSegment.libSegment])) oldNames) + fakeNames = PPE.namer (Names.prefix0 (Name.fromReverseSegments (newDepName :| [NameSegment.libSegment])) oldNames) -- @findTemporaryBranchName projectId oldDepName newDepName@ finds some unused branch name in @projectId@ with a name -- like "upgrade--to-". @@ -280,18 +282,19 @@ findTemporaryBranchName projectId oldDepName newDepName = do where preferred :: ProjectBranchName preferred = + -- filter isAlpha just to make it more likely this is a valid project name :sweat-smile: unsafeFrom @Text $ "upgrade-" - <> NameSegment.toText oldDepName + <> Text.filter Char.isAlpha (NameSegment.toEscapedText oldDepName) <> "-to-" - <> NameSegment.toText newDepName + <> Text.filter Char.isAlpha (NameSegment.toEscapedText newDepName) pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates)) deleteLibdep :: NameSegment -> Branch0 m -> Branch0 m deleteLibdep dep = - over (Branch.children . ix Name.libSegment . Branch.head_ . Branch.children) (Map.delete dep) + over (Branch.children . ix NameSegment.libSegment . Branch.head_ . Branch.children) (Map.delete dep) deleteLibdeps :: Branch0 m -> Branch0 m deleteLibdeps = - over Branch.children (Map.delete Name.libSegment) + over Branch.children (Map.delete NameSegment.libSegment) diff --git a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs index ea8344c784..f9a0bcec72 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs @@ -39,6 +39,7 @@ import Unison.Hashing.V2.Convert qualified as Hashing import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) +import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Names qualified as Names import Unison.Parser.Ann (Ann (..)) @@ -613,7 +614,7 @@ applyPropagate patch Edits {newTerms, termReplacements, typeReplacements, constr stepEverywhereButLib f branch = let children = Map.mapWithKey - (\name child -> if name == "lib" then child else Branch.step (Branch.stepEverywhere f) child) + (\name child -> if name == NameSegment.libSegment then child else Branch.step (Branch.stepEverywhere f) child) (branch ^. Branch.children) in f (Branch.branch0 (branch ^. Branch.terms) (branch ^. Branch.types) children (branch ^. Branch.edits)) isPropagated r = Set.notMember r allPatchTargets @@ -710,4 +711,4 @@ computeDirty getDependents patch shouldUpdate = nameNotInLibNamespace :: Name -> Bool nameNotInLibNamespace name = - not (Name.beginsWithSegment name "lib") + not (Name.beginsWithSegment name NameSegment.libSegment) diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 6a1ae59201..5769027cd5 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -35,6 +35,7 @@ import Unison.NameSegment (NameSegment (..)) import Unison.Prelude import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser) import Unison.Syntax.Lexer qualified +import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.Pretty qualified as P import Unison.Util.Pretty.MegaParsec qualified as P @@ -378,7 +379,7 @@ absolutePath = do nameSegment :: P NameSegment nameSegment = - NameSegment . Text.pack + NameSegment.unsafeFromText . Text.pack <$> ( (:) <$> P.satisfy Unison.Syntax.Lexer.wordyIdStartChar <*> P.many (P.satisfy Unison.Syntax.Lexer.wordyIdChar) diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index e02823d514..5d615853b4 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -53,7 +53,6 @@ import Unison.CommandLine.InputPattern qualified as IP import Unison.HashQualified' qualified as HQ' import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) -import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Server.Local.Endpoints.NamespaceListing (NamespaceListing (NamespaceListing)) import Unison.Server.Local.Endpoints.NamespaceListing qualified as Server @@ -171,10 +170,10 @@ completeWithinNamespace compTypes query currentPath = do | Text.null querySuffix = pure [] | otherwise = case NameSegment.fromText querySuffix of - Nothing -> pure Nothing - Just suffix -> do + Left _ -> pure [] + Right suffix -> do nonEmptyChildren <- V2Branch.nonEmptyChildren b - case Map.lookup querySuffix nonEmptyChildren of + case Map.lookup suffix nonEmptyChildren of Nothing -> pure [] Just childCausal -> do childBranch <- V2Causal.value childCausal @@ -213,7 +212,7 @@ completeWithinNamespace compTypes query currentPath = do -- completions. qualifyRefs :: NameSegment -> Map r metadata -> [HQ'.HashQualified NameSegment] qualifyRefs n refs - | ((Text.isInfixOf "#" . NameSegment.toEscapedText) querySuffix) || length refs > 1 = refs & Map.keys <&> qualify n + | Text.isInfixOf "#" querySuffix || length refs > 1 = refs & Map.keys <&> qualify n | otherwise = [HQ'.NameOnly n] -- If we're not completing namespaces, then all namespace completions should automatically @@ -251,22 +250,9 @@ completeWithinNamespace compTypes query currentPath = do -- (base,"List") parseLaxPath'Query :: Text -> (Path.Path', Text) parseLaxPath'Query txt = - case P.runParser (((,) <$> Path.splitP' <*> P.takeRest) "" (Text.unpack txt)) of - _ -> wundefined - --- case unsnoc (Text.splitOn "." txt) of --- -- This case is impossible due to the behaviour of 'splitOn' --- Nothing -> undefined --- -- ".base." --- -- ".base.List" --- Just ("" : pathPrefix, querySegment) -> (Path.AbsolutePath' . Path.Absolute . Path.fromList . fmap NameSegment $ pathPrefix, NameSegment querySegment) --- -- "" --- -- "base" --- -- "base.List" --- Just (pathPrefix, querySegment) -> --- ( Path.RelativePath' . Path.Relative . Path.fromList . fmap NameSegment $ pathPrefix, --- NameSegment querySegment --- ) + case P.runParser ((,) <$> Path.splitP' <*> P.takeRest) "" (Text.unpack txt) of + Left _err -> (Path.RelativePath' (Path.Relative Path.empty), txt) + Right (path, rest) -> (Path.unsplit' path, Text.pack rest) -- | Completes a namespace argument by prefix-matching against the query. prefixCompleteNamespace :: @@ -372,7 +358,7 @@ shareCompletion completionTypes authHTTPClient str = Right (userHandle : path0) -> do let (path, pathSuffix) = case unsnoc path0 of - Just (path, pathSuffix) -> (Path.fromList path, pathSuffix) + Just (path, pathSuffix) -> (Path.fromList path, NameSegment.toEscapedText pathSuffix) Nothing -> (Path.empty, "") NamespaceListing {namespaceListingChildren} <- MaybeT $ fetchShareNamespaceInfo authHTTPClient (NameSegment.toEscapedText userHandle) path namespaceListingChildren @@ -391,7 +377,7 @@ shareCompletion completionTypes authHTTPClient str = let name = Server.patchName np in (NamespaceCompletion, name) ) - & filter (\(typ, name) -> typ `NESet.member` completionTypes && NameSegment.toEscapedText pathSuffix `Text.isPrefixOf` name) + & filter (\(typ, name) -> typ `NESet.member` completionTypes && pathSuffix `Text.isPrefixOf` name) & fmap ( \(_, name) -> let queryPath = userHandle : Path.toList path diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index f9820a6042..32bfc70758 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -29,7 +29,6 @@ import Unison.Cli.Pretty (prettyProjectName, prettyProjectNameSlash, prettySlash import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Merge qualified as Branch import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input) import Unison.Codebase.Editor.Input qualified as Input @@ -56,7 +55,6 @@ import Unison.JitInfo qualified as JitInfo import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) -import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectBranchNameOrLatestRelease (..), ProjectBranchSpecifier (..), ProjectName, Semver) import Unison.Project.Util (ProjectContext (..), projectContextFromPath) @@ -3144,10 +3142,6 @@ namespaceOrDefinitionArg = Just Resolvers.namespaceOrDefinitionResolver } --- | Names of child branches of the branch, only gives options for one 'layer' deeper at a time. -childNamespaceNames :: Branch.Branch0 m -> [Text] -childNamespaceNames b = NameSegment.toText <$> Map.keys (Branch.nonEmptyChildren b) - newNameArg :: ArgumentType newNameArg = ArgumentType @@ -3204,8 +3198,7 @@ remoteNamespaceArg = "ghs" -> complete "git(git@github.com:" "gls" -> complete "git(git@gitlab.com:" "bbs" -> complete "git(git@bitbucket.com:" - _ -> do - sharePathCompletion http input, + _ -> sharePathCompletion http input, fzfResolver = Nothing } diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index d58d1cf9b2..199b2d3645 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -140,6 +140,7 @@ import Unison.Syntax.NamePrinter prettyShortHash, styleHashQualified, ) +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Syntax.TermPrinter qualified as TermPrinter import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Term (Term) @@ -486,7 +487,7 @@ notifyNumbered = \case E.AmbiguousReset'Hash -> \xs -> xs E.AmbiguousReset'Target -> \xs -> "" : xs reset = IP.makeExample IP.reset - relPath0 = prettyPath' (Path.toPath' path) + relPath0 = prettyPath path absPath0 = review ProjectUtils.projectBranchPathPrism (ProjectAndBranch (pn0 ^. #projectId) (bn0 ^. #branchId), path) ListNamespaceDependencies _ppe _path Empty -> ("This namespace has no external dependencies.", mempty) ListNamespaceDependencies ppe path' externalDependencies -> @@ -741,7 +742,7 @@ notifyUser dir = \case "Use" <> IP.makeExample IP.todo - [ prettyPath' (snoc mergedPath "patch"), + [ prettyPath' (snoc mergedPath (NameSegment.unsafeFromUnescapedText "patch")), prettyPath' mergedPath ] <> "to see what work is remaining for the merge.", @@ -1844,7 +1845,16 @@ notifyUser dir = \case <> "or" <> IP.makeExample IP.mergeLocal - [prettyAbsolute (Path.Absolute (Path.fromList ["path", "to", "code"]))] + [ prettyAbsolute + ( Path.Absolute + ( Path.fromList + [ NameSegment.unsafeFromUnescapedText "path", + NameSegment.unsafeFromUnescapedText "to", + NameSegment.unsafeFromUnescapedText "code" + ] + ) + ) + ] <> "to initialize this branch." ) CreatedProjectBranchFrom'OtherBranch (ProjectAndBranch otherProject otherBranch) -> @@ -2178,19 +2188,19 @@ notifyUser dir = \case UpgradeFailure path old new -> pure . P.wrap $ "I couldn't automatically upgrade" - <> P.text (NameSegment.toText old) + <> P.text (NameSegment.toEscapedText old) <> "to" - <> P.group (P.text (NameSegment.toText new) <> ".") + <> P.group (P.text (NameSegment.toEscapedText new) <> ".") <> "However, I've added the definitions that need attention to the top of" <> P.group (prettyFilePath path <> ".") UpgradeSuccess old new -> pure . P.wrap $ "I upgraded" - <> P.text (NameSegment.toText old) + <> P.text (NameSegment.toEscapedText old) <> "to" - <> P.group (P.text (NameSegment.toText new) <> ",") + <> P.group (P.text (NameSegment.toEscapedText new) <> ",") <> "and removed" - <> P.group (P.text (NameSegment.toText old) <> ".") + <> P.group (P.text (NameSegment.toEscapedText old) <> ".") where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" @@ -2700,7 +2710,7 @@ renderEditConflicts ppe Patch {..} = do then "deprecated and also replaced with" else "replaced with" ) - `P.hang` P.lines replacements + `P.hang` P.lines replacements formatTermEdits :: (Reference.TermReference, Set TermEdit.TermEdit) -> Numbered Pretty @@ -2715,7 +2725,7 @@ renderEditConflicts ppe Patch {..} = do then "deprecated and also replaced with" else "replaced with" ) - `P.hang` P.lines replacements + `P.hang` P.lines replacements formatConflict :: Either (Reference, Set TypeEdit.TypeEdit) diff --git a/unison-cli/src/Unison/LSP/Completion.hs b/unison-cli/src/Unison/LSP/Completion.hs index 4f799676f3..fb7a61a664 100644 --- a/unison-cli/src/Unison/LSP/Completion.hs +++ b/unison-cli/src/Unison/LSP/Completion.hs @@ -10,6 +10,7 @@ import Control.Lens hiding (List, (:<)) import Control.Monad.Reader import Data.Aeson qualified as Aeson import Data.Aeson.Types qualified as Aeson +import Data.Foldable qualified as Foldable import Data.List.Extra (nubOrdOn) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map qualified as Map @@ -18,6 +19,7 @@ import Data.Text qualified as Text import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Message qualified as Msg import Language.LSP.Protocol.Types +import Text.Megaparsec qualified as Megaparsec import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.HashQualified qualified as HQ @@ -41,7 +43,7 @@ import Unison.Referent qualified as Referent import Unison.Runtime.IOSource qualified as IOSource import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.HashQualified' qualified as HQ' (toText) -import Unison.Syntax.Name qualified as Name (fromText, toText) +import Unison.Syntax.Name qualified as Name (fromText, nameP, toText) import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as Pretty @@ -190,7 +192,7 @@ namesToCompletionTree Names {terms, types} = -- Special docs like "README" will still appear since they're not named 'doc' isDefinitionDoc name = case Name.reverseSegments name of - ("doc" :| _) -> True + ((NameSegment.toUnescapedText -> "doc") :| _) -> True _ -> False nameToCompletionTree :: Name -> LabeledDependency -> CompletionTree @@ -228,27 +230,25 @@ nameToCompletionTree name ref = -- @@ matchCompletions :: CompletionTree -> Text -> [(Path, Name, LabeledDependency)] matchCompletions (CompletionTree tree) txt = - matchSegments segments (Set.toList <$> tree) + case Megaparsec.runParser (Name.nameP <* Megaparsec.eof) "" (Text.unpack txt) of + Left _ -> [] + Right name -> matchSegments (Foldable.toList @NonEmpty (Name.segments name)) (Set.toList <$> tree) where - segments :: [Text] - segments = - Text.splitOn "." txt - & filter (not . Text.null) - matchSegments :: [Text] -> Cofree (Map NameSegment) [(Name, LabeledDependency)] -> [(Path, Name, LabeledDependency)] + matchSegments :: [NameSegment] -> Cofree (Map NameSegment) [(Name, LabeledDependency)] -> [(Path, Name, LabeledDependency)] matchSegments xs (currentMatches :< subtreeMap) = case xs of [] -> let current = currentMatches <&> (\(name, def) -> (Path.empty, name, def)) in (current <> mkDefMatches subtreeMap) [prefix] -> - Map.dropWhileAntitone ((< prefix) . NameSegment.toText) subtreeMap - & Map.takeWhileAntitone (Text.isPrefixOf prefix . NameSegment.toText) + Map.dropWhileAntitone (< prefix) subtreeMap + & Map.takeWhileAntitone (NameSegment.isPrefixOf prefix) & \matchingSubtrees -> let subMatches = ifoldMap (\ns subTree -> matchSegments [] subTree & consPathPrefix ns) matchingSubtrees in subMatches (ns : rest) -> - foldMap (matchSegments rest) (Map.lookup (NameSegment ns) subtreeMap) - & consPathPrefix (NameSegment ns) + foldMap (matchSegments rest) (Map.lookup ns subtreeMap) + & consPathPrefix ns consPathPrefix :: NameSegment -> ([(Path, Name, LabeledDependency)]) -> [(Path, Name, LabeledDependency)] consPathPrefix ns = over (mapped . _1) (Path.cons ns) mkDefMatches :: Map NameSegment (Cofree (Map NameSegment) [(Name, LabeledDependency)]) -> [(Path, Name, LabeledDependency)] diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index 7562700b94..f2baddd09b 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -1,6 +1,5 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} @@ -278,7 +277,7 @@ main = do Just startingPath -> pure startingPath Nothing -> do segments <- Codebase.runTransaction theCodebase Queries.expectMostRecentNamespace - pure (Path.Absolute (Path.fromList (map NameSegment.NameSegment segments))) + pure (Path.Absolute (Path.fromList (map NameSegment.unsafeFromUnescapedText segments))) Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath rootVar <- newEmptyTMVarIO pathVar <- newTVarIO startingPath From 186843b7c9db087b682b49edfd715272932dd35e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 30 Jan 2024 07:41:18 -0500 Subject: [PATCH 15/41] fix compiler errors in tests --- .../tests/Unison/Core/Test/Name.hs | 94 ++++++++++++++++--- .../tests/Unison/Test/Codebase/Branch.hs | 9 +- .../tests/Unison/Test/Codebase/Path.hs | 12 +-- unison-cli/tests/Unison/Test/UriParser.hs | 19 ++-- 4 files changed, 100 insertions(+), 34 deletions(-) diff --git a/parser-typechecker/tests/Unison/Core/Test/Name.hs b/parser-typechecker/tests/Unison/Core/Test/Name.hs index 41413eae58..69d8ae18df 100644 --- a/parser-typechecker/tests/Unison/Core/Test/Name.hs +++ b/parser-typechecker/tests/Unison/Core/Test/Name.hs @@ -5,8 +5,8 @@ import Data.List.NonEmpty qualified as List.NonEmpty import Data.Set qualified as Set import EasyTest import Unison.Name as Name +import Unison.NameSegment qualified as NameSegment import Unison.Syntax.Name qualified as Name (unsafeFromText) -import Unison.Syntax.NameSegment qualified as NameSegment (unsafeFromText) import Unison.Util.Relation qualified as R test :: Test () @@ -35,30 +35,82 @@ testCompareSuffix = testEndsWithReverseSegments :: [Test ()] testEndsWithReverseSegments = [ scope "a.b.c ends with []" (expectEqual True (endsWithReverseSegments "a.b.c" [])), - scope "a.b.c ends with [c, b]" (expectEqual True (endsWithReverseSegments "a.b.c" ["c", "b"])), - scope "a.b.c doesn't end with [d]" (expectEqual False (endsWithReverseSegments "a.b.c" ["d"])) + scope + "a.b.c ends with [c, b]" + ( expectEqual + True + ( endsWithReverseSegments + "a.b.c" + [ NameSegment.unsafeFromUnescapedText "c", + NameSegment.unsafeFromUnescapedText "b" + ] + ) + ), + scope + "a.b.c doesn't end with [d]" + ( expectEqual + False + ( endsWithReverseSegments + "a.b.c" + [NameSegment.unsafeFromUnescapedText "d"] + ) + ) ] testEndsWithSegments :: [Test ()] testEndsWithSegments = [ scope "a.b.c ends with []" (expectEqual True (endsWithSegments "a.b.c" [])), - scope "a.b.c ends with [b, c]" (expectEqual True (endsWithSegments "a.b.c" ["b", "c"])), - scope "a.b.c doesn't end with [d]" (expectEqual False (endsWithSegments "a.b.c" ["d"])) + scope + "a.b.c ends with [b, c]" + ( expectEqual + True + ( endsWithSegments + "a.b.c" + [ NameSegment.unsafeFromUnescapedText "b", + NameSegment.unsafeFromUnescapedText "c" + ] + ) + ), + scope + "a.b.c doesn't end with [d]" + ( expectEqual + False + ( endsWithSegments + "a.b.c" + [NameSegment.unsafeFromUnescapedText "d"] + ) + ) ] testSegments :: [Test ()] testSegments = [ do n <- int' 1 10 - segs <- List.NonEmpty.fromList <$> listOf n (pick [".", "foo"]) + segs <- + List.NonEmpty.fromList + <$> listOf + n + ( pick + [ NameSegment.unsafeFromUnescapedText ".", + NameSegment.unsafeFromUnescapedText "foo" + ] + ) expectEqual (segments (fromSegments segs)) segs ] testSplitName :: [Test ()] testSplitName = [ scope "x" (expectEqual (splits "x") [([], "x")]), - scope "A.x" (expectEqual (splits "A.x") [([], "A.x"), (["A"], "x")]), - scope "A.B.x" (expectEqual (splits "A.B.x") [([], "A.B.x"), (["A"], "B.x"), (["A", "B"], "x")]) + scope "A.x" (expectEqual (splits "A.x") [([], "A.x"), ([NameSegment.unsafeFromUnescapedText "A"], "x")]), + scope + "A.B.x" + ( expectEqual + (splits "A.B.x") + [ ([], "A.B.x"), + ([NameSegment.unsafeFromUnescapedText "A"], "B.x"), + ([NameSegment.unsafeFromUnescapedText "A", NameSegment.unsafeFromUnescapedText "B"], "x") + ] + ) ] testSuffixes :: [Test ()] @@ -85,8 +137,8 @@ testSuffixSearch = (n ".`.`", 6) ] n = Name.unsafeFromText - expectEqual' (NameSegment.unsafeFromText "." :| []) (Name.reverseSegments (n ".`.`")) - expectEqual' (NameSegment.unsafeFromText "." :| []) (Name.reverseSegments (n ".`.`")) + expectEqual' (NameSegment.unsafeFromUnescapedText "." :| []) (Name.reverseSegments (n ".`.`")) + expectEqual' (NameSegment.unsafeFromUnescapedText "." :| []) (Name.reverseSegments (n ".`.`")) expectEqual' (Set.fromList [1, 2]) @@ -121,22 +173,34 @@ testUnsafeFromString :: [Test ()] testUnsafeFromString = [ scope "." do expectEqual' (isAbsolute "`.`") False - expectEqual' (segments "`.`") (NameSegment.unsafeFromText "." :| []) + expectEqual' (segments "`.`") (NameSegment.unsafeFromUnescapedText "." :| []) ok, scope ".`.`" do expectEqual' (isAbsolute ".`.`") True - expectEqual' (segments ".`.`") (NameSegment.unsafeFromText "." :| []) + expectEqual' (segments ".`.`") (NameSegment.unsafeFromUnescapedText "." :| []) ok, scope "foo.bar" do expectEqual' (isAbsolute "foo.bar") False - expectEqual' (segments "foo.bar") ("foo" :| ["bar"]) + expectEqual' + (segments "foo.bar") + ( NameSegment.unsafeFromUnescapedText "foo" + :| [NameSegment.unsafeFromUnescapedText "bar"] + ) ok, scope ".foo.bar" do expectEqual' (isAbsolute ".foo.bar") True - expectEqual' (segments ".foo.bar") ("foo" :| ["bar"]) + expectEqual' + (segments ".foo.bar") + ( NameSegment.unsafeFromUnescapedText "foo" + :| [NameSegment.unsafeFromUnescapedText "bar"] + ) ok, scope "foo.`.`" do expectEqual' (isAbsolute "foo.`.`") False - expectEqual' (segments "foo.`.`") ("foo" :| [NameSegment.unsafeFromText "."]) + expectEqual' + (segments "foo.`.`") + ( NameSegment.unsafeFromUnescapedText "foo" + :| [NameSegment.unsafeFromUnescapedText "."] + ) ok ] diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Branch.hs b/parser-typechecker/tests/Unison/Test/Codebase/Branch.hs index 79ecf3644f..7c2c1ae7ce 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Branch.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Branch.hs @@ -11,6 +11,7 @@ import EasyTest import Unison.Codebase.Branch (Branch (Branch), Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Causal qualified as Causal +import Unison.NameSegment qualified as NameSegment import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Util.Relation qualified as Relation @@ -31,7 +32,7 @@ branch0Tests = b0 :: Branch0 Identity = Branch.branch0 mempty - (Star3.fromList [(dummy, "b", dummy, (dummy, dummy))]) + (Star3.fromList [(dummy, NameSegment.unsafeFromUnescapedText "b", dummy, (dummy, dummy))]) Map.empty Map.empty let -- a.b @@ -39,8 +40,8 @@ branch0Tests = b1 :: Branch0 Identity = Branch.branch0 mempty - (Star3.fromList [(dummy, "b", dummy, (dummy, dummy))]) - (Map.singleton "a" (Branch (Causal.one b0))) + (Star3.fromList [(dummy, NameSegment.unsafeFromUnescapedText "b", dummy, (dummy, dummy))]) + (Map.singleton (NameSegment.unsafeFromUnescapedText "a") (Branch (Causal.one b0))) Map.empty let -- b.a.b @@ -49,7 +50,7 @@ branch0Tests = Branch.branch0 mempty mempty - (Map.singleton "b" (Branch (Causal.one b1))) + (Map.singleton (NameSegment.unsafeFromUnescapedText "b") (Branch (Causal.one b1))) Map.empty expect (Set.valid (Relation.ran (Branch.deepTypes b2))) diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs index a79ceb2aed..4dfc6a5ceb 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs @@ -7,7 +7,7 @@ import EasyTest import Unison.Codebase.Path (Path (..), Path' (..), Relative (..)) import Unison.Codebase.Path.Parse (parseHQSplit', parseShortHashOrHQSplit') import Unison.HashQualified' qualified as HQ' -import Unison.NameSegment (NameSegment (..)) +import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.ShortHash qualified as SH @@ -19,12 +19,12 @@ test = in scope s . expect $ parseShortHashOrHQSplit' s == (Right . Right) - (relative ["foo"], HQ'.HashQualified (NameSegment "bar") (fromJust (SH.fromText "#34"))), + (relative ["foo"], HQ'.HashQualified (NameSegment.unsafeFromUnescapedText "bar") (fromJust (SH.fromText "#34"))), let s = "foo.bar.+" in scope s . expect $ parseShortHashOrHQSplit' s == (Right . Right) - (relative ["foo", "bar"], HQ'.NameOnly (NameSegment "+")), + (relative ["foo", "bar"], HQ'.NameOnly (NameSegment.unsafeFromUnescapedText "+")), let s = "#123" in scope s . expect $ parseShortHashOrHQSplit' s @@ -33,13 +33,13 @@ test = scope "parseHQ'Split'" . tests $ [ let s = "foo.bar#34" in scope s . expect $ - parseHQSplit' s == Right (relative ["foo"], HQ'.HashQualified (NameSegment "bar") (fromJust (SH.fromText "#34"))), + parseHQSplit' s == Right (relative ["foo"], HQ'.HashQualified (NameSegment.unsafeFromUnescapedText "bar") (fromJust (SH.fromText "#34"))), let s = "foo.bar.+" in scope s . expect $ - parseHQSplit' s == Right (relative ["foo", "bar"], HQ'.NameOnly (NameSegment "+")), + parseHQSplit' s == Right (relative ["foo", "bar"], HQ'.NameOnly (NameSegment.unsafeFromUnescapedText "+")), let s = "#123" in scope s . expect $ isLeft $ parseHQSplit' s ] ] relative :: Seq Text -> Path' -relative = Path' . Right . Relative . Path . fmap NameSegment +relative = Path' . Right . Relative . Path . fmap NameSegment.unsafeFromUnescapedText diff --git a/unison-cli/tests/Unison/Test/UriParser.hs b/unison-cli/tests/Unison/Test/UriParser.hs index ba71a26ba8..c5f053b9b0 100644 --- a/unison-cli/tests/Unison/Test/UriParser.hs +++ b/unison-cli/tests/Unison/Test/UriParser.hs @@ -12,6 +12,7 @@ import Unison.Codebase.Path qualified as Path import Unison.Codebase.ShortCausalHash (ShortCausalHash (..)) import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.NameSegment (NameSegment (..)) +import Unison.NameSegment qualified as NameSegment import Unison.Project (ProjectBranchSpecifier (..)) test :: Test () @@ -20,31 +21,31 @@ test = [ parserTests "repoPath" (UriParser.readRemoteNamespaceParser ProjectBranchSpecifier'Name <* P.eof) - [ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]), + [ ("unisonweb.base._releases.M4", looseR "unisonweb" [NameSegment.unsafeFromUnescapedText "base", NameSegment.unsafeFromUnescapedText "_releases", NameSegment.unsafeFromUnescapedText "M4"]), ("project", branchR (This "project")), ("/branch", branchR (That "branch")), ("project/branch", branchR (These "project" "branch")), ("git(/srv/git/project.git)", gitR "/srv/git/project.git" Nothing Nothing []), - ("git(/srv/git/project.git:abc)#def.hij.klm", gitR "/srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), + ("git(/srv/git/project.git:abc)#def.hij.klm", gitR "/srv/git/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), ("git(srv/git/project.git)", gitR "srv/git/project.git" Nothing Nothing []), - ("git(srv/git/project.git:abc)#def.hij.klm", gitR "srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), + ("git(srv/git/project.git:abc)#def.hij.klm", gitR "srv/git/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), ("git(file:///srv/git/project.git)", gitR "file:///srv/git/project.git" Nothing Nothing []), - ("git(file:///srv/git/project.git:abc)#def.hij.klm", gitR "file:///srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), + ("git(file:///srv/git/project.git:abc)#def.hij.klm", gitR "file:///srv/git/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), ("git(file://srv/git/project.git)", gitR "file://srv/git/project.git" Nothing Nothing []), - ("git(file://srv/git/project.git:abc)#def.hij.klm", gitR "file://srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), + ("git(file://srv/git/project.git:abc)#def.hij.klm", gitR "file://srv/git/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), ("git(https://example.com/git/project.git)", gitR "https://example.com/git/project.git" Nothing Nothing []), - ("git(https://user@example.com/git/project.git:abc)#def.hij.klm", gitR "https://user@example.com/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), + ("git(https://user@example.com/git/project.git:abc)#def.hij.klm", gitR "https://user@example.com/git/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), ("git(ssh://git@8.8.8.8:222/user/project.git)", gitR "ssh://git@8.8.8.8:222/user/project.git" Nothing Nothing []), - ("git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", gitR "ssh://git@github.com/user/project.git" (Just "abc") (sch "def") ["hij", "klm"]), + ("git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", gitR "ssh://git@github.com/user/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), ("git(git@github.com:user/project.git)", gitR "git@github.com:user/project.git" Nothing Nothing []), ("git(github.com:user/project.git)", gitR "github.com:user/project.git" Nothing Nothing []), - ("git(git@github.com:user/project.git:abc)#def.hij.klm", gitR "git@github.com:user/project.git" (Just "abc") (sch "def") ["hij", "klm"]) + ("git(git@github.com:user/project.git:abc)#def.hij.klm", gitR "git@github.com:user/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]) ] [".unisonweb.base"], parserTests "writeRemoteNamespace" (UriParser.writeRemoteNamespace <* P.eof) - [ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]), + [ ("unisonweb.base._releases.M4", looseW "unisonweb" [NameSegment.unsafeFromUnescapedText "base", NameSegment.unsafeFromUnescapedText "_releases", NameSegment.unsafeFromUnescapedText "M4"]), ("project", branchW (This "project")), ("/branch", branchW (That "branch")), ("project/branch", branchW (These "project" "branch")), From 80b528d1b0da821d1ede7df2b43725fdc3e0796d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 30 Jan 2024 11:08:52 -0500 Subject: [PATCH 16/41] add export list to Unison.NameSegment --- codebase2/core/Unison/NameSegment.hs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/codebase2/core/Unison/NameSegment.hs b/codebase2/core/Unison/NameSegment.hs index 9270625359..e637a3bc8f 100644 --- a/codebase2/core/Unison/NameSegment.hs +++ b/codebase2/core/Unison/NameSegment.hs @@ -1,4 +1,15 @@ -module Unison.NameSegment where +module Unison.NameSegment + ( NameSegment (UnsafeNameSegment), + unsafeFromUnescapedText, + toUnescapedText, + segments', + reverseSegments', + isEmpty, + isPrefixOf, + toTextBuilder, + libSegment, + ) +where import Data.Text qualified as Text import Data.Text.Lazy.Builder qualified as Text (Builder) @@ -74,4 +85,4 @@ toTextBuilder = libSegment :: NameSegment libSegment = - unsafeFromUnescapedText "lib" + unsafeFromUnescapedText "lib" From ab361b61684e9dca31998b735ac6ce7cda3c853a Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 31 Jan 2024 10:14:13 -0500 Subject: [PATCH 17/41] delete NameSegment.segments', implement Var.universallyQuantifyIfFree without it --- codebase2/core/Unison/NameSegment.hs | 12 ------------ unison-core/src/Unison/Var.hs | 15 +++------------ 2 files changed, 3 insertions(+), 24 deletions(-) diff --git a/codebase2/core/Unison/NameSegment.hs b/codebase2/core/Unison/NameSegment.hs index e637a3bc8f..6c53a04634 100644 --- a/codebase2/core/Unison/NameSegment.hs +++ b/codebase2/core/Unison/NameSegment.hs @@ -2,7 +2,6 @@ module Unison.NameSegment ( NameSegment (UnsafeNameSegment), unsafeFromUnescapedText, toUnescapedText, - segments', reverseSegments', isEmpty, isPrefixOf, @@ -41,17 +40,6 @@ toUnescapedText :: NameSegment -> Text toUnescapedText = coerce --- Split text into segments. A smarter version of `Text.splitOn` that handles --- the name `.` properly. -segments' :: Text -> [Text] -segments' n = go split - where - split = Text.splitOn "." n - go [] = [] - go ("" : "" : z) = "." : go z - go ("" : z) = go z - go (x : y) = x : go y - -- Same as reverse . segments', but produces the output as a -- lazy list, suitable for suffix-based ordering purposes or -- building suffix tries. Examples: diff --git a/unison-core/src/Unison/Var.hs b/unison-core/src/Unison/Var.hs index ef4363bbc1..e5c45090dc 100644 --- a/unison-core/src/Unison/Var.hs +++ b/unison-core/src/Unison/Var.hs @@ -32,11 +32,10 @@ module Unison.Var ) where -import Data.Char (isLower, toLower) +import Data.Char (isLower, toLower, isAlphaNum) import Data.Text (pack) import Data.Text qualified as Text import Unison.ABT qualified as ABT -import Unison.NameSegment qualified as Name import Unison.Prelude import Unison.Reference qualified as Reference import Unison.Util.Monoid (intercalateMap) @@ -195,14 +194,6 @@ data InferenceType reset :: (Var v) => v -> v reset v = typed (typeOf v) -unqualifiedName :: (Var v) => v -> Text -unqualifiedName = fromMaybe "" . lastMay . Name.segments' . name - -unqualified :: (Var v) => v -> v -unqualified v = case typeOf v of - User _ -> named . unqualifiedName $ v - _ -> v - namespaced :: (Var v) => [v] -> v namespaced vs = named $ intercalateMap "." name vs @@ -220,6 +211,6 @@ joinDot prefix v2 = universallyQuantifyIfFree :: forall v. (Var v) => v -> Bool universallyQuantifyIfFree v = - ok (name $ reset v) && unqualified v == v + Text.all isLower (Text.take 1 n) && Text.all isAlphaNum n where - ok n = (all isLower . take 1 . Text.unpack) n + n = name $ reset v From 9299a199ab7414c2fa57e423c08feff1a8ac42db Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 31 Jan 2024 10:25:17 -0500 Subject: [PATCH 18/41] remove NameSegment.reverseSegments' --- codebase2/core/Unison/NameSegment.hs | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/codebase2/core/Unison/NameSegment.hs b/codebase2/core/Unison/NameSegment.hs index 6c53a04634..a026656be1 100644 --- a/codebase2/core/Unison/NameSegment.hs +++ b/codebase2/core/Unison/NameSegment.hs @@ -2,7 +2,6 @@ module Unison.NameSegment ( NameSegment (UnsafeNameSegment), unsafeFromUnescapedText, toUnescapedText, - reverseSegments', isEmpty, isPrefixOf, toTextBuilder, @@ -40,25 +39,6 @@ toUnescapedText :: NameSegment -> Text toUnescapedText = coerce --- Same as reverse . segments', but produces the output as a --- lazy list, suitable for suffix-based ordering purposes or --- building suffix tries. Examples: --- --- reverseSegments' "foo.bar.baz" => ["baz","bar","foo"] --- reverseSegments' ".foo.bar.baz" => ["baz","bar","foo"] --- reverseSegments' ".." => ["."] --- reverseSegments' "Nat.++" => ["++","Nat"] --- reverseSegments' "Nat.++.zoo" => ["zoo","++","Nat"] -reverseSegments' :: Text -> [Text] -reverseSegments' = go - where - go "" = [] - go t = - let seg0 = Text.takeWhileEnd (/= '.') t - seg = if Text.null seg0 then Text.takeEnd 1 t else seg0 - rem = Text.dropEnd (Text.length seg + 1) t - in seg : go rem - isEmpty :: NameSegment -> Bool isEmpty = coerce Text.null From 7f93853228bf7fd965f05c6fb861d6324699df3a Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 31 Jan 2024 11:08:47 -0500 Subject: [PATCH 19/41] add instance IsString NameSegment --- .../U/Codebase/Sqlite/Queries.hs | 10 +- codebase2/core/Unison/NameSegment.hs | 27 ++-- parser-typechecker/src/Unison/PrintError.hs | 3 +- parser-typechecker/src/Unison/Project/Util.hs | 6 +- .../src/Unison/Syntax/FileParser.hs | 3 +- .../src/Unison/Syntax/TermParser.hs | 7 +- .../tests/Unison/Core/Test/Name.hs | 115 ++++-------------- .../tests/Unison/Test/Codebase/Branch.hs | 9 +- .../tests/Unison/Test/Codebase/Path.hs | 14 +-- unison-cli/src/Unison/Cli/MonadUtils.hs | 8 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 14 +-- .../Editor/HandleInput/ProjectCreate.hs | 2 +- .../Codebase/Editor/HandleInput/Pull.hs | 5 +- .../src/Unison/CommandLine/OutputMessages.hs | 33 ++--- unison-cli/tests/Unison/Test/UriParser.hs | 19 ++- unison-cli/unison/Main.hs | 3 +- unison-share-api/src/Unison/Server/Backend.hs | 2 +- unison-share-api/src/Unison/Server/Local.hs | 8 +- .../Unison/Server/Local/Endpoints/Current.hs | 4 +- .../Local/Endpoints/NamespaceDetails.hs | 8 +- unison-syntax/src/Unison/Syntax/Lexer.hs | 2 +- .../src/Unison/Syntax/NameSegment.hs | 4 +- 22 files changed, 106 insertions(+), 200 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 3f5ae662f7..2329171ca3 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -393,7 +393,7 @@ import Unison.Hash qualified as Hash import Unison.Hash32 (Hash32) import Unison.Hash32 qualified as Hash32 import Unison.Hash32.Orphans.Sqlite () -import Unison.NameSegment (NameSegment) +import Unison.NameSegment (NameSegment (UnsafeNameSegment)) import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Sqlite @@ -658,7 +658,7 @@ saveNameSegment = expectNameSegment :: TextId -> Transaction NameSegment expectNameSegment = - fmap NameSegment.unsafeFromUnescapedText . expectText + fmap UnsafeNameSegment . expectText saveHashObject :: HashId -> ObjectId -> HashVersion -> Transaction () saveHashObject hId oId version = @@ -4243,7 +4243,7 @@ data JsonParseFailure = JsonParseFailure deriving anyclass (SqliteExceptionReason) -- | Get the most recent namespace the user has visited. -expectMostRecentNamespace :: Transaction [Text] +expectMostRecentNamespace :: Transaction [NameSegment] expectMostRecentNamespace = queryOneColCheck [sql| @@ -4252,11 +4252,11 @@ expectMostRecentNamespace = |] check where - check :: Text -> Either JsonParseFailure [Text] + check :: Text -> Either JsonParseFailure [NameSegment] check bytes = case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure} - Right namespace -> Right namespace + Right namespace -> Right (map UnsafeNameSegment namespace) -- | Set the most recent namespace the user has visited. setMostRecentNamespace :: [Text] -> Transaction () diff --git a/codebase2/core/Unison/NameSegment.hs b/codebase2/core/Unison/NameSegment.hs index a026656be1..1c82476c1d 100644 --- a/codebase2/core/Unison/NameSegment.hs +++ b/codebase2/core/Unison/NameSegment.hs @@ -1,10 +1,13 @@ module Unison.NameSegment ( NameSegment (UnsafeNameSegment), - unsafeFromUnescapedText, toUnescapedText, isEmpty, isPrefixOf, toTextBuilder, + + -- * Sentinel name segments + defaultPatchSegment, + docSegment, libSegment, ) where @@ -21,17 +24,13 @@ newtype NameSegment deriving stock (Eq, Ord, Generic) deriving newtype (Alphabetical) +instance IsString NameSegment where + fromString = + UnsafeNameSegment . Text.pack + instance Show NameSegment where show = show . toUnescapedText --- | Convert a text to a name segment, when the text is known to be a valid name segment. --- --- For example, to make a name segment containing the text ".~", use @unsafeFromUnescapedText ".~"@, even if that --- operator would need to be escaped (e.g. "`.~`") when written by a user. -unsafeFromUnescapedText :: Text -> NameSegment -unsafeFromUnescapedText = - UnsafeNameSegment - -- | Convert a name segment to unescaped text. -- -- > toUnescapedText (unsafeFromText ".~") = ".~" @@ -51,6 +50,14 @@ toTextBuilder :: NameSegment -> Text.Builder toTextBuilder = coerce Text.Builder.fromText +defaultPatchSegment :: NameSegment +defaultPatchSegment = + "patch" + +docSegment :: NameSegment +docSegment = + "doc" + libSegment :: NameSegment libSegment = - unsafeFromUnescapedText "lib" + "lib" diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index b180ad87ec..a819e23a5d 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -28,7 +28,6 @@ import Unison.Kind qualified as Kind import Unison.KindInference.Error.Pretty (prettyKindError) import Unison.Name (Name) import Unison.Name qualified as Name -import Unison.NameSegment qualified as NameSegment import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names import Unison.Parser.Ann (Ann (..)) @@ -1700,7 +1699,7 @@ renderParseErrors s = \case else unknownTypesMsg <> "\n\n" <> dupDataAndAbilitiesMsg in (msgs, allRanges) go (Parser.DidntExpectExpression _tok (Just t@(L.payload -> L.SymbolyId (HQ'.NameOnly name)))) - | name == Name.fromSegment (NameSegment.unsafeFromUnescapedText "::") = + | name == Name.fromSegment "::" = let msg = mconcat [ "This looks like the start of an expression here but I was expecting a binding.", diff --git a/parser-typechecker/src/Unison/Project/Util.hs b/parser-typechecker/src/Unison/Project/Util.hs index f660554e31..6625abf048 100644 --- a/parser-typechecker/src/Unison/Project/Util.hs +++ b/parser-typechecker/src/Unison/Project/Util.hs @@ -62,7 +62,7 @@ pattern UUIDNameSegment uuid <- ) where UUIDNameSegment uuid = - NameSegment.unsafeFromUnescapedText (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid))) + UnsafeNameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid))) -- | The prism between paths like -- @@ -153,8 +153,8 @@ pattern BranchesNameSegment <- projectsNameSegment :: NameSegment projectsNameSegment = - NameSegment.unsafeFromUnescapedText "__projects" + "__projects" branchesNameSegment :: NameSegment branchesNameSegment = - NameSegment.unsafeFromUnescapedText "branches" + "branches" diff --git a/parser-typechecker/src/Unison/Syntax/FileParser.hs b/parser-typechecker/src/Unison/Syntax/FileParser.hs index c9de932c41..00544ce1b3 100644 --- a/parser-typechecker/src/Unison/Syntax/FileParser.hs +++ b/parser-typechecker/src/Unison/Syntax/FileParser.hs @@ -9,7 +9,6 @@ import Unison.ABT qualified as ABT import Unison.DataDeclaration (DataDeclaration) import Unison.DataDeclaration qualified as DD import Unison.Name qualified as Name -import Unison.NameSegment qualified as NameSegment import Unison.Names qualified as Names import Unison.Names.ResolutionResult qualified as Names import Unison.NamesWithHistory qualified as Names @@ -222,7 +221,7 @@ watched = P.try do kind <- (fmap . fmap . fmap) Name.toString (optional importWordyId) guid <- uniqueName 10 op <- optional (L.payload <$> P.lookAhead importSymbolyId) - guard (op == Just (Name.fromSegment (NameSegment.unsafeFromUnescapedText ">"))) + guard (op == Just (Name.fromSegment ">")) tok <- anyToken guard $ maybe True (`L.touches` tok) kind pure (maybe UF.RegularWatch L.payload kind, guid, maybe mempty ann kind <> ann tok) diff --git a/parser-typechecker/src/Unison/Syntax/TermParser.hs b/parser-typechecker/src/Unison/Syntax/TermParser.hs index ca480e145f..dad5d62d9d 100644 --- a/parser-typechecker/src/Unison/Syntax/TermParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TermParser.hs @@ -34,7 +34,6 @@ import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name -import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Names qualified as Names import Unison.NamesWithHistory qualified as Names @@ -995,9 +994,9 @@ bang = P.label "bang" do seqOp :: (Ord v) => P v m Pattern.SeqOp seqOp = - Pattern.Snoc <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment.unsafeFromUnescapedText ":+")))) - <|> Pattern.Cons <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment.unsafeFromUnescapedText "+:")))) - <|> Pattern.Concat <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment (NameSegment.unsafeFromUnescapedText "++")))) + Pattern.Snoc <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment ":+"))) + <|> Pattern.Cons <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment "+:"))) + <|> Pattern.Concat <$ matchToken (L.SymbolyId (HQ'.fromName (Name.fromSegment "++"))) term4 :: (Monad m, Var v) => TermP v m term4 = f <$> some termLeaf diff --git a/parser-typechecker/tests/Unison/Core/Test/Name.hs b/parser-typechecker/tests/Unison/Core/Test/Name.hs index 69d8ae18df..820c6bac3d 100644 --- a/parser-typechecker/tests/Unison/Core/Test/Name.hs +++ b/parser-typechecker/tests/Unison/Core/Test/Name.hs @@ -5,7 +5,6 @@ import Data.List.NonEmpty qualified as List.NonEmpty import Data.Set qualified as Set import EasyTest import Unison.Name as Name -import Unison.NameSegment qualified as NameSegment import Unison.Syntax.Name qualified as Name (unsafeFromText) import Unison.Util.Relation qualified as R @@ -37,24 +36,10 @@ testEndsWithReverseSegments = [ scope "a.b.c ends with []" (expectEqual True (endsWithReverseSegments "a.b.c" [])), scope "a.b.c ends with [c, b]" - ( expectEqual - True - ( endsWithReverseSegments - "a.b.c" - [ NameSegment.unsafeFromUnescapedText "c", - NameSegment.unsafeFromUnescapedText "b" - ] - ) - ), + (expectEqual True (endsWithReverseSegments "a.b.c" ["c", "b"])), scope "a.b.c doesn't end with [d]" - ( expectEqual - False - ( endsWithReverseSegments - "a.b.c" - [NameSegment.unsafeFromUnescapedText "d"] - ) - ) + (expectEqual False (endsWithReverseSegments "a.b.c" ["d"])) ] testEndsWithSegments :: [Test ()] @@ -62,53 +47,31 @@ testEndsWithSegments = [ scope "a.b.c ends with []" (expectEqual True (endsWithSegments "a.b.c" [])), scope "a.b.c ends with [b, c]" - ( expectEqual - True - ( endsWithSegments - "a.b.c" - [ NameSegment.unsafeFromUnescapedText "b", - NameSegment.unsafeFromUnescapedText "c" - ] - ) - ), + (expectEqual True (endsWithSegments "a.b.c" ["b", "c"])), scope "a.b.c doesn't end with [d]" - ( expectEqual - False - ( endsWithSegments - "a.b.c" - [NameSegment.unsafeFromUnescapedText "d"] - ) - ) + (expectEqual False (endsWithSegments "a.b.c" ["d"])) ] testSegments :: [Test ()] testSegments = [ do n <- int' 1 10 - segs <- - List.NonEmpty.fromList - <$> listOf - n - ( pick - [ NameSegment.unsafeFromUnescapedText ".", - NameSegment.unsafeFromUnescapedText "foo" - ] - ) + segs <- List.NonEmpty.fromList <$> listOf n (pick [".", "foo"]) expectEqual (segments (fromSegments segs)) segs ] testSplitName :: [Test ()] testSplitName = [ scope "x" (expectEqual (splits "x") [([], "x")]), - scope "A.x" (expectEqual (splits "A.x") [([], "A.x"), ([NameSegment.unsafeFromUnescapedText "A"], "x")]), + scope "A.x" (expectEqual (splits "A.x") [([], "A.x"), (["A"], "x")]), scope "A.B.x" ( expectEqual (splits "A.B.x") [ ([], "A.B.x"), - ([NameSegment.unsafeFromUnescapedText "A"], "B.x"), - ([NameSegment.unsafeFromUnescapedText "A", NameSegment.unsafeFromUnescapedText "B"], "x") + (["A"], "B.x"), + (["A", "B"], "x") ] ) ] @@ -116,10 +79,8 @@ testSplitName = testSuffixes :: [Test ()] testSuffixes = [ scope "one namespace" $ expectEqual (suffixes "bar") ["bar"], - scope "two namespaces" $ - expectEqual (suffixes "foo.bar") ["foo.bar", "bar"], - scope "multiple namespaces" $ - expectEqual (suffixes "foo.bar.baz") ["foo.bar.baz", "bar.baz", "baz"], + scope "two namespaces" $ expectEqual (suffixes "foo.bar") ["foo.bar", "bar"], + scope "multiple namespaces" $ expectEqual (suffixes "foo.bar.baz") ["foo.bar.baz", "bar.baz", "baz"], scope "terms named `.`" $ expectEqual (suffixes "base.`.`") ["base.`.`", "`.`"] ] @@ -137,34 +98,20 @@ testSuffixSearch = (n ".`.`", 6) ] n = Name.unsafeFromText - expectEqual' (NameSegment.unsafeFromUnescapedText "." :| []) (Name.reverseSegments (n ".`.`")) - expectEqual' (NameSegment.unsafeFromUnescapedText "." :| []) (Name.reverseSegments (n ".`.`")) + expectEqual' ("." :| []) (Name.reverseSegments (n ".`.`")) + expectEqual' ("." :| []) (Name.reverseSegments (n ".`.`")) - expectEqual' - (Set.fromList [1, 2]) - (Name.searchBySuffix (n "map") rel) - expectEqual' - (n "List.map") - (Name.suffixifyByHash (n "base.List.map") rel) - expectEqual' - (n "Set.map") - (Name.suffixifyByHash (n "base.Set.map") rel) - expectEqual' - (n "baz") - (Name.suffixifyByHash (n "foo.bar.baz") rel) - expectEqual' - (n "a.b.c") - (Name.suffixifyByHash (n "a.b.c") rel) - expectEqual' - (n "a1.b.c") - (Name.suffixifyByHash (n "a1.b.c") rel) + expectEqual' (Set.fromList [1, 2]) (Name.searchBySuffix (n "map") rel) + expectEqual' (n "List.map") (Name.suffixifyByHash (n "base.List.map") rel) + expectEqual' (n "Set.map") (Name.suffixifyByHash (n "base.Set.map") rel) + expectEqual' (n "baz") (Name.suffixifyByHash (n "foo.bar.baz") rel) + expectEqual' (n "a.b.c") (Name.suffixifyByHash (n "a.b.c") rel) + expectEqual' (n "a1.b.c") (Name.suffixifyByHash (n "a1.b.c") rel) note . show $ Name.reverseSegments (n "`.`") note . show $ Name.reverseSegments (n ".`.`") tests - [ scope "(.) shortest unique suffix" $ - expectEqual' (n "`.`") (Name.suffixifyByHash (n ".`.`") rel), - scope "(.) search by suffix" $ - expectEqual' (Set.fromList [6]) (Name.searchBySuffix (n "`.`") rel) + [ scope "(.) shortest unique suffix" $ expectEqual' (n "`.`") (Name.suffixifyByHash (n ".`.`") rel), + scope "(.) search by suffix" $ expectEqual' (Set.fromList [6]) (Name.searchBySuffix (n "`.`") rel) ] ok ] @@ -173,34 +120,22 @@ testUnsafeFromString :: [Test ()] testUnsafeFromString = [ scope "." do expectEqual' (isAbsolute "`.`") False - expectEqual' (segments "`.`") (NameSegment.unsafeFromUnescapedText "." :| []) + expectEqual' (segments "`.`") ("." :| []) ok, scope ".`.`" do expectEqual' (isAbsolute ".`.`") True - expectEqual' (segments ".`.`") (NameSegment.unsafeFromUnescapedText "." :| []) + expectEqual' (segments ".`.`") ("." :| []) ok, scope "foo.bar" do expectEqual' (isAbsolute "foo.bar") False - expectEqual' - (segments "foo.bar") - ( NameSegment.unsafeFromUnescapedText "foo" - :| [NameSegment.unsafeFromUnescapedText "bar"] - ) + expectEqual' (segments "foo.bar") ("foo" :| ["bar"]) ok, scope ".foo.bar" do expectEqual' (isAbsolute ".foo.bar") True - expectEqual' - (segments ".foo.bar") - ( NameSegment.unsafeFromUnescapedText "foo" - :| [NameSegment.unsafeFromUnescapedText "bar"] - ) + expectEqual' (segments ".foo.bar") ("foo" :| ["bar"]) ok, scope "foo.`.`" do expectEqual' (isAbsolute "foo.`.`") False - expectEqual' - (segments "foo.`.`") - ( NameSegment.unsafeFromUnescapedText "foo" - :| [NameSegment.unsafeFromUnescapedText "."] - ) + expectEqual' (segments "foo.`.`") ("foo" :| ["."]) ok ] diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Branch.hs b/parser-typechecker/tests/Unison/Test/Codebase/Branch.hs index 7c2c1ae7ce..79ecf3644f 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Branch.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Branch.hs @@ -11,7 +11,6 @@ import EasyTest import Unison.Codebase.Branch (Branch (Branch), Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Causal qualified as Causal -import Unison.NameSegment qualified as NameSegment import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Util.Relation qualified as Relation @@ -32,7 +31,7 @@ branch0Tests = b0 :: Branch0 Identity = Branch.branch0 mempty - (Star3.fromList [(dummy, NameSegment.unsafeFromUnescapedText "b", dummy, (dummy, dummy))]) + (Star3.fromList [(dummy, "b", dummy, (dummy, dummy))]) Map.empty Map.empty let -- a.b @@ -40,8 +39,8 @@ branch0Tests = b1 :: Branch0 Identity = Branch.branch0 mempty - (Star3.fromList [(dummy, NameSegment.unsafeFromUnescapedText "b", dummy, (dummy, dummy))]) - (Map.singleton (NameSegment.unsafeFromUnescapedText "a") (Branch (Causal.one b0))) + (Star3.fromList [(dummy, "b", dummy, (dummy, dummy))]) + (Map.singleton "a" (Branch (Causal.one b0))) Map.empty let -- b.a.b @@ -50,7 +49,7 @@ branch0Tests = Branch.branch0 mempty mempty - (Map.singleton (NameSegment.unsafeFromUnescapedText "b") (Branch (Causal.one b1))) + (Map.singleton "b" (Branch (Causal.one b1))) Map.empty expect (Set.valid (Relation.ran (Branch.deepTypes b2))) diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs index 4dfc6a5ceb..f3b19f71ad 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Path.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Path.hs @@ -7,7 +7,7 @@ import EasyTest import Unison.Codebase.Path (Path (..), Path' (..), Relative (..)) import Unison.Codebase.Path.Parse (parseHQSplit', parseShortHashOrHQSplit') import Unison.HashQualified' qualified as HQ' -import Unison.NameSegment qualified as NameSegment +import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.ShortHash qualified as SH @@ -19,12 +19,12 @@ test = in scope s . expect $ parseShortHashOrHQSplit' s == (Right . Right) - (relative ["foo"], HQ'.HashQualified (NameSegment.unsafeFromUnescapedText "bar") (fromJust (SH.fromText "#34"))), + (relative ["foo"], HQ'.HashQualified "bar" (fromJust (SH.fromText "#34"))), let s = "foo.bar.+" in scope s . expect $ parseShortHashOrHQSplit' s == (Right . Right) - (relative ["foo", "bar"], HQ'.NameOnly (NameSegment.unsafeFromUnescapedText "+")), + (relative ["foo", "bar"], HQ'.NameOnly "+"), let s = "#123" in scope s . expect $ parseShortHashOrHQSplit' s @@ -33,13 +33,13 @@ test = scope "parseHQ'Split'" . tests $ [ let s = "foo.bar#34" in scope s . expect $ - parseHQSplit' s == Right (relative ["foo"], HQ'.HashQualified (NameSegment.unsafeFromUnescapedText "bar") (fromJust (SH.fromText "#34"))), + parseHQSplit' s == Right (relative ["foo"], HQ'.HashQualified "bar" (fromJust (SH.fromText "#34"))), let s = "foo.bar.+" in scope s . expect $ - parseHQSplit' s == Right (relative ["foo", "bar"], HQ'.NameOnly (NameSegment.unsafeFromUnescapedText "+")), + parseHQSplit' s == Right (relative ["foo", "bar"], HQ'.NameOnly "+"), let s = "#123" in scope s . expect $ isLeft $ parseHQSplit' s ] ] -relative :: Seq Text -> Path' -relative = Path' . Right . Relative . Path . fmap NameSegment.unsafeFromUnescapedText +relative :: Seq NameSegment -> Path' +relative = Path' . Right . Relative . Path diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index a3ce9a8b56..9935172104 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -63,7 +63,6 @@ module Unison.Cli.MonadUtils -- * Patches -- ** Default patch - defaultPatchNameSegment, defaultPatchPath, -- ** Getting patches @@ -112,7 +111,6 @@ import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Parser.Ann (Ann (..)) @@ -499,14 +497,10 @@ getTypesAt path = do ------------------------------------------------------------------------------------------------------------------------ -- Getting patches -defaultPatchNameSegment :: NameSegment -defaultPatchNameSegment = - NameSegment.unsafeFromUnescapedText "patch" - -- | The default patch path. defaultPatchPath :: Path.Split' defaultPatchPath = - (Path.RelativePath' (Path.Relative Path.empty), defaultPatchNameSegment) + (Path.RelativePath' (Path.Relative Path.empty), NameSegment.defaultPatchSegment) -- | Get the patch at a path, or the empty patch if there's no such patch. getPatchAt :: Path.Split' -> Cli Patch diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 2af2a9f051..be70a090f3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -708,8 +708,8 @@ loop e = do -- add the new definitions to the codebase and to the namespace Cli.runTransaction (traverse_ (uncurry3 (Codebase.putTerm codebase)) [guid, author, copyrightHolder]) authorPath <- Cli.resolveSplit' authorPath' - copyrightHolderPath <- Cli.resolveSplit' (base |> NameSegment.unsafeFromUnescapedText "copyrightHolders" |> authorNameSegment) - guidPath <- Cli.resolveSplit' (authorPath' |> NameSegment.unsafeFromUnescapedText "guid") + copyrightHolderPath <- Cli.resolveSplit' (base |> "copyrightHolders" |> authorNameSegment) + guidPath <- Cli.resolveSplit' (authorPath' |> "guid") Cli.stepManyAt description [ BranchUtil.makeAddTermName (Path.convert authorPath) (d authorRef), @@ -729,8 +729,8 @@ loop e = do where d :: Reference.Id -> Referent d = Referent.Ref . Reference.DerivedId - base :: Path.Split' = (Path.relativeEmpty', NameSegment.unsafeFromUnescapedText "metadata") - authorPath' = base |> NameSegment.unsafeFromUnescapedText "authors" |> authorNameSegment + base :: Path.Split' = (Path.relativeEmpty', "metadata") + authorPath' = base |> "authors" |> authorNameSegment MoveTermI src' dest' -> doMoveTerm src' dest' =<< inputDescription input MoveTypeI src' dest' -> doMoveType src' dest' =<< inputDescription input MoveAllI src' dest' -> do @@ -1000,7 +1000,7 @@ loop e = do -- due to builtin terms; so we don't just reuse `uf` above. let srcb = BranchUtil.fromNames Builtin.names currentPath <- Cli.getCurrentPath - _ <- Cli.updateAtM description (currentPath `snoc` NameSegment.unsafeFromUnescapedText "builtin") \destb -> + _ <- Cli.updateAtM description (currentPath `snoc` "builtin") \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success MergeIOBuiltinsI -> do @@ -1024,7 +1024,7 @@ loop e = do let names0 = Builtin.names <> UF.typecheckedToNames IOSource.typecheckedFile' let srcb = BranchUtil.fromNames names0 currentPath <- Cli.getCurrentPath - _ <- Cli.updateAtM description (currentPath `snoc` NameSegment.unsafeFromUnescapedText "builtin") \destb -> + _ <- Cli.updateAtM description (currentPath `snoc` "builtin") \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success ListEditsI maybePath -> do @@ -1906,7 +1906,7 @@ searchBranchScored names0 score queries = compilerPath :: Path.Path' compilerPath = Path.Path' {Path.unPath' = Left abs} where - segs = NameSegment.unsafeFromUnescapedText <$> ["unison", "internal"] + segs = ["unison", "internal"] rootPath = Path.Path {Path.toSeq = Seq.fromList segs} abs = Path.Absolute {Path.unabsolute = rootPath} diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index f710f43dae..d5bc8e9c51 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs @@ -136,7 +136,7 @@ projectCreate tryDownloadingBase maybeProjectName = do projectBranchLibBaseObject = over Branch.children - (Map.insert (NameSegment.unsafeFromUnescapedText "base") baseLatestReleaseBranchObject) + (Map.insert "base" baseLatestReleaseBranchObject) Branch.empty0 projectBranchLibObject = Branch.cons projectBranchLibBaseObject Branch.empty in over diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 574b9c5a02..4b17b0aeff 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -51,6 +51,7 @@ import Unison.CommandLine.InputPattern qualified as InputPattern import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName)) import Unison.NameSegment (NameSegment (..)) +import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName) import Unison.Share.API.Hash (HashJWT) @@ -329,13 +330,13 @@ loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do Cli.respond Output.AboutToPropagatePatch Cli.time "loadPropagateDiffDefaultPatch" do original <- Cli.getBranch0At dest - patch <- liftIO $ Branch.getPatch Cli.defaultPatchNameSegment original + patch <- liftIO $ Branch.getPatch NameSegment.defaultPatchSegment original patchDidChange <- propagatePatch inputDescription patch dest when patchDidChange do whenJust maybeDest0 \dest0 -> do Cli.respond Output.CalculatingDiff patched <- Cli.getBranchAt dest - let patchPath = Path.Path' (Right (Path.Relative (Path.fromList [Cli.defaultPatchNameSegment]))) + let patchPath = Path.Path' (Right (Path.Relative (Path.fromList [NameSegment.defaultPatchSegment]))) (ppe, diff) <- diffHelper original (Branch.head patched) Cli.respondNumbered (ShowDiffAfterMergePropagate dest0 dest patchPath ppe diff) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 5ed118d3f1..f5610cbd7e 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -742,7 +742,7 @@ notifyUser dir = \case "Use" <> IP.makeExample IP.todo - [ prettyPath' (snoc mergedPath (NameSegment.unsafeFromUnescapedText "patch")), + [ prettyPath' (snoc mergedPath NameSegment.defaultPatchSegment), prettyPath' mergedPath ] <> "to see what work is remaining for the merge.", @@ -1843,18 +1843,7 @@ notifyUser dir = \case ( "Use" <> IP.makeExample IP.mergeLocal [prettySlashProjectBranchName (UnsafeProjectBranchName "somebranch")] <> "or" - <> IP.makeExample - IP.mergeLocal - [ prettyAbsolute - ( Path.Absolute - ( Path.fromList - [ NameSegment.unsafeFromUnescapedText "path", - NameSegment.unsafeFromUnescapedText "to", - NameSegment.unsafeFromUnescapedText "code" - ] - ) - ) - ] + <> IP.makeExample IP.mergeLocal [prettyAbsolute (Path.Absolute (Path.fromList ["path", "to", "code"]))] <> "to initialize this branch." ) CreatedProjectBranchFrom'OtherBranch (ProjectAndBranch otherProject otherBranch) -> @@ -1945,15 +1934,15 @@ notifyUser dir = \case prettyProjectAndBranchName projectAndBranch <> "does not exist on" <> prettyURI host RemoteProjectBranchDoesntExist'Push host projectAndBranch -> let push = P.group . P.backticked . IP.patternName $ IP.push - in pure . P.wrap $ - "The previous push target named" - <> prettyProjectAndBranchName projectAndBranch - <> "has been deleted from" - <> P.group (prettyURI host <> ".") - <> "I've deleted the invalid push target." - <> "Run the" - <> push - <> "command again to push to a new target." + in pure . P.wrap $ + "The previous push target named" + <> prettyProjectAndBranchName projectAndBranch + <> "has been deleted from" + <> P.group (prettyURI host <> ".") + <> "I've deleted the invalid push target." + <> "Run the" + <> push + <> "command again to push to a new target." RemoteProjectBranchHeadMismatch host projectAndBranch -> pure . P.wrap $ prettyProjectAndBranchName projectAndBranch diff --git a/unison-cli/tests/Unison/Test/UriParser.hs b/unison-cli/tests/Unison/Test/UriParser.hs index c5f053b9b0..ba71a26ba8 100644 --- a/unison-cli/tests/Unison/Test/UriParser.hs +++ b/unison-cli/tests/Unison/Test/UriParser.hs @@ -12,7 +12,6 @@ import Unison.Codebase.Path qualified as Path import Unison.Codebase.ShortCausalHash (ShortCausalHash (..)) import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.NameSegment (NameSegment (..)) -import Unison.NameSegment qualified as NameSegment import Unison.Project (ProjectBranchSpecifier (..)) test :: Test () @@ -21,31 +20,31 @@ test = [ parserTests "repoPath" (UriParser.readRemoteNamespaceParser ProjectBranchSpecifier'Name <* P.eof) - [ ("unisonweb.base._releases.M4", looseR "unisonweb" [NameSegment.unsafeFromUnescapedText "base", NameSegment.unsafeFromUnescapedText "_releases", NameSegment.unsafeFromUnescapedText "M4"]), + [ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]), ("project", branchR (This "project")), ("/branch", branchR (That "branch")), ("project/branch", branchR (These "project" "branch")), ("git(/srv/git/project.git)", gitR "/srv/git/project.git" Nothing Nothing []), - ("git(/srv/git/project.git:abc)#def.hij.klm", gitR "/srv/git/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), + ("git(/srv/git/project.git:abc)#def.hij.klm", gitR "/srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), ("git(srv/git/project.git)", gitR "srv/git/project.git" Nothing Nothing []), - ("git(srv/git/project.git:abc)#def.hij.klm", gitR "srv/git/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), + ("git(srv/git/project.git:abc)#def.hij.klm", gitR "srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), ("git(file:///srv/git/project.git)", gitR "file:///srv/git/project.git" Nothing Nothing []), - ("git(file:///srv/git/project.git:abc)#def.hij.klm", gitR "file:///srv/git/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), + ("git(file:///srv/git/project.git:abc)#def.hij.klm", gitR "file:///srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), ("git(file://srv/git/project.git)", gitR "file://srv/git/project.git" Nothing Nothing []), - ("git(file://srv/git/project.git:abc)#def.hij.klm", gitR "file://srv/git/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), + ("git(file://srv/git/project.git:abc)#def.hij.klm", gitR "file://srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), ("git(https://example.com/git/project.git)", gitR "https://example.com/git/project.git" Nothing Nothing []), - ("git(https://user@example.com/git/project.git:abc)#def.hij.klm", gitR "https://user@example.com/git/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), + ("git(https://user@example.com/git/project.git:abc)#def.hij.klm", gitR "https://user@example.com/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), ("git(ssh://git@8.8.8.8:222/user/project.git)", gitR "ssh://git@8.8.8.8:222/user/project.git" Nothing Nothing []), - ("git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", gitR "ssh://git@github.com/user/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]), + ("git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", gitR "ssh://git@github.com/user/project.git" (Just "abc") (sch "def") ["hij", "klm"]), ("git(git@github.com:user/project.git)", gitR "git@github.com:user/project.git" Nothing Nothing []), ("git(github.com:user/project.git)", gitR "github.com:user/project.git" Nothing Nothing []), - ("git(git@github.com:user/project.git:abc)#def.hij.klm", gitR "git@github.com:user/project.git" (Just "abc") (sch "def") [NameSegment.unsafeFromUnescapedText "hij", NameSegment.unsafeFromUnescapedText "klm"]) + ("git(git@github.com:user/project.git:abc)#def.hij.klm", gitR "git@github.com:user/project.git" (Just "abc") (sch "def") ["hij", "klm"]) ] [".unisonweb.base"], parserTests "writeRemoteNamespace" (UriParser.writeRemoteNamespace <* P.eof) - [ ("unisonweb.base._releases.M4", looseW "unisonweb" [NameSegment.unsafeFromUnescapedText "base", NameSegment.unsafeFromUnescapedText "_releases", NameSegment.unsafeFromUnescapedText "M4"]), + [ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]), ("project", branchW (This "project")), ("/branch", branchW (That "branch")), ("project/branch", branchW (These "project" "branch")), diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index f2baddd09b..a66c367d77 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -69,7 +69,6 @@ import Unison.CommandLine.Types qualified as CommandLine import Unison.CommandLine.Welcome (CodebaseInitStatus (..)) import Unison.CommandLine.Welcome qualified as Welcome import Unison.LSP qualified as LSP -import Unison.NameSegment qualified as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal qualified as PT @@ -277,7 +276,7 @@ main = do Just startingPath -> pure startingPath Nothing -> do segments <- Codebase.runTransaction theCodebase Queries.expectMostRecentNamespace - pure (Path.Absolute (Path.fromList (map NameSegment.unsafeFromUnescapedText segments))) + pure (Path.Absolute (Path.fromList segments)) Headless -> pure $ fromMaybe defaultInitialPath mayStartingPath rootVar <- newEmptyTMVarIO pathVar <- newTVarIO startingPath diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 6eaa50e5c9..5894692b5e 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -876,7 +876,7 @@ docsForDefinitionName :: Name -> IO [TermReference] docsForDefinitionName codebase (NameSearch {termSearch}) searchType name = do - let potentialDocNames = [name, name Cons.:> NameSegment.unsafeFromUnescapedText "doc"] + let potentialDocNames = [name, name Cons.:> "doc"] Codebase.runTransaction codebase do refs <- potentialDocNames & foldMapM \name -> diff --git a/unison-share-api/src/Unison/Server/Local.hs b/unison-share-api/src/Unison/Server/Local.hs index 16e00a742a..211d79f7ea 100644 --- a/unison-share-api/src/Unison/Server/Local.hs +++ b/unison-share-api/src/Unison/Server/Local.hs @@ -67,13 +67,7 @@ inferNamesRoot p b Cons.:< release Cons.:< _rest ) = - Just - ( Path.fromList - [ NameSegment.unsafeFromUnescapedText "public", - NameSegment.unsafeFromUnescapedText "base", - release - ] - ) + Just (Path.fromList ["public", "base", release]) findBaseProject _ = Nothing go :: Path -> Branch Sqlite.Transaction -> ReaderT Path (WriterT (Last Path) Sqlite.Transaction) () go p b = do diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs index 4f622ae215..3b25dae977 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs @@ -17,7 +17,6 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..)) import Unison.NameSegment (NameSegment) -import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Project.Util (pattern BranchesNameSegment, pattern ProjectsNameSegment, pattern UUIDNameSegment) import Unison.Server.Backend @@ -58,8 +57,7 @@ serveCurrent = lift . getCurrentProjectBranch getCurrentProjectBranch :: MonadIO m => Codebase m v a -> m Current getCurrentProjectBranch codebase = do - namespace <- Codebase.runTransaction codebase Queries.expectMostRecentNamespace - let segments = NameSegment.unsafeFromUnescapedText <$> namespace + segments <- Codebase.runTransaction codebase Queries.expectMostRecentNamespace let absolutePath = toPath segments case toIds segments of ProjectAndBranch (Just projectId) branchId -> diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs index 0a12729b71..624ca071e0 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs @@ -16,7 +16,6 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Path qualified as Path import Unison.Codebase.Runtime qualified as Rt import Unison.Codebase.ShortCausalHash (ShortCausalHash) -import Unison.NameSegment qualified as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Server.Backend @@ -74,9 +73,4 @@ namespaceDetails runtime codebase namespacePath mayRoot _mayWidth = do pure $ namespaceDetails where readmeNames = - Set.fromList - [ NameSegment.unsafeFromUnescapedText "README", - NameSegment.unsafeFromUnescapedText "Readme", - NameSegment.unsafeFromUnescapedText "ReadMe", - NameSegment.unsafeFromUnescapedText "readme" - ] + Set.fromList ["README", "Readme", "ReadMe", "readme"] diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 0727677a15..d39e3af912 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -381,7 +381,7 @@ lexemes' eof = (Just (WordyId tname)) | isTopLevel -> beforeStartToks - <> [WordyId (HQ'.fromName (Name.snoc (HQ'.toName tname) (NameSegment.unsafeFromUnescapedText "doc"))) <$ openTok, Open "=" <$ openTok] + <> [WordyId (HQ'.fromName (Name.snoc (HQ'.toName tname) "doc")) <$ openTok, Open "=" <$ openTok] <> [openTok] <> bodyToks0 <> [closeTok] diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index eec4c60d16..773ab38f08 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -106,7 +106,7 @@ symbolyP = do then do end <- posP P.customFailure (Token text start end) - else pure (NameSegment.unsafeFromUnescapedText text) + else pure (UnsafeNameSegment text) where unescaped = P.takeWhile1P (Just (description symbolyIdChars)) symbolyIdChar @@ -133,7 +133,7 @@ wordyP = do then do end <- posP P.customFailure (Token word start end) - else pure (NameSegment.unsafeFromUnescapedText word) + else pure (UnsafeNameSegment word) where wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" From 07078e99899dc6239d9fcb3141893bb2356c03e2 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 31 Jan 2024 11:15:00 -0500 Subject: [PATCH 20/41] UnsafeNameSegment -> NameSegment --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 6 +++--- codebase2/core/Unison/NameSegment.hs | 6 +++--- parser-typechecker/src/Unison/Project/Util.hs | 2 +- .../src/Unison/Codebase/Editor/HandleInput/Update2.hs | 6 +++--- unison-syntax/src/Unison/Syntax/NameSegment.hs | 4 ++-- 5 files changed, 12 insertions(+), 12 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 2329171ca3..12d6c2ae01 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -393,7 +393,7 @@ import Unison.Hash qualified as Hash import Unison.Hash32 (Hash32) import Unison.Hash32 qualified as Hash32 import Unison.Hash32.Orphans.Sqlite () -import Unison.NameSegment (NameSegment (UnsafeNameSegment)) +import Unison.NameSegment (NameSegment (NameSegment)) import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Sqlite @@ -658,7 +658,7 @@ saveNameSegment = expectNameSegment :: TextId -> Transaction NameSegment expectNameSegment = - fmap UnsafeNameSegment . expectText + fmap NameSegment . expectText saveHashObject :: HashId -> ObjectId -> HashVersion -> Transaction () saveHashObject hId oId version = @@ -4256,7 +4256,7 @@ expectMostRecentNamespace = check bytes = case Aeson.eitherDecodeStrict (Text.encodeUtf8 bytes) of Left failure -> Left JsonParseFailure {bytes, failure = Text.pack failure} - Right namespace -> Right (map UnsafeNameSegment namespace) + Right namespace -> Right (map NameSegment namespace) -- | Set the most recent namespace the user has visited. setMostRecentNamespace :: [Text] -> Transaction () diff --git a/codebase2/core/Unison/NameSegment.hs b/codebase2/core/Unison/NameSegment.hs index 1c82476c1d..545d952a40 100644 --- a/codebase2/core/Unison/NameSegment.hs +++ b/codebase2/core/Unison/NameSegment.hs @@ -1,5 +1,5 @@ module Unison.NameSegment - ( NameSegment (UnsafeNameSegment), + ( NameSegment (..), toUnescapedText, isEmpty, isPrefixOf, @@ -20,13 +20,13 @@ import Unison.Util.Alphabetical (Alphabetical) -- Represents the parts of a name between the `.`s newtype NameSegment - = UnsafeNameSegment Text + = NameSegment Text deriving stock (Eq, Ord, Generic) deriving newtype (Alphabetical) instance IsString NameSegment where fromString = - UnsafeNameSegment . Text.pack + NameSegment . Text.pack instance Show NameSegment where show = show . toUnescapedText diff --git a/parser-typechecker/src/Unison/Project/Util.hs b/parser-typechecker/src/Unison/Project/Util.hs index 6625abf048..d75f2250a0 100644 --- a/parser-typechecker/src/Unison/Project/Util.hs +++ b/parser-typechecker/src/Unison/Project/Util.hs @@ -62,7 +62,7 @@ pattern UUIDNameSegment uuid <- ) where UUIDNameSegment uuid = - UnsafeNameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid))) + NameSegment (Text.cons '_' (Text.map (\c -> if c == '-' then '_' else c) (UUID.toText uuid))) -- | The prism between paths like -- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index 7ad598626a..eeb547c2da 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -58,7 +58,7 @@ import Unison.Name (Name) import Unison.Name qualified as Name import Unison.Name.Forward (ForwardName (..)) import Unison.Name.Forward qualified as ForwardName -import Unison.NameSegment (NameSegment (UnsafeNameSegment)) +import Unison.NameSegment (NameSegment (..)) import Unison.NameSegment qualified as NameSegment import Unison.Names (Names (Names)) import Unison.Names qualified as Names @@ -395,12 +395,12 @@ incrementLastSegmentChar (ForwardName segments) = in ForwardName $ maybe (NonEmpty.singleton incrementedLastSegment) (|> incrementedLastSegment) (NonEmpty.nonEmpty initSegments) where incrementLastCharInSegment :: NameSegment -> NameSegment - incrementLastCharInSegment (UnsafeNameSegment text) = + incrementLastCharInSegment (NameSegment text) = let incrementedText = if Text.null text then text else Text.init text `Text.append` Text.singleton (succ $ Text.last text) - in UnsafeNameSegment incrementedText + in NameSegment incrementedText -- @getTermAndDeclNames file@ returns the names of the terms and decls defined in a typechecked Unison file. getTermAndDeclNames :: (Var v) => TypecheckedUnisonFile v a -> Defns (Set Name) (Set Name) diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index 773ab38f08..984f090def 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -106,7 +106,7 @@ symbolyP = do then do end <- posP P.customFailure (Token text start end) - else pure (UnsafeNameSegment text) + else pure (NameSegment text) where unescaped = P.takeWhile1P (Just (description symbolyIdChars)) symbolyIdChar @@ -133,7 +133,7 @@ wordyP = do then do end <- posP P.customFailure (Token word start end) - else pure (UnsafeNameSegment word) + else pure (NameSegment word) where wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" From 914e367ae5b312c8864e1cca078d9a927ccb5435 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 31 Jan 2024 11:19:15 -0500 Subject: [PATCH 21/41] implement NameSegment.toEscapedText --- unison-syntax/src/Unison/Syntax/NameSegment.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index 984f090def..ba42c4c09a 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -43,8 +43,9 @@ import Unison.Syntax.ReservedWords (keywords, reservedOperators) -- -- > toEscapedText (unsafeFromText ".~") = "`.~`" toEscapedText :: NameSegment -> Text -toEscapedText = - wundefined +toEscapedText segment@(NameSegment text) + | isSymboly segment && not (Text.all symbolyIdChar text) = "`" <> text <> "`" + | otherwise = text -- | Convert text to a name segment. -- From 30442550609760a8d432e1cf5b38acc0ccb2b604 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 1 Feb 2024 02:39:48 -0500 Subject: [PATCH 22/41] sytax work --- .../src/U/Codebase/Decl/Hashing.hs | 2 +- codebase2/core/Unison/NameSegment.hs | 15 +-- parser-typechecker/src/Unison/Builtin.hs | 14 +-- .../src/Unison/Codebase/Execute.hs | 13 +-- .../src/Unison/Codebase/MainTerm.hs | 12 +-- .../src/Unison/Codebase/Path.hs | 24 +++-- parser-typechecker/src/Unison/FileParsers.hs | 6 +- .../src/Unison/Hashing/V2/Convert.hs | 4 +- .../src/Unison/PrettyPrintEnv/FQN.hs | 4 +- parser-typechecker/src/Unison/PrintError.hs | 26 ++--- parser-typechecker/src/Unison/Runtime/ANF.hs | 8 +- .../src/Unison/Runtime/Interface.hs | 6 +- .../src/Unison/Syntax/DeclParser.hs | 6 +- .../src/Unison/Syntax/DeclPrinter.hs | 28 +++-- .../src/Unison/Syntax/FileParser.hs | 11 +- .../src/Unison/Syntax/TermParser.hs | 10 +- .../src/Unison/Syntax/TermPrinter.hs | 11 +- parser-typechecker/src/Unison/Typechecker.hs | 6 +- .../src/Unison/UnisonFile/Names.hs | 24 ++--- .../tests/Unison/Core/Test/Name.hs | 66 ++++++------ .../src/Unison/Codebase/Editor/HandleInput.hs | 88 +++++++-------- .../Codebase/Editor/HandleInput/FormatFile.hs | 4 +- .../Unison/Codebase/Editor/HandleInput/Run.hs | 8 +- .../Editor/HandleInput/TermResolution.hs | 4 +- .../Codebase/Editor/HandleInput/Tests.hs | 4 +- .../Codebase/Editor/HandleInput/Update.hs | 16 +-- .../Codebase/Editor/HandleInput/Update2.hs | 10 +- .../src/Unison/Codebase/Editor/Input.hs | 6 +- .../src/Unison/Codebase/Editor/Output.hs | 8 +- .../src/Unison/Codebase/Editor/Slurp.hs | 10 +- .../src/Unison/Codebase/Editor/UriParser.hs | 2 +- .../src/Unison/CommandLine/Completion.hs | 8 +- .../src/Unison/CommandLine/InputPatterns.hs | 34 +++--- .../src/Unison/CommandLine/OutputMessages.hs | 42 ++++---- unison-cli/src/Unison/LSP/Completion.hs | 6 +- unison-cli/src/Unison/LSP/FileAnalysis.hs | 2 +- unison-cli/src/Unison/LSP/Hover.hs | 2 +- unison-cli/unison/ArgParse.hs | 7 +- unison-core/src/Unison/Name/Internal.hs | 14 +++ unison-share-api/src/Unison/Server/Backend.hs | 10 +- unison-share-api/src/Unison/Server/Errors.hs | 4 +- .../Unison/Server/Local/Endpoints/Current.hs | 2 +- .../Server/Local/Endpoints/FuzzyFind.hs | 4 +- unison-share-api/src/Unison/Server/Orphans.hs | 20 ++-- unison-share-api/src/Unison/Server/Syntax.hs | 9 +- unison-share-api/src/Unison/Server/Types.hs | 4 +- unison-share-api/src/Unison/Util/Find.hs | 45 ++++---- .../src/Unison/Syntax/HashQualified'.hs | 63 ++++++----- .../src/Unison/Syntax/HashQualified.hs | 73 +++++++------ unison-syntax/src/Unison/Syntax/Lexer.hs | 20 +--- unison-syntax/src/Unison/Syntax/Name.hs | 101 ++++++++---------- .../src/Unison/Syntax/NameSegment.hs | 31 +++--- unison-syntax/src/Unison/Syntax/Parser.hs | 6 +- unison-syntax/test/Main.hs | 17 ++- 54 files changed, 492 insertions(+), 488 deletions(-) diff --git a/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Decl/Hashing.hs b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Decl/Hashing.hs index c16b0d931e..6b1f96484b 100644 --- a/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Decl/Hashing.hs +++ b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Decl/Hashing.hs @@ -34,7 +34,7 @@ verifyDeclFormatHash (ComponentHash hash) (DeclFormat.Decl (DeclFormat.LocallyIn & Map.toList & fmap (\(_refId, (v, decl, ())) -> (v, either H2.toDataDecl id $ H2.v2ToH2Decl decl)) & Map.fromList - & H2.hashDecls Name.unsafeFromVar + & H2.hashDecls Name.unsafeParseVar & \case Left _err -> Just HH.DeclHashResolutionFailure Right m -> diff --git a/codebase2/core/Unison/NameSegment.hs b/codebase2/core/Unison/NameSegment.hs index 545d952a40..e548adfa89 100644 --- a/codebase2/core/Unison/NameSegment.hs +++ b/codebase2/core/Unison/NameSegment.hs @@ -1,9 +1,7 @@ module Unison.NameSegment ( NameSegment (..), toUnescapedText, - isEmpty, isPrefixOf, - toTextBuilder, -- * Sentinel name segments defaultPatchSegment, @@ -13,8 +11,6 @@ module Unison.NameSegment where import Data.Text qualified as Text -import Data.Text.Lazy.Builder qualified as Text (Builder) -import Data.Text.Lazy.Builder qualified as Text.Builder import Unison.Prelude import Unison.Util.Alphabetical (Alphabetical) @@ -29,7 +25,8 @@ instance IsString NameSegment where NameSegment . Text.pack instance Show NameSegment where - show = show . toUnescapedText + show = + Text.unpack . toUnescapedText -- | Convert a name segment to unescaped text. -- @@ -38,18 +35,10 @@ toUnescapedText :: NameSegment -> Text toUnescapedText = coerce -isEmpty :: NameSegment -> Bool -isEmpty = - coerce Text.null - isPrefixOf :: NameSegment -> NameSegment -> Bool isPrefixOf = coerce Text.isPrefixOf -toTextBuilder :: NameSegment -> Text.Builder -toTextBuilder = - coerce Text.Builder.fromText - defaultPatchSegment :: NameSegment defaultPatchSegment = "patch" diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index a425e48c40..38d965eee4 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -38,7 +38,7 @@ import Unison.Prelude import Unison.Reference qualified as R import Unison.Referent qualified as Referent import Unison.Symbol (Symbol) -import Unison.Syntax.Name qualified as Name (unsafeFromText, unsafeFromVar) +import Unison.Syntax.Name qualified as Name (unsafeParseText, unsafeParseVar) import Unison.Type qualified as Type import Unison.Typechecker.TypeLookup qualified as TL import Unison.Util.Relation qualified as Rel @@ -56,24 +56,24 @@ names = Names terms types terms = Rel.mapRan Referent.Ref (Rel.fromMap termNameRefs) <> Rel.fromList - [ (Name.unsafeFromVar vc, Referent.Con (ConstructorReference (R.DerivedId r) cid) ct) + [ (Name.unsafeParseVar vc, Referent.Con (ConstructorReference (R.DerivedId r) cid) ct) | (ct, (_, (r, decl))) <- ((CT.Data,) <$> builtinDataDecls) <> ((CT.Effect,) . (second . second) DD.toDataDecl <$> builtinEffectDecls), ((_, vc, _), cid) <- DD.constructors' decl `zip` [0 ..] ] <> Rel.fromList - [ (Name.unsafeFromVar v, Referent.Ref (R.DerivedId i)) + [ (Name.unsafeParseVar v, Referent.Ref (R.DerivedId i)) | (v, i) <- Map.toList TD.builtinTermsRef ] types = Rel.fromList builtinTypes <> Rel.fromList - [ (Name.unsafeFromVar v, R.DerivedId r) + [ (Name.unsafeParseVar v, R.DerivedId r) | (v, (r, _)) <- builtinDataDecls ] <> Rel.fromList - [ (Name.unsafeFromVar v, R.DerivedId r) + [ (Name.unsafeParseVar v, R.DerivedId r) | (v, (r, _)) <- builtinEffectDecls ] @@ -147,7 +147,7 @@ builtinTypeDependentsOfComponent h0 = Rel.searchRan ord builtinDependencies -- if we decide to change their names. builtinTypes :: [(Name, R.Reference)] builtinTypes = - Map.toList . Map.mapKeys Name.unsafeFromText $ + Map.toList . Map.mapKeys Name.unsafeParseText $ foldl' go mempty builtinTypesSrc where go m = \case @@ -286,7 +286,7 @@ instance Show BuiltinDSL where show _ = "" termNameRefs :: Map Name R.Reference -termNameRefs = Map.mapKeys Name.unsafeFromText $ foldl' go mempty (stripVersion builtinsSrc) +termNameRefs = Map.mapKeys Name.unsafeParseText $ foldl' go mempty (stripVersion builtinsSrc) where go m = \case B r _tp -> Map.insert r (R.Builtin r) m diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index d624ed522f..4d8a5317a9 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} - -- | Execute a computation of type '{IO} () that has been previously added to -- the codebase, without setting up an interactive environment. -- @@ -20,6 +16,7 @@ import Unison.Codebase.Runtime (Runtime) import Unison.Codebase.Runtime qualified as Runtime import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) +import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.Symbol (Symbol) import Unison.Util.Pretty qualified as P @@ -27,7 +24,7 @@ import Unison.Util.Pretty qualified as P execute :: Codebase.Codebase IO Symbol Ann -> Runtime Symbol -> - String -> + Text -> IO (Either Runtime.Error ()) execute codebase runtime mainName = (`finally` Runtime.terminate runtime) . runExceptT $ do @@ -37,9 +34,9 @@ execute codebase runtime mainName = let mainType = Runtime.mainType runtime mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType case mt of - MainTerm.NotAFunctionName s -> throwError ("Not a function name: " <> P.string s) - MainTerm.NotFound s -> throwError ("Not found: " <> P.string s) - MainTerm.BadType s _ -> throwError (P.string s <> " is not of type '{IO} ()") + MainTerm.NotAFunctionName s -> throwError ("Not a function name: " <> P.text s) + MainTerm.NotFound s -> throwError ("Not found: " <> P.text s) + MainTerm.BadType s _ -> throwError (P.text s <> " is not of type '{IO} ()") MainTerm.Success _ tm _ -> do let codeLookup = Codebase.toCodeLookup codebase ppe = PPE.empty diff --git a/parser-typechecker/src/Unison/Codebase/MainTerm.hs b/parser-typechecker/src/Unison/Codebase/MainTerm.hs index 751aa3329d..f117e7f671 100644 --- a/parser-typechecker/src/Unison/Codebase/MainTerm.hs +++ b/parser-typechecker/src/Unison/Codebase/MainTerm.hs @@ -16,7 +16,7 @@ import Unison.Parser.Ann qualified as Parser.Ann import Unison.Prelude import Unison.Reference (Reference) import Unison.Referent qualified as Referent -import Unison.Syntax.HashQualified qualified as HQ (fromString) +import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Term (Term) import Unison.Term qualified as Term import Unison.Type (Type) @@ -26,20 +26,20 @@ import Unison.Var (Var) import Unison.Var qualified as Var data MainTerm v - = NotAFunctionName String - | NotFound String - | BadType String (Maybe (Type v Ann)) + = NotAFunctionName Text + | NotFound Text + | BadType Text (Maybe (Type v Ann)) | Success (HQ.HashQualified Name) (Term v Ann) (Type v Ann) getMainTerm :: (Monad m, Var v) => (Reference -> m (Maybe (Type v Ann))) -> Names.Names -> - String -> + Text -> Type.Type v Ann -> m (MainTerm v) getMainTerm loadTypeOfTerm parseNames mainName mainType = - case HQ.fromString mainName of + case HQ.parseText mainName of Nothing -> pure (NotAFunctionName mainName) Just hq -> do let refs = Names.lookupHQTerm Names.IncludeSuffixes hq parseNames diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index 64122cd5fc..e033cd8ae8 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -45,8 +45,8 @@ module Unison.Codebase.Path fromName, fromName', fromPath', - fromText, - fromText', + unsafeParseText, + unsafeParseText', toAbsoluteSplit, toSplit', toList, @@ -93,7 +93,7 @@ import Unison.Name (Convert (..), Name, Parse) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.Prelude hiding (empty, toList) -import Unison.Syntax.Name qualified as Name (toText, unsafeFromText) +import Unison.Syntax.Name qualified as Name (toText, unsafeParseText) import Unison.Util.List qualified as List -- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"] @@ -311,11 +311,13 @@ fromName' n path = fromName n unsafeToName :: Path -> Name -unsafeToName = Name.unsafeFromText . toText +unsafeToName = + fromMaybe (error "empty path") . toName -- | Convert a Path' to a Name unsafeToName' :: Path' -> Name -unsafeToName' = Name.unsafeFromText . toText' +unsafeToName' = + fromMaybe (error "empty path") . toName' toName :: Path -> Maybe Name toName = \case @@ -353,10 +355,10 @@ toText path = Nothing -> "." Just name -> Name.toText name -fromText :: Text -> Path -fromText = \case +unsafeParseText :: Text -> Path +unsafeParseText = \case "" -> empty - text -> fromName (Name.unsafeFromText text) + text -> fromName (Name.unsafeParseText text) -- | Construct a Path' from a text -- @@ -368,11 +370,11 @@ fromText = \case -- -- >>> show $ fromText' "" -- "" -fromText' :: Text -> Path' -fromText' = \case +unsafeParseText' :: Text -> Path' +unsafeParseText' = \case "" -> RelativePath' (Relative mempty) "." -> AbsolutePath' (Absolute mempty) - text -> fromName' (Name.unsafeFromText text) + text -> fromName' (Name.unsafeParseText text) toText' :: Path' -> Text toText' path = diff --git a/parser-typechecker/src/Unison/FileParsers.hs b/parser-typechecker/src/Unison/FileParsers.hs index 7cf18b08f3..dbd053d1e2 100644 --- a/parser-typechecker/src/Unison/FileParsers.hs +++ b/parser-typechecker/src/Unison/FileParsers.hs @@ -26,7 +26,7 @@ import Unison.Reference (Reference) import Unison.Referent qualified as Referent import Unison.Result (CompilerBug (..), Note (..), ResultT, pattern Result) import Unison.Result qualified as Result -import Unison.Syntax.Name qualified as Name (toText, unsafeFromVar) +import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar) import Unison.Syntax.Parser qualified as Parser import Unison.Term qualified as Term import Unison.Type qualified as Type @@ -96,7 +96,7 @@ computeTypecheckingEnvironment shouldUseTndr ambientAbilities typeLookupf uf = [ (Name.toText name, Var.name v, r) | (name, r) <- Rel.toList (Names.terms preexistingNames), v <- Set.toList (Term.freeVars tm), - name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments (Name.unsafeFromVar v)) + name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments (Name.unsafeParseVar v)) ] possibleRefs = Referent.toReference . view _3 <$> possibleDeps tl <- fmap (UF.declsToTypeLookup uf <>) (typeLookupf (UF.dependencies uf <> Set.fromList possibleRefs)) @@ -122,7 +122,7 @@ computeTypecheckingEnvironment shouldUseTndr ambientAbilities typeLookupf uf = [ (Var.name v, nr) | (name, r) <- Rel.toList (Names.terms $ UF.toNames uf), v <- Set.toList (Term.freeVars tm), - name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments (Name.unsafeFromVar v)), + name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments (Name.unsafeParseVar v)), typ <- toList $ TL.typeOfReferent tl r, let nr = Typechecker.NamedReference (Name.toText name) typ (Right r) ] diff --git a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs index 09769d43e8..d8335a9e85 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs @@ -45,7 +45,7 @@ import Unison.Names.ResolutionResult (ResolutionResult) import Unison.Pattern qualified as Memory.Pattern import Unison.Reference qualified as Memory.Reference import Unison.Referent qualified as Memory.Referent -import Unison.Syntax.Name qualified as Name (unsafeFromVar) +import Unison.Syntax.Name qualified as Name (unsafeParseVar) import Unison.Term qualified as Memory.Term import Unison.Type qualified as Memory.Type import Unison.Util.Map qualified as Map @@ -230,7 +230,7 @@ hashDataDecls :: ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)] hashDataDecls memDecls = do let hashingDecls = fmap m2hDecl memDecls - hashingResult <- Hashing.hashDecls Name.unsafeFromVar hashingDecls + hashingResult <- Hashing.hashDecls Name.unsafeParseVar hashingDecls pure $ map h2mDeclResult hashingResult where h2mDeclResult :: (Ord v) => (v, Hashing.ReferenceId, Hashing.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a) diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs index c146c5c018..b52e6c1137 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs @@ -4,7 +4,7 @@ import Data.Map qualified as Map import Unison.HashQualified qualified as HQ import Unison.Name (Name) import Unison.Prelude -import Unison.Syntax.Name qualified as Name (unsafeFromText) +import Unison.Syntax.Name qualified as Name (unsafeParseText) -- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo' -- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation. @@ -25,7 +25,7 @@ elideFQN imports hq = let hash = HQ.toHash hq name' = do name <- HQ.toName hq - let hit = fmap Name.unsafeFromText (Map.lookup name imports) + let hit = fmap Name.unsafeParseText (Map.lookup name imports) -- Cut out the "const id $" to get tracing of FQN elision attempts. let t = const id $ trace ("hit: " ++ show hit ++ " finding: " ++ show hq ++ " in imports: " ++ show imports) t (pure $ fromMaybe name hit) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index a819e23a5d..2cdf194f14 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -41,7 +41,7 @@ import Unison.Result (Note (..)) import Unison.Result qualified as Result import Unison.Settings qualified as Settings import Unison.Symbol (Symbol) -import Unison.Syntax.HashQualified qualified as HQ (toString) +import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Syntax.Lexer qualified as L import Unison.Syntax.Name qualified as Name (toText) import Unison.Syntax.NamePrinter (prettyHashQualified0) @@ -1232,15 +1232,15 @@ renderKind Kind.Star = "*" renderKind (Kind.Arrow k1 k2) = renderKind k1 <> " -> " <> renderKind k2 showTermRef :: (IsString s) => Env -> Referent -> s -showTermRef env r = fromString . HQ.toString $ PPE.termName env r +showTermRef env r = fromString . Text.unpack . HQ.toText $ PPE.termName env r showTypeRef :: (IsString s) => Env -> R.Reference -> s -showTypeRef env r = fromString . HQ.toString $ PPE.typeName env r +showTypeRef env r = fromString . Text.unpack . HQ.toText $ PPE.typeName env r -- todo: do something different/better if cid not found showConstructor :: (IsString s) => Env -> ConstructorReference -> s showConstructor env r = - fromString . HQ.toString $ + fromString . Text.unpack . HQ.toText $ PPE.patternName env r styleInOverallType :: @@ -1803,10 +1803,10 @@ renderParseErrors s = \case let msg = Pr.lines [ if missing - then "I couldn't resolve the reference " <> style ErrorSite (HQ.toString (L.payload tok)) <> "." - else "The reference " <> style ErrorSite (HQ.toString (L.payload tok)) <> " was ambiguous.", + then "I couldn't resolve the reference " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> "." + else "The reference " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> " was ambiguous.", "", - tokenAsErrorSite s $ HQ.toString <$> tok, + tokenAsErrorSite s $ HQ.toText <$> tok, if missing then "Make sure it's spelled correctly." else "Try hash-qualifying the term you meant to reference." @@ -1818,10 +1818,10 @@ renderParseErrors s = \case let msg = Pr.lines [ if Set.null referents - then "I couldn't find a term for " <> style ErrorSite (HQ.toString (L.payload tok)) <> "." - else "The term reference " <> style ErrorSite (HQ.toString (L.payload tok)) <> " was ambiguous.", + then "I couldn't find a term for " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> "." + else "The term reference " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> " was ambiguous.", "", - tokenAsErrorSite s $ HQ.toString <$> tok, + tokenAsErrorSite s $ HQ.toText <$> tok, if missing then "Make sure it's spelled correctly." else "Try hash-qualifying the term you meant to reference." @@ -1833,10 +1833,10 @@ renderParseErrors s = \case let msg = Pr.lines [ if Set.null referents - then "I couldn't find a type for " <> style ErrorSite (HQ.toString (L.payload tok)) <> "." - else "The type reference " <> style ErrorSite (HQ.toString (L.payload tok)) <> " was ambiguous.", + then "I couldn't find a type for " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> "." + else "The type reference " <> style ErrorSite (Text.unpack (HQ.toText (L.payload tok))) <> " was ambiguous.", "", - tokenAsErrorSite s $ HQ.toString <$> tok, + tokenAsErrorSite s $ HQ.toText <$> tok, if missing then "Make sure it's spelled correctly." else "Try hash-qualifying the type you meant to reference." diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index c644ca1dbf..d460986c6c 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -101,7 +101,7 @@ import Unison.ConstructorReference (ConstructorReference, GConstructorReference import Unison.Hashing.V2.Convert (hashTermComponentsWithoutTypes) import Unison.Pattern (SeqOp (..)) import Unison.Pattern qualified as P -import Unison.Prelude hiding (Text) +import Unison.Prelude import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId)) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.Symbol (Symbol) @@ -621,11 +621,11 @@ saturate dat = ABT.visitPure $ \case fvs = foldMap freeVars args args' = saturate dat <$> args -addDefaultCases :: (Var v) => (Monoid a) => String -> Term v a -> Term v a +addDefaultCases :: (Var v) => (Monoid a) => Text -> Term v a -> Term v a addDefaultCases = ABT.visitPure . defaultCaseVisitor defaultCaseVisitor :: - (Var v) => (Monoid a) => String -> Term v a -> Maybe (Term v a) + (Var v) => (Monoid a) => Text -> Term v a -> Maybe (Term v a) defaultCaseVisitor func m@(Match' scrut cases) | scrut <- addDefaultCases func scrut, cases <- fmap (addDefaultCases func) <$> cases = @@ -634,7 +634,7 @@ defaultCaseVisitor func m@(Match' scrut cases) a = ABT.annotation m v = Var.freshIn mempty $ typed Var.Blank txt = "pattern match failure in function `" <> func <> "`" - msg = text a $ Data.Text.pack txt + msg = text a txt bu = ref a (Builtin "bug") dflt = MatchCase (P.Var a) Nothing diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index 657b6616a3..7a27afc217 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -109,7 +109,7 @@ import Unison.Runtime.Pattern import Unison.Runtime.Serialize as SER import Unison.Runtime.Stack import Unison.Symbol (Symbol) -import Unison.Syntax.HashQualified qualified as HQ (toString) +import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Syntax.NamePrinter (prettyHashQualified) import Unison.Syntax.TermPrinter import Unison.Term qualified as Tm @@ -529,7 +529,7 @@ intermediateTerms ppe ctx rtms = . splitPatterns (dspec ctx) . addDefaultCases tmName where - tmName = HQ.toString . termName ppe $ RF.Ref ref + tmName = HQ.toText . termName ppe $ RF.Ref ref where orig = Map.fromList @@ -597,7 +597,7 @@ intermediateTerm ppe ctx tm = case normalizeTerm ctx tm of (ref, frem, cmbs, dcmp) -> (ref, frem, fmap f cmbs, dcmp) where - tmName = HQ.toString . termName ppe $ RF.Ref ref + tmName = HQ.toText . termName ppe $ RF.Ref ref f = superNormalize . splitPatterns (dspec ctx) diff --git a/parser-typechecker/src/Unison/Syntax/DeclParser.hs b/parser-typechecker/src/Unison/Syntax/DeclParser.hs index dd039655f4..0408211a52 100644 --- a/parser-typechecker/src/Unison/Syntax/DeclParser.hs +++ b/parser-typechecker/src/Unison/Syntax/DeclParser.hs @@ -15,7 +15,7 @@ import Unison.Name qualified as Name import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Syntax.Lexer qualified as L -import Unison.Syntax.Name qualified as Name (toText, unsafeFromVar) +import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar) import Unison.Syntax.Parser import Unison.Syntax.TermParser qualified as TermParser import Unison.Syntax.TypeParser qualified as TypeParser @@ -99,7 +99,7 @@ resolveUnresolvedModifier unresolvedModifier var = resolveUniqueModifier :: (Monad m, Var v) => v -> Text -> P v m DD.Modifier resolveUniqueModifier var guid0 = do ParsingEnv {uniqueTypeGuid} <- ask - guid <- fromMaybe guid0 <$> lift (lift (uniqueTypeGuid (Name.unsafeFromVar var))) + guid <- fromMaybe guid0 <$> lift (lift (uniqueTypeGuid (Name.unsafeParseVar var))) pure $ DD.Unique guid defaultUniqueModifier :: (Monad m, Var v) => v -> P v m DD.Modifier @@ -182,7 +182,7 @@ dataDeclaration maybeUnresolvedModifier = do ) fields <- field closingToken <- closeBlock - let lastSegment = name <&> (\v -> Var.named (Name.toText $ Name.unqualified (Name.unsafeFromVar v))) + let lastSegment = name <&> (\v -> Var.named (Name.toText $ Name.unqualified (Name.unsafeParseVar v))) pure ([go lastSegment (snd <$> fields)], [(name, fields)], ann closingToken) (constructors, accessors, closingAnn) <- msum [Left <$> record, Right <$> sepBy (reserved "|") dataConstructor] <&> \case diff --git a/parser-typechecker/src/Unison/Syntax/DeclPrinter.hs b/parser-typechecker/src/Unison/Syntax/DeclPrinter.hs index ed86480ab6..8ed391b44a 100644 --- a/parser-typechecker/src/Unison/Syntax/DeclPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/DeclPrinter.hs @@ -1,8 +1,8 @@ module Unison.Syntax.DeclPrinter (prettyDecl, prettyDeclW, prettyDeclHeader, prettyDeclOrBuiltinHeader, AccessorName) where import Control.Monad.Writer (Writer, runWriter, tell) -import Data.List (isPrefixOf) import Data.Map qualified as Map +import Data.Text qualified as Text import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.ConstructorType qualified as CT import Unison.DataDeclaration @@ -21,7 +21,7 @@ import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..)) import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference (Reference, Reference' (DerivedId)) import Unison.Referent qualified as Referent -import Unison.Syntax.HashQualified qualified as HQ (toString, toVar, unsafeFromString) +import Unison.Syntax.HashQualified qualified as HQ (toText, toVar, unsafeParseText) import Unison.Syntax.NamePrinter (styleHashQualified'') import Unison.Syntax.TypePrinter (runPretty) import Unison.Syntax.TypePrinter qualified as TypePrinter @@ -83,7 +83,7 @@ prettyGADT env ctorType r name dd = constructor (n, (_, _, t)) = prettyPattern (PPED.unsuffixifiedPPE env) ctorType name (ConstructorReference r n) <> fmt S.TypeAscriptionColon " :" - `P.hang` TypePrinter.prettySyntax (PPED.suffixifiedPPE env) t + `P.hang` TypePrinter.prettySyntax (PPED.suffixifiedPPE env) t header = prettyEffectHeader name (DD.EffectDeclaration dd) <> fmt S.ControlKeyword " where" prettyPattern :: @@ -115,9 +115,9 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd = (header <>) . P.sep (fmt S.DelimiterChar (" | " `P.orElse` "\n | ")) <$> constructor - `traverse` zip - [0 ..] - (DD.constructors' dd) + `traverse` zip + [0 ..] + (DD.constructors' dd) where constructor (n, (_, _, Type.ForallsNamed' _ t)) = constructor' n t constructor (n, (_, _, t)) = constructor' n t @@ -136,7 +136,7 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd = Just accessor -> HQ.NameOnly $ declName `Name.joinDot` fieldName `Name.joinDot` accessor | HQ.NameOnly declName <- [name], HQ.NameOnly fieldName <- fs, - accessor <- [Nothing, Just "set", Just "modify"] + accessor <- [Nothing, Just (Name.fromSegment "set"), Just (Name.fromSegment "modify")] ] pure . P.group $ fmt S.DelimiterChar "{ " @@ -148,7 +148,7 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd = P.group $ styleHashQualified'' (fmt (S.TypeReference r)) fname <> fmt S.TypeAscriptionColon " :" - `P.hang` runPretty suffixifiedPPE (TypePrinter.prettyRaw Map.empty (-1) typ) + `P.hang` runPretty suffixifiedPPE (TypePrinter.prettyRaw Map.empty (-1) typ) header = prettyDataHeader name dd <> fmt S.DelimiterChar (" = " `P.orElse` "\n = ") -- Comes up with field names for a data declaration which has the form of a @@ -180,18 +180,24 @@ fieldNames env r name dd = do vars = [Var.freshenId (fromIntegral n) (Var.named "_") | n <- [0 .. Type.arity typ - 1]] hashes <- DD.hashFieldAccessors env (HQ.toVar name) vars r dd let names = - [ (r, HQ.toString . PPE.termName env . Referent.Ref $ DerivedId r) + [ (r, HQ.toText . PPE.termName env . Referent.Ref $ DerivedId r) | r <- (\(refId, _trm, _typ) -> refId) <$> Map.elems hashes ] let fieldNames = Map.fromList - [ (r, f) | (r, n) <- names, typename <- pure (HQ.toString name), typename `isPrefixOf` n, rest <- pure $ drop (length typename + 1) n, (f, rest) <- pure $ span (/= '.') rest, rest `elem` ["", ".set", ".modify"] + [ (r, f) + | (r, n) <- names, + typename <- pure (HQ.toText name), + typename `Text.isPrefixOf` n, + rest <- pure $ Text.drop (Text.length typename + 1) n, + (f, rest) <- pure $ Text.span (/= '.') rest, + rest `elem` ["", ".set", ".modify"] ] if Map.size fieldNames == length names then Just - [ HQ.unsafeFromString name + [ HQ.unsafeParseText name | v <- vars, Just (ref, _, _) <- [Map.lookup (Var.namespaced [HQ.toVar name, v]) hashes], Just name <- [Map.lookup ref fieldNames] diff --git a/parser-typechecker/src/Unison/Syntax/FileParser.hs b/parser-typechecker/src/Unison/Syntax/FileParser.hs index 00544ce1b3..58b44d18ac 100644 --- a/parser-typechecker/src/Unison/Syntax/FileParser.hs +++ b/parser-typechecker/src/Unison/Syntax/FileParser.hs @@ -4,6 +4,7 @@ import Control.Lens import Control.Monad.Reader (asks, local) import Data.Map qualified as Map import Data.Set qualified as Set +import Data.Text qualified as Text import Text.Megaparsec qualified as P import Unison.ABT qualified as ABT import Unison.DataDeclaration (DataDeclaration) @@ -17,7 +18,7 @@ import Unison.Parser.Ann qualified as Ann import Unison.Prelude import Unison.Syntax.DeclParser (declarations) import Unison.Syntax.Lexer qualified as L -import Unison.Syntax.Name qualified as Name (toString, unsafeFromVar) +import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar) import Unison.Syntax.Parser import Unison.Syntax.TermParser qualified as TermParser import Unison.Term (Term) @@ -53,7 +54,7 @@ file = do Just (r, _) <- [Map.lookup (L.payload typ) (UF.datas env)] ] toPair (tok, typ) = (L.payload tok, ann tok <> ann typ) - let importNames = [(Name.unsafeFromVar v, Name.unsafeFromVar v2) | (v, v2) <- imports] + let importNames = [(Name.unsafeParseVar v, Name.unsafeParseVar v2) | (v, v2) <- imports] let locals = Names.importing importNames (UF.names env) -- At this stage of the file parser, we've parsed all the type and ability -- declarations. The `push locals` here has the effect @@ -94,13 +95,13 @@ file = do -- All unique local term name suffixes - these we want to -- avoid resolving to a term that's in the codebase locals :: [Name.Name] - locals = (Name.unsafeFromVar <$> Map.keys canonicalVars) + locals = (Name.unsafeParseVar <$> Map.keys canonicalVars) -- A function to replace unique local term suffixes with their -- fully qualified name replacements = [(v, Term.var () v2) | (v, v2) <- Map.toList canonicalVars, v /= v2] resolveLocals = ABT.substsInheritAnnotation replacements - let bindNames = Term.bindSomeNames Name.unsafeFromVar (Set.fromList fqLocalTerms) curNames . resolveLocals + let bindNames = Term.bindSomeNames Name.unsafeParseVar (Set.fromList fqLocalTerms) curNames . resolveLocals terms <- case List.validate (traverseOf _3 bindNames) terms of Left es -> resolutionFailures (toList es) Right terms -> pure terms @@ -218,7 +219,7 @@ stanza = watchExpression <|> unexpectedAction <|> binding watched :: (Monad m, Var v) => P v m (UF.WatchKind, Text, Ann) watched = P.try do - kind <- (fmap . fmap . fmap) Name.toString (optional importWordyId) + kind <- (fmap . fmap . fmap) (Text.unpack . Name.toText) (optional importWordyId) guid <- uniqueName 10 op <- optional (L.payload <$> P.lookAhead importSymbolyId) guard (op == Just (Name.fromSegment ">")) diff --git a/parser-typechecker/src/Unison/Syntax/TermParser.hs b/parser-typechecker/src/Unison/Syntax/TermParser.hs index dad5d62d9d..36f399207c 100644 --- a/parser-typechecker/src/Unison/Syntax/TermParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TermParser.hs @@ -44,7 +44,7 @@ import Unison.Prelude import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.Syntax.Lexer qualified as L -import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeFromVar) +import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar) import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Syntax.Parser hiding (seq) import Unison.Syntax.Parser qualified as Parser (seq, uniqueName) @@ -1026,7 +1026,7 @@ typedecl = verifyRelativeVarName :: (Var v) => P v m (L.Token v) -> P v m (L.Token v) verifyRelativeVarName p = do v <- p - verifyRelativeName' (Name.unsafeFromVar <$> v) + verifyRelativeName' (Name.unsafeParseVar <$> v) pure v verifyRelativeName' :: (Ord v) => L.Token Name -> P v m () @@ -1097,7 +1097,7 @@ binding = label "binding" do -- we haven't seen a type annotation, so lookahead to '=' before commit (lhsLoc, name, args) <- P.try (lhs <* P.lookAhead (openBlockWith "=")) (_bodySpanAnn, body) <- block "=" - verifyRelativeName' (fmap Name.unsafeFromVar name) + verifyRelativeName' (fmap Name.unsafeParseVar name) let binding = mkBinding lhsLoc args body -- We don't actually use the span annotation from the block (yet) because it -- may contain a bunch of white-space and comments following a top-level-definition. @@ -1105,7 +1105,7 @@ binding = label "binding" do pure $ ((spanAnn, (L.payload name)), binding) Just (nameT, typ) -> do (lhsLoc, name, args) <- lhs - verifyRelativeName' (fmap Name.unsafeFromVar name) + verifyRelativeName' (fmap Name.unsafeParseVar name) when (L.payload name /= L.payload nameT) $ customFailure $ SignatureNeedsAccompanyingBody nameT @@ -1191,7 +1191,7 @@ substImports ns imports = -- not in Names, but in a later term binding [ (suffix, Type.var () full) | (suffix, full) <- imports, - Names.hasTypeNamed Names.IncludeSuffixes (Name.unsafeFromVar full) ns + Names.hasTypeNamed Names.IncludeSuffixes (Name.unsafeParseVar full) ns ] block' :: diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index ba22d5ea86..fcc3b76a2a 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -52,7 +52,7 @@ 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.Name qualified as Name (fromText, fromTextEither, isSymboly, toText, unsafeFromText) +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) import Unison.Syntax.TypePrinter qualified as TypePrinter @@ -1265,7 +1265,7 @@ printAnnotate n tm = Set.fromList [n | v <- ABT.allVars tm, n <- varToName v] usedTypeNames = Set.fromList [n | Ann' _ ty <- ABT.subterms tm, v <- ABT.allVars ty, n <- varToName v] - varToName v = toList (Name.fromText (Var.name v)) + varToName v = toList (Name.parseText (Var.name v)) go :: (Ord v) => Term2 v at ap v b -> Term2 v () () v b go = extraMap' id (const ()) (const ()) @@ -1312,7 +1312,7 @@ countName n = } joinName :: Prefix -> Suffix -> Name -joinName p s = Name.unsafeFromText $ dotConcat $ p ++ [s] +joinName p s = Name.unsafeParseText $ dotConcat $ p ++ [s] dotConcat :: [Text] -> Text dotConcat = Text.concat . intersperse "." @@ -1389,7 +1389,7 @@ calcImports im tm = (im', render $ getUses result) |> filter ( \s -> let (p, i) = lookupOrDie s m - in (i > 1 || isRight (Name.fromTextEither s)) && not (null p) + in (i > 1 || isRight (Name.parseTextEither s)) && not (null p) ) |> map (\s -> (s, lookupOrDie s m)) |> Map.fromList @@ -2155,7 +2155,8 @@ avoidShadowing tm (PrettyPrintEnv terms types) = & maybe fullName HQ'.NameOnly in (fullName, minimallySuffixed) tweak _ p = p - varToName v = toList (Name.fromText (Var.name v)) + varToName :: Var v => v -> [Name] + varToName = toList . Name.parseText . Var.name isLeaf :: Term2 vt at ap v a -> Bool isLeaf (Var' {}) = True diff --git a/parser-typechecker/src/Unison/Typechecker.hs b/parser-typechecker/src/Unison/Typechecker.hs index 042000c0c6..d88e752ca6 100644 --- a/parser-typechecker/src/Unison/Typechecker.hs +++ b/parser-typechecker/src/Unison/Typechecker.hs @@ -51,7 +51,7 @@ import Unison.Result pattern Result, ) import Unison.Result qualified as Result -import Unison.Syntax.Name qualified as Name (toText, unsafeFromText) +import Unison.Syntax.Name qualified as Name (toText, unsafeParseText) import Unison.Term (Term) import Unison.Term qualified as Term import Unison.Type (Type) @@ -242,7 +242,7 @@ typeDirectedNameResolution ppe oldNotes oldType env = do addTypedComponent :: Context.InfoNote v loc -> State (Env v loc) () addTypedComponent (Context.TopLevelComponent vtts) = for_ vtts $ \(v, typ, _) -> - for_ (Name.suffixes . Name.unsafeFromText . Var.name $ Var.reset v) $ \suffix -> + for_ (Name.suffixes . Name.unsafeParseText . Var.name $ Var.reset v) $ \suffix -> termsByShortname %= Map.insertWith (<>) @@ -278,7 +278,7 @@ typeDirectedNameResolution ppe oldNotes oldType env = do Map.insertWith Set.union suggestionReplacement - (Set.singleton (Name.unsafeFromText suggestionName)) + (Set.singleton (Name.unsafeParseText suggestionName)) b ) Map.empty diff --git a/parser-typechecker/src/Unison/UnisonFile/Names.hs b/parser-typechecker/src/Unison/UnisonFile/Names.hs index 667e0016f6..9fb62f0958 100644 --- a/parser-typechecker/src/Unison/UnisonFile/Names.hs +++ b/parser-typechecker/src/Unison/UnisonFile/Names.hs @@ -31,8 +31,8 @@ import Unison.WatchKind qualified as WK toNames :: (Var v) => UnisonFile v a -> Names toNames uf = datas <> effects where - datas = foldMap (DD.Names.dataDeclToNames' Name.unsafeFromVar) (Map.toList (UF.dataDeclarationsId uf)) - effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeFromVar) (Map.toList (UF.effectDeclarationsId uf)) + datas = foldMap (DD.Names.dataDeclToNames' Name.unsafeParseVar) (Map.toList (UF.dataDeclarationsId uf)) + effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeParseVar) (Map.toList (UF.effectDeclarationsId uf)) addNamesFromUnisonFile :: (Var v) => UnisonFile v a -> Names -> Names addNamesFromUnisonFile unisonFile names = Names.shadowing (toNames unisonFile) names @@ -42,13 +42,13 @@ typecheckedToNames uf = Names (terms <> ctors) types where terms = Relation.fromList - [ (Name.unsafeFromVar v, Referent.Ref r) + [ (Name.unsafeParseVar v, Referent.Ref r) | (v, (_a, r, wk, _, _)) <- Map.toList $ UF.hashTerms uf, wk == Nothing || wk == Just WK.TestWatch ] types = Relation.fromList - [ (Name.unsafeFromVar v, r) + [ (Name.unsafeParseVar v, r) | (v, r) <- Map.toList $ fmap fst (UF.dataDeclarations' uf) @@ -56,7 +56,7 @@ typecheckedToNames uf = Names (terms <> ctors) types ] ctors = Relation.fromMap - . Map.mapKeys Name.unsafeFromVar + . Map.mapKeys Name.unsafeParseVar . fmap (fmap Reference.DerivedId) . UF.hashConstructors $ uf @@ -87,8 +87,8 @@ bindNames names (UnisonFileId d e ts ws) = do let termVars = (view _1 <$> ts) ++ (Map.elems ws >>= map (view _1)) termVarsSet = Set.fromList termVars -- todo: can we clean up this lambda using something like `second` - ts' <- traverse (\(v, a, t) -> (v,a,) <$> Term.bindNames Name.unsafeFromVar termVarsSet names t) ts - ws' <- traverse (traverse (\(v, a, t) -> (v,a,) <$> Term.bindNames Name.unsafeFromVar termVarsSet names t)) ws + ts' <- traverse (\(v, a, t) -> (v,a,) <$> Term.bindNames Name.unsafeParseVar termVarsSet names t) ts + ws' <- traverse (traverse (\(v, a, t) -> (v,a,) <$> Term.bindNames Name.unsafeParseVar termVarsSet names t)) ws pure $ UnisonFileId d e ts' ws' -- | Given the set of fully-qualified variable names, this computes @@ -111,7 +111,7 @@ variableCanonicalizer :: forall v. Var v => [v] -> Map v v variableCanonicalizer vs = done $ List.multimap do v <- vs - let n = Name.unsafeFromVar v + let n = Name.unsafeParseVar v suffix <- Name.suffixes n pure (Var.named (Name.toText suffix), v) where @@ -134,9 +134,9 @@ environmentFor names dataDecls0 effectDecls0 = do let locallyBoundTypes = variableCanonicalizer (Map.keys dataDecls0 <> Map.keys effectDecls0) -- data decls and hash decls may reference each other, and thus must be hashed together dataDecls :: Map v (DataDeclaration v a) <- - traverse (DD.Names.bindNames Name.unsafeFromVar locallyBoundTypes names) dataDecls0 + traverse (DD.Names.bindNames Name.unsafeParseVar locallyBoundTypes names) dataDecls0 effectDecls :: Map v (EffectDeclaration v a) <- - traverse (DD.withEffectDeclM (DD.Names.bindNames Name.unsafeFromVar locallyBoundTypes names)) effectDecls0 + traverse (DD.withEffectDeclM (DD.Names.bindNames Name.unsafeParseVar locallyBoundTypes names)) effectDecls0 let allDecls0 :: Map v (DataDeclaration v a) allDecls0 = Map.union dataDecls (toDataDecl <$> effectDecls) hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- Hashing.hashDataDecls allDecls0 @@ -145,8 +145,8 @@ environmentFor names dataDecls0 effectDecls0 = do dataDecls' = Map.difference allDecls effectDecls effectDecls' = second EffectDeclaration <$> Map.difference allDecls dataDecls -- ctor and effect terms - ctors = foldMap (DD.Names.dataDeclToNames' Name.unsafeFromVar) (Map.toList dataDecls') - effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeFromVar) (Map.toList effectDecls') + ctors = foldMap (DD.Names.dataDeclToNames' Name.unsafeParseVar) (Map.toList dataDecls') + effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeParseVar) (Map.toList effectDecls') names' = ctors <> effects overlaps = let w v dd (toDataDecl -> ed) = DupDataAndAbility v (DD.annotation dd) (DD.annotation ed) diff --git a/parser-typechecker/tests/Unison/Core/Test/Name.hs b/parser-typechecker/tests/Unison/Core/Test/Name.hs index 820c6bac3d..86ed2cc691 100644 --- a/parser-typechecker/tests/Unison/Core/Test/Name.hs +++ b/parser-typechecker/tests/Unison/Core/Test/Name.hs @@ -5,7 +5,7 @@ import Data.List.NonEmpty qualified as List.NonEmpty import Data.Set qualified as Set import EasyTest import Unison.Name as Name -import Unison.Syntax.Name qualified as Name (unsafeFromText) +import Unison.Syntax.Name qualified as Name (unsafeParseText) import Unison.Util.Relation qualified as R test :: Test () @@ -24,33 +24,33 @@ test = testCompareSuffix :: [Test ()] testCompareSuffix = - [ scope "[b.c a.b.c]" (expectEqual (compareSuffix "b.c" "a.b.c") EQ), - scope "[a.b.c a.b.c]" (expectEqual (compareSuffix "a.b.c" "a.b.c") EQ), - scope "[b.c a.b.b]" (expectEqual (compareSuffix "b.c" "a.b.b") LT), - scope "[a.b.c b.c]" (expectEqual (compareSuffix "a.b.c" "b.c") LT), - scope "[b.b a.b.c]" (expectEqual (compareSuffix "b.b" "a.b.c") GT) + [ scope "[b.c a.b.c]" (expectEqual (compareSuffix (Name.unsafeParseText "b.c") (Name.unsafeParseText "a.b.c")) EQ), + scope "[a.b.c a.b.c]" (expectEqual (compareSuffix (Name.unsafeParseText "a.b.c") (Name.unsafeParseText "a.b.c")) EQ), + scope "[b.c a.b.b]" (expectEqual (compareSuffix (Name.unsafeParseText "b.c") (Name.unsafeParseText "a.b.b")) LT), + scope "[a.b.c b.c]" (expectEqual (compareSuffix (Name.unsafeParseText "a.b.c") (Name.unsafeParseText "b.c")) LT), + scope "[b.b a.b.c]" (expectEqual (compareSuffix (Name.unsafeParseText "b.b") (Name.unsafeParseText "a.b.c")) GT) ] testEndsWithReverseSegments :: [Test ()] testEndsWithReverseSegments = - [ scope "a.b.c ends with []" (expectEqual True (endsWithReverseSegments "a.b.c" [])), + [ scope "a.b.c ends with []" (expectEqual True (endsWithReverseSegments (Name.unsafeParseText "a.b.c") [])), scope "a.b.c ends with [c, b]" - (expectEqual True (endsWithReverseSegments "a.b.c" ["c", "b"])), + (expectEqual True (endsWithReverseSegments (Name.unsafeParseText "a.b.c") ["c", "b"])), scope "a.b.c doesn't end with [d]" - (expectEqual False (endsWithReverseSegments "a.b.c" ["d"])) + (expectEqual False (endsWithReverseSegments (Name.unsafeParseText "a.b.c") ["d"])) ] testEndsWithSegments :: [Test ()] testEndsWithSegments = - [ scope "a.b.c ends with []" (expectEqual True (endsWithSegments "a.b.c" [])), + [ scope "a.b.c ends with []" (expectEqual True (endsWithSegments (Name.unsafeParseText "a.b.c") [])), scope "a.b.c ends with [b, c]" - (expectEqual True (endsWithSegments "a.b.c" ["b", "c"])), + (expectEqual True (endsWithSegments (Name.unsafeParseText "a.b.c") ["b", "c"])), scope "a.b.c doesn't end with [d]" - (expectEqual False (endsWithSegments "a.b.c" ["d"])) + (expectEqual False (endsWithSegments (Name.unsafeParseText "a.b.c") ["d"])) ] testSegments :: [Test ()] @@ -63,25 +63,25 @@ testSegments = testSplitName :: [Test ()] testSplitName = - [ scope "x" (expectEqual (splits "x") [([], "x")]), - scope "A.x" (expectEqual (splits "A.x") [([], "A.x"), (["A"], "x")]), + [ scope "x" (expectEqual (splits (Name.unsafeParseText "x")) [([], Name.unsafeParseText "x")]), + scope "A.x" (expectEqual (splits (Name.unsafeParseText "A.x")) [([], Name.unsafeParseText "A.x"), (["A"], Name.unsafeParseText "x")]), scope "A.B.x" ( expectEqual - (splits "A.B.x") - [ ([], "A.B.x"), - (["A"], "B.x"), - (["A", "B"], "x") + (splits (Name.unsafeParseText "A.B.x")) + [ ([], Name.unsafeParseText "A.B.x"), + (["A"], Name.unsafeParseText "B.x"), + (["A", "B"], Name.unsafeParseText "x") ] ) ] testSuffixes :: [Test ()] testSuffixes = - [ scope "one namespace" $ expectEqual (suffixes "bar") ["bar"], - scope "two namespaces" $ expectEqual (suffixes "foo.bar") ["foo.bar", "bar"], - scope "multiple namespaces" $ expectEqual (suffixes "foo.bar.baz") ["foo.bar.baz", "bar.baz", "baz"], - scope "terms named `.`" $ expectEqual (suffixes "base.`.`") ["base.`.`", "`.`"] + [ scope "one namespace" $ expectEqual (suffixes (Name.unsafeParseText "bar")) [Name.unsafeParseText "bar"], + scope "two namespaces" $ expectEqual (suffixes (Name.unsafeParseText "foo.bar")) [Name.unsafeParseText "foo.bar", Name.unsafeParseText "bar"], + scope "multiple namespaces" $ expectEqual (suffixes (Name.unsafeParseText "foo.bar.baz")) [Name.unsafeParseText "foo.bar.baz", Name.unsafeParseText "bar.baz", Name.unsafeParseText "baz"], + scope "terms named `.`" $ expectEqual (suffixes (Name.unsafeParseText "base.`.`")) [Name.unsafeParseText "base.`.`", Name.unsafeParseText "`.`"] ] testSuffixSearch :: [Test ()] @@ -97,7 +97,7 @@ testSuffixSearch = (n "a1.b.c", 5), (n ".`.`", 6) ] - n = Name.unsafeFromText + n = Name.unsafeParseText expectEqual' ("." :| []) (Name.reverseSegments (n ".`.`")) expectEqual' ("." :| []) (Name.reverseSegments (n ".`.`")) @@ -119,23 +119,23 @@ testSuffixSearch = testUnsafeFromString :: [Test ()] testUnsafeFromString = [ scope "." do - expectEqual' (isAbsolute "`.`") False - expectEqual' (segments "`.`") ("." :| []) + expectEqual' (isAbsolute (Name.unsafeParseText "`.`")) False + expectEqual' (segments (Name.unsafeParseText "`.`")) ("." :| []) ok, scope ".`.`" do - expectEqual' (isAbsolute ".`.`") True - expectEqual' (segments ".`.`") ("." :| []) + expectEqual' (isAbsolute (Name.unsafeParseText ".`.`")) True + expectEqual' (segments (Name.unsafeParseText ".`.`")) ("." :| []) ok, scope "foo.bar" do - expectEqual' (isAbsolute "foo.bar") False - expectEqual' (segments "foo.bar") ("foo" :| ["bar"]) + expectEqual' (isAbsolute (Name.unsafeParseText "foo.bar")) False + expectEqual' (segments (Name.unsafeParseText "foo.bar")) ("foo" :| ["bar"]) ok, scope ".foo.bar" do - expectEqual' (isAbsolute ".foo.bar") True - expectEqual' (segments ".foo.bar") ("foo" :| ["bar"]) + expectEqual' (isAbsolute (Name.unsafeParseText ".foo.bar")) True + expectEqual' (segments (Name.unsafeParseText ".foo.bar")) ("foo" :| ["bar"]) ok, scope "foo.`.`" do - expectEqual' (isAbsolute "foo.`.`") False - expectEqual' (segments "foo.`.`") ("foo" :| ["."]) + expectEqual' (isAbsolute (Name.unsafeParseText "foo.`.`")) False + expectEqual' (segments (Name.unsafeParseText "foo.`.`")) ("foo" :| ["."]) ok ] diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 104817a86d..24963a3951 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -176,9 +176,9 @@ import Unison.Share.Codeserver qualified as Codeserver import Unison.ShortHash qualified as SH import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) -import Unison.Syntax.HashQualified qualified as HQ (fromString, toString, toText, unsafeFromString) +import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeParseText, parseText) import Unison.Syntax.Lexer qualified as L -import Unison.Syntax.Name qualified as Name (toString, toText, toVar, unsafeFromVar) +import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar) import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Syntax.Parser qualified as Parser import Unison.Syntax.TermPrinter qualified as TP @@ -800,7 +800,7 @@ loop e = do (seg, _) <- Map.toList (Branch._edits b) ] Cli.respond $ ListOfPatches $ Set.fromList patches - Cli.setNumberedArgs $ fmap Name.toString patches + Cli.setNumberedArgs $ fmap (Text.unpack . Name.toText) patches FindShallowI pathArg -> do Cli.Env {codebase} <- ask @@ -903,8 +903,8 @@ loop e = do ambiguous t rs = Cli.returnEarly case t of HQ.HashOnly h -> HashAmbiguous h rs' - (Path.parseHQSplit' . HQ.toString -> Right n) -> DeleteNameAmbiguous hqLength n rs' Set.empty - _ -> BadName (HQ.toString t) + (Path.parseHQSplit' . Text.unpack . HQ.toText -> Right n) -> DeleteNameAmbiguous hqLength n rs' Set.empty + _ -> BadName (HQ.toText t) where rs' = Set.map Referent.Ref $ Set.fromList rs @@ -1044,9 +1044,9 @@ loop e = do hqLength <- Cli.runTransaction Codebase.hashLength uf <- Cli.expectLatestTypecheckedFile let datas, effects, terms :: [(Name, Reference.Id)] - datas = [(Name.unsafeFromVar v, r) | (v, (r, _d)) <- Map.toList $ UF.dataDeclarationsId' uf] - effects = [(Name.unsafeFromVar v, r) | (v, (r, _e)) <- Map.toList $ UF.effectDeclarationsId' uf] - terms = [(Name.unsafeFromVar v, r) | (v, (_, r, _wk, _tm, _tp)) <- Map.toList $ UF.hashTermsId uf] + datas = [(Name.unsafeParseVar v, r) | (v, (r, _d)) <- Map.toList $ UF.dataDeclarationsId' uf] + effects = [(Name.unsafeParseVar v, r) | (v, (r, _e)) <- Map.toList $ UF.effectDeclarationsId' uf] + terms = [(Name.unsafeParseVar v, r) | (v, (_, r, _wk, _tm, _tp)) <- Map.toList $ UF.hashTermsId uf] Cli.respond $ DumpUnisonFileHashes hqLength datas effects terms DebugTabCompletionI inputs -> do Cli.Env {authHTTPClient, codebase} <- ask @@ -1314,7 +1314,7 @@ inputDescription input = scope <- p' scope0 pure ("patch " <> p <> " " <> scope) UndoI {} -> pure "undo" - ExecuteI s args -> pure ("execute " <> Text.unwords (fmap Text.pack (s : args))) + ExecuteI s args -> pure ("execute " <> Text.unwords (s : fmap Text.pack args)) IOTestI hq -> pure ("io.test " <> HQ.toText hq) IOTestAllI -> pure "io.test.all" UpdateBuiltinsI -> pure "builtins.update" @@ -1322,8 +1322,8 @@ inputDescription input = MergeIOBuiltinsI -> pure "builtins.mergeio" MakeStandaloneI out nm -> pure ("compile " <> Text.pack out <> " " <> HQ.toText nm) ExecuteSchemeI nm args -> - pure $ "run.native " <> Text.unwords (fmap Text.pack (nm : args)) - CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> Text.pack fi) + pure $ "run.native " <> Text.unwords (nm : fmap Text.pack args) + CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> fi) GenSchemeLibsI mdir -> pure $ "compile.native.genlibs" <> Text.pack (maybe "" (" " ++) mdir) @@ -1483,8 +1483,8 @@ handleFindI isVerbose fscope ws input = do searchResultsFor names (Set.toList matches) [] -- name query - (map HQ.unsafeFromString -> qs) -> do - let srs = searchBranchScored names fuzzyNameDistance qs + qs -> do + let srs = searchBranchScored names fuzzyNameDistance (map (HQ.unsafeParseText . Text.pack) qs) pure $ uniqueBy SR.toReferent srs let respondResults results = do Cli.setNumberedArgs $ fmap searchResultToHQString results @@ -1812,13 +1812,13 @@ confirmedCommand i = do -- | restores the full hash to these search results, for _numberedArgs purposes searchResultToHQString :: SearchResult -> String searchResultToHQString = \case - SR.Tm' n r _ -> HQ.toString $ HQ.requalify n r - SR.Tp' n r _ -> HQ.toString $ HQ.requalify n (Referent.Ref r) + SR.Tm' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify n r + SR.Tp' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify n (Referent.Ref r) _ -> error "impossible match failure" -- Return a list of definitions whose names fuzzy match the given queries. fuzzyNameDistance :: Name -> Name -> Maybe Int -fuzzyNameDistance (Name.toString -> q) (Name.toString -> n) = +fuzzyNameDistance (Name.toText -> q) (Name.toText -> n) = Find.simpleFuzzyScore q n -- return `name` and `name....` @@ -1969,20 +1969,17 @@ doGenerateSchemeBoot force mppe mdir = do gen ppe saveWrap cwrapf dirTm compoundWrapName where a = External - hq nm - | Just hqn <- HQ.fromString nm = hqn - | otherwise = error $ "internal error: cannot hash qualify: " ++ nm - - sbName = hq ".unison.internal.compiler.scheme.saveBaseFile" - swName = hq ".unison.internal.compiler.scheme.saveWrapperFile" - sdName = hq ".unison.internal.compiler.scheme.saveDataInfoFile" - dinfoName = hq ".unison.internal.compiler.scheme.dataInfos" - bootName = hq ".unison.internal.compiler.scheme.bootSpec" - builtinName = hq ".unison.internal.compiler.scheme.builtinSpec" + + sbName = HQ.unsafeParseText ".unison.internal.compiler.scheme.saveBaseFile" + swName = HQ.unsafeParseText ".unison.internal.compiler.scheme.saveWrapperFile" + sdName = HQ.unsafeParseText ".unison.internal.compiler.scheme.saveDataInfoFile" + dinfoName = HQ.unsafeParseText ".unison.internal.compiler.scheme.dataInfos" + bootName = HQ.unsafeParseText ".unison.internal.compiler.scheme.bootSpec" + builtinName = HQ.unsafeParseText ".unison.internal.compiler.scheme.builtinSpec" simpleWrapName = - hq ".unison.internal.compiler.scheme.simpleWrapperSpec" + HQ.unsafeParseText ".unison.internal.compiler.scheme.simpleWrapperSpec" compoundWrapName = - hq ".unison.internal.compiler.scheme.compoundWrapperSpec" + HQ.unsafeParseText ".unison.internal.compiler.scheme.compoundWrapperSpec" gen ppe save file dir nm = liftIO (doesFileExist file) >>= \b -> when (not b || force) do @@ -2004,10 +2001,10 @@ typecheckAndEval ppe tm = do Result.Result notes Nothing -> do currentPath <- Cli.getCurrentPath let tes = [err | Result.TypeError err <- toList notes] - Cli.returnEarly (TypeErrors currentPath (Text.pack rendered) ppe tes) + Cli.returnEarly (TypeErrors currentPath rendered ppe tes) where a = External - rendered = P.toPlainUnbroken $ TP.pretty ppe tm + rendered = Text.pack (P.toPlainUnbroken $ TP.pretty ppe tm) ensureSchemeExists :: Cli () ensureSchemeExists = @@ -2051,16 +2048,16 @@ runScheme file args = do unless success $ Cli.returnEarly (PrintMessage "Scheme evaluation failed.") -buildScheme :: String -> String -> Cli () +buildScheme :: Text -> String -> Cli () buildScheme main file = do ensureSchemeExists statDir <- getSchemeStaticLibDir genDir <- getSchemeGenLibDir buildRacket genDir statDir main file -buildRacket :: String -> String -> String -> String -> Cli () +buildRacket :: String -> String -> Text -> String -> Cli () buildRacket genDir statDir main file = - let args = ["-l", "raco", "--", "exe", "-o", main, file] + let args = ["-l", "raco", "--", "exe", "-o", Text.unpack main, file] opts = racketOpts genDir statDir args in void . liftIO $ catch @@ -2084,25 +2081,25 @@ doCompile native output main = do ) (Cli.returnEarly . EvaluationFailure) -doRunAsScheme :: String -> [String] -> Cli () -doRunAsScheme main0 args = case HQ.fromString main0 of +doRunAsScheme :: Text -> [String] -> Cli () +doRunAsScheme main0 args = case HQ.parseText main0 of Just main -> do fullpath <- generateSchemeFile True main0 main runScheme fullpath args Nothing -> Cli.respond $ BadName main0 -doCompileScheme :: String -> HQ.HashQualified Name -> Cli () +doCompileScheme :: Text -> HQ.HashQualified Name -> Cli () doCompileScheme out main = generateSchemeFile True out main >>= buildScheme out -generateSchemeFile :: Bool -> String -> HQ.HashQualified Name -> Cli String +generateSchemeFile :: Bool -> Text -> HQ.HashQualified Name -> Cli String generateSchemeFile exec out main = do (comp, ppe) <- resolveMainRef main ensureCompilerExists doGenerateSchemeBoot False (Just ppe) Nothing cacheDir <- getCacheDir liftIO $ createDirectoryIfMissing True (cacheDir "scheme-tmp") - let scratch = out ++ ".scm" + let scratch = Text.unpack out ++ ".scm" fullpath = cacheDir "scheme-tmp" scratch output = Text.pack fullpath sscm <- Term.ref a <$> resolveTermRef saveNm @@ -2117,12 +2114,9 @@ generateSchemeFile exec out main = do pure fullpath where a = External - hq nm - | Just hqn <- HQ.fromString nm = hqn - | otherwise = error $ "internal error: cannot hash qualify: " ++ nm - saveNm = hq ".unison.internal.compiler.saveScheme" - filePathNm = hq "FilePath.FilePath" + saveNm = HQ.unsafeParseText ".unison.internal.compiler.saveScheme" + filePathNm = HQ.unsafeParseText "FilePath.FilePath" delete :: Input -> @@ -2275,7 +2269,7 @@ displayI outputLoc hq = do let suffixifiedPPE = PPE.suffixifiedPPE pped let bias = maybeToList $ HQ.toName hq latestTypecheckedFile <- Cli.getLatestTypecheckedFile - case addWatch (HQ.toString hq) latestTypecheckedFile of + case addWatch (Text.unpack (HQ.toText hq)) latestTypecheckedFile of Nothing -> do let results = Names.lookupHQTerm Names.IncludeSuffixes hq names ref <- @@ -2293,7 +2287,7 @@ displayI outputLoc hq = do let suffixifiedFilePPE = PPE.biasTo bias $ PPE.suffixifiedPPE filePPED (_, watches) <- evalUnisonFile Sandboxed suffixifiedFilePPE unisonFile [] (_, _, _, _, tm, _) <- - Map.lookup toDisplay watches & onNothing (error $ "Evaluation dropped a watch expression: " <> HQ.toString hq) + Map.lookup toDisplay watches & onNothing (error $ "Evaluation dropped a watch expression: " <> Text.unpack (HQ.toText hq)) let ns = UF.addNamesFromTypeCheckedUnisonFile unisonFile names doDisplay outputLoc ns tm @@ -2312,7 +2306,7 @@ docsI src = do in Name.convert hq' dotDoc :: HQ.HashQualified Name - dotDoc = hq <&> \n -> Name.joinDot n "doc" + dotDoc = hq <&> \n -> Name.joinDot n (Name.fromSegment "doc") findInScratchfileByName :: Cli () findInScratchfileByName = do @@ -2371,7 +2365,7 @@ parseType input src = do Parsers.parseType (Text.unpack (fst lexed)) parsingEnv & onLeftM \err -> Cli.returnEarly (TypeParseError src err) - Type.bindNames Name.unsafeFromVar mempty names (Type.generalizeLowercase mempty typ) & onLeft \errs -> + Type.bindNames Name.unsafeParseVar mempty names (Type.generalizeLowercase mempty typ) & onLeft \errs -> Cli.returnEarly (ParseResolutionFailures src (toList errs)) -- Adds a watch expression of the given name to the file, if diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FormatFile.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FormatFile.hs index 717901322a..17abb88ad9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FormatFile.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FormatFile.hs @@ -65,7 +65,7 @@ formatFile makePPEDForFile formattingWidth currentPath inputParsedFile inputType ) & Map.filter (\(tldAnn, _, _) -> isInFormatRange tldAnn) & itraverse \sym (tldAnn, ref, decl) -> do - symName <- hoistMaybe (Name.fromVar sym) + symName <- hoistMaybe (Name.parseVar sym) let declNameSegments = NEL.appendr (Path.toList (Path.unabsolute currentPath)) (Name.segments symName) let declName = Name.fromSegments declNameSegments let hqName = HQ.fromName symName @@ -84,7 +84,7 @@ formatFile makePPEDForFile formattingWidth currentPath inputParsedFile inputType (FileSummary.termsBySymbol fileSummary) & Map.filter (\(tldAnn, _, trm, _) -> shouldFormatTerm tldAnn trm) & itraverse \sym (tldAnn, mayRefId, trm, _typ) -> do - symName <- hoistMaybe (Name.fromVar sym) + symName <- hoistMaybe (Name.parseVar sym) let defNameSegments = NEL.appendr (Path.toList (Path.unabsolute currentPath)) (Name.segments symName) let defName = Name.fromSegments defNameSegments let hqName = HQ.NameOnly symName diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs index 4faadebba6..dbd1281c7f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs @@ -40,7 +40,7 @@ import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF import Unison.Var qualified as Var -handleRun :: Bool -> String -> [String] -> Cli () +handleRun :: Bool -> Text -> [String] -> Cli () handleRun native main args = do (unisonFile, mainResType) <- do (sym, term, typ, otyp) <- getTerm main @@ -75,7 +75,7 @@ data GetTermResult -- | Look up runnable term with the given name in the codebase or -- latest typechecked unison file. Return its symbol, term, type, and -- the type of the evaluated term. -getTerm :: String -> Cli (Symbol, Term Symbol Ann, Type Symbol Ann, Type Symbol Ann) +getTerm :: Text -> Cli (Symbol, Term Symbol Ann, Type Symbol Ann, Type Symbol Ann) getTerm main = getTerm' main >>= \case NoTermWithThatName -> do @@ -90,7 +90,7 @@ getTerm main = Cli.returnEarly $ Output.BadMainFunction "run" main ty suffixifiedPPE [mainType] GetTermSuccess x -> pure x -getTerm' :: String -> Cli GetTermResult +getTerm' :: Text -> Cli GetTermResult getTerm' mainName = let getFromCodebase = do Cli.Env {codebase, runtime} <- ask @@ -108,7 +108,7 @@ getTerm' mainName = pure (GetTermSuccess (v, tm, typ, otyp)) getFromFile uf = do let components = join $ UF.topLevelComponents uf - let mainComponent = filter ((\v -> Var.nameStr v == mainName) . view _1) components + let mainComponent = filter ((\v -> Var.name v == mainName) . view _1) components case mainComponent of [(v, _, tm, ty)] -> checkType ty \otyp -> diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs index 8b237ad436..7e12e623e9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs @@ -31,7 +31,7 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference (Reference) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.Symbol (Symbol) -import Unison.Syntax.HashQualified qualified as HQ (toString) +import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Type (Type) import Unison.Typechecker qualified as Typechecker @@ -118,7 +118,7 @@ resolveMainRef main = do pped <- Cli.prettyPrintEnvDeclFromNames names let suffixifiedPPE = PPED.suffixifiedPPE pped let mainType = Runtime.mainType runtime - smain = HQ.toString main + smain = HQ.toText main lookupTermRefWithType codebase main >>= \case [(rf, ty)] | Typechecker.fitsScheme ty mainType -> pure (rf, suffixifiedPPE) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs index 74b3944feb..6f37e534a1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs @@ -134,7 +134,7 @@ handleIOTest main = do (fails, oks) <- refs & foldMapM \(ref, typ) -> do when (not $ isIOTest typ) do - Cli.returnEarly (BadMainFunction "io.test" (HQ.toString main) typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime)) + Cli.returnEarly (BadMainFunction "io.test" (HQ.toText main) typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime)) runIOTest suffixifiedPPE ref Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails @@ -180,7 +180,7 @@ resolveHQNames parseNames hqNames = getNameFromScratchFile :: HQ.HashQualified Name -> MaybeT Cli (Reference.Id, Type.Type Symbol Ann) getNameFromScratchFile main = do typecheckedFile <- MaybeT Cli.getLatestTypecheckedFile - mainName <- hoistMaybe $ Name.fromText (HQ.toText main) + mainName <- hoistMaybe $ Name.parseText (HQ.toText main) (_, ref, _wk, _term, typ) <- hoistMaybe $ Map.lookup (Name.toVar mainName) (UF.hashTermsId typecheckedFile) pure (ref, typ) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs index 96cf087458..8bb20ff673 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs @@ -53,7 +53,7 @@ import Unison.Referent qualified as Referent import Unison.Result qualified as Result import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) -import Unison.Syntax.Name qualified as Name (toVar, unsafeFromVar) +import Unison.Syntax.Name qualified as Name (toVar, unsafeParseVar) import Unison.Term (Term) import Unison.Term qualified as Term import Unison.Type (Type) @@ -90,7 +90,7 @@ handleUpdate input optionalPatch requestedNames = do typeEdits :: [(Name, Reference, Reference)] typeEdits = do v <- Set.toList (SC.types (updates sr)) - let n = Name.unsafeFromVar v + let n = Name.unsafeParseVar v let oldRefs0 = Names.typesNamed currentCodebaseNames n let newRefs = Names.typesNamed fileNames n case (,) <$> NESet.nonEmptySet oldRefs0 <*> Set.asSingleton newRefs of @@ -105,7 +105,7 @@ handleUpdate input optionalPatch requestedNames = do termEdits :: [(Name, Reference, Reference)] termEdits = do v <- Set.toList (SC.terms (updates sr)) - let n = Name.unsafeFromVar v + let n = Name.unsafeParseVar v let oldRefs0 = Names.refTermsNamed currentCodebaseNames n let newRefs = Names.refTermsNamed fileNames n case (,) <$> NESet.nonEmptySet oldRefs0 <*> Set.asSingleton newRefs of @@ -215,7 +215,7 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do Set.map Name.toVar . Names.namesForReferent slurpCheckNames . Referent.fromTermReferenceId let nameToTermRefs :: Symbol -> Set TermReference - nameToTermRefs = Names.refTermsNamed slurpCheckNames . Name.unsafeFromVar + nameToTermRefs = Names.refTermsNamed slurpCheckNames . Name.unsafeParseVar slurp1 <- do Cli.Env {codebase} <- ask @@ -593,10 +593,10 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions) SC.terms slurp <> UF.constructorsForDecls (SC.types slurp) uf names = UF.typecheckedToNames uf doTerm :: Symbol -> (Path, Branch0 m -> Branch0 m) - doTerm v = case toList (Names.termsNamed names (Name.unsafeFromVar v)) of + doTerm v = case toList (Names.termsNamed names (Name.unsafeParseVar v)) of [] -> errorMissingVar v [r] -> - let split = Path.splitFromName (Name.unsafeFromVar v) + let split = Path.splitFromName (Name.unsafeParseVar v) in BranchUtil.makeAddTermName split r wha -> error $ @@ -605,10 +605,10 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions) <> ": " <> show wha doType :: Symbol -> (Path, Branch0 m -> Branch0 m) - doType v = case toList (Names.typesNamed names (Name.unsafeFromVar v)) of + doType v = case toList (Names.typesNamed names (Name.unsafeParseVar v)) of [] -> errorMissingVar v [r] -> - let split = Path.splitFromName (Name.unsafeFromVar v) + let split = Path.splitFromName (Name.unsafeParseVar v) in BranchUtil.makeAddTypeName split r wha -> error $ diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs index eeb547c2da..f96546d909 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Update2.hs @@ -225,7 +225,7 @@ typecheckedUnisonFileToBranchUpdates abort getConstructors tuf = do makeDeclUpdates (symbol, (typeRefId, decl)) = do -- some decls will be deleted, we want to delete their -- constructors as well - deleteConstructorActions <- case map (BranchUtil.makeAnnihilateTermName . Path.splitFromName) <$> getConstructors (Name.unsafeFromVar symbol) of + deleteConstructorActions <- case map (BranchUtil.makeAnnihilateTermName . Path.splitFromName) <$> getConstructors (Name.unsafeParseVar symbol) of Left err -> abort err Right actions -> pure actions let deleteTypeAction = BranchUtil.makeAnnihilateTypeName split @@ -258,7 +258,7 @@ typecheckedUnisonFileToBranchUpdates abort getConstructors tuf = do else [] splitVar :: Symbol -> Path.Split - splitVar = Path.splitFromName . Name.unsafeFromVar + splitVar = Path.splitFromName . Name.unsafeParseVar -- | get references from `names` that have the same names as in `defns` -- For constructors, we get the type reference. @@ -411,14 +411,14 @@ getTermAndDeclNames tuf = UF.hashTermsId tuf & Map.foldMapWithKey \var (_, _, wk, _, _) -> if WK.watchKindShouldBeStoredInDatabase wk - then Set.singleton (Name.unsafeFromVar var) + then Set.singleton (Name.unsafeParseVar var) else Set.empty effects = keysToNames $ UF.effectDeclarationsId' tuf datas = keysToNames $ UF.dataDeclarationsId' tuf effectCtors = foldMap ctorsToNames $ fmap (Decl.toDataDecl . snd) $ UF.effectDeclarationsId' tuf dataCtors = foldMap ctorsToNames $ fmap snd $ UF.dataDeclarationsId' tuf - keysToNames = Set.map Name.unsafeFromVar . Map.keysSet - ctorsToNames = Set.fromList . map Name.unsafeFromVar . Decl.constructorVars + keysToNames = Set.map Name.unsafeParseVar . Map.keysSet + ctorsToNames = Set.fromList . map Name.unsafeParseVar . Decl.constructorVars -- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the -- (transitive) dependents of the dependencies. diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index c2d73f9f82..3b0e3901f3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -172,7 +172,7 @@ data Input -- Second `Maybe Int` is cap on diff elements shown, if any HistoryI (Maybe Int) (Maybe Int) BranchId | -- execute an IO thunk with args - ExecuteI String [String] + ExecuteI Text [String] | -- save the result of a previous Execute SaveExecuteResultI Name | -- execute an IO [Result] @@ -182,9 +182,9 @@ data Input | -- make a standalone binary file MakeStandaloneI String (HQ.HashQualified Name) | -- execute an IO thunk using scheme - ExecuteSchemeI String [String] + ExecuteSchemeI Text [String] | -- compile to a scheme file - CompileSchemeI String (HQ.HashQualified Name) + CompileSchemeI Text (HQ.HashQualified Name) | -- generate scheme libraries, optional target directory GenSchemeLibsI (Maybe String) | -- fetch scheme compiler from a given username and branch diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 2cc685a29c..c31f0ab421 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -153,13 +153,13 @@ data Output | InvalidSourceName String | SourceLoadFailed String | -- No main function, the [Type v Ann] are the allowed types - NoMainFunction String PPE.PrettyPrintEnv [Type Symbol Ann] + NoMainFunction Text PPE.PrettyPrintEnv [Type Symbol Ann] | -- | Function found, but has improper type -- Note: the constructor name is misleading here; we weren't necessarily looking for a "main". BadMainFunction - String + Text -- ^ what we were trying to do (e.g. "run", "io.test") - String + Text -- ^ name of function (Type Symbol Ann) -- ^ bad type of function @@ -305,7 +305,7 @@ data Output | DumpNumberedArgs NumberedArgs | DumpBitBooster CausalHash (Map CausalHash [CausalHash]) | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] - | BadName String + | BadName Text | CouldntLoadBranch CausalHash | HelpMessage Input.InputPattern | NamespaceEmpty (NonEmpty AbsBranchId) diff --git a/unison-cli/src/Unison/Codebase/Editor/Slurp.hs b/unison-cli/src/Unison/Codebase/Editor/Slurp.hs index 16d3e57742..3c7e9e5239 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Slurp.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Slurp.hs @@ -23,7 +23,7 @@ import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Referent' qualified as Referent import Unison.Symbol (Symbol) -import Unison.Syntax.Name qualified as Name (toText, unsafeFromVar) +import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar) import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF import Unison.Util.Map qualified as Map @@ -159,7 +159,7 @@ computeNamesWithDeprecations uf unalteredCodebaseNames involvedVars = \case & filter (\(typeV, _) -> Set.member (TypeVar typeV) involvedVars) & concatMap (\(_typeV, (_refId, decl)) -> DD.constructors' decl) & fmap - ( \(_ann, v, _typ) -> Name.unsafeFromVar v + ( \(_ann, v, _typ) -> Name.unsafeParseVar v ) & Set.fromList @@ -170,7 +170,7 @@ computeNamesWithDeprecations uf unalteredCodebaseNames involvedVars = \case let effectNames = Map.keys (UF.effectDeclarationsId' uf) typeName <- declNames <> effectNames when (not . null $ involvedVars) (guard (TypeVar typeName `Set.member` involvedVars)) - pure $ Names.typesNamed unalteredCodebaseNames (Name.unsafeFromVar typeName) + pure $ Names.typesNamed unalteredCodebaseNames (Name.unsafeParseVar typeName) existingConstructorsFromEditedTypes = Set.fromList $ do -- List Monad ref <- Set.toList oldRefsForEditedTypes @@ -194,8 +194,8 @@ computeSelfStatuses vars varReferences codebaseNames = Just r -> r Nothing -> error $ "Expected LabeledDependency in map for var: " <> show tv v = untagged tv - existingTypesAtName = Names.typesNamed codebaseNames (Name.unsafeFromVar v) - existingTermsOrCtorsAtName = Names.termsNamed codebaseNames (Name.unsafeFromVar v) + existingTypesAtName = Names.typesNamed codebaseNames (Name.unsafeParseVar v) + existingTermsOrCtorsAtName = Names.termsNamed codebaseNames (Name.unsafeParseVar v) in case ld of LD.TypeReference _typeRef -> case Set.toList existingTypesAtName of diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 5769027cd5..03c5745df5 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -379,7 +379,7 @@ absolutePath = do nameSegment :: P NameSegment nameSegment = - NameSegment.unsafeFromText . Text.pack + NameSegment.unsafeParseText . Text.pack <$> ( (:) <$> P.satisfy Unison.Syntax.Lexer.wordyIdStartChar <*> P.many (P.satisfy Unison.Syntax.Lexer.wordyIdChar) diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 5d615853b4..e58ef39c50 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -149,7 +149,7 @@ completeWithinNamespace compTypes query currentPath = do currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib - & fmap (\(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> NameSegment.unsafeFromText match)) + & fmap (\(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> NameSegment.unsafeParseText match)) & filter (\(_isFinished, match) -> List.isPrefixOf query match) & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) & pure @@ -169,7 +169,7 @@ completeWithinNamespace compTypes query currentPath = do getChildSuggestions shortHashLen b | Text.null querySuffix = pure [] | otherwise = - case NameSegment.fromText querySuffix of + case NameSegment.parseText querySuffix of Left _ -> pure [] Right suffix -> do nonEmptyChildren <- V2Branch.nonEmptyChildren b @@ -180,7 +180,7 @@ completeWithinNamespace compTypes query currentPath = do nib <- namesInBranch shortHashLen childBranch nib & fmap - ( \(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> suffix Lens.:> NameSegment.unsafeFromText match) + ( \(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> suffix Lens.:> NameSegment.unsafeParseText match) ) & filter (\(_isFinished, match) -> List.isPrefixOf query match) & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) @@ -382,7 +382,7 @@ shareCompletion completionTypes authHTTPClient str = ( \(_, name) -> let queryPath = userHandle : Path.toList path result = - (queryPath ++ [NameSegment.unsafeFromText name]) + (queryPath ++ [NameSegment.unsafeParseText name]) & List.NonEmpty.fromList & Name.fromSegments & Name.toText diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index edc338f9d3..34f2cc19e8 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -59,8 +59,8 @@ import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectBranchNameOrLatestRelease (..), ProjectBranchSpecifier (..), ProjectName, Semver) import Unison.Project.Util (ProjectContext (..), projectContextFromPath) -import Unison.Syntax.HashQualified qualified as HQ (fromString) -import Unison.Syntax.Name qualified as Name (fromText, unsafeFromString) +import Unison.Syntax.HashQualified qualified as HQ (parseText) +import Unison.Syntax.Name qualified as Name (parseText, unsafeParseText) import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr, segmentP) import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (intercalateMap) @@ -213,7 +213,7 @@ add = ( "`add` adds to the codebase all the definitions from the most recently " <> "typechecked file." ) - $ \ws -> pure $ Input.AddI (Set.fromList $ map Name.unsafeFromString ws) + \ws -> pure $ Input.AddI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) previewAdd :: InputPattern previewAdd = @@ -227,7 +227,7 @@ previewAdd = <> "results. Use `load` to reparse & typecheck the file if the context " <> "has changed." ) - $ \ws -> pure $ Input.PreviewAddI (Set.fromList $ map Name.unsafeFromString ws) + \ws -> pure $ Input.PreviewAddI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) update :: InputPattern update = @@ -279,7 +279,7 @@ updateOldNoPatch = pure $ Input.UpdateI Input.NoPatch - (Set.fromList $ map Name.unsafeFromString ws) + (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) ) updateOld :: InputPattern @@ -320,7 +320,7 @@ updateOld = pure $ Input.UpdateI (Input.UsePatch patch) - (Set.fromList $ map Name.unsafeFromString ws) + (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) [] -> Right $ Input.UpdateI Input.DefaultPatch mempty previewUpdate :: InputPattern @@ -335,7 +335,7 @@ previewUpdate = <> "typechecking results. Use `load` to reparse & typecheck the file if " <> "the context has changed." ) - \ws -> pure $ Input.PreviewUpdateI (Set.fromList $ map Name.unsafeFromString ws) + \ws -> pure $ Input.PreviewUpdateI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) patch :: InputPattern patch = @@ -1869,7 +1869,7 @@ editNamespace = [ "`edit.namespace` will load all terms and types contained within the current namespace into your scratch file. This includes definitions in namespaces, but excludes libraries.", "`edit.namespace ns1 ns2 ...` loads the terms and types contained within the provided namespaces." ], - parse = Right . Input.EditNamespaceI . fmap (Path.fromText . Text.pack) + parse = Right . Input.EditNamespaceI . fmap (Path.unsafeParseText . Text.pack) } topicNameArg :: ArgumentType @@ -2158,7 +2158,7 @@ names isGlobal = [("name or hash", Required, definitionQueryArg)] (P.wrap $ makeExample (names isGlobal) ["foo"] <> " shows the hash and all known names for `foo`.") \case - [thing] -> case HQ.fromString thing of + [thing] -> case HQ.parseText (Text.pack thing) of Just hq -> Right $ Input.NamesI isGlobal hq Nothing -> Left $ @@ -2358,7 +2358,7 @@ docToMarkdown = ) \case [docNameText] -> first fromString $ do - docName <- maybeToEither "Invalid name" . Name.fromText . Text.pack $ docNameText + docName <- maybeToEither "Invalid name" . Name.parseText . Text.pack $ docNameText pure $ Input.DocToMarkdownI docName _ -> Left $ showPatternHelp docToMarkdown @@ -2379,8 +2379,8 @@ execute = ] ) \case - [w] -> pure $ Input.ExecuteI w [] - (w : ws) -> pure $ Input.ExecuteI w ws + [w] -> pure $ Input.ExecuteI (Text.pack w) [] + w : ws -> pure $ Input.ExecuteI (Text.pack w) ws _ -> Left $ showPatternHelp execute saveExecuteResult :: InputPattern @@ -2394,7 +2394,7 @@ saveExecuteResult = <> "as `name`." ) \case - [w] -> pure $ Input.SaveExecuteResultI (Name.unsafeFromString w) + [w] -> pure $ Input.SaveExecuteResultI (Name.unsafeParseText (Text.pack w)) _ -> Left $ showPatternHelp saveExecuteResult ioTest :: InputPattern @@ -2467,7 +2467,7 @@ runScheme = ] ) \case - (main : args) -> Right $ Input.ExecuteSchemeI main args + main : args -> Right $ Input.ExecuteSchemeI (Text.pack main) args _ -> Left $ showPatternHelp runScheme compileScheme :: InputPattern @@ -2487,7 +2487,7 @@ compileScheme = ) \case [main, file] -> - Input.CompileSchemeI file <$> parseHashQualifiedName main + Input.CompileSchemeI (Text.pack file) <$> parseHashQualifiedName main _ -> Left $ showPatternHelp compileScheme schemeLibgen :: InputPattern @@ -2934,7 +2934,7 @@ upgrade = where parseRelativeNameSegment :: String -> Maybe NameSegment parseRelativeNameSegment string = do - name <- Name.fromText (Text.pack string) + name <- Name.parseText (Text.pack string) guard (Name.isRelative name) segment NE.:| [] <- Just (Name.reverseSegments name) Just segment @@ -3713,7 +3713,7 @@ parseHashQualifiedName s = <> "I expected something like `foo`, `#abc123`, or `foo#abc123`." ) Right - $ HQ.fromString s + $ HQ.parseText (Text.pack s) parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo parseWriteGitRepo label input = do diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index f5610cbd7e..92c0707368 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -127,8 +127,8 @@ import Unison.Share.Sync.Types (CodeserverTransportError (..)) import Unison.ShortHash qualified as ShortHash import Unison.Sync.Types qualified as Share import Unison.Syntax.DeclPrinter qualified as DeclPrinter -import Unison.Syntax.HashQualified qualified as HQ (toString, toText, unsafeFromVar) -import Unison.Syntax.Name qualified as Name (toString, toText) +import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeFromVar) +import Unison.Syntax.Name qualified as Name (toText) import Unison.Syntax.NamePrinter ( prettyHashQualified, prettyHashQualified', @@ -300,7 +300,7 @@ notifyNumbered = \case "", tip $ "Add" - <> prettyName "License" + <> prettyName (Name.fromSegment "License") <> "values for" <> prettyName (Name.fromSegment authorNS) <> "under" @@ -509,12 +509,13 @@ notifyNumbered = \case newNextNum = nextNum + length unnumberedNames in ( newNextNum, ( nameToNum <> (Map.fromList (zip unnumberedNames [nextNum ..])), - args <> fmap Name.toString unnumberedNames + args <> fmap Name.toText unnumberedNames ) ) ) (1, (mempty, mempty)) & snd + & over (_2 . mapped) Text.unpack externalDepsTable :: Map LabeledDependency (Set Name) -> [(P.Pretty P.ColorText, P.Pretty P.ColorText)] externalDepsTable = ifoldMap $ \ld dependents -> [(prettyLD ld, prettyDependents dependents)] @@ -605,7 +606,7 @@ showListEdits patch ppe = TermEdit.Replace rhsRef _typing -> do n2 <- gets snd <* modify (second succ) let rhsTermName = PPE.termName ppe (Referent.Ref rhsRef) - lift $ tell ([lhsHash], [HQ.toString rhsTermName]) + lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTermName)]) pure ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTermName), "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTermName) @@ -630,7 +631,7 @@ showListEdits patch ppe = TypeEdit.Replace rhsRef -> do n2 <- gets snd <* modify (second succ) let rhsTypeName = PPE.typeName ppe rhsRef - lift $ tell ([lhsHash], [HQ.toString rhsTypeName]) + lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTypeName)]) pure ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTypeName), "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTypeName) @@ -643,7 +644,7 @@ notifyUser dir = \case . P.warnCallout . P.wrap $ "Cannot save the last run result into" - <> P.backticked (P.string (Name.toString name)) + <> P.backticked (P.text (Name.toText name)) <> "because that name conflicts with a name in the scratch file." NoLastRunResult -> pure @@ -881,21 +882,21 @@ notifyUser dir = \case P.lines [ P.wrap $ "I looked for a function" - <> P.backticked (P.string main) + <> P.backticked (P.text main) <> "in the most recently typechecked file and codebase but couldn't find one. It has to have the type:", "", - P.indentN 2 $ P.lines [P.string main <> " : " <> TypePrinter.pretty ppe t | t <- ts] + P.indentN 2 $ P.lines [P.text main <> " : " <> TypePrinter.pretty ppe t | t <- ts] ] BadMainFunction what main ty ppe ts -> pure . P.callout "😶" $ P.lines [ P.string "I found this function:", "", - P.indentN 2 $ P.string main <> " : " <> TypePrinter.pretty ppe ty, + P.indentN 2 $ P.text main <> " : " <> TypePrinter.pretty ppe ty, "", - P.wrap $ P.string "but in order for me to" <> P.backticked (P.string what) <> "it needs to be a subtype of:", + P.wrap $ P.string "but in order for me to" <> P.backticked (P.text what) <> "it needs to be a subtype of:", "", - P.indentN 2 $ P.lines [P.string main <> " : " <> TypePrinter.pretty ppe t | t <- ts] + P.indentN 2 $ P.lines [P.text main <> " : " <> TypePrinter.pretty ppe t | t <- ts] ] NoUnisonFile -> do dir' <- canonicalizePath dir @@ -1544,8 +1545,7 @@ notifyUser dir = \case "", P.wrap "Try again with a few more hash characters to disambiguate." ] - BadName n -> - pure . P.wrap $ P.string n <> " is not a kind of name I understand." + BadName n -> pure . P.wrap $ P.text n <> " is not a kind of name I understand." TermNotFound' sh -> pure $ "I could't find a term with hash " @@ -2699,7 +2699,7 @@ renderNameConflicts ppe conflictedNames = do P.lines <$> do for (Map.toList conflictedNames) $ \(name, hashes) -> do prettyConflicts <- for hashes \hash -> do - n <- addNumberedArg (HQ.toString hash) + n <- addNumberedArg (Text.unpack (HQ.toText hash)) pure $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash) pure . P.wrap $ ( "The " @@ -2731,7 +2731,7 @@ renderEditConflicts ppe Patch {..} = do <> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits) numberedHQName :: HQ.HashQualified Name -> Numbered Pretty numberedHQName hqName = do - n <- addNumberedArg (HQ.toString hqName) + n <- addNumberedArg (Text.unpack (HQ.toText hqName)) pure $ formatNum n <> styleHashQualified P.bold hqName formatTypeEdits :: (Reference, Set TypeEdit.TypeEdit) -> @@ -2844,11 +2844,11 @@ todoOutput ppe todo = runNumbered do todoEdits :: Numbered Pretty todoEdits = do numberedTypes <- for (unscore <$> dirtyTypes) \(ref, displayObj) -> do - n <- addNumberedArg (HQ.toString $ PPE.typeName ppeu ref) + n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.typeName ppeu ref)) pure $ formatNum n <> prettyDeclPair ppeu (ref, displayObj) let filteredTerms = goodTerms (unscore <$> dirtyTerms) termNumbers <- for filteredTerms \(ref, _, _) -> do - n <- addNumberedArg (HQ.toString $ PPE.termName ppeu ref) + n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.termName ppeu ref)) pure $ formatNum n let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms numberedTerms = zipWith (<>) termNumbers formattedTerms @@ -3264,8 +3264,8 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = -- prefixBranchId ".base" "List.map" -> ".base.List.map" prefixBranchId :: Input.AbsBranchId -> Name -> String prefixBranchId branchId name = case branchId of - Left sch -> "#" <> SCH.toString sch <> ":" <> Name.toString (Name.makeAbsolute name) - Right pathPrefix -> Name.toString (Name.makeAbsolute . Path.prefixName pathPrefix $ name) + Left sch -> "#" <> SCH.toString sch <> ":" <> Text.unpack (Name.toText (Name.makeAbsolute name)) + Right pathPrefix -> Text.unpack (Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name)) addNumberedArg' :: String -> Numbered Pretty addNumberedArg' s = case sn of @@ -3522,7 +3522,7 @@ numberedArgsForEndangerments (PPED.unsuffixifiedPPE -> ppe) m = m & Map.elems & concatMap toList - & fmap (HQ.toString . PPE.labeledRefName ppe) + & fmap (Text.unpack . HQ.toText . PPE.labeledRefName ppe) -- | Format and render all dependents which are endangered by references going extinct. endangeredDependentsTable :: diff --git a/unison-cli/src/Unison/LSP/Completion.hs b/unison-cli/src/Unison/LSP/Completion.hs index d2caa680bf..31ec59aa40 100644 --- a/unison-cli/src/Unison/LSP/Completion.hs +++ b/unison-cli/src/Unison/LSP/Completion.hs @@ -43,7 +43,7 @@ import Unison.Referent qualified as Referent import Unison.Runtime.IOSource qualified as IOSource import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.HashQualified' qualified as HQ' (toText) -import Unison.Syntax.Name qualified as Name (fromText, nameP, toText) +import Unison.Syntax.Name qualified as Name (parseText, nameP, toText) import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as Pretty @@ -340,8 +340,8 @@ instance Aeson.ToJSON CompletionItemDetails where instance Aeson.FromJSON CompletionItemDetails where parseJSON = Aeson.withObject "CompletionItemDetails" \obj -> do dep <- ((obj Aeson..: "dep") >>= ldParser) - relativeName <- (obj Aeson..: "relativeName" >>= maybe (fail "Invalid name in CompletionItemDetails") pure . Name.fromText) - fullyQualifiedName <- (obj Aeson..: "fullyQualifiedName" >>= maybe (fail "Invalid name in CompletionItemDetails") pure . Name.fromText) + relativeName <- (obj Aeson..: "relativeName" >>= maybe (fail "Invalid name in CompletionItemDetails") pure . Name.parseText) + fullyQualifiedName <- (obj Aeson..: "fullyQualifiedName" >>= maybe (fail "Invalid name in CompletionItemDetails") pure . Name.parseText) fileUri <- obj Aeson..: "fileUri" pure $ CompletionItemDetails {..} where diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 66f2d48fa1..614427aaf8 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -458,7 +458,7 @@ mkTypeSignatureHints parsedFile typecheckedFile = do & Zip.zip symbolsWithoutTypeSigs & imapMaybe ( \v (ann, (_ann, ref, _wk, _trm, typ)) -> do - name <- Name.fromText (Var.name v) + name <- Name.parseText (Var.name v) range <- annToRange ann let newRangeEnd = range ^. LSPTypes.start diff --git a/unison-cli/src/Unison/LSP/Hover.hs b/unison-cli/src/Unison/LSP/Hover.hs index 120161d232..aa6e6b7cf3 100644 --- a/unison-cli/src/Unison/LSP/Hover.hs +++ b/unison-cli/src/Unison/LSP/Hover.hs @@ -94,7 +94,7 @@ hoverInfo uri pos = LD.TypeReference (Reference.Builtin {}) -> do pure (symAtCursor <> " : ") LD.TypeReference ref@(Reference.DerivedId refId) -> do - nameAtCursor <- MaybeT . pure $ Name.fromText symAtCursor + nameAtCursor <- MaybeT . pure $ Name.parseText symAtCursor decl <- LSPQ.getTypeDeclaration uri refId let typ = Text.pack . Pretty.toPlain prettyWidth . Pretty.syntaxToColor $ DeclPrinter.prettyDecl pped ref (HQ.NameOnly nameAtCursor) decl pure typ diff --git a/unison-cli/unison/ArgParse.hs b/unison-cli/unison/ArgParse.hs index 43def809b8..0e2bc891cc 100644 --- a/unison-cli/unison/ArgParse.hs +++ b/unison-cli/unison/ArgParse.hs @@ -4,9 +4,6 @@ -- See the excellent documentation at https://hackage.haskell.org/package/optparse-applicative module ArgParse where -import Control.Applicative (Alternative (many, (<|>)), Applicative (liftA2), optional) -import Data.Foldable (Foldable (fold)) -import Data.Functor ((<&>)) import Data.List qualified as List import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE @@ -53,17 +50,17 @@ import Options.Applicative.Help (bold, (<+>)) import Options.Applicative.Help.Pretty qualified as P import Stats import System.Environment (lookupEnv) -import Text.Read (readMaybe) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.CommandLine.Types (ShouldWatchFiles (..)) +import Unison.Prelude import Unison.PrettyTerminal qualified as PT import Unison.Server.CodebaseServer (CodebaseServerOpts (..)) import Unison.Server.CodebaseServer qualified as Server import Unison.Util.Pretty (Width (..)) -- The name of a symbol to execute. -type SymbolName = String +type SymbolName = Text -- | Valid ways to provide source code to the run command data RunSource diff --git a/unison-core/src/Unison/Name/Internal.hs b/unison-core/src/Unison/Name/Internal.hs index 04f62ffee3..fcd855001e 100644 --- a/unison-core/src/Unison/Name/Internal.hs +++ b/unison-core/src/Unison/Name/Internal.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} + -- | The private Unison.Name innards. Prefer importing Unison.Name instead, unless you need the data constructor of -- Name. module Unison.Name.Internal @@ -11,6 +14,8 @@ import Control.Lens as Lens import Data.List.NonEmpty (pattern (:|)) import Data.List.NonEmpty qualified as List (NonEmpty) import Data.List.NonEmpty qualified as List.NonEmpty +import GHC.TypeLits (TypeError) +import GHC.TypeLits qualified as TypeError (ErrorMessage (Text)) import Unison.NameSegment (NameSegment) import Unison.Position (Position (..)) import Unison.Prelude @@ -42,6 +47,15 @@ instance Alphabetical Name where (False, True) -> GT _ -> compareAlphabetical (segments n1) (segments n2) +instance + TypeError + ( 'TypeError.Text + "You cannot make a Name from a string literal because there may (some day) be more than one syntax" + ) => + IsString Name + where + fromString = undefined + instance Ord Name where compare (Name p0 ss0) (Name p1 ss1) = compare ss0 ss1 <> compare p0 p1 diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 0226c91d33..2592ad965f 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -168,9 +168,9 @@ import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.HashQualified' qualified as HQ' (toText) -import Unison.Syntax.Name as Name (toText, unsafeFromText) +import Unison.Syntax.Name as Name (toText, unsafeParseText) import Unison.Syntax.NamePrinter qualified as NP -import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText, unsafeFromText) +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText, unsafeParseText) import Unison.Syntax.TermPrinter qualified as TermPrinter import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Term (Term) @@ -349,7 +349,7 @@ fuzzyFind printNames query = -- Prefer shorter FQNs rank (alignment, name, _) = - ( Name.countSegments (Name.unsafeFromText name), + ( Name.countSegments (Name.unsafeParseText name), negate (FZF.score alignment) ) @@ -764,7 +764,7 @@ mkTypeDefinition codebase pped namesRoot rootCausal width r docs tp = do liftIO $ Codebase.runTransaction codebase do causalAtPath <- Codebase.getShallowCausalAtPath namesRoot (Just rootCausal) branchAtPath <- V2Causal.value causalAtPath - typeEntryTag <$> typeListEntry codebase (Just branchAtPath) (ExactName (NameSegment.unsafeFromText bn) r) + typeEntryTag <$> typeListEntry codebase (Just branchAtPath) (ExactName (NameSegment.unsafeParseText bn) r) pure $ TypeDefinition (HQ'.toText <$> PPE.allTypeNames fqnPPE r) @@ -798,7 +798,7 @@ mkTermDefinition codebase termPPED namesRoot rootCausal width r docs tm = do tag <- lift ( termEntryTag - <$> termListEntry codebase (Just branchAtPath) (ExactName (NameSegment.unsafeFromText bn) (Cv.referent1to2 referent)) + <$> termListEntry codebase (Just branchAtPath) (ExactName (NameSegment.unsafeParseText bn) (Cv.referent1to2 referent)) ) mk ts bn tag where diff --git a/unison-share-api/src/Unison/Server/Errors.hs b/unison-share-api/src/Unison/Server/Errors.hs index 665f6645d3..28e2e555f6 100644 --- a/unison-share-api/src/Unison/Server/Errors.hs +++ b/unison-share-api/src/Unison/Server/Errors.hs @@ -28,7 +28,7 @@ import Unison.Server.Types mungeString, ) import Unison.ShortHash qualified as SH -import Unison.Syntax.HashQualified qualified as HQ (toString) +import Unison.Syntax.HashQualified qualified as HQ (toText) badHQN :: HashQualifiedName -> ServerError badHQN hqn = @@ -108,7 +108,7 @@ noSuchDefinition :: HQ.HashQualified Name -> ServerError noSuchDefinition hqName = err404 { errBody = - "Couldn't find a definition for " <> BSC.pack (HQ.toString hqName) + "Couldn't find a definition for " <> LazyByteString.fromStrict (Text.encodeUtf8 (HQ.toText hqName)) } ambiguousHashForDefinition :: SH.ShortHash -> ServerError diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs index 3b25dae977..5cc218b7eb 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs @@ -40,7 +40,7 @@ instance ToSample Current where Current (Just $ UnsafeProjectName "@unison/base") (Just $ UnsafeProjectBranchName "main") - (Path.Absolute $ Path.fromText ".__projects._53393e4b_1f61_467c_a488_b6068c727daa.branches._f0aec0e3_249f_4004_b836_572fea3981c1") + (Path.Absolute $ Path.unsafeParseText ".__projects._53393e4b_1f61_467c_a488_b6068c727daa.branches._f0aec0e3_249f_4004_b836_572fea3981c1") ) ] diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs index 85d0f5d762..13f8322eb9 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs @@ -182,10 +182,10 @@ serveFuzzyFind codebase mayRoot relativeTo limit typeWidth query = do $ Backend.termEntryToNamedTerm ppe typeWidth te ) ) - <$> Backend.termListEntry codebase relativeToBranch (ExactName (NameSegment.unsafeFromText n) (Cv.referent1to2 r)) + <$> Backend.termListEntry codebase relativeToBranch (ExactName (NameSegment.unsafeParseText n) (Cv.referent1to2 r)) Backend.FoundTypeRef r -> Codebase.runTransaction codebase do - te <- Backend.typeListEntry codebase relativeToBranch (ExactName (NameSegment.unsafeFromText n) r) + te <- Backend.typeListEntry codebase relativeToBranch (ExactName (NameSegment.unsafeParseText n) r) let namedType = Backend.typeEntryToNamedType te let typeName = Backend.bestNameForType @Symbol ppe (mayDefaultWidth typeWidth) r typeHeader <- Backend.typeDeclHeader codebase ppe r diff --git a/unison-share-api/src/Unison/Server/Orphans.hs b/unison-share-api/src/Unison/Server/Orphans.hs index 22e9f09fb4..7acf081b0e 100644 --- a/unison-share-api/src/Unison/Server/Orphans.hs +++ b/unison-share-api/src/Unison/Server/Orphans.hs @@ -36,9 +36,9 @@ import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH -import Unison.Syntax.HashQualified qualified as HQ (fromText) -import Unison.Syntax.HashQualified' qualified as HQ' (fromText) -import Unison.Syntax.Name qualified as Name (fromTextEither, toText) +import Unison.Syntax.HashQualified qualified as HQ (parseText) +import Unison.Syntax.HashQualified' qualified as HQ' (parseText) +import Unison.Syntax.Name qualified as Name (parseTextEither, toText) import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Util.Pretty (Width (..)) @@ -217,7 +217,7 @@ instance ToParam (QueryParam "name" Name) where Normal instance FromHttpApiData Name where - parseQueryParam = Name.fromTextEither + parseQueryParam = Name.parseTextEither deriving via Int instance FromHttpApiData Width @@ -316,22 +316,22 @@ instance ToJSON (HQ'.HashQualified NameSegment) where instance FromJSON (HQ'.HashQualified Name) where parseJSON = Aeson.withText "HashQualified'" \txt -> - maybe (fail "Invalid HashQualified' Name") pure $ HQ'.fromText txt + maybe (fail "Invalid HashQualified' Name") pure $ HQ'.parseText txt instance FromJSON (HQ.HashQualified Name) where parseJSON = Aeson.withText "HashQualified" \txt -> - maybe (fail "Invalid HashQualified Name") pure $ HQ.fromText txt + maybe (fail "Invalid HashQualified Name") pure $ HQ.parseText txt instance FromJSON (HQ'.HashQualified NameSegment) where parseJSON = Aeson.withText "HashQualified'" \txt -> do - hqName <- maybe (fail "Invalid HashQualified' NameSegment") pure $ HQ'.fromText txt + hqName <- maybe (fail "Invalid HashQualified' NameSegment") pure $ HQ'.parseText txt for hqName \name -> case Name.segments name of (ns :| []) -> pure ns _ -> fail $ "Expected a single name segment but received several: " <> Text.unpack txt instance FromJSON (HQ.HashQualified NameSegment) where parseJSON = Aeson.withText "HashQualified" \txt -> do - hqName <- maybe (fail "Invalid HashQualified' NameSegment") pure $ HQ.fromText txt + hqName <- maybe (fail "Invalid HashQualified' NameSegment") pure $ HQ.parseText txt for hqName \name -> case Name.segments name of (ns :| []) -> pure ns _ -> fail $ "Expected a single name segment but received several: " <> Text.unpack txt @@ -339,13 +339,13 @@ instance FromJSON (HQ.HashQualified NameSegment) where instance FromHttpApiData (HQ.HashQualified Name) where parseQueryParam txt = Text.replace "@" "#" txt - & HQ.fromText + & HQ.parseText & maybe (Left "Invalid Hash Qualified Name. Expected one of the following forms: name@hash, name, @hash") Right instance FromHttpApiData (HQ'.HashQualified Name) where parseQueryParam txt = Text.replace "@" "#" txt - & HQ'.fromText + & HQ'.parseText & maybe (Left "Invalid Hash Qualified Name. Expected one of the following forms: name@hash, name") Right instance ToParamSchema (HQ.HashQualified n) where diff --git a/unison-share-api/src/Unison/Server/Syntax.hs b/unison-share-api/src/Unison/Server/Syntax.hs index 74efcef19d..728b550e34 100644 --- a/unison-share-api/src/Unison/Server/Syntax.hs +++ b/unison-share-api/src/Unison/Server/Syntax.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Duplicate of the Unison.Util.SyntaxText module, but we expect these to @@ -27,7 +22,7 @@ import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Syntax.HashQualified qualified as HashQualified (toText) -import Unison.Syntax.Name qualified as Name (unsafeFromText) +import Unison.Syntax.Name qualified as Name (unsafeParseText) import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Util.AnnotatedText ( AnnotatedText (..), @@ -321,7 +316,7 @@ segmentToHtml (Segment segmentText element) = content | Text.isInfixOf "->" sText = span_ [class_ "arrow"] $ L.toHtml sText - | isFQN = nameToHtml (Name.unsafeFromText sText) + | isFQN = nameToHtml (Name.unsafeParseText sText) | otherwise = L.toHtml sText in case ref of Just (r, refType) -> diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 88dce1f6c2..71da646101 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -49,7 +49,7 @@ import Unison.Server.Doc (Doc) import Unison.Server.Orphans () import Unison.Server.Syntax (SyntaxText) import Unison.ShortHash (ShortHash) -import Unison.Syntax.HashQualified qualified as HQ (fromText) +import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Util.Pretty (Width (..)) @@ -146,7 +146,7 @@ instance FromHttpApiData (ExactName Name ShortHash) where -- # is special in URLs, so we use @ for hash qualification instead; -- e.g. ".base.List.map@abc" -- e.g. ".base.Nat@@Nat" - case HQ.fromText (Text.replace "@" "#" txt) of + case HQ.parseText (Text.replace "@" "#" txt) of Nothing -> Left "Invalid absolute name with Hash" Just hq' -> case hq' of HQ.NameOnly _ -> Left "A name and hash are required, but only a name was provided" diff --git a/unison-share-api/src/Unison/Util/Find.hs b/unison-share-api/src/Unison/Util/Find.hs index 8aff26f7ba..22923d7b03 100644 --- a/unison-share-api/src/Unison/Util/Find.hs +++ b/unison-share-api/src/Unison/Util/Find.hs @@ -8,7 +8,6 @@ module Unison.Util.Find ) where -import Data.Char qualified as Char import Data.List qualified as List import Data.Text qualified as Text -- http://www.serpentine.com/blog/2007/02/27/a-haskell-regular-expression-tutorial/ @@ -27,7 +26,7 @@ import Unison.Referent qualified as Referent import Unison.Server.SearchResult (SearchResult) import Unison.Server.SearchResult qualified as SR import Unison.ShortHash qualified as SH -import Unison.Syntax.Name qualified as Name (toString) +import Unison.Syntax.Name qualified as Name (toText) import Unison.Syntax.NamePrinter (prettyHashQualified) import Unison.Util.Monoid (intercalateMap) import Unison.Util.Pretty qualified as P @@ -46,46 +45,46 @@ fuzzyFinder query items render = simpleFuzzyFinder :: forall a. - String -> + Text -> [a] -> - (a -> String) -> + (a -> Text) -> [(a, P.Pretty P.ColorText)] simpleFuzzyFinder query items render = - sortAndCleanup $ do + sortAndCleanup do a <- items let s = render a score <- toList (simpleFuzzyScore query s) - pure ((a, hi s), score) + pure ((a, hi (Text.unpack s)), score) where hi = highlightSimple query sortAndCleanup = List.map fst . List.sortOn snd -- highlights `query` if it is a prefix of `s`, or if it -- appears in the final segement of s (after the final `.`) -highlightSimple :: String -> String -> P.Pretty P.ColorText -highlightSimple "" = P.string -highlightSimple query = go +highlightSimple :: Text -> String -> P.Pretty P.ColorText +highlightSimple query + | Text.null query = P.string + | otherwise = go where go [] = mempty go s@(h : t) - | query `List.isPrefixOf` s = hiQuery <> go (drop len s) + | query `Text.isPrefixOf` (Text.pack s) = hiQuery <> go (drop len s) | otherwise = P.string [h] <> go t - len = length query - hiQuery = P.hiBlack (P.string query) + len = Text.length query + hiQuery = P.hiBlack (P.text query) -simpleFuzzyScore :: String -> String -> Maybe Int +simpleFuzzyScore :: Text -> Text -> Maybe Int simpleFuzzyScore query s - | query `List.isPrefixOf` s = Just (bonus s 2) - | query `List.isSuffixOf` s = Just (bonus s 1) - | query `List.isInfixOf` s = Just (bonus s 3) - | lowerquery `List.isInfixOf` lowers = Just (bonus s 4) + | query `Text.isPrefixOf` s = Just (bonus s 2) + | query `Text.isSuffixOf` s = Just (bonus s 1) + | query `Text.isInfixOf` s = Just (bonus s 3) + | lowerquery `Text.isInfixOf` lowers = Just (bonus s 4) | otherwise = Nothing where -- prefer relative names - bonus ('.' : _) n = n * 10 - bonus _ n = n - lowerquery = Char.toLower <$> query - lowers = Char.toLower <$> s + bonus s n = if Text.take 1 s == "." then n * 10 else n + lowerquery = Text.toLower query + lowers = Text.toLower s -- This logic was split out of fuzzyFinder because the `RE.MatchArray` has an -- `Ord` instance that helps us sort the fuzzy matches in a nice way. (see @@ -155,13 +154,13 @@ fuzzyFindInBranch :: [(SearchResult, P.Pretty P.ColorText)] fuzzyFindInBranch b hq = simpleFuzzyFinder - (Name.toString (HQ'.toName hq)) + (Name.toText (HQ'.toName hq)) (candidates b hq) ( \sr -> case HQ.toName (SR.name sr) of -- see invariant on `candidates` below. Nothing -> error "search result without name" - Just name -> Name.toString name + Just name -> Name.toText name ) getName :: SearchResult -> (SearchResult, P.Pretty P.ColorText) diff --git a/unison-syntax/src/Unison/Syntax/HashQualified'.hs b/unison-syntax/src/Unison/Syntax/HashQualified'.hs index d7aac9e0e6..56fb96304b 100644 --- a/unison-syntax/src/Unison/Syntax/HashQualified'.hs +++ b/unison-syntax/src/Unison/Syntax/HashQualified'.hs @@ -2,47 +2,62 @@ -- | Syntax-related combinators for HashQualified' (to/from string types). module Unison.Syntax.HashQualified' - ( fromString, - fromText, - unsafeFromText, - toString, + ( -- * String conversions + parseText, + unsafeParseText, toText, + + -- * Parsers + hashQualifiedP, ) where import Data.Text qualified as Text +import Text.Megaparsec (ParsecT) +import Text.Megaparsec qualified as P +import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.HashQualified' qualified as HQ' import Unison.Name (Name, Parse) import Unison.Name qualified as Name import Unison.Prelude hiding (fromString) -import Unison.Prelude qualified -import Unison.ShortHash qualified as SH -import Unison.Syntax.Name qualified as Name (toText, unsafeFromText) - -instance IsString (HQ'.HashQualified Name) where - fromString = unsafeFromText . Text.pack +import Unison.Syntax.Lexer.Token (Token) +import Unison.Syntax.Name qualified as Name (nameP, toText) +import Unison.Syntax.NameSegment qualified as NameSegment +import Unison.Syntax.ShortHash qualified as ShortHash (shortHashP) instance Parse Text (HQ'.HashQualified Name) where - parse = fromText + parse = parseText -fromString :: String -> Maybe (HQ'.HashQualified Name) -fromString = fromText . Text.pack +------------------------------------------------------------------------------------------------------------------------ +-- String conversions --- Parses possibly-hash-qualified into structured type. -fromText :: Text -> Maybe (HQ'.HashQualified Name) -fromText t = case Text.breakOn "#" t of - (name, "") -> Just $ HQ'.NameOnly (Name.unsafeFromText name) -- safe bc breakOn # - (name, hash) -> HQ'.HashQualified (Name.unsafeFromText name) <$> SH.fromText hash +parseText :: Text -> Maybe (HQ'.HashQualified Name) +parseText text = + eitherToMaybe (P.runParser parser "" (Text.unpack text)) + where + parser = + hashQualifiedP (P.withParsecT (fmap NameSegment.renderParseErr) Name.nameP) <* P.eof -unsafeFromText :: (HasCallStack) => Text -> HQ'.HashQualified Name -unsafeFromText txt = fromMaybe msg (fromText txt) +unsafeParseText :: (HasCallStack) => Text -> HQ'.HashQualified Name +unsafeParseText txt = fromMaybe msg (parseText txt) where msg = error ("HashQualified.unsafeFromText " <> show txt) -toString :: HQ'.HashQualified Name -> String -toString = - Text.unpack . toText - toText :: HQ'.HashQualified Name -> Text toText = HQ'.toTextWith Name.toText + +------------------------------------------------------------------------------------------------------------------------ +-- Hash-qualified parsers + +-- | A hash-qualified parser. +hashQualifiedP :: + Monad m => + ParsecT (Token Text) [Char] m name -> + ParsecT (Token Text) [Char] m (HQ'.HashQualified name) +hashQualifiedP nameP = + P.try do + name <- nameP + optional ShortHash.shortHashP <&> \case + Nothing -> HQ'.NameOnly name + Just hash -> HQ'.HashQualified name hash diff --git a/unison-syntax/src/Unison/Syntax/HashQualified.hs b/unison-syntax/src/Unison/Syntax/HashQualified.hs index 57da2e3f9a..22819e9685 100644 --- a/unison-syntax/src/Unison/Syntax/HashQualified.hs +++ b/unison-syntax/src/Unison/Syntax/HashQualified.hs @@ -2,67 +2,70 @@ -- | Syntax-related combinators for HashQualified (to/from string types). module Unison.Syntax.HashQualified - ( fromString, - fromText, - unsafeFromString, - unsafeFromText, - unsafeFromVar, - toString, + ( parseText, + unsafeParseText, toText, + unsafeFromVar, toVar, ) where import Data.Text qualified as Text +import Text.Megaparsec (ParsecT) +import Text.Megaparsec qualified as P +import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.HashQualified (HashQualified (..)) import Unison.HashQualified qualified as HashQualified +import Unison.HashQualified' qualified as HQ' import Unison.Name (Name, Parse) import Unison.Name qualified as Name import Unison.Prelude hiding (fromString) -import Unison.ShortHash qualified as SH -import Unison.Syntax.Name qualified as Name (fromText, toText) +import Unison.Syntax.HashQualified' qualified as HQ' +import Unison.Syntax.Lexer.Token (Token) +import Unison.Syntax.Name qualified as Name (nameP, toText) +import Unison.Syntax.NameSegment qualified as NameSegment +import Unison.Syntax.ShortHash qualified as ShortHash import Unison.Var (Var) import Unison.Var qualified as Var import Prelude hiding (take) instance Parse Text (HashQualified Name) where - parse = fromText - -fromString :: String -> Maybe (HashQualified Name) -fromString = fromText . Text.pack + parse = parseText --- Parses possibly-hash-qualified into structured type. --- Doesn't validate against base58 or the codebase. -fromText :: Text -> Maybe (HashQualified Name) -fromText t = case Text.breakOn "#" t of -- breakOn leaves the '#' on the RHS - ("", "") -> Nothing - (name, "") -> NameOnly <$> Name.fromText name - ("", hash) -> HashOnly <$> SH.fromText hash - (name, hash) -> HashQualified <$> Name.fromText name <*> SH.fromText hash - -unsafeFromString :: String -> HashQualified Name -unsafeFromString s = fromMaybe msg . fromString $ s +parseText :: Text -> Maybe (HashQualified Name) +parseText text = + eitherToMaybe (P.runParser parser "" (Text.unpack text)) where - msg = error $ "HashQualified.unsafeFromString " <> show s + parser = + hashQualifiedP (P.withParsecT (fmap NameSegment.renderParseErr) Name.nameP) <* P.eof --- Won't crash as long as SH.unsafeFromText doesn't crash on any input that --- starts with '#', which is true as of the time of this writing, but not great. -unsafeFromText :: Text -> HashQualified Name -unsafeFromText txt = fromMaybe msg . fromText $ txt +unsafeParseText :: Text -> HashQualified Name +unsafeParseText txt = fromMaybe msg . parseText $ txt where msg = error $ "HashQualified.unsafeFromText " <> show txt -unsafeFromVar :: (Var v) => v -> HashQualified Name -unsafeFromVar = unsafeFromText . Var.name - -toString :: HashQualified Name -> String -toString = - Text.unpack . toText - toText :: HashQualified Name -> Text toText = HashQualified.toTextWith Name.toText +unsafeFromVar :: (Var v) => v -> HashQualified Name +unsafeFromVar = + unsafeParseText . Var.name + toVar :: (Var v) => HashQualified Name -> v toVar = Var.named . toText + +------------------------------------------------------------------------------------------------------------------------ +-- Hash-qualified parsers + +-- | A hash-qualified parser. +hashQualifiedP :: + Monad m => + ParsecT (Token Text) [Char] m name -> + ParsecT (Token Text) [Char] m (HashQualified name) +hashQualifiedP nameP = + P.try do + optional ShortHash.shortHashP >>= \case + Nothing -> HQ'.toHQ <$> HQ'.hashQualifiedP nameP + Just hash -> pure (HashOnly hash) diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index d39e3af912..919fa5c645 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -8,8 +8,6 @@ module Unison.Syntax.Lexer Pos (..), Lexeme (..), lexer, - simpleWordyId, - simpleSymbolyId, line, column, escapeChars, @@ -49,9 +47,9 @@ import Unison.NameSegment (NameSegment) import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.ShortHash (ShortHash) -import Unison.Syntax.HashQualified' qualified as HQ' (toString) +import Unison.Syntax.HashQualified' qualified as HQ' (toText) import Unison.Syntax.Lexer.Token (Token (..), posP, tokenP) -import Unison.Syntax.Name qualified as Name (isSymboly, nameP, toText, unsafeFromString) +import Unison.Syntax.Name qualified as Name (isSymboly, nameP, toText, unsafeParseText) import Unison.Syntax.NameSegment (symbolyIdChar, wordyIdChar, wordyIdStartChar) import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr (..), wordyP) import Unison.Syntax.ReservedWords (delimiters, typeModifiers, typeOrAbility) @@ -290,7 +288,7 @@ lexer0' scope rem = | notLayout t1 && touches t1 t2 && isSigned num = t1 : Token - (SymbolyId (HQ'.fromName (Name.unsafeFromString (take 1 num)))) + (SymbolyId (HQ'.fromName (Name.unsafeParseText (Text.pack (take 1 num))))) (start t2) (inc $ start t2) : Token (Numeric (drop 1 num)) (inc $ start t2) (end t2) @@ -1129,14 +1127,6 @@ findClose :: [String] -> Layout -> Maybe (String, Int) findClose _ [] = Nothing findClose s ((h, _) : tl) = if h `elem` s then Just (h, 1) else fmap (1 +) <$> findClose s tl -simpleWordyId :: Name -> Lexeme -simpleWordyId name = - WordyId (HQ'.fromName name) - -simpleSymbolyId :: Name -> Lexeme -simpleSymbolyId name = - SymbolyId (HQ'.fromName name) - notLayout :: Token Lexeme -> Bool notLayout t = case payload t of Close -> False @@ -1324,8 +1314,8 @@ instance P.VisualStream [Token Lexeme] where case showEscapeChar c of Just c -> "?\\" ++ [c] Nothing -> '?' : [c] - pretty (WordyId n) = HQ'.toString n - pretty (SymbolyId n) = HQ'.toString n + pretty (WordyId n) = Text.unpack (HQ'.toText n) + pretty (SymbolyId n) = Text.unpack (HQ'.toText n) pretty (Blank s) = "_" ++ s pretty (Numeric n) = n pretty (Hash sh) = show sh diff --git a/unison-syntax/src/Unison/Syntax/Name.hs b/unison-syntax/src/Unison/Syntax/Name.hs index fa9928601b..28c63d0b0e 100644 --- a/unison-syntax/src/Unison/Syntax/Name.hs +++ b/unison-syntax/src/Unison/Syntax/Name.hs @@ -3,15 +3,13 @@ -- | Utilities related to the parsing and printing of names using the default syntax. module Unison.Syntax.Name ( -- * String conversions - unsafeFromString, - toString, - fromText, - fromTextEither, - unsafeFromText, + parseText, + parseTextEither, + unsafeParseText, toText, - unsafeFromVar, + unsafeParseVar, + parseVar, toVar, - fromVar, -- * Name parsers nameP, @@ -35,35 +33,50 @@ import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.Name qualified as Name (fromSegments, lastSegment, makeAbsolute) import Unison.Name.Internal (Name (Name)) import Unison.NameSegment (NameSegment) -import Unison.NameSegment qualified as NameSegment import Unison.Position (Position (..)) import Unison.Prelude import Unison.Syntax.Lexer.Token (Token) import Unison.Syntax.NameSegment (segmentStartChar) -import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr, isSymboly, renderParseErr, segmentP) +import Unison.Syntax.NameSegment qualified as NameSegment + ( ParseErr, + isSymboly, + renderParseErr, + segmentP, + toEscapedTextBuilder, + ) import Unison.Var (Var) import Unison.Var qualified as Var ------------------------------------------------------------------------------------------------------------------------ -- String conversions -instance IsString Name where - fromString = - unsafeFromString +-- | Parse a name from a string literal. +parseText :: Text -> Maybe Name +parseText = + eitherToMaybe . parseTextEither --- | Convert a name to a string representation. -toString :: Name -> String -toString = - Text.unpack . toText +-- | Parse a name from a string literal. +parseTextEither :: Text -> Either Text Name +parseTextEither s = + P.runParser (P.withParsecT (fmap NameSegment.renderParseErr) nameP <* P.eof) "" (Text.unpack s) + & mapLeft (Text.pack . P.errorBundlePretty) + +-- | Unsafely parse a name from a string literal. +-- +-- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes +-- no attempt at rejecting bogus names like "foo...bar...baz". +unsafeParseText :: (HasCallStack) => Text -> Name +unsafeParseText = + either (error . Text.unpack) id . parseTextEither -- | Convert a name to a string representation. toText :: Name -> Text toText (Name pos (x0 :| xs)) = - build (buildPos pos <> foldr step mempty xs <> NameSegment.toTextBuilder x0) + build (buildPos pos <> foldr step mempty xs <> NameSegment.toEscapedTextBuilder x0) where step :: NameSegment -> Text.Builder -> Text.Builder step x acc = - acc <> NameSegment.toTextBuilder x <> "." + acc <> NameSegment.toEscapedTextBuilder x <> "." build :: Text.Builder -> Text build = @@ -74,56 +87,28 @@ toText (Name pos (x0 :| xs)) = Absolute -> "." Relative -> "" --- | Convert a name to a string representation, then parse that as a var. -toVar :: (Var v) => Name -> v -toVar = - Var.named . toText - -- | Parse a name from a var, by first rendering the var as a string. -fromVar :: Var v => v -> Maybe Name -fromVar = - fromText . Var.name - --- | Parse a name from a string literal. --- --- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes --- no attempt at rejecting bogus names like "foo...bar...baz". -fromText :: Text -> Maybe Name -fromText = - eitherToMaybe . fromTextEither - --- | Parse a name from a string literal. -fromTextEither :: Text -> Either Text Name -fromTextEither s = - P.runParser (P.withParsecT (fmap NameSegment.renderParseErr) nameP <* P.eof) "" (Text.unpack s) - & mapLeft (Text.pack . P.errorBundlePretty) - --- | Unsafely parse a name from a string literal. --- See 'unsafeFromText'. -unsafeFromString :: String -> Name -unsafeFromString = - unsafeFromText . Text.pack - --- | Unsafely parse a name from a string literal. --- --- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes --- no attempt at rejecting bogus names like "foo...bar...baz". -unsafeFromText :: (HasCallStack) => Text -> Name -unsafeFromText = - either (error . Text.unpack) id . fromTextEither +parseVar :: Var v => v -> Maybe Name +parseVar = + parseText . Var.name -- | Unsafely parse a name from a var, by first rendering the var as a string. -- -- See 'unsafeFromText'. -unsafeFromVar :: (Var v) => v -> Name -unsafeFromVar = - unsafeFromText . Var.name +unsafeParseVar :: (Var v) => v -> Name +unsafeParseVar = + unsafeParseText . Var.name + +-- | Convert a name to a string representation, then parse that as a var. +toVar :: (Var v) => Name -> v +toVar = + Var.named . toText ------------------------------------------------------------------------------------------------------------------------ -- Name parsers -- | A name parser. -nameP :: forall m. Monad m => ParsecT (Token NameSegment.ParseErr) [Char] m Name +nameP :: Monad m => ParsecT (Token NameSegment.ParseErr) [Char] m Name nameP = P.try do leadingDot <- isJust <$> P.optional (P.char '.') diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index ba42c4c09a..448978c4aa 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -2,8 +2,9 @@ module Unison.Syntax.NameSegment ( -- * String conversions toEscapedText, - fromText, - unsafeFromText, + toEscapedTextBuilder, + parseText, + unsafeParseText, -- * Name segment parsers isSymboly, @@ -35,6 +36,8 @@ import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Syntax.Lexer.Token (Token (..), posP) import Unison.Syntax.ReservedWords (keywords, reservedOperators) +import Data.Text.Lazy.Builder qualified as Text.Builder +import Data.Text.Lazy.Builder qualified as Text (Builder) ------------------------------------------------------------------------------------------------------------------------ -- String conversions @@ -47,21 +50,25 @@ toEscapedText segment@(NameSegment text) | isSymboly segment && not (Text.all symbolyIdChar text) = "`" <> text <> "`" | otherwise = text --- | Convert text to a name segment. +toEscapedTextBuilder :: NameSegment -> Text.Builder +toEscapedTextBuilder = + Text.Builder.fromText . toEscapedText + +-- | Parse text as a name segment. -- --- > fromText "foo" = Right (NameSegment "foo") --- > fromText ".~" = Left ... --- > fromText "`.~`" = Right (NameSegment ".~") -fromText :: Text -> Either Text NameSegment -fromText text = +-- > parseText "foo" = Right (NameSegment "foo") +-- > parseText ".~" = Left ... +-- > parseText "`.~`" = Right (NameSegment ".~") +parseText :: Text -> Either Text NameSegment +parseText text = case P.runParser (P.withParsecT (fmap renderParseErr) (segmentP <* P.eof)) "" (Text.unpack text) of Left err -> Left (Text.pack (P.errorBundlePretty err)) Right segment -> Right segment --- | Convert text to a name segment. -unsafeFromText :: Text -> NameSegment -unsafeFromText = - either (error . Text.unpack) id . fromText +-- | Parse text as a name segment. +unsafeParseText :: Text -> NameSegment +unsafeParseText = + either (error . Text.unpack) id . parseText ------------------------------------------------------------------------------------------------------------------------ -- Name segment parsers diff --git a/unison-syntax/src/Unison/Syntax/Parser.hs b/unison-syntax/src/Unison/Syntax/Parser.hs index a7b607aa10..6e0fd3e23f 100644 --- a/unison-syntax/src/Unison/Syntax/Parser.hs +++ b/unison-syntax/src/Unison/Syntax/Parser.hs @@ -83,7 +83,7 @@ import Unison.Prelude import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.Syntax.Lexer qualified as L -import Unison.Syntax.Name qualified as Name (toVar, unsafeFromString) +import Unison.Syntax.Name qualified as Name (toVar, unsafeParseText) import Unison.Term (MatchCase (..)) import Unison.UnisonFile.Error qualified as UF import Unison.Util.Bytes (Bytes) @@ -313,7 +313,7 @@ wordyDefinitionName = queryToken $ \case 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.unsafeFromString ("_" <> s) + L.Blank s | not (null s) -> Just $ Name.unsafeParseText (Text.pack ("_" <> s)) _ -> Nothing -- The `+` in: use Foo.bar + as a Name @@ -340,7 +340,7 @@ hqWordyId_ :: Ord v => P v m (L.Token (HQ.HashQualified Name)) hqWordyId_ = queryToken \case L.WordyId n -> Just $ HQ'.toHQ n L.Hash h -> Just $ HQ.HashOnly h - L.Blank s | not (null s) -> Just $ HQ.NameOnly (Name.unsafeFromString ("_" <> s)) + L.Blank s | not (null s) -> Just $ HQ.NameOnly (Name.unsafeParseText (Text.pack ("_" <> s))) _ -> Nothing -- Parse a hash-qualified symboly ID like >>=#foo or && diff --git a/unison-syntax/test/Main.hs b/unison-syntax/test/Main.hs index 198d15cbd0..50472b4151 100644 --- a/unison-syntax/test/Main.hs +++ b/unison-syntax/test/Main.hs @@ -10,8 +10,9 @@ import Unison.HashQualified' qualified as HQ' import Unison.Prelude import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as ShortHash +import Unison.Syntax.HashQualified' qualified as HQ' (unsafeParseText) import Unison.Syntax.Lexer -import Unison.Syntax.Name qualified as Name (unsafeFromString) +import Unison.Syntax.Name qualified as Name (unsafeParseText) main :: IO () main = @@ -92,8 +93,8 @@ test = t ".Foo.`++`.+" [simpleSymbolyId ".Foo.`++`.+"], t ".Foo.`+.+`.+" [simpleSymbolyId ".Foo.`+.+`.+"], -- idents with hashes - t "foo#bar" [WordyId (HQ'.HashQualified "foo" "#bar")], - t "+#bar" [SymbolyId (HQ'.HashQualified "+" "#bar")], + t "foo#bar" [simpleWordyId "foo#bar"], + t "+#bar" [simpleSymbolyId "+#bar"], -- note - these are all the same, just with different spacing let ex1 = "if x then y else z" ex2 = unlines ["if", " x", "then", " y", "else z"] @@ -201,7 +202,7 @@ test = suffix <- ["0", "x", "!", "'"] -- examples of wordyIdChar let i = kw ++ suffix -- a keyword at the front of an identifier should still be an identifier - pure $ t i [simpleWordyId (Name.unsafeFromString i)], + pure $ t i [simpleWordyId (Text.pack i)], -- Test string literals t "\"simple string without escape characters\"" @@ -226,5 +227,13 @@ t s expected = note $ "actual : " ++ show actual crash "actual != expected" +simpleSymbolyId :: Text -> Lexeme +simpleSymbolyId = + SymbolyId . HQ'.unsafeParseText + +simpleWordyId :: Text -> Lexeme +simpleWordyId = + WordyId . HQ'.unsafeParseText + instance IsString ShortHash where fromString = fromJust . ShortHash.fromText . Text.pack From fb3104d5937edae9e4f3d162a5f66179dae5fb63 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 1 Feb 2024 02:41:42 -0500 Subject: [PATCH 23/41] delete a couple unused imports --- unison-syntax/test/Main.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/unison-syntax/test/Main.hs b/unison-syntax/test/Main.hs index 50472b4151..e566b52609 100644 --- a/unison-syntax/test/Main.hs +++ b/unison-syntax/test/Main.hs @@ -6,13 +6,11 @@ import Data.Maybe (fromJust) import Data.Text qualified as Text import EasyTest import System.IO.CodePage (withCP65001) -import Unison.HashQualified' qualified as HQ' import Unison.Prelude import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as ShortHash import Unison.Syntax.HashQualified' qualified as HQ' (unsafeParseText) import Unison.Syntax.Lexer -import Unison.Syntax.Name qualified as Name (unsafeParseText) main :: IO () main = From 9799b4f479fbdd43054f941fd548174278d2b528 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 1 Feb 2024 13:48:51 -0500 Subject: [PATCH 24/41] fix and move Var.namespaced --- .../src/Unison/DataDeclaration/Dependencies.hs | 3 ++- .../src/Unison/Syntax/DeclParser.hs | 8 +++++--- .../src/Unison/Syntax/DeclPrinter.hs | 12 +++++------- .../src/Unison/Syntax/FileParser.hs | 6 ++++-- unison-core/src/Unison/DataDeclaration.hs | 11 +++++++---- unison-core/src/Unison/Var.hs | 14 +------------- unison-syntax/src/Unison/Syntax/Var.hs | 15 +++++++++++++++ unison-syntax/unison-syntax.cabal | 1 + 8 files changed, 40 insertions(+), 30 deletions(-) create mode 100644 unison-syntax/src/Unison/Syntax/Var.hs diff --git a/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs b/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs index 4eb6c67007..ae1864a79e 100644 --- a/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs +++ b/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs @@ -27,6 +27,7 @@ import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Result qualified as Result +import Unison.Syntax.Var qualified as Var (namespaced) import Unison.Term qualified as Term import Unison.Type qualified as Type import Unison.Typechecker qualified as Typechecker @@ -83,7 +84,7 @@ hashFieldAccessors :: ) hashFieldAccessors ppe declName vars declRef dd = do let accessors :: [(v, (), Term.Term v ())] - accessors = DD.generateRecordAccessors mempty (map (,()) vars) declName declRef + accessors = DD.generateRecordAccessors Var.namespaced mempty (map (,()) vars) declName declRef let typeLookup :: TypeLookup v () typeLookup = TypeLookup diff --git a/parser-typechecker/src/Unison/Syntax/DeclParser.hs b/parser-typechecker/src/Unison/Syntax/DeclParser.hs index 0408211a52..dfe3acb46f 100644 --- a/parser-typechecker/src/Unison/Syntax/DeclParser.hs +++ b/parser-typechecker/src/Unison/Syntax/DeclParser.hs @@ -5,6 +5,7 @@ where import Control.Lens import Control.Monad.Reader (MonadReader (..)) +import Data.List.NonEmpty (pattern (:|)) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Text.Megaparsec qualified as P @@ -19,10 +20,11 @@ import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar) import Unison.Syntax.Parser import Unison.Syntax.TermParser qualified as TermParser import Unison.Syntax.TypeParser qualified as TypeParser +import Unison.Syntax.Var qualified as Var (namespaced) import Unison.Type (Type) import Unison.Type qualified as Type import Unison.Var (Var) -import Unison.Var qualified as Var +import Unison.Var qualified as Var (name, named) import Prelude hiding (readFile) -- The parsed form of record accessors, as in: @@ -162,7 +164,7 @@ dataDeclaration maybeUnresolvedModifier = do ctorAnn = ann ctorName <> maybe (ann ctorName) ann (lastMay ctorArgs) in ( ctorAnn, ( ann ctorName, - Var.namespaced [L.payload name, L.payload ctorName], + Var.namespaced (L.payload name :| [L.payload ctorName]), Type.foralls ctorAnn typeArgVs ctorType ) ) @@ -263,7 +265,7 @@ effectDeclaration maybeUnresolvedModifier = do <$> TypeParser.computationType ) where - explodeToken v t = (ann v, Var.namespaced [L.payload name, L.payload v], t) + explodeToken v t = (ann v, Var.namespaced (L.payload name :| [L.payload v]), t) -- If the effect is not syntactically present in the constructor types, -- add them after parsing. ensureEffect t = case t of diff --git a/parser-typechecker/src/Unison/Syntax/DeclPrinter.hs b/parser-typechecker/src/Unison/Syntax/DeclPrinter.hs index 8ed391b44a..e7be294f25 100644 --- a/parser-typechecker/src/Unison/Syntax/DeclPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/DeclPrinter.hs @@ -1,15 +1,12 @@ module Unison.Syntax.DeclPrinter (prettyDecl, prettyDeclW, prettyDeclHeader, prettyDeclOrBuiltinHeader, AccessorName) where import Control.Monad.Writer (Writer, runWriter, tell) +import Data.List.NonEmpty (pattern (:|)) import Data.Map qualified as Map import Data.Text qualified as Text import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.ConstructorType qualified as CT -import Unison.DataDeclaration - ( DataDeclaration, - EffectDeclaration, - toDataDecl, - ) +import Unison.DataDeclaration (DataDeclaration, EffectDeclaration, toDataDecl) import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.Dependencies qualified as DD import Unison.HashQualified qualified as HQ @@ -25,12 +22,13 @@ import Unison.Syntax.HashQualified qualified as HQ (toText, toVar, unsafeParseTe import Unison.Syntax.NamePrinter (styleHashQualified'') import Unison.Syntax.TypePrinter (runPretty) import Unison.Syntax.TypePrinter qualified as TypePrinter +import Unison.Syntax.Var qualified as Var (namespaced) import Unison.Type qualified as Type import Unison.Util.Pretty (Pretty) import Unison.Util.Pretty qualified as P import Unison.Util.SyntaxText qualified as S import Unison.Var (Var) -import Unison.Var qualified as Var +import Unison.Var qualified as Var (freshenId, name, named) type SyntaxText = S.SyntaxText' Reference @@ -199,7 +197,7 @@ fieldNames env r name dd = do Just [ HQ.unsafeParseText name | v <- vars, - Just (ref, _, _) <- [Map.lookup (Var.namespaced [HQ.toVar name, v]) hashes], + Just (ref, _, _) <- [Map.lookup (Var.namespaced (HQ.toVar name :| [v])) hashes], Just name <- [Map.lookup ref fieldNames] ] else Nothing diff --git a/parser-typechecker/src/Unison/Syntax/FileParser.hs b/parser-typechecker/src/Unison/Syntax/FileParser.hs index 58b44d18ac..19fbbe25a1 100644 --- a/parser-typechecker/src/Unison/Syntax/FileParser.hs +++ b/parser-typechecker/src/Unison/Syntax/FileParser.hs @@ -2,6 +2,7 @@ module Unison.Syntax.FileParser where import Control.Lens import Control.Monad.Reader (asks, local) +import Data.List.NonEmpty (pattern (:|)) import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text @@ -21,6 +22,7 @@ import Unison.Syntax.Lexer qualified as L import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar) import Unison.Syntax.Parser import Unison.Syntax.TermParser qualified as TermParser +import Unison.Syntax.Var qualified as Var (namespaced) import Unison.Term (Term) import Unison.Term qualified as Term import Unison.UnisonFile (UnisonFile (..)) @@ -49,7 +51,7 @@ file = do Left es -> resolutionFailures (toList es) let accessors :: [[(v, Ann, Term v Ann)]] accessors = - [ DD.generateRecordAccessors Ann.GeneratedFrom (toPair <$> fields) (L.payload typ) r + [ DD.generateRecordAccessors Var.namespaced Ann.GeneratedFrom (toPair <$> fields) (L.payload typ) r | (typ, fields) <- parsedAccessors, Just (r, _) <- [Map.lookup (L.payload typ) (UF.datas env)] ] @@ -215,7 +217,7 @@ stanza = watchExpression <|> unexpectedAction <|> binding binding@((_, v), _) <- TermParser.binding pure $ case doc of Nothing -> Binding binding - Just (spanAnn, doc) -> Bindings [((spanAnn, Var.joinDot v (Var.named "doc")), doc), binding] + Just (spanAnn, doc) -> Bindings [((spanAnn, Var.namespaced (v :| [Var.named "doc"])), doc), binding] watched :: (Monad m, Var v) => P v m (UF.WatchKind, Text, Ann) watched = P.try do diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index bfeb0b1d84..88c9afd85d 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -39,6 +39,8 @@ where import Control.Lens (Iso', Lens', imap, iso, lens, over, _3) import Control.Monad.State (evalState) +import Data.List.NonEmpty (pattern (:|)) +import Data.List.NonEmpty qualified as List (NonEmpty) import Data.Map qualified as Map import Data.Set qualified as Set import Unison.ABT qualified as ABT @@ -147,19 +149,20 @@ withEffectDeclM f = fmap EffectDeclaration . f . toDataDecl -- propose to move this code to some very feature-specific module —AI generateRecordAccessors :: (Semigroup a, Var v) => + (List.NonEmpty v -> v) -> (a -> a) -> [(v, a)] -> v -> Reference -> [(v, a, Term v a)] -generateRecordAccessors generatedAnn fields typename typ = +generateRecordAccessors namespaced generatedAnn fields typename typ = join [tm t i | (t, i) <- fields `zip` [(0 :: Int) ..]] where argname = Var.uncapitalize typename tm (fname, fieldAnn) i = - [ (Var.namespaced [typename, fname], ann, get), - (Var.namespaced [typename, fname, Var.named "set"], ann, set), - (Var.namespaced [typename, fname, Var.named "modify"], ann, modify) + [ (namespaced (typename :| [fname]), ann, get), + (namespaced (typename :| [fname, Var.named "set"]), ann, set), + (namespaced (typename :| [fname, Var.named "modify"]), ann, modify) ] where ann = generatedAnn fieldAnn diff --git a/unison-core/src/Unison/Var.hs b/unison-core/src/Unison/Var.hs index e5c45090dc..a78b6638e2 100644 --- a/unison-core/src/Unison/Var.hs +++ b/unison-core/src/Unison/Var.hs @@ -16,13 +16,11 @@ module Unison.Var inferTypeConstructor, inferTypeConstructorArg, isAction, - joinDot, missingResult, name, nameStr, named, nameds, - namespaced, rawName, reset, uncapitalize, @@ -32,13 +30,12 @@ module Unison.Var ) where -import Data.Char (isLower, toLower, isAlphaNum) +import Data.Char (isAlphaNum, isLower, toLower) import Data.Text (pack) import Data.Text qualified as Text import Unison.ABT qualified as ABT import Unison.Prelude import Unison.Reference qualified as Reference -import Unison.Util.Monoid (intercalateMap) import Unison.WatchKind (WatchKind, pattern TestWatch) -- | A class for variables. Variables may have auxiliary information which @@ -194,21 +191,12 @@ data InferenceType reset :: (Var v) => v -> v reset v = typed (typeOf v) -namespaced :: (Var v) => [v] -> v -namespaced vs = named $ intercalateMap "." name vs - nameStr :: (Var v) => v -> String nameStr = Text.unpack . name nameds :: (Var v) => String -> v nameds s = named (Text.pack s) -joinDot :: (Var v) => v -> v -> v -joinDot prefix v2 = - if name prefix == "." - then named (name prefix `mappend` name v2) - else named (name prefix `mappend` "." `mappend` name v2) - universallyQuantifyIfFree :: forall v. (Var v) => v -> Bool universallyQuantifyIfFree v = Text.all isLower (Text.take 1 n) && Text.all isAlphaNum n diff --git a/unison-syntax/src/Unison/Syntax/Var.hs b/unison-syntax/src/Unison/Syntax/Var.hs new file mode 100644 index 0000000000..9fbc934d29 --- /dev/null +++ b/unison-syntax/src/Unison/Syntax/Var.hs @@ -0,0 +1,15 @@ +module Unison.Syntax.Var + ( namespaced, + ) +where + +import Data.List.NonEmpty (pattern (:|)) +import Data.List.NonEmpty qualified as List (NonEmpty) +import Unison.Name qualified as Name +import Unison.Prelude +import Unison.Syntax.Name qualified as Name +import Unison.Var (Var) + +namespaced :: (Var v) => List.NonEmpty v -> v +namespaced (v :| vs) = + Name.toVar (foldl' Name.joinDot (Name.unsafeParseVar v) (map Name.unsafeParseVar vs)) diff --git a/unison-syntax/unison-syntax.cabal b/unison-syntax/unison-syntax.cabal index 48f5d0dd24..1060586e5a 100644 --- a/unison-syntax/unison-syntax.cabal +++ b/unison-syntax/unison-syntax.cabal @@ -28,6 +28,7 @@ library Unison.Syntax.Parser Unison.Syntax.ReservedWords Unison.Syntax.ShortHash + Unison.Syntax.Var Unison.UnisonFile.Error hs-source-dirs: src From 17f7067e554c97b10cb296be44785ebc741167e4 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 2 Feb 2024 04:50:03 -0500 Subject: [PATCH 25/41] lexer fix --- unison-syntax/src/Unison/Syntax/Lexer.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 2f860ab6a6..386f56b06d 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/unison-syntax/src/Unison/Syntax/Lexer.hs @@ -881,7 +881,10 @@ lexemes' eof = <|> layoutKeywords where keywords = - symbolyKw "." + -- yes "wordy" - just like a wordy keyword like "true", the literal "." (as in the dot in + -- "forall a. a -> a") is considered the keyword "." so long as it is either followed by EOF, a space, or some + -- non-wordy character (because ".foo" is a single identifier lexeme) + wordyKw "." <|> symbolyKw ":" <|> openKw "@rewrite" <|> symbolyKw "@" From 3f3860fba3d2cb620cbbe006d0ac1d24531be239 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 2 Feb 2024 11:43:00 -0500 Subject: [PATCH 26/41] bugfix: term printer put too many use statements --- parser-typechecker/src/Unison/Syntax/TermPrinter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index 740a159bf2..e913671e47 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -1389,7 +1389,7 @@ calcImports im tm = (im', render $ getUses result) |> filter ( \s -> let (p, i) = lookupOrDie s m - in (i > 1 || isRight (Name.parseTextEither s)) && not (null p) + in (i > 1 || either (const False) Name.isSymboly (Name.parseTextEither s)) && not (null p) ) |> map (\s -> (s, lookupOrDie s m)) |> Map.fromList From 609c47b0bf3ace729330f6c1461f81c9d66beea0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 2 Feb 2024 11:55:35 -0500 Subject: [PATCH 27/41] bugfix: Path.toText rendered an empty path as ".", not "" --- parser-typechecker/src/Unison/Codebase/Path.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index e033cd8ae8..1eab32cff3 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -350,10 +350,8 @@ instance Show Path where -- | Note: This treats the path as relative. toText :: Path -> Text -toText path = - case toName path of - Nothing -> "." - Just name -> Name.toText name +toText = + maybe Text.empty Name.toText . toName unsafeParseText :: Text -> Path unsafeParseText = \case From 34cc9c820a5b13fe86c2546316508b10fd16b455 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 3 Feb 2024 00:06:07 -0500 Subject: [PATCH 28/41] fix "." parsing in term parser --- parser-typechecker/src/Unison/Syntax/TermParser.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/parser-typechecker/src/Unison/Syntax/TermParser.hs b/parser-typechecker/src/Unison/Syntax/TermParser.hs index 36f399207c..45280037ef 100644 --- a/parser-typechecker/src/Unison/Syntax/TermParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TermParser.hs @@ -105,7 +105,7 @@ rewriteBlock = do rewriteCase = rewriteTermlike "case" DD.rewriteCase rewriteType = do kw <- quasikeyword "signature" - vs <- P.try (some prefixDefinitionName <* symbolyQuasikeyword ".") <|> pure [] + vs <- P.try (some prefixDefinitionName <* reserved ".") <|> pure [] lhs <- TypeParser.computationType rhs <- openBlockWith "==>" *> TypeParser.computationType <* closeBlock pure (DD.rewriteType (ann kw <> ann rhs) (L.payload <$> vs) lhs rhs) @@ -412,11 +412,6 @@ quasikeyword kw = queryToken \case L.WordyId (HQ'.NameOnly n) | nameIsKeyword n kw -> Just () _ -> Nothing -symbolyQuasikeyword :: (Ord v) => Text -> P v m (L.Token ()) -symbolyQuasikeyword kw = queryToken \case - L.SymbolyId (HQ'.NameOnly n) | nameIsKeyword n kw -> Just () - _ -> Nothing - nameIsKeyword :: Name -> Text -> Bool nameIsKeyword name keyword = case (Name.isRelative name, Name.reverseSegments name) of From fd74c51100af4d5161f799b2616cadeb7eb2d7c9 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 20 Feb 2024 13:17:55 -0500 Subject: [PATCH 29/41] commit transcript diff that fixes forall display bug --- unison-src/transcripts-manual/rewrites.output.md | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/unison-src/transcripts-manual/rewrites.output.md b/unison-src/transcripts-manual/rewrites.output.md index c0cd55be75..a4764c7735 100644 --- a/unison-src/transcripts-manual/rewrites.output.md +++ b/unison-src/transcripts-manual/rewrites.output.md @@ -123,12 +123,11 @@ After adding to the codebase, here's the rewritten source: ex1 = List.map Nat.increment [1, 2, 3, 4, 5, 6, 7] rule1 : - ∀ i g o g1. - (i ->{g} o) - -> Nat - -> Rewrites - ( RewriteTerm Nat Nat, - RewriteTerm (i ->{g, g1} o) (i ->{g} o)) + (i ->{g} o) + -> Nat + -> Rewrites + ( RewriteTerm Nat Nat, + RewriteTerm (i ->{g, g1} o) (i ->{g} o)) rule1 f x = use Nat + @rewrite From 08ae88c681d2db6b9cea9dec71f64295704eb579 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 20 Feb 2024 17:00:18 -0500 Subject: [PATCH 30/41] fix ancient bug in the local ui that reared its head at last --- .../src/Unison/CommandLine/Completion.hs | 4 +- .../src/Unison/CommandLine/OutputMessages.hs | 4 +- unison-share-api/src/Unison/Server/Backend.hs | 87 ++++++------------- .../src/Unison/Server/Local/Definitions.hs | 4 +- .../Server/Local/Endpoints/FuzzyFind.hs | 50 +++++------ unison-share-api/src/Unison/Server/Types.hs | 11 ++- 6 files changed, 59 insertions(+), 101 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index e58ef39c50..83d3eb52b3 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -368,10 +368,10 @@ shareCompletion completionTypes authHTTPClient str = let name = Server.namespaceName nn in (NamespaceCompletion, name) Server.TermObject nt -> - let name = HQ'.toTextWith NameSegment.toEscapedText $ Server.termName nt + let name = HQ'.toTextWith Name.toText $ Server.termName nt in (NamespaceCompletion, name) Server.TypeObject nt -> - let name = HQ'.toTextWith NameSegment.toEscapedText $ Server.typeName nt + let name = HQ'.toTextWith Name.toText $ Server.typeName nt in (TermCompletion, name) Server.PatchObject np -> let name = Server.patchName np diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 4efc72cfae..e0e3783238 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1075,11 +1075,11 @@ notifyUser dir = \case formatEntry :: (Var v) => PPE.PrettyPrintEnv -> ShallowListEntry v a -> (Pretty, Pretty) formatEntry ppe = \case ShallowTermEntry termEntry -> - ( P.syntaxToColor . prettyHashQualified' . fmap Name.fromSegment . Backend.termEntryHQName $ termEntry, + ( P.syntaxToColor . prettyHashQualified' . Backend.termEntryHQName $ termEntry, P.lit "(" <> maybe "type missing" (TypePrinter.pretty ppe) (Backend.termEntryType termEntry) <> P.lit ")" ) ShallowTypeEntry typeEntry -> - ( P.syntaxToColor . prettyHashQualified' . fmap Name.fromSegment . Backend.typeEntryHQName $ typeEntry, + ( P.syntaxToColor . prettyHashQualified' . Backend.typeEntryHQName $ typeEntry, isBuiltin (typeEntryReference typeEntry) ) ShallowBranchEntry ns _ (NamespaceStats {numContainedTerms, numContainedTypes}) -> diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 2592ad965f..07a7eeefbc 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -170,7 +170,7 @@ import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.HashQualified' qualified as HQ' (toText) import Unison.Syntax.Name as Name (toText, unsafeParseText) import Unison.Syntax.NamePrinter qualified as NP -import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText, unsafeParseText) +import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Syntax.TermPrinter qualified as TermPrinter import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Term (Term) @@ -269,7 +269,7 @@ loadReferentType codebase = \case data TermEntry v a = TermEntry { termEntryReferent :: V2Referent.Referent, termEntryHash :: ShortHash, - termEntryName :: NameSegment, + termEntryName :: Name, termEntryConflicted :: Bool, termEntryType :: Maybe (Type v a), termEntryTag :: TermTag @@ -288,9 +288,9 @@ termEntryLabeledDependencies TermEntry {termEntryType, termEntryReferent, termEn _ -> error "termEntryLabeledDependencies: not a constructor, but one was required" termEntryDisplayName :: TermEntry v a -> Text -termEntryDisplayName = HQ'.toTextWith NameSegment.toEscapedText . termEntryHQName +termEntryDisplayName = HQ'.toTextWith Name.toText . termEntryHQName -termEntryHQName :: TermEntry v a -> HQ'.HashQualified NameSegment +termEntryHQName :: TermEntry v a -> HQ'.HashQualified Name termEntryHQName TermEntry {termEntryName, termEntryConflicted, termEntryHash} = if termEntryConflicted then HQ'.HashQualified termEntryName termEntryHash @@ -299,7 +299,7 @@ termEntryHQName TermEntry {termEntryName, termEntryConflicted, termEntryHash} = data TypeEntry = TypeEntry { typeEntryReference :: Reference, typeEntryHash :: ShortHash, - typeEntryName :: NameSegment, + typeEntryName :: Name, typeEntryConflicted :: Bool, typeEntryTag :: TypeTag } @@ -310,9 +310,9 @@ typeEntryLabeledDependencies TypeEntry {typeEntryReference} = Set.singleton (LD.TypeReference typeEntryReference) typeEntryDisplayName :: TypeEntry -> Text -typeEntryDisplayName = HQ'.toTextWith NameSegment.toEscapedText . typeEntryHQName +typeEntryDisplayName = HQ'.toTextWith Name.toText . typeEntryHQName -typeEntryHQName :: TypeEntry -> HQ'.HashQualified NameSegment +typeEntryHQName :: TypeEntry -> HQ'.HashQualified Name typeEntryHQName TypeEntry {typeEntryName, typeEntryConflicted, typeEntryReference} = if typeEntryConflicted then HQ'.HashQualified typeEntryName (Reference.toShortHash typeEntryReference) @@ -422,12 +422,9 @@ resultListType = Type.app mempty (Type.list mempty) (Type.ref mempty Decls.testR termListEntry :: (MonadIO m) => Codebase m Symbol Ann -> - -- | Optional branch to check if the term is conflicted. - -- If omitted, all terms are just listed as not conflicted. - Maybe (V2Branch.Branch n) -> - ExactName NameSegment V2Referent.Referent -> + ExactName Name V2Referent.Referent -> m (TermEntry Symbol Ann) -termListEntry codebase mayBranch (ExactName nameSegment ref) = do +termListEntry codebase (ExactName name ref) = do ot <- Codebase.runTransaction codebase $ do v1Referent <- Cv.referent2to1 (Codebase.getDeclType codebase) ref ot <- loadReferentType codebase v1Referent @@ -436,21 +433,13 @@ termListEntry codebase mayBranch (ExactName nameSegment ref) = do pure $ TermEntry { termEntryReferent = ref, - termEntryName = nameSegment, + termEntryName = name, termEntryType = ot, termEntryTag = tag, - termEntryConflicted = isConflicted, + -- See typeEntryConflicted + termEntryConflicted = False, termEntryHash = Cv.referent2toshorthash1 Nothing ref } - where - isConflicted = case mayBranch of - Nothing -> False - Just branch -> - branch - & V2Branch.terms - & Map.lookup nameSegment - & maybe 0 Map.size - & (> 1) getTermTag :: (Var v, MonadIO m) => @@ -494,31 +483,21 @@ getTypeTag codebase r = do typeListEntry :: (Var v) => Codebase m v Ann -> - -- | Optional branch to check if the term is conflicted. - -- If omitted, all terms are just listed as not conflicted. - Maybe (V2Branch.Branch n) -> - ExactName NameSegment Reference -> + ExactName Name Reference -> Sqlite.Transaction TypeEntry -typeListEntry codebase mayBranch (ExactName nameSegment ref) = do +typeListEntry codebase (ExactName name ref) = do hashLength <- Codebase.hashLength tag <- getTypeTag codebase ref pure $ TypeEntry { typeEntryReference = ref, - typeEntryName = nameSegment, - typeEntryConflicted = isConflicted, + typeEntryName = name, + -- Mitchell says: at one point this was implemented incorrectly, but fixing it seemed like more trouble than it + -- was worth, because we don't really care about conflicted things anymore. Ditto for termEntryConflicted. + typeEntryConflicted = False, typeEntryTag = tag, typeEntryHash = SH.shortenTo hashLength $ Reference.toShortHash ref } - where - isConflicted = case mayBranch of - Nothing -> False - Just branch -> - branch - & V2Branch.types - & Map.lookup nameSegment - & maybe 0 Map.size - & (> 1) typeDeclHeader :: forall v m. @@ -580,13 +559,13 @@ lsBranch codebase b0 = do (ns, refs) <- Map.toList m r <- Map.keys refs pure (r, ns) - termEntries <- for (flattenRefs $ V2Branch.terms b0) $ \(r, ns) -> do - ShallowTermEntry <$> termListEntry codebase (Just b0) (ExactName ns r) + termEntries <- for (flattenRefs $ V2Branch.terms b0) \(r, ns) -> do + ShallowTermEntry <$> termListEntry codebase (ExactName (Name.fromSegment ns) r) typeEntries <- Codebase.runTransaction codebase do for (flattenRefs $ V2Branch.types b0) \(r, ns) -> do let v1Ref = Cv.reference2to1 r - ShallowTypeEntry <$> typeListEntry codebase (Just b0) (ExactName ns v1Ref) + ShallowTypeEntry <$> typeListEntry codebase (ExactName (Name.fromSegment ns) v1Ref) childrenWithStats <- Codebase.runTransaction codebase (V2Branch.childStats b0) let branchEntries :: [ShallowListEntry Symbol Ann] = do (ns, (h, stats)) <- Map.toList $ childrenWithStats @@ -749,8 +728,6 @@ mkTypeDefinition :: MonadIO m => Codebase IO Symbol Ann -> PPED.PrettyPrintEnvDecl -> - Path.Path -> - V2Branch.CausalBranch Sqlite.Transaction -> Width -> Reference -> [(HashQualifiedName, UnisonHash, Doc.Doc)] -> @@ -758,13 +735,11 @@ mkTypeDefinition :: (AnnotatedText (UST.Element Reference)) (AnnotatedText (UST.Element Reference)) -> m TypeDefinition -mkTypeDefinition codebase pped namesRoot rootCausal width r docs tp = do +mkTypeDefinition codebase pped width r docs tp = do let bn = bestNameForType @Symbol (PPED.suffixifiedPPE pped) width r tag <- liftIO $ Codebase.runTransaction codebase do - causalAtPath <- Codebase.getShallowCausalAtPath namesRoot (Just rootCausal) - branchAtPath <- V2Causal.value causalAtPath - typeEntryTag <$> typeListEntry codebase (Just branchAtPath) (ExactName (NameSegment.unsafeParseText bn) r) + typeEntryTag <$> typeListEntry codebase (ExactName (Name.unsafeParseText bn) r) pure $ TypeDefinition (HQ'.toText <$> PPE.allTypeNames fqnPPE r) @@ -778,8 +753,6 @@ mkTypeDefinition codebase pped namesRoot rootCausal width r docs tp = do mkTermDefinition :: Codebase IO Symbol Ann -> PPED.PrettyPrintEnvDecl -> - Path.Path -> - V2Branch.CausalBranch Sqlite.Transaction -> Width -> Reference -> [(HashQualifiedName, UnisonHash, Doc.Doc)] -> @@ -787,19 +760,11 @@ mkTermDefinition :: (AnnotatedText (UST.Element Reference)) (AnnotatedText (UST.Element Reference)) -> Backend IO TermDefinition -mkTermDefinition codebase termPPED namesRoot rootCausal width r docs tm = do +mkTermDefinition codebase termPPED width r docs tm = do let referent = Referent.Ref r - (ts, branchAtPath) <- liftIO $ Codebase.runTransaction codebase do - ts <- Codebase.getTypeOfTerm codebase r - causalAtPath <- Codebase.getShallowCausalAtPath namesRoot (Just rootCausal) - branchAtPath <- V2Causal.value causalAtPath - pure (ts, branchAtPath) + ts <- liftIO (Codebase.runTransaction codebase (Codebase.getTypeOfTerm codebase r)) let bn = bestNameForTerm @Symbol (PPED.suffixifiedPPE termPPED) width (Referent.Ref r) - tag <- - lift - ( termEntryTag - <$> termListEntry codebase (Just branchAtPath) (ExactName (NameSegment.unsafeParseText bn) (Cv.referent1to2 referent)) - ) + tag <- lift (termEntryTag <$> termListEntry codebase (ExactName (Name.unsafeParseText bn) (Cv.referent1to2 referent))) mk ts bn tag where fqnTermPPE = PPED.unsuffixifiedPPE termPPED diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index 3fb8ec86ba..248dc12e95 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -80,13 +80,13 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings ifor (typesToSyntax suffixifyBindings width pped types) \ref tp -> do let hqTypeName = PPE.typeNameOrHashOnly fqnPPE ref docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTypeName)) - mkTypeDefinition codebase pped namesRoot shallowRoot width ref docs tp + mkTypeDefinition codebase pped width ref docs tp termDefinitions <- ifor (termsToSyntax suffixifyBindings width pped terms) \reference trm -> do let referent = Referent.Ref reference let hqTermName = PPE.termNameOrHashOnly fqnPPE referent docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTermName)) - mkTermDefinition codebase pped namesRoot shallowRoot width reference docs trm + mkTermDefinition codebase pped width reference docs trm let renderedDisplayTerms = Map.mapKeys Reference.toText termDefinitions renderedDisplayTypes = Map.mapKeys Reference.toText typeDefinitions renderedMisses = fmap HQ.toText misses diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs index 13f8322eb9..b206623b6f 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs @@ -20,7 +20,6 @@ import Servant.Docs ) import Servant.OpenApi () import Text.FuzzyFind qualified as FZF -import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase @@ -43,8 +42,8 @@ import Unison.Server.Types mayDefaultWidth, ) import Unison.Symbol (Symbol) -import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.Pretty (Width) +import qualified Unison.Syntax.Name as Name type FuzzyFindAPI = "find" @@ -155,10 +154,6 @@ serveFuzzyFind codebase mayRoot relativeTo limit typeWidth query = do Backend.hoistBackend (Codebase.runTransaction codebase) do Backend.normaliseRootCausalHash mayRoot (localNamesOnly, ppe) <- Backend.namesAtPathFromRootBranchHash codebase (Just rootCausal) path - relativeToBranch <- do - (lift . Codebase.runTransaction codebase) do - relativeToCausal <- Codebase.getShallowCausalAtPath path (Just rootCausal) - V2Causal.value relativeToCausal let alignments :: ( [ ( FZF.Alignment, UnisonName, @@ -168,26 +163,25 @@ serveFuzzyFind codebase mayRoot relativeTo limit typeWidth query = do ) alignments = take (fromMaybe 10 limit) $ Backend.fuzzyFind localNamesOnly (fromMaybe "" query) - lift (join <$> traverse (loadEntry (Just relativeToBranch) (PPE.suffixifiedPPE ppe)) alignments) + lift (join <$> traverse (loadEntry (PPE.suffixifiedPPE ppe)) alignments) where - loadEntry relativeToBranch ppe (a, n, refs) = do - for refs $ - \case - Backend.FoundTermRef r -> - ( \te -> - ( a, - FoundTermResult - . FoundTerm - (Backend.bestNameForTerm @Symbol ppe (mayDefaultWidth typeWidth) r) - $ Backend.termEntryToNamedTerm ppe typeWidth te - ) - ) - <$> Backend.termListEntry codebase relativeToBranch (ExactName (NameSegment.unsafeParseText n) (Cv.referent1to2 r)) - Backend.FoundTypeRef r -> - Codebase.runTransaction codebase do - te <- Backend.typeListEntry codebase relativeToBranch (ExactName (NameSegment.unsafeParseText n) r) - let namedType = Backend.typeEntryToNamedType te - let typeName = Backend.bestNameForType @Symbol ppe (mayDefaultWidth typeWidth) r - typeHeader <- Backend.typeDeclHeader codebase ppe r - let ft = FoundType typeName typeHeader namedType - pure (a, FoundTypeResult ft) + loadEntry ppe (a, n, refs) = do + for refs \case + Backend.FoundTermRef r -> + ( \te -> + ( a, + FoundTermResult + . FoundTerm + (Backend.bestNameForTerm @Symbol ppe (mayDefaultWidth typeWidth) r) + $ Backend.termEntryToNamedTerm ppe typeWidth te + ) + ) + <$> Backend.termListEntry codebase (ExactName (Name.unsafeParseText n) (Cv.referent1to2 r)) + Backend.FoundTypeRef r -> + Codebase.runTransaction codebase do + te <- Backend.typeListEntry codebase (ExactName (Name.unsafeParseText n) r) + let namedType = Backend.typeEntryToNamedType te + let typeName = Backend.bestNameForType @Symbol ppe (mayDefaultWidth typeWidth) r + typeHeader <- Backend.typeDeclHeader codebase ppe r + let ft = FoundType typeName typeHeader namedType + pure (a, FoundTypeResult ft) diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 71da646101..e130cdbc23 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -42,7 +42,6 @@ import Unison.Hash qualified as Hash import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) -import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) import Unison.Server.Doc (Doc) @@ -50,7 +49,7 @@ import Unison.Server.Orphans () import Unison.Server.Syntax (SyntaxText) import Unison.ShortHash (ShortHash) import Unison.Syntax.HashQualified qualified as HQ (parseText) -import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) +import Unison.Syntax.Name qualified as Name import Unison.Util.Pretty (Width (..)) type APIHeaders x = @@ -246,7 +245,7 @@ unisonRefToText = \case data NamedTerm = NamedTerm { -- The name of the term, should be hash qualified if conflicted, otherwise name only. - termName :: HQ'.HashQualified NameSegment, + termName :: HQ'.HashQualified Name, termHash :: ShortHash, termType :: Maybe SyntaxText, termTag :: TermTag @@ -256,7 +255,7 @@ data NamedTerm = NamedTerm instance ToJSON NamedTerm where toJSON (NamedTerm n h typ tag) = Aeson.object - [ "termName" .= HQ'.toTextWith NameSegment.toEscapedText n, + [ "termName" .= HQ'.toTextWith Name.toText n, "termHash" .= h, "termType" .= typ, "termTag" .= tag @@ -273,7 +272,7 @@ instance FromJSON NamedTerm where deriving instance ToSchema NamedTerm data NamedType = NamedType - { typeName :: HQ'.HashQualified NameSegment, + { typeName :: HQ'.HashQualified Name, typeHash :: ShortHash, typeTag :: TypeTag } @@ -282,7 +281,7 @@ data NamedType = NamedType instance ToJSON NamedType where toJSON (NamedType n h tag) = Aeson.object - [ "typeName" .= HQ'.toTextWith NameSegment.toEscapedText n, + [ "typeName" .= HQ'.toTextWith Name.toText n, "typeHash" .= h, "typeTag" .= tag ] From 64757efa3edea3cf6b0581de17cc99de04cf4803 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 21 Feb 2024 13:30:30 -0500 Subject: [PATCH 31/41] fix another old-bug-rearing-head situation --- .../src/Unison/Codebase/Editor/HandleInput.hs | 33 ++++++++++--------- .../src/Unison/Syntax/HashQualified.hs | 11 ++++++- 2 files changed, 28 insertions(+), 16 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 9421eec832..e5aad457d8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -32,6 +32,7 @@ import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileEx import System.Exit (ExitCode (..)) import System.FilePath (()) import System.Process (callProcess, readCreateProcessWithExitCode, shell) +import Text.Megaparsec qualified as Megaparsec import U.Codebase.Branch.Diff qualified as V2Branch.Diff import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) @@ -178,8 +179,9 @@ import Unison.Share.Codeserver qualified as Codeserver import Unison.ShortHash qualified as SH import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) -import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeParseText, parseText) +import Unison.Syntax.HashQualified qualified as HQ (parseText, parseTextWith, toText, unsafeParseText) import Unison.Syntax.Lexer qualified as L +import Unison.Syntax.Lexer qualified as Lexer import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar) import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) import Unison.Syntax.Parser qualified as Parser @@ -1496,7 +1498,13 @@ handleFindI isVerbose fscope ws input = do -- name query qs -> do - let srs = searchBranchScored names fuzzyNameDistance (map (HQ.unsafeParseText . Text.pack) qs) + 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 searchResultToHQString results @@ -1828,11 +1836,6 @@ searchResultToHQString = \case SR.Tp' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify n (Referent.Ref r) _ -> error "impossible match failure" --- Return a list of definitions whose names fuzzy match the given queries. -fuzzyNameDistance :: Name -> Name -> Maybe Int -fuzzyNameDistance (Name.toText -> q) (Name.toText -> n) = - Find.simpleFuzzyScore q n - -- return `name` and `name....` _searchBranchPrefix :: Branch m -> Name -> [SearchResult] _searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of @@ -1867,8 +1870,8 @@ searchBranchScored :: forall score. (Ord score) => Names -> - (Name -> Name -> Maybe score) -> - [HQ.HashQualified Name] -> + (Text -> Text -> Maybe score) -> + [HQ.HashQualified Text] -> [SearchResult] searchBranchScored names0 score queries = nubOrd @@ -1878,9 +1881,9 @@ searchBranchScored names0 score queries = where searchTermNamespace = queries >>= do1query where - do1query :: HQ.HashQualified Name -> [(Maybe score, SearchResult)] + do1query :: HQ.HashQualified Text -> [(Maybe score, SearchResult)] do1query q = mapMaybe (score1hq q) (R.toList . Names.terms $ names0) - score1hq :: HQ.HashQualified Name -> (Name, Referent) -> Maybe (Maybe score, SearchResult) + score1hq :: HQ.HashQualified Text -> (Name, Referent) -> Maybe (Maybe score, SearchResult) score1hq query (name, ref) = case query of HQ.NameOnly qn -> pair qn @@ -1894,12 +1897,12 @@ searchBranchScored names0 score queries = where result = SR.termSearchResult names0 name ref pair qn = - (\score -> (Just score, result)) <$> score qn name + (\score -> (Just score, result)) <$> score qn (Name.toText name) searchTypeNamespace = queries >>= do1query where - do1query :: HQ.HashQualified Name -> [(Maybe score, SearchResult)] + do1query :: HQ.HashQualified Text -> [(Maybe score, SearchResult)] do1query q = mapMaybe (score1hq q) (R.toList . Names.types $ names0) - score1hq :: HQ.HashQualified Name -> (Name, Reference) -> Maybe (Maybe score, SearchResult) + score1hq :: HQ.HashQualified Text -> (Name, Reference) -> Maybe (Maybe score, SearchResult) score1hq query (name, ref) = case query of HQ.NameOnly qn -> pair qn @@ -1913,7 +1916,7 @@ searchBranchScored names0 score queries = where result = SR.typeSearchResult names0 name ref pair qn = - (\score -> (Just score, result)) <$> score qn name + (\score -> (Just score, result)) <$> score qn (Name.toText name) compilerPath :: Path.Path' compilerPath = Path.Path' {Path.unPath' = Left abs} diff --git a/unison-syntax/src/Unison/Syntax/HashQualified.hs b/unison-syntax/src/Unison/Syntax/HashQualified.hs index 22819e9685..effbd3f0a1 100644 --- a/unison-syntax/src/Unison/Syntax/HashQualified.hs +++ b/unison-syntax/src/Unison/Syntax/HashQualified.hs @@ -2,11 +2,16 @@ -- | Syntax-related combinators for HashQualified (to/from string types). module Unison.Syntax.HashQualified - ( parseText, + ( -- * String conversions + parseText, + parseTextWith, unsafeParseText, toText, unsafeFromVar, toVar, + + -- * Parsers + hashQualifiedP, ) where @@ -39,6 +44,10 @@ parseText text = parser = hashQualifiedP (P.withParsecT (fmap NameSegment.renderParseErr) Name.nameP) <* P.eof +parseTextWith :: P.Parsec (Token Text) [Char] name -> Text -> Maybe (HashQualified name) +parseTextWith parser text = + eitherToMaybe (P.runParser (hashQualifiedP parser <* P.eof) "" (Text.unpack text)) + unsafeParseText :: Text -> HashQualified Name unsafeParseText txt = fromMaybe msg . parseText $ txt where From ed881583e71ca0472850a7a40d86474d517d9b61 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 21 Feb 2024 15:16:00 -0500 Subject: [PATCH 32/41] fix a few things, but oops completion is broken somehow --- .../src/Unison/CommandLine/Completion.hs | 11 +++--- unison-src/transcripts/fix1063.md | 4 +- unison-src/transcripts/fix1063.output.md | 12 +++--- unison-src/transcripts/fix2231.md | 6 +-- unison-src/transcripts/fix2231.output.md | 10 ++--- .../transcripts/tab-completion.output.md | 38 ++++++++----------- 6 files changed, 36 insertions(+), 45 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 83d3eb52b3..27e1cc5412 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -21,7 +21,6 @@ module Unison.CommandLine.Completion where import Control.Lens (ifoldMap) -import Control.Lens qualified as Lens import Control.Lens.Cons (unsnoc) import Data.Aeson qualified as Aeson import Data.List (isPrefixOf) @@ -52,7 +51,7 @@ import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.CommandLine.InputPattern qualified as IP import Unison.HashQualified' qualified as HQ' import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment) +import Unison.NameSegment (NameSegment (..)) import Unison.Prelude import Unison.Server.Local.Endpoints.NamespaceListing (NamespaceListing (NamespaceListing)) import Unison.Server.Local.Endpoints.NamespaceListing qualified as Server @@ -149,7 +148,8 @@ completeWithinNamespace compTypes query currentPath = do currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib - & fmap (\(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> NameSegment.unsafeParseText match)) + -- See Note [Naughty NameSegment] + & fmap (\(isFinished, match) -> (isFinished, Text.unpack (Path.toText' queryPathPrefix <> "." <> match))) & filter (\(_isFinished, match) -> List.isPrefixOf query match) & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) & pure @@ -179,9 +179,8 @@ completeWithinNamespace compTypes query currentPath = do childBranch <- V2Causal.value childCausal nib <- namesInBranch shortHashLen childBranch nib - & fmap - ( \(isFinished, match) -> (isFinished, Text.unpack . Path.toText' $ queryPathPrefix Lens.:> suffix Lens.:> NameSegment.unsafeParseText match) - ) + -- See Note [Naughty NameSegment] + & fmap (\(isFinished, match) -> (isFinished, Text.unpack (Path.toText' queryPathPrefix <> "." <> match))) & filter (\(_isFinished, match) -> List.isPrefixOf query match) & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) & pure diff --git a/unison-src/transcripts/fix1063.md b/unison-src/transcripts/fix1063.md index 4a876a6b13..a7160f3564 100644 --- a/unison-src/transcripts/fix1063.md +++ b/unison-src/transcripts/fix1063.md @@ -5,11 +5,11 @@ Tests that functions named `.` are rendered correctly. ``` ``` unison -(.) f g x = f (g x) +(`.`) f g x = f (g x) use Boolean not -noop = not . not +noop = not `.` not ``` ``` ucm diff --git a/unison-src/transcripts/fix1063.output.md b/unison-src/transcripts/fix1063.output.md index 22f1958d10..80a1cc8a26 100644 --- a/unison-src/transcripts/fix1063.output.md +++ b/unison-src/transcripts/fix1063.output.md @@ -1,11 +1,11 @@ Tests that functions named `.` are rendered correctly. ```unison -(.) f g x = f (g x) +(`.`) f g x = f (g x) use Boolean not -noop = not . not +noop = not `.` not ``` ```ucm @@ -18,8 +18,7 @@ noop = not . not ⍟ These new definitions are ok to `add`: - . : ∀ i1 g1 o i g. - (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o + `.` : (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o noop : Boolean -> Boolean ``` @@ -28,8 +27,7 @@ noop = not . not ⍟ I've added these definitions: - . : ∀ i1 g1 o i g. - (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o + `.` : (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o noop : Boolean -> Boolean .> view noop @@ -37,6 +35,6 @@ noop = not . not noop : Boolean -> Boolean noop = use Boolean not - not . not + not `.` not ``` diff --git a/unison-src/transcripts/fix2231.md b/unison-src/transcripts/fix2231.md index 2d217e1db7..0b1ed16419 100644 --- a/unison-src/transcripts/fix2231.md +++ b/unison-src/transcripts/fix2231.md @@ -11,10 +11,10 @@ strategies. ``` ```unison -(.) : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c -(.) f g x = f (g x) +(<<) : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c +(<<) f g x = f (g x) -f = atan . tan +f = atan << tan foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b foldl f a = cases diff --git a/unison-src/transcripts/fix2231.output.md b/unison-src/transcripts/fix2231.output.md index d8cda9b7f7..2ff24e5bcf 100644 --- a/unison-src/transcripts/fix2231.output.md +++ b/unison-src/transcripts/fix2231.output.md @@ -7,10 +7,10 @@ the choices may not work equally well with the type checking strategies. ```unison -(.) : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c -(.) f g x = f (g x) +(<<) : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c +(<<) f g x = f (g x) -f = atan . tan +f = atan << tan foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b foldl f a = cases @@ -30,7 +30,7 @@ txt = foldl (Text.++) "" ["a", "b", "c"] ⍟ These new definitions are ok to `add`: - . : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c + << : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c f : Float -> Float foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b txt : Text @@ -41,7 +41,7 @@ txt = foldl (Text.++) "" ["a", "b", "c"] ⍟ I've added these definitions: - . : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c + << : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c f : Float -> Float foldl : (b ->{e} a ->{e} b) -> b -> [a] ->{e} b txt : Text diff --git a/unison-src/transcripts/tab-completion.output.md b/unison-src/transcripts/tab-completion.output.md index 3719ca60f7..93454358d7 100644 --- a/unison-src/transcripts/tab-completion.output.md +++ b/unison-src/transcripts/tab-completion.output.md @@ -59,14 +59,15 @@ unique type subnamespace.AType = A | B -- Should tab complete namespaces since they may contain terms/types .> debug.tab-complete view sub - subnamespace. - subnamespace2. + -- Should not complete things from child namespaces of the current query if there are other completions at this level .> debug.tab-complete view subnamespace - subnamespace. - subnamespace2. + * subnamespace.AType + subnamespace.AType. + * subnamespace.someName + * subnamespace.someOtherName -- Should complete things from child namespaces of the current query if it's dot-suffixed .> debug.tab-complete view subnamespace. @@ -79,24 +80,21 @@ unique type subnamespace.AType = A | B -- Should complete things from child namespaces of the current query if there are no more completions at this level. .> debug.tab-complete view subnamespace2 - subnamespace2. * subnamespace2.thing -- Should prefix-filter by query suffix .> debug.tab-complete view subnamespace.some - * subnamespace.someName - * subnamespace.someOtherName + .> debug.tab-complete view subnamespace.someOther - * subnamespace.someOtherName + -- Should tab complete absolute names .othernamespace> debug.tab-complete view .subnamespace.some - * .subnamespace.someName - * .subnamespace.someOtherName + ``` ## Tab complete namespaces @@ -105,13 +103,11 @@ unique type subnamespace.AType = A | B -- Should tab complete namespaces .> debug.tab-complete cd sub - subnamespace - subnamespace2 + .> debug.tab-complete cd subnamespace - subnamespace - subnamespace2 + subnamespace.AType .> debug.tab-complete cd subnamespace. @@ -119,13 +115,13 @@ unique type subnamespace.AType = A | B .> debug.tab-complete io.test sub - subnamespace. - subnamespace2. + .> debug.tab-complete io.test subnamespace - subnamespace. - subnamespace2. + subnamespace.AType. + * subnamespace.someName + * subnamespace.someOtherName .> debug.tab-complete io.test subnamespace. @@ -166,12 +162,11 @@ add b = b .> debug.tab-complete delete.type Foo - * Foo - Foo. + .> debug.tab-complete delete.term add - * add + ``` ## Tab complete projects and branches @@ -238,6 +233,5 @@ myproject/main> add myproject/main> debug.tab-complete merge mybr /mybranch - mybranchsubnamespace ``` From 12a75f18b39653ba90557f08ec688b99d5fd8bcd Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 22 Feb 2024 10:55:13 -0500 Subject: [PATCH 33/41] partially fix tab-completion --- .../src/Unison/Codebase/Path/Parse.hs | 23 +++++++++++++++---- .../src/Unison/CommandLine/Completion.hs | 9 ++++---- .../transcripts/tab-completion.output.md | 21 ++++++++--------- 3 files changed, 32 insertions(+), 21 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs index f99d08df83..e5411d4ad3 100644 --- a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -9,6 +9,8 @@ module Unison.Codebase.Path.Parse parseShortHashOrHQSplit', -- * Path parsers + pathP, + pathP', splitP, splitP', ) @@ -17,6 +19,7 @@ where import Data.Text qualified as Text import Text.Megaparsec (Parsec) import Text.Megaparsec qualified as P +import Text.Megaparsec.Char qualified as P (char) import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.Codebase.Path import Unison.HashQualified' qualified as HQ' @@ -31,9 +34,8 @@ import Unison.Syntax.ShortHash qualified as ShortHash -- Path parsing functions parsePath :: String -> Either Text Path -parsePath = \case - "" -> Right empty - path -> unsplit <$> parseSplit path +parsePath = + runParser pathP parsePath' :: String -> Either Text Path' parsePath' = \case @@ -65,12 +67,23 @@ parseHQSplit' = runParser :: Parsec (Lexer.Token Text) [Char] a -> String -> Either Text a runParser p = - mapLeft (Text.pack . P.errorBundlePretty) - . P.runParser (p <* P.eof) "" + mapLeft (Text.pack . P.errorBundlePretty) . P.runParser (p <* P.eof) "" ------------------------------------------------------------------------------------------------------------------------ -- Path parsers +pathP :: Parsec (Lexer.Token Text) [Char] Path +pathP = + (unsplit <$> splitP) <|> pure empty + +pathP' :: Parsec (Lexer.Token Text) [Char] Path' +pathP' = + asum + [ unsplit' <$> splitP', + P.char '.' $> absoluteEmpty', + pure relativeEmpty' + ] + splitP :: Parsec (Lexer.Token Text) [Char] Split splitP = splitFromName <$> P.withParsecT (fmap NameSegment.renderParseErr) Name.relativeNameP diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 27e1cc5412..60f836a82d 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -148,7 +148,6 @@ completeWithinNamespace compTypes query currentPath = do currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib - -- See Note [Naughty NameSegment] & fmap (\(isFinished, match) -> (isFinished, Text.unpack (Path.toText' queryPathPrefix <> "." <> match))) & filter (\(_isFinished, match) -> List.isPrefixOf query match) & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) @@ -179,7 +178,6 @@ completeWithinNamespace compTypes query currentPath = do childBranch <- V2Causal.value childCausal nib <- namesInBranch shortHashLen childBranch nib - -- See Note [Naughty NameSegment] & fmap (\(isFinished, match) -> (isFinished, Text.unpack (Path.toText' queryPathPrefix <> "." <> match))) & filter (\(_isFinished, match) -> List.isPrefixOf query match) & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) @@ -250,8 +248,11 @@ completeWithinNamespace compTypes query currentPath = do parseLaxPath'Query :: Text -> (Path.Path', Text) parseLaxPath'Query txt = case P.runParser ((,) <$> Path.splitP' <*> P.takeRest) "" (Text.unpack txt) of - Left _err -> (Path.RelativePath' (Path.Relative Path.empty), txt) - Right (path, rest) -> (Path.unsplit' path, Text.pack rest) + Left _err -> (Path.relativeEmpty', txt) + Right ((path, segment), rest) -> + if take 1 rest == "." + then (Path.unsplit' (path, segment), Text.empty) + else (path, NameSegment.toEscapedText segment) -- | Completes a namespace argument by prefix-matching against the query. prefixCompleteNamespace :: diff --git a/unison-src/transcripts/tab-completion.output.md b/unison-src/transcripts/tab-completion.output.md index 93454358d7..71860d5fa5 100644 --- a/unison-src/transcripts/tab-completion.output.md +++ b/unison-src/transcripts/tab-completion.output.md @@ -64,10 +64,7 @@ unique type subnamespace.AType = A | B -- Should not complete things from child namespaces of the current query if there are other completions at this level .> debug.tab-complete view subnamespace - * subnamespace.AType - subnamespace.AType. - * subnamespace.someName - * subnamespace.someOtherName + -- Should complete things from child namespaces of the current query if it's dot-suffixed .> debug.tab-complete view subnamespace. @@ -80,21 +77,23 @@ unique type subnamespace.AType = A | B -- Should complete things from child namespaces of the current query if there are no more completions at this level. .> debug.tab-complete view subnamespace2 - * subnamespace2.thing + -- Should prefix-filter by query suffix .> debug.tab-complete view subnamespace.some - + * subnamespace.someName + * subnamespace.someOtherName .> debug.tab-complete view subnamespace.someOther - + * subnamespace.someOtherName -- Should tab complete absolute names .othernamespace> debug.tab-complete view .subnamespace.some - + * .subnamespace.someName + * .subnamespace.someOtherName ``` ## Tab complete namespaces @@ -107,7 +106,7 @@ unique type subnamespace.AType = A | B .> debug.tab-complete cd subnamespace - subnamespace.AType + .> debug.tab-complete cd subnamespace. @@ -119,9 +118,7 @@ unique type subnamespace.AType = A | B .> debug.tab-complete io.test subnamespace - subnamespace.AType. - * subnamespace.someName - * subnamespace.someOtherName + .> debug.tab-complete io.test subnamespace. From e31aba46203463780b0b23a1e43ea2b6637d163a Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 22 Feb 2024 13:18:26 -0500 Subject: [PATCH 34/41] fix tab completion --- .../src/Unison/CommandLine/Completion.hs | 41 +++++++++++++------ .../transcripts/tab-completion.output.md | 27 ++++++++---- 2 files changed, 47 insertions(+), 21 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 60f836a82d..a72ac3c923 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -21,6 +21,7 @@ module Unison.CommandLine.Completion where import Control.Lens (ifoldMap) +import Control.Lens qualified as Lens import Control.Lens.Cons (unsnoc) import Data.Aeson qualified as Aeson import Data.List (isPrefixOf) @@ -148,7 +149,12 @@ completeWithinNamespace compTypes query currentPath = do currentBranchSuggestions <- do nib <- namesInBranch shortHashLen b nib - & fmap (\(isFinished, match) -> (isFinished, Text.unpack (Path.toText' queryPathPrefix <> "." <> match))) + & fmap + ( \(ty, isFinished, match) -> + ( isFinished, + Text.unpack (dotifyNamespace ty (Path.toText' (queryPathPrefix Lens.:> NameSegment match))) + ) + ) & filter (\(_isFinished, match) -> List.isPrefixOf query match) & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) & pure @@ -178,11 +184,16 @@ completeWithinNamespace compTypes query currentPath = do childBranch <- V2Causal.value childCausal nib <- namesInBranch shortHashLen childBranch nib - & fmap (\(isFinished, match) -> (isFinished, Text.unpack (Path.toText' queryPathPrefix <> "." <> match))) + & fmap + ( \(ty, isFinished, match) -> + ( isFinished, + Text.unpack (dotifyNamespace ty (Path.toText' (queryPathPrefix Lens.:> suffix Lens.:> NameSegment match))) + ) + ) & filter (\(_isFinished, match) -> List.isPrefixOf query match) & fmap (\(isFinished, match) -> prettyCompletionWithQueryPrefix isFinished query match) & pure - namesInBranch :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [(Bool, Text)] + namesInBranch :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [(CompletionType, Bool, Text)] namesInBranch hashLen b = do nonEmptyChildren <- V2Branch.nonEmptyChildren b let textifyHQ :: (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [(Bool, Text)] @@ -192,10 +203,18 @@ completeWithinNamespace compTypes query currentPath = do & fmap (HQ'.toTextWith NameSegment.toEscapedText) & fmap (True,) pure $ - ((False,) <$> dotifyNamespaces (fmap NameSegment.toEscapedText . Map.keys $ nonEmptyChildren)) - <> Monoid.whenM (NESet.member TermCompletion compTypes) (textifyHQ (hqFromNamedV2Referent hashLen) $ V2Branch.terms b) - <> Monoid.whenM (NESet.member TypeCompletion compTypes) (textifyHQ (hqFromNamedV2Reference hashLen) $ V2Branch.types b) - <> Monoid.whenM (NESet.member PatchCompletion compTypes) (fmap ((True,) . NameSegment.toEscapedText) . Map.keys $ V2Branch.patches b) + concat + [ (NamespaceCompletion,False,) <$> (fmap NameSegment.toEscapedText . Map.keys $ nonEmptyChildren), + Monoid.whenM + (NESet.member TermCompletion compTypes) + (map (\(x, y) -> (TermCompletion, x, y)) (textifyHQ (hqFromNamedV2Referent hashLen) $ V2Branch.terms b)), + Monoid.whenM + (NESet.member TypeCompletion compTypes) + (map (\(x, y) -> (TypeCompletion, x, y)) (textifyHQ (hqFromNamedV2Reference hashLen) $ V2Branch.types b)), + Monoid.whenM + (NESet.member PatchCompletion compTypes) + (fmap ((PatchCompletion,True,) . NameSegment.toEscapedText) . Map.keys $ V2Branch.patches b) + ] -- Regrettably there'shqFromNamedV2Referencenot a great spot to combinators for V2 references and shorthashes right now. hqFromNamedV2Referent :: Int -> NameSegment -> Referent.Referent -> HQ'.HashQualified NameSegment @@ -214,11 +233,9 @@ completeWithinNamespace compTypes query currentPath = do -- If we're not completing namespaces, then all namespace completions should automatically -- drill-down by adding a trailing '.' - dotifyNamespaces :: [Text] -> [Text] - dotifyNamespaces namespaces = - if not (NESet.member NamespaceCompletion compTypes) - then fmap (<> ".") namespaces - else namespaces + dotifyNamespace :: CompletionType -> Text -> Text + dotifyNamespace NamespaceCompletion | not (NESet.member NamespaceCompletion compTypes) = (<> ".") + dotifyNamespace _ = id -- | A path parser which which is more lax with respect to well formed paths, -- specifically we can determine a valid path prefix with a (possibly empty) suffix query. diff --git a/unison-src/transcripts/tab-completion.output.md b/unison-src/transcripts/tab-completion.output.md index 71860d5fa5..3719ca60f7 100644 --- a/unison-src/transcripts/tab-completion.output.md +++ b/unison-src/transcripts/tab-completion.output.md @@ -59,12 +59,14 @@ unique type subnamespace.AType = A | B -- Should tab complete namespaces since they may contain terms/types .> debug.tab-complete view sub - + subnamespace. + subnamespace2. -- Should not complete things from child namespaces of the current query if there are other completions at this level .> debug.tab-complete view subnamespace - + subnamespace. + subnamespace2. -- Should complete things from child namespaces of the current query if it's dot-suffixed .> debug.tab-complete view subnamespace. @@ -77,7 +79,8 @@ unique type subnamespace.AType = A | B -- Should complete things from child namespaces of the current query if there are no more completions at this level. .> debug.tab-complete view subnamespace2 - + subnamespace2. + * subnamespace2.thing -- Should prefix-filter by query suffix .> debug.tab-complete view subnamespace.some @@ -102,11 +105,13 @@ unique type subnamespace.AType = A | B -- Should tab complete namespaces .> debug.tab-complete cd sub - + subnamespace + subnamespace2 .> debug.tab-complete cd subnamespace - + subnamespace + subnamespace2 .> debug.tab-complete cd subnamespace. @@ -114,11 +119,13 @@ unique type subnamespace.AType = A | B .> debug.tab-complete io.test sub - + subnamespace. + subnamespace2. .> debug.tab-complete io.test subnamespace - + subnamespace. + subnamespace2. .> debug.tab-complete io.test subnamespace. @@ -159,11 +166,12 @@ add b = b .> debug.tab-complete delete.type Foo - + * Foo + Foo. .> debug.tab-complete delete.term add - + * add ``` ## Tab complete projects and branches @@ -230,5 +238,6 @@ myproject/main> add myproject/main> debug.tab-complete merge mybr /mybranch + mybranchsubnamespace ``` From d34522e6a4b6bf4e53f571b8157c55afb49071ee Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 22 Feb 2024 14:12:03 -0500 Subject: [PATCH 35/41] allow () escaped in backticks --- unison-src/transcripts/unitnamespace.md | 6 +++--- unison-src/transcripts/unitnamespace.output.md | 8 ++++---- unison-syntax/src/Unison/Syntax/NameSegment.hs | 13 ++++++++----- 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/unison-src/transcripts/unitnamespace.md b/unison-src/transcripts/unitnamespace.md index 3fcee464f8..c6373ab141 100644 --- a/unison-src/transcripts/unitnamespace.md +++ b/unison-src/transcripts/unitnamespace.md @@ -3,7 +3,7 @@ foo = "bar" ``` ```ucm -.> cd () -.()> add -.> delete.namespace () +.> cd `()` +.`()`> add +.> delete.namespace `()` ``` diff --git a/unison-src/transcripts/unitnamespace.output.md b/unison-src/transcripts/unitnamespace.output.md index 2eed93f834..82beeed69d 100644 --- a/unison-src/transcripts/unitnamespace.output.md +++ b/unison-src/transcripts/unitnamespace.output.md @@ -16,17 +16,17 @@ foo = "bar" ``` ```ucm -.> cd () +.> cd `()` - ☝️ The namespace .() is empty. + ☝️ The namespace .`()` is empty. -.()> add +.`()`> add ⍟ I've added these definitions: foo : ##Text -.> delete.namespace () +.> delete.namespace `()` Done. diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index 448978c4aa..707f28166a 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -27,6 +27,8 @@ where import Data.Char qualified as Char import Data.Set qualified as Set import Data.Text qualified as Text +import Data.Text.Lazy.Builder qualified as Text (Builder) +import Data.Text.Lazy.Builder qualified as Text.Builder import Text.Megaparsec (ParsecT) import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P @@ -36,8 +38,6 @@ import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Syntax.Lexer.Token (Token (..), posP) import Unison.Syntax.ReservedWords (keywords, reservedOperators) -import Data.Text.Lazy.Builder qualified as Text.Builder -import Data.Text.Lazy.Builder qualified as Text (Builder) ------------------------------------------------------------------------------------------------------------------------ -- String conversions @@ -165,14 +165,17 @@ symbolyIdChar = -- | The set of characters allowed in an unescaped symboly identifier. symbolyIdChars :: Set Char -symbolyIdChars = Set.fromList "!$%^&*-=+<>~\\/|:" +symbolyIdChars = + Set.fromList "!$%^&*-=+<>~\\/|:" escapedSymbolyIdChar :: Char -> Bool -escapedSymbolyIdChar = (`Set.member` escapedSymbolyIdChars) +escapedSymbolyIdChar = + (`Set.member` escapedSymbolyIdChars) -- | The set of characters allowed in an escaped symboly identifier. escapedSymbolyIdChars :: Set Char -escapedSymbolyIdChars = Set.insert '.' symbolyIdChars +escapedSymbolyIdChars = + Set.fromList ".()" <> symbolyIdChars wordyIdStartChar :: Char -> Bool wordyIdStartChar ch = From 19070ce126e4c7d4e6223c8f81a9138e199bbf8d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 22 Feb 2024 14:50:59 -0500 Subject: [PATCH 36/41] regenerate all-base-hashes output --- .../all-base-hashes.output.md | 32 ++++++++----------- 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/unison-src/transcripts-using-base/all-base-hashes.output.md b/unison-src/transcripts-using-base/all-base-hashes.output.md index 3c027adfa9..726583129b 100644 --- a/unison-src/transcripts-using-base/all-base-hashes.output.md +++ b/unison-src/transcripts-using-base/all-base-hashes.output.md @@ -2539,25 +2539,22 @@ This transcript is intended to make visible accidental changes to the hashing al ->{IO} [(Link.Term, Code)] 729. -- #srpc2uag5p1grvshbcm3urjntakgi3g3dthfse2cp38sd6uestd5neseces5ue7kum2ca0gsg9i0cilkl0gn8dn3q5dn86v4r8lbha0 - compose : ∀ i1 g1 o i g. - (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o + compose : (i1 ->{g1} o) -> (i ->{g} i1) -> i ->{g1, g} o 730. -- #stnrk323b8mm7dknlonfl70epd9f9ede60iom7sgok31mmggnic7etgi0are2uccs9g429qo3ruaeb9tk90bh35obnce1038p5qe6co - compose2 : ∀ i2 g2 o i1 g1 i g. - (i2 ->{g2} o) - -> (i1 ->{g1} i ->{g} i2) - -> i1 - -> i - ->{g2, g1, g} o + compose2 : (i2 ->{g2} o) + -> (i1 ->{g1} i ->{g} i2) + -> i1 + -> i + ->{g2, g1, g} o 731. -- #mrc183aovjcae3i03r1a0ia26crmmkcf2e723pda860ps6q11rancsenjoqhc3fn0eraih1mobcvt245jr77l27uoujqa452utq8p68 - compose3 : ∀ i3 g3 o i2 g2 i1 g1 i g. - (i3 ->{g3} o) - -> (i2 ->{g2} i1 ->{g1} i ->{g} i3) - -> i2 - -> i1 - -> i - ->{g3, g2, g1, g} o + compose3 : (i3 ->{g3} o) + -> (i2 ->{g2} i1 ->{g1} i ->{g} i3) + -> i2 + -> i1 + -> i + ->{g3, g2, g1, g} o 732. -- #ilkeid6l866bmq90d2v1ilqp9dsjo6ucmf8udgrokq3nr3mo9skl2vao2mo7ish136as52rsf19u9v3jkmd85bl08gnmamo4e5v2fqo contains : Text -> Text -> Boolean @@ -2814,7 +2811,7 @@ This transcript is intended to make visible accidental changes to the hashing al setEcho : Handle -> Boolean ->{IO, Exception} () 808. -- #in06o7cfgnlmm6pvdtv0jv9hniahcli0fvh27o01ork1p77ro2v51rc05ts1h6p9mtffqld4ufs8klcc4bse1tsj93cu0na0bbiuqb0 - snd : ∀ a1 a. (a1, a) -> a + snd : (a1, a) -> a 809. -- #km3cpkvcnvcos0isfbnb7pb3s45ri5q42n74jmm9c4v1bcu8nlk63353u4ohfr7av4k00s4s180ddnqbam6a01thhlt2tie1hm5a9bo socketAccept : Socket ->{IO, Exception} Socket @@ -2874,8 +2871,7 @@ This transcript is intended to make visible accidental changes to the hashing al Throw.throw : e ->{Throw e} a 828. -- #f6pkvs6ukf8ngh2j8lm935p1bqadso76o7e3t0j1ukupjh1rg0m1rhtp7u492sq17p3bkbintbnjehc1cqs33qlhnfkoihf5uee4ug0 - uncurry : ∀ i1 g1 i g o. - (i1 ->{g1} i ->{g} o) -> (i1, i) ->{g1, g} o + uncurry : (i1 ->{g1} i ->{g} o) -> (i1, i) ->{g1, g} o 829. -- #u1o44hd0cdlfa8racf458sahdmgea409k8baajgc5k7bqukf2ak5ggs2ped0u3h85v99pgefgb9r7ct2dv4nn9eihjghnqf30p4l57g Value.transitiveDeps : Value ->{IO} [(Link.Term, Code)] From 5330261d0cee4e9c8671af9859de76e40eeeecff Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 22 Feb 2024 14:52:09 -0500 Subject: [PATCH 37/41] regenerate serial-test-00 output --- .../serial-test-00.output.md | 22 +++++++++---------- 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/unison-src/transcripts-using-base/serial-test-00.output.md b/unison-src/transcripts-using-base/serial-test-00.output.md index 937058f7ee..747131c145 100644 --- a/unison-src/transcripts-using-base/serial-test-00.output.md +++ b/unison-src/transcripts-using-base/serial-test-00.output.md @@ -82,12 +82,11 @@ mkTestCase = do -> (Tree Text -> Text) -> (Tree Nat, Tree Nat, Tree Nat, Tree Text) -> Text - foldMap : ∀ r g2 g1 a g. - r - -> (r ->{g2} r ->{g1} r) - -> (a ->{g} r) - -> Tree a - ->{g2, g1, g} r + foldMap : r + -> (r ->{g2} r ->{g1} r) + -> (a ->{g} r) + -> Tree a + ->{g2, g1, g} r mkTestCase : '{IO, Exception} () tree0 : Tree Nat tree1 : Tree Nat @@ -105,12 +104,11 @@ mkTestCase = do -> (Tree Text -> Text) -> (Tree Nat, Tree Nat, Tree Nat, Tree Text) -> Text - foldMap : ∀ r g2 g1 a g. - r - -> (r ->{g2} r ->{g1} r) - -> (a ->{g} r) - -> Tree a - ->{g2, g1, g} r + foldMap : r + -> (r ->{g2} r ->{g1} r) + -> (a ->{g} r) + -> Tree a + ->{g2, g1, g} r mkTestCase : '{IO, Exception} () tree0 : Tree Nat tree1 : Tree Nat From c61484112cb8f329772e4fb880a65b8d413c62d3 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 22 Feb 2024 14:53:17 -0500 Subject: [PATCH 38/41] make deleteReplacements transcript work --- unison-src/transcripts/deleteReplacements.md | 2 +- unison-src/transcripts/deleteReplacements.output.md | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-src/transcripts/deleteReplacements.md b/unison-src/transcripts/deleteReplacements.md index bc396df896..70ad9e6af7 100644 --- a/unison-src/transcripts/deleteReplacements.md +++ b/unison-src/transcripts/deleteReplacements.md @@ -67,7 +67,7 @@ unique[bb] type bar = Foo | Bar we get an error when attempting to delete something that is neither a type nor a term ```ucm:error .> view.patch -.> delete.type-replacement not-here +.> delete.type-replacement notHere .> view.patch ``` diff --git a/unison-src/transcripts/deleteReplacements.output.md b/unison-src/transcripts/deleteReplacements.output.md index 61383546b5..9908542f73 100644 --- a/unison-src/transcripts/deleteReplacements.output.md +++ b/unison-src/transcripts/deleteReplacements.output.md @@ -214,12 +214,12 @@ we get an error when attempting to delete something that is neither a type nor a This patch is empty. -.> delete.type-replacement not-here +.> delete.type-replacement notHere ⚠️ The following names were not found in the codebase. Check your spelling. - not-here + notHere .> view.patch From 5cb5469c1e3d2450919ab073257ad68afb2daa07 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 23 Feb 2024 14:23:32 -0500 Subject: [PATCH 39/41] allow reserved things between backticks --- unison-syntax/src/Unison/Syntax/Name.hs | 3 - .../src/Unison/Syntax/NameSegment.hs | 91 +++++++++++-------- 2 files changed, 52 insertions(+), 42 deletions(-) diff --git a/unison-syntax/src/Unison/Syntax/Name.hs b/unison-syntax/src/Unison/Syntax/Name.hs index 28c63d0b0e..17112b6b95 100644 --- a/unison-syntax/src/Unison/Syntax/Name.hs +++ b/unison-syntax/src/Unison/Syntax/Name.hs @@ -62,9 +62,6 @@ parseTextEither s = & mapLeft (Text.pack . P.errorBundlePretty) -- | Unsafely parse a name from a string literal. --- --- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes --- no attempt at rejecting bogus names like "foo...bar...baz". unsafeParseText :: (HasCallStack) => Text -> Name unsafeParseText = either (error . Text.unpack) id . parseTextEither diff --git a/unison-syntax/src/Unison/Syntax/NameSegment.hs b/unison-syntax/src/Unison/Syntax/NameSegment.hs index 707f28166a..2dc83709eb 100644 --- a/unison-syntax/src/Unison/Syntax/NameSegment.hs +++ b/unison-syntax/src/Unison/Syntax/NameSegment.hs @@ -47,8 +47,16 @@ import Unison.Syntax.ReservedWords (keywords, reservedOperators) -- > toEscapedText (unsafeFromText ".~") = "`.~`" toEscapedText :: NameSegment -> Text toEscapedText segment@(NameSegment text) - | isSymboly segment && not (Text.all symbolyIdChar text) = "`" <> text <> "`" + | shouldEscape = "`" <> text <> "`" | otherwise = text + where + shouldEscape = + if isSymboly segment + then isReservedOperator || symbolNeedsEscaping + else isKeyword + isKeyword = Set.member text keywords + isReservedOperator = Set.member text reservedOperators + symbolNeedsEscaping = not (Text.all symbolyIdChar text) toEscapedTextBuilder :: NameSegment -> Text.Builder toEscapedTextBuilder = @@ -90,61 +98,66 @@ segmentP = -- | A symboly name segment parser, which consists only of symboly characters. -- --- A symboly name segment can optionally be escaped by surrounding it with backticks. Thus, there are two different --- syntaxes for the ++ operator, for example: --- --- 1. ++ --- 2. `++` --- --- The only difference is that the literal dot character (.) is allowed in escaped segments, but not unescaped segments. --- Thus, there is only one syntax for the .~ operator: --- --- 1. `.~` +-- A symboly name segment can optionally be escaped by surrounding it with backticks, which expands the list of allowed +-- symbols to include these three: . ( ) -- --- The backticks of escaped symboly segments are not present in the data itself, i.e. the string "`.~`" corresponds --- to the data NameSegment ".~". --- --- Throws the parsed name segment as an error if it's reserved, e.g. "=". +-- Throws the parsed name segment as an error if it's unescaped and reserved, e.g. "=". symbolyP :: ParsecT (Token Text) [Char] m NameSegment symbolyP = do start <- posP - string <- escaped <|> unescaped - let text = Text.pack string - if Set.member text reservedOperators - then do - end <- posP - P.customFailure (Token text start end) - else pure (NameSegment text) + asum + [ do + _ <- P.try (P.lookAhead (P.char '`' *> P.satisfy escapedSymbolyIdChar)) + escapeP (segmentP (description escapedSymbolyIdChars) escapedSymbolyIdChar), + do + symbol <- segmentP (description symbolyIdChars) symbolyIdChar + check start symbol + pure symbol + ] where - unescaped = - P.takeWhile1P (Just (description symbolyIdChars)) symbolyIdChar + segmentP name predicate = + NameSegment . Text.pack <$> P.takeWhile1P (Just name) predicate - escaped = do - _ <- P.char '`' - s <- P.takeWhile1P (Just (description escapedSymbolyIdChars)) escapedSymbolyIdChar - _ <- P.char '`' - pure s + check start (NameSegment symbol) = + when (Set.member symbol reservedOperators) do + end <- posP + P.customFailure (Token symbol start end) description valid = "operator (valid characters: " ++ Set.toList valid ++ ")" -- | A wordy name segment parser, which consists only of wordy characters. -- --- Throws the parsed name segment as an error if it's a keyword, e.g. "match". +-- Throws the parsed name segment as an error if it's an unescaped keyword, e.g. "match". wordyP :: ParsecT (Token Text) [Char] m NameSegment wordyP = do start <- posP - ch <- P.satisfy wordyIdStartChar - rest <- P.takeWhileP (Just wordyMsg) wordyIdChar - let word = Text.pack (ch : rest) - if Set.member word keywords - then do - end <- posP - P.customFailure (Token word start end) - else pure (NameSegment word) + asum + [ do + _ <- P.try (P.lookAhead (P.char '`' *> P.satisfy wordyIdStartChar)) + escapeP unescaped, + do + word <- unescaped + check start word + pure word + ] where + unescaped = do + ch <- P.satisfy wordyIdStartChar + rest <- P.takeWhileP (Just wordyMsg) wordyIdChar + pure (NameSegment (Text.pack (ch : rest))) + + check start (NameSegment word) = + when (Set.member word keywords) do + end <- posP + P.customFailure (Token word start end) + wordyMsg = "identifier (ex: abba1, snake_case, .foo.bar#xyz, or 🌻)" +escapeP :: ParsecT (Token Text) [Char] m a -> ParsecT (Token Text) [Char] m a +escapeP parser = + P.char '`' *> parser <* P.char '`' + ------------------------------------------------------------------------------------------------------------------------ -- Character classifiers @@ -157,7 +170,7 @@ isSymboly = segmentStartChar :: Char -> Bool segmentStartChar c = - wordyIdStartChar c || symbolyIdChar c || c == '`' -- backtick starts an escaped symboly segment + wordyIdStartChar c || symbolyIdChar c || c == '`' -- backtick starts an escaped segment symbolyIdChar :: Char -> Bool symbolyIdChar = From 179e131e94b3bb8cf1ef0faba9923e6674c83e6e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 26 Feb 2024 10:01:48 -0500 Subject: [PATCH 40/41] add transcript --- unison-src/transcripts/name-segment-escape.md | 15 ++++++++ .../transcripts/name-segment-escape.output.md | 38 +++++++++++++++++++ 2 files changed, 53 insertions(+) create mode 100644 unison-src/transcripts/name-segment-escape.md create mode 100644 unison-src/transcripts/name-segment-escape.output.md diff --git a/unison-src/transcripts/name-segment-escape.md b/unison-src/transcripts/name-segment-escape.md new file mode 100644 index 0000000000..a782953188 --- /dev/null +++ b/unison-src/transcripts/name-segment-escape.md @@ -0,0 +1,15 @@ +You can use a keyword or reserved operator as a name segment if you surround it with backticks. + +```ucm:error +.> view `match` +.> view `=` +``` + +You can also use backticks to expand the set of valid symbols in a symboly name segment to include these three: `.()` + +This allows you to spell `.` or `()` as name segments (which historically have appeared in the namespace). + +```ucm:error +.> view `.` +.> view `()` +``` diff --git a/unison-src/transcripts/name-segment-escape.output.md b/unison-src/transcripts/name-segment-escape.output.md new file mode 100644 index 0000000000..7eef020774 --- /dev/null +++ b/unison-src/transcripts/name-segment-escape.output.md @@ -0,0 +1,38 @@ +You can use a keyword or reserved operator as a name segment if you surround it with backticks. + +```ucm +.> view `match` + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + `match` + +.> view `=` + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + `=` + +``` +You can also use backticks to expand the set of valid symbols in a symboly name segment to include these three: `.()` + +This allows you to spell `.` or `()` as name segments (which historically have appeared in the namespace). + +```ucm +.> view `.` + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + `.` + +.> view `()` + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + `()` + +``` From 581e2e105ae1f8b55dfc317fac5491d54bddc7b0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 26 Feb 2024 16:35:24 -0500 Subject: [PATCH 41/41] add transcript --- unison-src/transcripts/fix2970.md | 10 +++++++++ unison-src/transcripts/fix2970.output.md | 26 ++++++++++++++++++++++++ 2 files changed, 36 insertions(+) create mode 100644 unison-src/transcripts/fix2970.md create mode 100644 unison-src/transcripts/fix2970.output.md diff --git a/unison-src/transcripts/fix2970.md b/unison-src/transcripts/fix2970.md new file mode 100644 index 0000000000..d9a6a6b532 --- /dev/null +++ b/unison-src/transcripts/fix2970.md @@ -0,0 +1,10 @@ +Also fixes #1519 (it's the same issue). + +```ucm +.> builtins.merge +``` + +```unison +foo.+.doc : Nat +foo.+.doc = 10 +``` diff --git a/unison-src/transcripts/fix2970.output.md b/unison-src/transcripts/fix2970.output.md new file mode 100644 index 0000000000..904508e2cd --- /dev/null +++ b/unison-src/transcripts/fix2970.output.md @@ -0,0 +1,26 @@ +Also fixes #1519 (it's the same issue). + +```ucm +.> builtins.merge + + Done. + +``` +```unison +foo.+.doc : Nat +foo.+.doc = 10 +``` + +```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`: + + foo.+.doc : Nat + +```