Merge trunk

Author: ChrisPenner

parser-typechecker/src/Unison/PrintError.hs

@@ -1000,11 +1000,11 @@ renderTypeError e env src = case e of
           ]
       C.KindInferenceFailure _ -> "kind inference failure"
       C.DuplicateDefinitions vs ->
-        let go :: (v, [loc]) -> Pretty (AnnotatedText a)
+        let go :: (v, NESet loc) -> Pretty (AnnotatedText a)
             go (v, locs) =
               "["
                 <> renderVar v
-                <> mconcat (intersperse " : " $ annotatedToEnglish <$> locs)
+                <> mconcat (intersperse " : " $ annotatedToEnglish <$> toList locs)
                 <> "]"
          in "DuplicateDefinitions:" <> mconcat (go <$> Nel.toList vs)
       C.ConcatPatternWithoutConstantLength loc typ ->
@@ -1121,7 +1121,7 @@ renderContext env ctx@(C.Context es) =
       e -> Pr.shown e
     showElem ctx (C.Solved _ v (Type.Monotype t)) =
       "'" <> shortName v <> " = " <> renderType' env (C.apply ctx t)
-    showElem ctx (C.Ann v t) =
+    showElem ctx (C.Ann v _ t) =
       shortName v <> " : " <> renderType' env (C.apply ctx t)
     showElem _ (C.Marker v) = "|" <> shortName v <> "|"
 

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

@@ -112,7 +112,7 @@ rewriteBlock = do
     rewriteTermlike kw mk = do
       kw <- quasikeyword kw
       lhs <- term
-      (_spanAnn, rhs) <- layoutBlock "==>"
+      (_openAnn, _spanAnn, rhs) <- layoutBlock "==>"
       pure (mk (ann kw <> ann rhs) lhs rhs)
     rewriteTerm = rewriteTermlike "term" DD.rewriteTerm
     rewriteCase = rewriteTermlike "case" DD.rewriteCase
@@ -234,10 +234,10 @@ matchCase = do
             [ Nothing <$ quasikeyword "otherwise",
               Just <$> infixAppOrBooleanOp
             ]
-        (_spanAnn, t) <- layoutBlock "->"
+        (_openAnn, _spanAnn, t) <- layoutBlock "->"
         pure (guard, t)
   let unguardedBlock = label "case match" do
-        (_spanAnn, t) <- layoutBlock "->"
+        (_openAnn, _spanAnn, t) <- layoutBlock "->"
         pure (Nothing, t)
   -- a pattern's RHS is either one or more guards, or a single unguarded block.
   guardsAndBlocks <- guardedBlocks <|> (pure @[] <$> unguardedBlock)
