⅄ trunk → 22-10-18-backticky-parser

CONTRIBUTORS.markdown

@@ -67,6 +67,7 @@ The format for this list: name, GitHub handle
 * Nicole Prindle (@nprindle)
 * Harald Gliebe (@hagl)
 * Phil de Joux (@philderbeast)
+* Daroc Alden (@setupminimal)
 * Travis Staton (@tstat)
 * Dan Freeman (@dfreeman)
 * Emil Hotkowski (@emilhotkowski)

parser-typechecker/src/Unison/PrintError.hs

@@ -1,6 +1,18 @@
 {-# LANGUAGE RecordWildCards #-}
 
-module Unison.PrintError where
+module Unison.PrintError
+  ( Env,
+    defaultWidth,
+    prettyParseError,
+    prettyResolutionFailures,
+    prettyVar,
+    printNoteWithSource,
+    renderCompilerBug,
+    renderNoteAsANSI,
+    renderParseErrorAsANSI,
+    renderParseErrors,
+  )
+where
 
 import Control.Lens ((%~))
 import Control.Lens.Tuple (_1, _2, _3)
@@ -19,7 +31,6 @@ import Data.Text qualified as Text
 import Text.Megaparsec qualified as P
 import Unison.ABT qualified as ABT
 import Unison.Builtin.Decls (unitRef, pattern TupleType')
-import Unison.Codebase.Path qualified as Path
 import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
 import Unison.HashQualified (HashQualified)
 import Unison.HashQualified' qualified as HQ'
@@ -80,12 +91,6 @@ pattern Type2 = Color.Green
 pattern ErrorSite :: Color
 pattern ErrorSite = Color.HiRed
 
-pattern TypeKeyword :: Color
-pattern TypeKeyword = Color.Yellow
-
-pattern AbilityKeyword :: Color
-pattern AbilityKeyword = Color.Green
-
 pattern Identifier :: Color
 pattern Identifier = Color.Bold
 
@@ -114,18 +119,6 @@ fromOverHere src spots0 removing =
         1 -> "\n  from right here:\n\n" <> showSource src spots
         _ -> "\n  from these spots, respectively:\n\n" <> showSource src spots
 
-showTypeWithProvenance ::
-  (Var v, Annotated a, Ord style) =>
-  Env ->
-  String ->
-  style ->
-  Type v a ->
-  Pretty (AnnotatedText style)
-showTypeWithProvenance env src color typ =
-  style color (renderType' env typ)
-    <> ".\n"
-    <> fromOverHere' src [styleAnnotated color typ] []
-
 styleAnnotated :: (Annotated a) => sty -> a -> Maybe (Range, sty)
 styleAnnotated sty a = (,sty) <$> rangeForAnnotated a
 
@@ -1210,9 +1203,6 @@ renderSuggestion env sug =
 spaces :: (IsString a, Monoid a) => (b -> a) -> [b] -> a
 spaces = intercalateMap " "
 
-arrows :: (IsString a, Monoid a) => (b -> a) -> [b] -> a
-arrows = intercalateMap " ->"
-
 commas :: (IsString a, Monoid a) => (b -> a) -> [b] -> a
 commas = intercalateMap ", "
 
@@ -1243,17 +1233,6 @@ showConstructor env r =
   fromString . Text.unpack . HQ.toText $
     PPE.patternName env r
 
-styleInOverallType ::
-  (Var v, Annotated a, Eq a) =>
-  Env ->
-  C.Type v a ->
-  C.Type v a ->
-  Color ->
-  Pretty ColorText
-styleInOverallType e overallType leafType c = renderType e f overallType
-  where
-    f loc s = if loc == ABT.annotation leafType then Color.style c <$> s else s
-
 _posToEnglish :: (IsString s) => L.Pos -> s
 _posToEnglish (L.Pos l c) =
   fromString $ "Line " ++ show l ++ ", Column " ++ show c
@@ -1928,15 +1907,6 @@ showSource src annotations =
 showSource1 :: (Ord a) => String -> (Range, a) -> Pretty (AnnotatedText a)
 showSource1 src annotation = showSource src [annotation]
 
-findTerm :: Seq (C.PathElement v loc) -> Maybe loc
-findTerm = go
-  where
-    go (C.InSynthesize t :<| _) = Just $ ABT.annotation t
-    go (C.InCheck t _ :<| _) = Just $ ABT.annotation t
-    go (C.InSynthesizeApp _ t _ :<| _) = Just $ ABT.annotation t
-    go (_ :<| t) = go t
-    go Empty = Nothing
-
 prettyTypecheckError ::
   (Var v, Ord loc, Show loc, Parser.Annotated loc) =>
   C.ErrorNote v loc ->
@@ -2026,6 +1996,3 @@ useExamples =
           (Pr.blue "use .foo bar.baz", Pr.wrap "Introduces `bar.baz` as a local alias for the absolute name `.foo.bar.baz`")
         ]
     ]
-
-prettyPath' :: Path.Path' -> Pretty ColorText
-prettyPath' p' = Pr.blue (Pr.shown p')

parser-typechecker/src/Unison/Syntax/FileParser.hs

@@ -1,4 +1,6 @@
-module Unison.Syntax.FileParser where
+module Unison.Syntax.FileParser
+  ( file
+  ) where
 
 import Control.Lens
 import Control.Monad.Reader (asks, local)

parser-typechecker/src/Unison/Syntax/TypeParser.hs

@@ -1,4 +1,10 @@
-module Unison.Syntax.TypeParser where
+{-# LANGUAGE OverloadedStrings #-}
+
+module Unison.Syntax.TypeParser
+  ( computationType
+  , valueType
+  , valueTypeLeaf
+  ) where
 
 import Control.Monad.Reader (asks)
 import Data.Set qualified as Set

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

@@ -6,6 +6,7 @@ module Unison.Codebase.Editor.HandleInput.Update2
     -- * Misc helpers to be organized later
     addDefinitionsToUnisonFile,
     findCtorNames,
+    findCtorNamesMaybe,
     forwardCtorNames,
     makeParsingEnv,
     prettyParseTypecheck,
@@ -143,7 +144,7 @@ handleUpdate2 = do
         Cli.respond Output.UpdateTypecheckingSuccess
         pure secondTuf
 
-  saveTuf (findCtorNames Output.UOUUpdate namesExcludingLibdeps ctorNames Nothing) secondTuf
+  saveTuf (findCtorNamesMaybe Output.UOUUpdate namesExcludingLibdeps ctorNames Nothing) secondTuf
   Cli.respond Output.Success
 
 -- TODO: find a better module for this function, as it's used in a couple places
@@ -183,7 +184,7 @@ makeParsingEnv path names = do
       }
 
 -- save definitions and namespace
-saveTuf :: (Name -> Either Output [Name]) -> TypecheckedUnisonFile Symbol Ann -> Cli ()
+saveTuf :: (Name -> Either Output (Maybe [Name])) -> TypecheckedUnisonFile Symbol Ann -> Cli ()
 saveTuf getConstructors tuf = do
   Cli.Env {codebase} <- ask
   currentPath <- Cli.getCurrentPath
@@ -206,7 +207,10 @@ saveTuf getConstructors tuf = do
 --     [ ("foo.bar", insert-term("baz",<#foo>)) ]
 typecheckedUnisonFileToBranchUpdates ::
   (forall void. Output -> Transaction void) ->
-  (Name -> Either Output [Name]) ->
+  -- | Returns 'Nothing' if the decl isn't in namesExcludingLibdeps,
+  -- in which case we know the decl is new and do not need to generate
+  -- delete actions for it.
+  (Name -> Either Output (Maybe [Name])) ->
   TypecheckedUnisonFile Symbol Ann ->
   Transaction [(Path, Branch0 m -> Branch0 m)]
 typecheckedUnisonFileToBranchUpdates abort getConstructors tuf = do
@@ -225,7 +229,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.unsafeParseVar symbol) of
+          deleteConstructorActions <- case maybe [] (map (BranchUtil.makeAnnihilateTermName . Path.splitFromName)) <$> getConstructors (Name.unsafeParseVar symbol) of
             Left err -> abort err
             Right actions -> pure actions
           let deleteTypeAction = BranchUtil.makeAnnihilateTypeName split
@@ -363,9 +367,13 @@ forwardCtorNames names =
     ]
 
 -- | given a decl name, find names for all of its constructors, in order.
+--
+-- Precondition: 'n' is an element of 'names'
 findCtorNames :: Output.UpdateOrUpgrade -> Names -> Map ForwardName (Referent, Name) -> Maybe Int -> Name -> Either Output.Output [Name]
 findCtorNames operation names forwardCtorNames ctorCount n =
-  let declRef = Set.findMin $ Relation.lookupDom n names.types
+  let declRef = case Set.lookupMin (Relation.lookupDom n names.types) of
+        Nothing -> error "[findCtorNames] precondition violation: n is not an element of names"
+        Just x -> x
       f = ForwardName.fromName n
       (_, centerRight) = Map.split f forwardCtorNames
       (center, _) = Map.split (incrementLastSegmentChar f) centerRight
@@ -385,6 +393,18 @@ findCtorNames operation names forwardCtorNames ctorCount n =
         then Right $ Map.elems m
         else Left $ Output.UpdateIncompleteConstructorSet operation n m ctorCount
 
+findCtorNamesMaybe ::
+  Output.UpdateOrUpgrade ->
+  Names ->
+  Map ForwardName (Referent, Name) ->
+  Maybe Int ->
+  Name ->
+  Either Output.Output (Maybe [Name])
+findCtorNamesMaybe operation names forwardCtorNames ctorCount name =
+  case Relation.memberDom name (Names.types names) of
+    True -> Just <$> findCtorNames operation names forwardCtorNames ctorCount name
+    False -> Right Nothing
+
 -- Used by `findCtorNames` to filter `forwardCtorNames` to a narrow range which will be searched linearly.
 -- >>> incrementLastSegmentChar $ ForwardName.fromName $ Name.unsafeFromText "foo.bar.quux"
 -- ForwardName {toList = "foo" :| ["bar","quuy"]}

unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs

@@ -25,6 +25,7 @@ import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch
 import Unison.Codebase.Editor.HandleInput.Update2
   ( addDefinitionsToUnisonFile,
     findCtorNames,
+    findCtorNamesMaybe,
     forwardCtorNames,
     getNamespaceDependentsOf,
     makeComplicatedPPE,
@@ -202,7 +203,7 @@ handleUpgrade oldDepName newDepName = do
       Codebase.addDefsToCodebase codebase typecheckedUnisonFile
       typecheckedUnisonFileToBranchUpdates
         abort
-        (findCtorNames Output.UOUUpgrade namesExcludingLibdeps constructorNamesExcludingLibdeps Nothing)
+        (findCtorNamesMaybe Output.UOUUpgrade namesExcludingLibdeps constructorNamesExcludingLibdeps Nothing)
         typecheckedUnisonFile
   Cli.stepAt
     textualDescriptionOfUpgrade

unison-src/transcripts/fix4618.md

@@ -0,0 +1,21 @@
+```ucm:hide
+.> builtins.merge
+```
+
+```unison
+foo = 5
+unique type Bugs.Zonk = Bugs
+```
+
+```ucm
+.> add
+```
+
+```unison
+foo = 4
+unique type Bugs =
+```
+
+```ucm
+.> update
+```

unison-src/transcripts/fix4618.output.md

@@ -0,0 +1,60 @@
+```unison
+foo = 5
+unique type Bugs.Zonk = Bugs
+```
+
+```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`:
+    
+      type Bugs.Zonk
+      foo : Nat
+
+```
+```ucm
+.> add
+
+  ⍟ I've added these definitions:
+  
+    type Bugs.Zonk
+    foo : Nat
+
+```
+```unison
+foo = 4
+unique type Bugs =
+```
+
+```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`:
+    
+      type Bugs
+    
+    ⍟ These names already exist. You can `update` them to your
+      new definition:
+    
+      foo : Nat
+
+```
+```ucm
+.> update
+
+  Okay, I'm searching the branch for code that needs to be
+  updated...
+
+  Done.
+
+```