Merge pull request #5106 from neduard/ghc-964-updates-part-1

codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs

@@ -15,7 +15,7 @@ data LocalIds' t h = LocalIds
   { textLookup :: Vector t,
     defnLookup :: Vector h
   }
-  deriving (Show)
+  deriving (Functor, Show)
 
 type LocalIds = LocalIds' TextId ObjectId
 

codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TermEdit.hs

@@ -22,6 +22,12 @@ type Referent' t h = Referent.Referent' (Reference' t h) (Reference' t h)
 data TermEdit' t h = Replace (Referent' t h) Typing | Deprecate
   deriving (Eq, Ord, Show)
 
+instance Functor (TermEdit' t) where
+  fmap :: (a -> b) -> TermEdit' t a -> TermEdit' t b
+  fmap f (Replace (Referent.Ref termRef) typing) = Replace (Referent.Ref (fmap f termRef)) typing
+  fmap f (Replace (Referent.Con typeRef consId) typing) = Replace (Referent.Con (fmap f typeRef) consId) typing
+  fmap _ Deprecate = Deprecate
+
 _Replace :: Prism (TermEdit' t h) (TermEdit' t' h') (Referent' t h, Typing) (Referent' t' h', Typing)
 _Replace = prism embed project
   where

codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TypeEdit.hs

@@ -17,7 +17,7 @@ type TypeEdit = TypeEdit' Db.TextId Db.ObjectId
 type HashTypeEdit = TypeEdit' Text ComponentHash
 
 data TypeEdit' t h = Replace (Reference' t h) | Deprecate
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Functor, Ord, Show)
 
 _Replace :: Prism (TypeEdit' t h) (TypeEdit' t' h') (Reference' t h) (Reference' t' h')
 _Replace = prism Replace project

codebase2/codebase/U/Codebase/Referent.hs

@@ -63,7 +63,7 @@ type Id = Id' Hash Hash
 data Id' hTm hTp
   = RefId (Reference.Id' hTm)
   | ConId (Reference.Id' hTp) ConstructorId
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Functor, Ord, Show)
 
 instance Bifunctor Referent' where
   bimap f g = \case

codebase2/codebase/U/Codebase/Reflog.hs

@@ -13,6 +13,7 @@ data Entry causal text = Entry
     toRootCausalHash :: causal,
     reason :: text
   }
+  deriving (Functor)
 
 instance Bifunctor Entry where
   bimap = bimapDefault

codebase2/core/U/Codebase/Reference.hs

@@ -74,7 +74,7 @@ data ReferenceType = RtTerm | RtType deriving (Eq, Ord, Show)
 data Reference' t h
   = ReferenceBuiltin t
   | ReferenceDerived (Id' h)
-  deriving stock (Eq, Generic, Ord, Show)
+  deriving stock (Eq, Generic, Functor, Ord, Show)
 
 -- | A type declaration reference.
 type TermReference' t h = Reference' t h

codebase2/core/Unison/Core/Project.hs

@@ -29,7 +29,7 @@ data ProjectAndBranch a b = ProjectAndBranch
   { project :: a,
     branch :: b
   }
-  deriving stock (Eq, Generic, Show)
+  deriving stock (Eq, Generic, Show, Functor)
 
 instance Bifunctor ProjectAndBranch where
   bimap f g (ProjectAndBranch a b) = ProjectAndBranch (f a) (g b)

codebase2/util-term/U/Util/Type.hs

@@ -61,7 +61,7 @@ flattenEffects es = [es]
 generalize :: (Ord v) => [v] -> TypeR r v -> TypeR r v
 generalize vs t = foldr f t vs
   where
-    f v t = if Set.member v (ABT.freeVars t) then forall v t else t
+    f v t = if Set.member v (ABT.freeVars t) then forAll v t else t
 
 -- * Patterns
 
@@ -80,8 +80,8 @@ pattern Effect1' e t <- ABT.Tm' (Effect e t)
 pattern Ref' :: r -> TypeR r v
 pattern Ref' r <- ABT.Tm' (Ref r)
 
-forall :: (Ord v) => v -> TypeR r v -> TypeR r v
-forall v body = ABT.tm () (Forall (ABT.abs () v body))
+forAll :: (Ord v) => v -> TypeR r v -> TypeR r v
+forAll v body = ABT.tm () (Forall (ABT.abs () v body))
 
 unforall' :: TypeR r v -> ([v], TypeR r v)
 unforall' (ForallsNamed' vs t) = (vs, t)