@@ -562,10 +562,12 @@ lam p = label "lambda" $ mkLam <$> P.try (some prefixDefinitionName <* reserved
        in Term.lam' (ann (head vs) <> ann b) annotatedArgs b
 
 letBlock, handle, ifthen :: (Monad m, Var v) => TermP v m
-letBlock = label "let" $ (snd <$> layoutBlock "let")
+letBlock = label "let" $ do
+  (_openAnn, _spanAnn, tm) <- layoutBlock "let"
+  pure tm
 handle = label "handle" do
-  (handleSpan, b) <- block "handle"
-  (_withSpan, handler) <- layoutBlock "with"
+  (_handleOpenAnn, handleSpan, b) <- block "handle"
+  (_withOpenAnn, _withSpan, handler) <- layoutBlock "with"
   -- We don't use the annotation span from 'with' here because it will
   -- include a dedent if it's at the end of block.
   -- Meaning the newline gets overwritten when pretty-printing and it messes things up.
@@ -600,9 +602,9 @@ lamCase = do
 
 ifthen = label "if" do
   start <- peekAny
-  (_spanAnn, c) <- block "if"
-  (_spanAnn, t) <- block "then"
-  (_spanAnn, f) <- layoutBlock "else"
+  (_ifOpenAnn, _spanAnn, c) <- block "if"
+  (_thenAnn, _spanAnn, t) <- block "then"
+  (_elseAnn, _spanAnn, f) <- layoutBlock "else"
   pure $ Term.iff (ann start <> ann f) c t f
 
 text :: (Var v) => TermP v m
@@ -736,11 +738,17 @@ doc2Block = do
     docTop d = \case
       Doc.Section title body -> pure $ Term.apps' (f d "Section") [docParagraph d title, Term.list (gann body) body]
       Doc.Eval code ->
-        Term.app (gann d) (f d "Eval") . addDelay . snd
-          <$> subParse (block' False False "syntax.docEval" (pure $ pure ()) $ Ann.External <$ P.eof) code
+        let inner = do
+              (_openAnn, ann, tm) <- (block' False False "syntax.docEval" (pure $ pure ()) $ Ann.External <$ P.eof)
+              pure (ann, tm)
+         in Term.app (gann d) (f d "Eval") . addDelay . snd
+              <$> subParse inner code
       Doc.ExampleBlock code ->
-        Term.apps' (f d "ExampleBlock") . (Term.nat (gann d) 0 :) . pure . addDelay . snd
-          <$> subParse (block' False True "syntax.docExampleBlock" (pure $ pure ()) $ Ann.External <$ P.eof) code
+        let inner = do
+              (_openAnn, ann, tm) <- (block' False True "syntax.docExampleBlock" (pure $ pure ()) $ Ann.External <$ P.eof)
+              pure (ann, tm)
+         in Term.apps' (f d "ExampleBlock") . (Term.nat (gann d) 0 :) . pure . addDelay . snd
+              <$> subParse inner code
       Doc.CodeBlock label body ->
         pure $
           Term.apps'
@@ -1219,9 +1227,8 @@ delayQuote = P.label "quote" do
 
 delayBlock :: (Monad m, Var v) => P v m (Ann {- Ann spanning the whole block -}, Term v Ann)
 delayBlock = P.label "do" do
-  (spanAnn, b) <- layoutBlock "do"
-  let argSpan = (ann b {- would be nice to use the annotation for 'do' here, but it's not terribly important -})
-  pure $ (spanAnn, DD.delayTerm (ann b) argSpan b)
+  (openAnn, spanAnn, b) <- layoutBlock "do"
+  pure $ (spanAnn, DD.delayTerm (ann b) openAnn b)
 
 bang :: (Monad m, Var v) => TermP v m
 bang = P.label "bang" do
@@ -1363,7 +1370,7 @@ destructuringBind = do
   --   (Some 42) = List.head elems
   pat <- P.try (parsePattern <* P.lookAhead (openBlockWith "="))
   (p, boundVars) <- over (_2 . mapped) snd <$> bindConstructorsInPattern pat
-  (_spanAnn, scrute) <- layoutBlock "=" -- Dwight K. Scrute ("The People's Scrutinee")
+  (_eqAnn, _spanAnn, scrute) <- layoutBlock "=" -- Dwight K. Scrute ("The People's Scrutinee")
   let guard = Nothing
   let absChain vs t = foldr (\v t -> ABT.abs' (ann t) v t) t vs
       thecase t = Term.MatchCase p (fmap (absChain boundVars) guard) $ absChain boundVars t
@@ -1381,7 +1388,15 @@ destructuringBind = do
 -- binding) and the entire body.
 -- * If the binding is a lambda, the  lambda node includes the entire LHS of the binding,
 -- including the name as well.
-binding :: forall m v. (Monad m, Var v) => P v m ((Ann, v), Term v Ann)
+binding ::
+  forall m v.
+  (Monad m, Var v) =>
+  P
+    v
+    m
+    ( (Ann {- annotation for the location of 'v' -}, v),
+      Term v Ann
+    )
 binding = label "binding" do
   typ <- optional typedecl
   -- a ++ b = ...
@@ -1401,25 +1416,25 @@ binding = label "binding" do
     Nothing -> 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 "="
+      (_eqAnn, _bodySpanAnn, body) <- block "="
       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.
-      let spanAnn = ann lhsLoc <> ann binding
-      pure $ ((spanAnn, (L.payload name)), binding)
+      -- let spanAnn = ann lhsLoc <> ann binding
+      pure $ ((ann name, (L.payload name)), binding)
     Just (nameT, typ) -> do
       (lhsLoc, name, args) <- lhs
       verifyRelativeName' (fmap Name.unsafeParseVar name)
       when (L.payload name /= L.payload nameT) $
         customFailure $
           SignatureNeedsAccompanyingBody nameT
-      (_bodySpanAnn, body) <- block "="
+      (_eqAnn, _bodySpanAnn, body) <- block "="
       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.
       let spanAnn = ann nameT <> ann binding
-      pure $ ((spanAnn, L.payload name), Term.ann (ann nameT <> ann binding) binding typ)
+      pure $ ((ann nameT, L.payload name), Term.ann spanAnn binding typ)
   where
     mkBinding :: Ann -> [L.Token v] -> Term.Term v Ann -> Term.Term v Ann
     mkBinding _lhsLoc [] body = body
@@ -1430,10 +1445,30 @@ binding = label "binding" do
 customFailure :: (P.MonadParsec e s m) => e -> m a
 customFailure = P.customFailure
 
-block :: forall m v. (Monad m, Var v) => String -> P v m (Ann, Term v Ann)
+block ::
+  forall m v.
+  (Monad m, Var v) =>
+  String ->
+  P
+    v
+    m
+    ( Ann {- annotation of block-open symbol, e.g. 'do', 'let' -},
+      Ann {- annotation for whole block -},
+      Term v Ann
+    )
 block s = block' False False s (openBlockWith s) closeBlock
 
-layoutBlock :: forall m v. (Monad m, Var v) => String -> P v m (Ann, Term v Ann)
+layoutBlock ::
+  forall m v.
+  (Monad m, Var v) =>
+  String ->
+  P
+    v
+    m
+    ( Ann {- annotation of block-open symbol, e.g. 'do', 'let' -},
+      Ann {- annotation for whole layout block -},
+      Term v Ann
+    )
 layoutBlock s = block' False False s (openBlockWith s) optionalCloseBlock
 
 -- example: use Foo.bar.Baz + ++ x
@@ -1468,7 +1503,7 @@ importp = do
       pure (suffix, Name.joinDot (L.payload prefix) suffix)
 
 data BlockElement v
-  = Binding ((Ann, v), Term v Ann)
+  = Binding ((Ann {- span for the binding name -}, v), Term v Ann)
   | DestructuringBind (Ann, Term v Ann -> Term v Ann)
   | Action (Term v Ann)
 
@@ -1512,22 +1547,22 @@ block' ::
   String ->
   P v m (L.Token ()) ->
   P v m end ->
-  P v m (Ann {- ann which spans the whole block -}, Term v Ann)
+  P v m (Ann {- span for the opening token, e.g. the "do" or opening bracket -}, Ann {- ann which spans the whole block -}, Term v Ann)
 block' isTop implicitUnitAtEnd s openBlock closeBlock = do
   open <- openBlock
   (names, imports) <- imports
   _ <- optional semi
   statements <- local (\e -> e {names}) $ sepBy semi statement
   end <- closeBlock
   body <- substImports names imports <$> go open statements
-  pure (ann open <> ann end, body)
+  pure (ann open, ann open <> ann end, body)
   where
     statement = asum [Binding <$> binding, DestructuringBind <$> destructuringBind, Action <$> blockTerm]
     go :: L.Token () -> [BlockElement v] -> P v m (Term v Ann)
     go open =
       let finish :: Term.Term v Ann -> TermP v m
           finish tm = case Components.minimize' tm of
-            Left dups -> customFailure $ DuplicateTermNames (toList dups)
+            Left dups -> customFailure $ DuplicateTermNames (toList (fmap (second toList) dups))
             Right tm -> pure tm
           toTm :: [BlockElement v] -> TermP v m
           toTm [] = customFailure $ EmptyBlock (const s <$> open)
@@ -1537,19 +1572,21 @@ block' isTop implicitUnitAtEnd s openBlock closeBlock = do
             where
               step :: BlockElement v -> Term v Ann -> TermP v m
               step elem result = case elem of
-                Binding ((a, v), tm) ->
+                Binding ((a, v), tm) -> do
+                  let fullLetRecSpan = ann a <> ann result
                   pure $
                     Term.consLetRec
                       isTop
-                      (ann a <> ann result)
+                      fullLetRecSpan
                       (a, v, tm)
                       result
-                Action tm ->
+                Action tm -> do
+                  let fullLetRecSpan = (ann tm <> ann result)
                   pure $
                     Term.consLetRec
                       isTop
-                      (ann tm <> ann result)
-                      (ann tm, positionalVar (ann tm) (Var.named "_"), tm)
+                      fullLetRecSpan
+                      (Ann.External, positionalVar (ann tm) (Var.named "_"), tm)
                       result
                 DestructuringBind (_, f) ->
                   f <$> finish result

parser-typechecker/src/Unison/Typechecker.hs

@@ -99,7 +99,7 @@ data Env v loc = Env
 -- a function to resolve the type of @Ref@ constructors
 -- contained in that term.
 synthesize ::
-  (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc) =>
+  (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc, Semigroup loc) =>
   PrettyPrintEnv ->
   Context.PatternMatchCoverageCheckAndKindInferenceSwitch ->
   Env v loc ->
@@ -353,7 +353,7 @@ typeDirectedNameResolution ppe oldNotes oldType env = do
 -- contained in the term. Returns @typ@ if successful,
 -- and a note about typechecking failure otherwise.
 check ::
-  (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc) =>
+  (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc, Semigroup loc) =>
   PrettyPrintEnv ->
   Env v loc ->
   Term v loc ->
@@ -376,7 +376,7 @@ check ppe env term typ =
 --     tweak (Type.ForallNamed' v body) = Type.forall() v (tweak body)
 --     tweak t = Type.arrow() t t
 -- | Returns `True` if the expression is well-typed, `False` otherwise
-wellTyped :: (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc) => PrettyPrintEnv -> Env v loc -> Term v loc -> f Bool
+wellTyped :: (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc, Semigroup loc) => PrettyPrintEnv -> Env v loc -> Term v loc -> f Bool
 wellTyped ppe env term = go <$> runResultT (synthesize ppe Context.PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled env term)
   where
     go (may, _) = isJust may

parser-typechecker/src/Unison/Typechecker/Components.hs

@@ -1,12 +1,11 @@
 module Unison.Typechecker.Components (minimize, minimize') where
 
-import Control.Arrow ((&&&))
-import Data.Function (on)
-import Data.List (groupBy, sortBy)
 import Data.List.NonEmpty (NonEmpty)
-import Data.List.NonEmpty qualified as Nel
+import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as Map
 import Data.Set qualified as Set
+import Data.Set.NonEmpty (NESet)
+import Data.Set.NonEmpty qualified as NESet
 import Unison.ABT qualified as ABT
 import Unison.Prelude
 import Unison.Term (Term')
@@ -35,25 +34,26 @@ ordered = ABT.orderedComponents
 --
 -- Fails on the left if there are duplicate definitions.
 minimize ::
-  (Var v) =>
+  forall vt v a.
+  (Var v, Ord a) =>
   Term' vt v a ->
-  Either (NonEmpty (v, [a])) (Maybe (Term' vt v a))
+  Either (NonEmpty (v, NESet a)) (Maybe (Term' vt v a))
 minimize (Term.LetRecNamedAnnotatedTop' isTop blockAnn bs e) =
-  let bindings = first snd <$> bs
-      group =
-        map (fst . head &&& map (ABT.annotation . snd))
-          . groupBy ((==) `on` fst)
-          . sortBy
-            (compare `on` fst)
-      grouped = group bindings
-      dupes = filter ok grouped
+  let bindings :: [(v, Term' vt v a)]
+      bindings = bs <&> \((_a, v), t) -> (v, t)
+      grouped :: Map v (NESet a)
+      grouped =
+        bs
+          & fmap (\((a, v), _t) -> (v, NESet.singleton a)) -- For duplicates, we care about the binding location.
+          & Map.fromListWith (NESet.union)
+      dupes = Map.filterWithKey ok grouped
         where
-          ok (v, as)
+          ok v as
             | Var.name v == "_" = False
             | otherwise = length as > 1
-   in if not $ null dupes
-        then Left $ Nel.fromList dupes
-        else
+   in case NEL.nonEmpty $ Map.toList dupes of
+        Just dupeList -> Left dupeList
+        Nothing -> do
           let cs0 = if isTop then unordered bindings else ordered bindings
               -- within a cycle, we put the lambdas first, so
               -- unguarded definitions can refer to these lambdas, example:
@@ -90,5 +90,5 @@ minimize (Term.LetRecNamedAnnotatedTop' isTop blockAnn bs e) =
 minimize _ = Right Nothing
 
 minimize' ::
-  (Var v) => Term' vt v a -> Either (NonEmpty (v, [a])) (Term' vt v a)
+  (Var v, Ord a) => Term' vt v a -> Either (NonEmpty (v, NESet a)) (Term' vt v a)
 minimize' term = fromMaybe term <$> minimize term