lib/unison-prelude/src/Unison/Util/Tuple.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeOperators #-}
 
 -- | Tuple utils.
 module Unison.Util.Tuple

lib/unison-util-nametree/src/Unison/Util/Defns.hs

@@ -28,7 +28,7 @@ data Defns terms types = Defns
   { terms :: terms,
     types :: types
   }
-  deriving stock (Generic, Show)
+  deriving stock (Generic, Functor, Show)
   deriving (Monoid, Semigroup) via GenericSemigroupMonoid (Defns terms types)
 
 instance Bifoldable Defns where

parser-typechecker/src/Unison/Builtin.hs

@@ -985,7 +985,7 @@ refPromiseBuiltins =
 forall1 :: Text -> (Type -> Type) -> Type
 forall1 name body =
   let a = Var.named name
-   in Type.forall () a (body $ Type.var () a)
+   in Type.forAll () a (body $ Type.var () a)
 
 forall2 ::
   Text -> Text -> (Type -> Type -> Type) -> Type

parser-typechecker/src/Unison/Builtin/Decls.hs

@@ -596,7 +596,7 @@ builtinEffectDecls =
         Structural
         ()
         []
-        [ ((), v "Exception.raise", Type.forall () (v "x") (failureType () `arr` self (var "x")))
+        [ ((), v "Exception.raise", Type.forAll () (v "x") (failureType () `arr` self (var "x")))
         ]
 
 pattern UnitRef :: Reference

parser-typechecker/src/Unison/Codebase/Execute.hs

@@ -6,7 +6,8 @@
 module Unison.Codebase.Execute where
 
 import Control.Exception (finally)
-import Control.Monad.Except
+import Control.Monad.Except (throwError, runExceptT)
+import Control.Monad.IO.Class (liftIO)
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Branch.Names qualified as Branch

parser-typechecker/src/Unison/Codebase/MainTerm.hs

@@ -57,7 +57,7 @@ getMainTerm loadTypeOfTerm parseNames mainName mainType = do
 builtinMain :: (Var v) => a -> Type.Type v a
 builtinMain a =
   let result = Var.named "result"
-   in Type.forall a result (builtinMainWithResultType a (Type.var a result))
+   in Type.forAll a result (builtinMainWithResultType a (Type.var a result))
 
 -- '{io2.IO, Exception} res
 builtinMainWithResultType :: (Var v) => a -> Type.Type v a -> Type.Type v a

parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs

@@ -4,7 +4,6 @@
 
 module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema6To7 (migrateSchema6To7) where
 
-import Control.Monad.Except
 import Control.Monad.State
 import U.Codebase.Branch.Type (NamespaceStats)
 import U.Codebase.Sqlite.DbId qualified as DB

parser-typechecker/src/Unison/KindInference/Solve/Monad.hs

@@ -14,6 +14,7 @@ module Unison.KindInference.Solve.Monad
 where
 
 import Control.Lens (Lens', (%%~))
+import Control.Monad.Fix (MonadFix (..))
 import Control.Monad.Reader qualified as M
 import Control.Monad.State.Strict qualified as M
 import Data.Functor.Identity
@@ -64,7 +65,7 @@ newtype Solve v loc a = Solve {unSolve :: Env -> SolveState v loc -> (a, SolveSt
     ( Functor,
       Applicative,
       Monad,
-      M.MonadFix,
+      MonadFix,
       M.MonadReader Env,
       M.MonadState (SolveState v loc)
     )

parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs

@@ -518,12 +518,9 @@ addConstraint con0 nc = do
     C.PosLit var pmlit ->
       let updateLiteral pos neg lit
             | Just lit1 <- pos,
-              lit1 == lit = case lit1 == lit of
+              lit1 == lit =
                 -- we already have this positive constraint
-                True -> (pure (), Ignore)
-                -- contradicts positive info
-                False -> (contradiction, Ignore)
-            -- the constraint contradicts negative info
+                (pure (), Ignore)
             | Set.member lit neg = (contradiction, Ignore)
             | otherwise = (pure (), Update (Just lit, neg))
        in modifyLiteralC var pmlit updateLiteral nc

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

@@ -31,7 +31,7 @@ type TypeP v m = P v m (Type v Ann)
 -- the right of a function arrow:
 --   valueType ::= Int | Text | App valueType valueType | Arrow valueType computationType
 valueType :: (Monad m, Var v) => TypeP v m
-valueType = forall type1 <|> type1
+valueType = forAll type1 <|> type1
 
 -- Computation
 -- computationType ::= [{effect*}] valueType
@@ -119,8 +119,8 @@ arrow rec =
    in chainr1 (effect <|> rec) (reserved "->" *> eff)
 
 -- "forall a b . List a -> List b -> Maybe Text"
-forall :: (Var v) => TypeP v m -> TypeP v m
-forall rec = do
+forAll :: (Var v) => TypeP v m -> TypeP v m
+forAll rec = do
   kw <- reserved "forall" <|> reserved "∀"
   vars <- fmap (fmap L.payload) . some $ prefixDefinitionName
   _ <- reserved "."

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

@@ -963,7 +963,7 @@ apply' solvedExistentials t = go t
       Type.Ann' v k -> Type.ann a (go v) k
       Type.Effect1' e t -> Type.effect1 a (go e) (go t)
       Type.Effects' es -> Type.effects a (map go es)
-      Type.ForallNamed' v t' -> Type.forall a v (go t')
+      Type.ForallNamed' v t' -> Type.forAll a v (go t')
       Type.IntroOuterNamed' v t' -> Type.introOuter a v (go t')
       _ -> error $ "Match error in Context.apply': " ++ show t
       where
@@ -1059,7 +1059,7 @@ vectorConstructorOfArity loc arity = do
   let elementVar = Var.named "elem"
       args = replicate arity (loc, Type.var loc elementVar)
       resultType = Type.app loc (Type.list loc) (Type.var loc elementVar)
-      vt = Type.forall loc elementVar (Type.arrows args resultType)
+      vt = Type.forAll loc elementVar (Type.arrows args resultType)
   pure vt
 
 generalizeAndUnTypeVar :: (Var v) => Type v a -> Type.Type v a
@@ -1984,7 +1984,7 @@ tweakEffects v0 t0
     rewrite p ty
       | Type.ForallNamed' v t <- ty,
         v0 /= v =
-          second (Type.forall a v) <$> rewrite p t
+          second (Type.forAll a v) <$> rewrite p t
       | Type.Arrow' i o <- ty = do
           (vis, i) <- rewrite (not <$> p) i
           (vos, o) <- rewrite p o
@@ -2097,7 +2097,7 @@ generalizeP p ctx0 ty = foldr gen (applyCtx ctx0 ty) ctx
           -- location of the forall is just the location of the input type
           -- and the location of each quantified variable is just inherited
           -- from its source location
-          Type.forall
+          Type.forAll
             (loc t)
             (TypeVar.Universal v)
             (ABT.substInheritAnnotation tv (universal' () v) t)

parser-typechecker/tests/Unison/Test/DataDeclaration.hs

@@ -88,7 +88,7 @@ unhashComponentTest =
     inventedVarsFreshnessTest =
       let var = Type.var ()
           app = Type.app ()
-          forall = Type.forall ()
+          forAll = Type.forAll ()
           (-->) = Type.arrow ()
           h = Hash.fromByteString (encodeUtf8 "abcd")
           ref = R.Id h 0
@@ -104,8 +104,8 @@ unhashComponentTest =
                 annotation = (),
                 bound = [],
                 constructors' =
-                  [ ((), nil, forall a (listType `app` var a)),
-                    ((), cons, forall b (var b --> listType `app` var b --> listType `app` var b))
+                  [ ((), nil, forAll a (listType `app` var a)),
+                    ((), cons, forAll b (var b --> listType `app` var b --> listType `app` var b))
                   ]
               }
           component :: Map R.Id (Decl Symbol ())
@@ -120,7 +120,7 @@ unhashComponentTest =
        in tests
             [ -- check that `nil` constructor's type did not collapse to `forall a. a a`,
               -- which would happen if the var invented for `listRef` was simply `Var.refNamed listRef`
-              expectEqual (forall z (listType' `app` var z)) nilType',
+              expectEqual (forAll z (listType' `app` var z)) nilType',
               -- check that the variable assigned to `listRef` is different from `cons`,
               -- which would happen if the var invented for `listRef` was simply `Var.refNamed listRef`
               expectNotEqual cons listVar

parser-typechecker/tests/Unison/Test/Term.hs

@@ -33,7 +33,7 @@ test =
                           Type.arrow () (tv "a") (tv "x")
                       )
                   )
-                  (Type.forall () (v "a") (tv "a"))
+                  (Type.forAll () (v "a") (tv "a"))
               tm' = Term.substTypeVar (v "x") (tv "a") tm
               expected =
                 Term.ann
@@ -45,7 +45,7 @@ test =
                           Type.arrow () (Type.var () $ v1 "a") (tv "a")
                       )
                   )
-                  (Type.forall () (v1 "a") (Type.var () $ v1 "a"))
+                  (Type.forAll () (v1 "a") (Type.var () $ v1 "a"))
           note $ show tm'
           note $ show expected
           expect $ tm == tm

parser-typechecker/tests/Unison/Test/Type.hs

@@ -28,7 +28,7 @@ test =
               v2 = Var.named "b"
               vt = var () v
               vt2 = var () v2
-              x = forall () v (nat () --> effect () [vt, builtin () "eff"] (nat ())) :: Type Symbol ()
-              y = forall () v2 (nat () --> effect () [vt2] (nat ())) :: Type Symbol ()
+              x = forAll () v (nat () --> effect () [vt, builtin () "eff"] (nat ())) :: Type Symbol ()
+              y = forAll () v2 (nat () --> effect () [vt2] (nat ())) :: Type Symbol ()
           expect . not $ Typechecker.isSubtype x y
       ]

parser-typechecker/tests/Unison/Test/Typechecker.hs

@@ -18,12 +18,12 @@ test =
 isSubtypeTest :: Test ()
 isSubtypeTest =
   let symbol i n = Symbol i (Var.User n)
-      forall v t = Type.forall () v t
+      forAll v t = Type.forAll () v t
       var v = Type.var () v
 
       a = symbol 0 "a"
       a_ i = symbol i "a"
-      lhs = forall a (var a) -- ∀a. a
+      lhs = forAll a (var a) -- ∀a. a
       rhs_ i = var (a_ i) -- a_i
    in -- check that `∀a. a <: a_i` (used to fail for i = 2, 3)
       tests [expectSubtype lhs (rhs_ i) | i <- [0 .. 5]]

unison-cli/src/Unison/CommandLine/Completion.hs

@@ -196,12 +196,6 @@ completeWithinNamespace compTypes query currentPath = do
     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)]
-          textifyHQ f xs =
-            xs
-              & hashQualifyCompletions f
-              & fmap (HQ'.toTextWith NameSegment.toEscapedText)
-              & fmap (True,)
       pure $
         concat
           [ (NamespaceCompletion,False,) <$> (fmap NameSegment.toEscapedText . Map.keys $ nonEmptyChildren),
@@ -216,6 +210,12 @@ completeWithinNamespace compTypes query currentPath = do
               (fmap ((PatchCompletion,True,) . NameSegment.toEscapedText) . Map.keys $ V2Branch.patches b)
           ]
 
+    textifyHQ :: (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [(Bool, Text)]
+    textifyHQ f xs =
+      xs
+        & hashQualifyCompletions f
+        & fmap (HQ'.toTextWith NameSegment.toEscapedText)
+        & fmap (True,)
     -- Regrettably there'shqFromNamedV2Referencenot a great spot to combinators for V2 references and shorthashes right now.
     hqFromNamedV2Referent :: Int -> NameSegment -> Referent.Referent -> HQ'.HashQualified NameSegment
     hqFromNamedV2Referent hashLen n r = HQ'.HashQualified n (Cv.referent2toshorthash1 (Just hashLen) r)

unison-cli/src/Unison/LSP/CodeLens.hs

@@ -6,7 +6,6 @@
 module Unison.LSP.CodeLens where
 
 import Control.Lens hiding (List)
-import Control.Monad.Except
 import Data.Aeson qualified as Aeson
 import Data.Map qualified as Map
 import Data.Text qualified as Text

unison-cli/src/Unison/LSP/UCMWorker.hs

@@ -1,6 +1,9 @@
 module Unison.LSP.UCMWorker where
 
-import Control.Monad.Reader
+import Control.Monad (guard)
+import Control.Monad.State (liftIO)
+import Control.Monad.Reader.Class (ask)
+import Data.Functor (void)
 import U.Codebase.HashTags
 import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Branch qualified as Branch

unison-core/src/Unison/Term.hs

@@ -397,7 +397,7 @@ substTypeVar vt ty = go Set.empty
                           t2 = ABT.bindInheritAnnotation body (Type.var () v2)
                        in uncapture ((ABT.annotation t, v2) : vs) (renameTypeVar v v2 e) t2
                 uncapture vs e t0 =
-                  let t = foldl (\body (loc, v) -> Type.forall loc v body) t0 vs
+                  let t = foldl (\body (loc, v) -> Type.forAll loc v body) t0 vs
                       bound' = case Type.unForalls (Type.stripIntroOuters t) of
                         Nothing -> bound
                         Just (vs, _) -> bound <> Set.fromList vs