Prepare for GHC 9.2.* upgrade

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

@@ -179,6 +179,7 @@ import qualified Control.Monad.Writer as Writer
 import Data.Bifunctor (Bifunctor (bimap))
 import Data.Bitraversable (bitraverse)
 import Data.Bytes.Put (runPutS)
+import qualified Data.Maybe as Maybe
 import qualified Data.Foldable as Foldable
 import qualified Data.List.Extra as List
 import qualified Data.List.NonEmpty as List (NonEmpty)
@@ -1926,7 +1927,8 @@ x2cTType :: (LocalTextId -> Text) -> (LocalDefnId -> Hash) -> S.Term.Type -> C.T
 x2cTType substText substHash = C.Type.rmap (bimap substText substHash)
 
 c2sTerm :: C.Term Symbol -> C.Term.Type Symbol -> Transaction (LocalIds, S.Term.Term, S.Term.Type)
-c2sTerm tm tp = c2xTerm saveText expectObjectIdForPrimaryHash tm (Just tp) <&> \(w, tm, Just tp) -> (w, tm, tp)
+c2sTerm tm tp = c2xTerm saveText expectObjectIdForPrimaryHash tm (Just tp) <&>
+  \(w, tm, mayTp) -> (w, tm, Maybe.fromJust mayTp)
 
 addTypeToIndexForTerm :: S.Referent.Id -> C.Reference -> Transaction ()
 addTypeToIndexForTerm sTermId cTypeRef = do

lib/unison-prelude/src/Unison/Prelude.hs

@@ -40,7 +40,7 @@ import Data.Coerce as X (Coercible, coerce)
 import Data.Either as X
 import Data.Either.Combinators as X (mapLeft, maybeToRight)
 import Data.Either.Extra (eitherToMaybe, maybeToEither)
-import Data.Foldable as X (asum, fold, foldl', for_, toList, traverse_)
+import Data.Foldable as X (fold, foldl', for_, toList, traverse_)
 import Data.Function as X ((&))
 import Data.Functor as X
 import Data.Functor.Identity as X

lib/unison-pretty-printer/src/Unison/Lexer/Pos.hs

@@ -20,11 +20,11 @@ column (Pos _ column) = column
 
 instance Show Pos where show (Pos line col) = "line " <> show line <> ", column " <> show col
 
-instance Semigroup Pos where (<>) = mappend
-
-instance Monoid Pos where
-  mempty = Pos 0 0
-  Pos line col `mappend` Pos line2 col2 =
+instance Semigroup Pos where
+  Pos line col <> Pos line2 col2 =
     if line2 == 0
       then Pos line (col + col2)
       else Pos (line + line2) col2
+
+instance Monoid Pos where
+  mempty = Pos 0 0

lib/unison-pretty-printer/src/Unison/Util/Pretty.hs

@@ -874,18 +874,18 @@ indentAfterNewline by = flatMap f
 instance IsString s => IsString (Pretty s) where
   fromString s = lit' (foldMap chDelta s) (fromString s)
 
-instance Semigroup (Pretty s) where (<>) = mappend
-
-instance Monoid (Pretty s) where
-  mempty = Pretty mempty Empty
-  mappend p1 p2 = Pretty (delta p1 <> delta p2)
+instance Semigroup (Pretty s) where
+  p1 <> p2 = Pretty (delta p1 <> delta p2)
     . Append
     $ case (out p1, out p2) of
       (Append ps1, Append ps2) -> ps1 <> ps2
       (Append ps1, _) -> ps1 <> pure p2
       (_, Append ps2) -> pure p1 <> ps2
       (_, _) -> pure p1 <> pure p2
 
+instance Monoid (Pretty s) where
+  mempty = Pretty mempty Empty
+
 data Delta
   = -- | The number of columns.
     SingleLine !Width
@@ -906,7 +906,6 @@ instance Semigroup Delta where
 
 instance Monoid Delta where
   mempty = SingleLine 0
-  mappend = (<>)
 
 maxCol :: Delta -> Width
 maxCol = \case

lib/unison-util-relation/src/Unison/Util/Relation.hs

@@ -747,7 +747,6 @@ bitraverse f g = fmap fromList . traverse (\(a, b) -> (,) <$> f a <*> g b) . toL
 
 instance (Ord a, Ord b) => Monoid (Relation a b) where
   mempty = empty
-  mappend = (<>)
 
 instance (Ord a, Ord b) => Semigroup (Relation a b) where
   (<>) = union

lib/unison-util-relation/src/Unison/Util/Relation3.hs

@@ -188,12 +188,11 @@ delete a b c Relation3 {..} =
        in if r' == mempty then Nothing else Just r'
 
 instance (Ord a, Ord b, Ord c) => Semigroup (Relation3 a b c) where
-  (<>) = mappend
-
-instance (Ord a, Ord b, Ord c) => Monoid (Relation3 a b c) where
-  mempty = Relation3 mempty mempty mempty
-  s1 `mappend` s2 = Relation3 d1' d2' d3'
+  s1 <> s2 = Relation3 d1' d2' d3'
     where
       d1' = Map.unionWith (<>) (d1 s1) (d1 s2)
       d2' = Map.unionWith (<>) (d2 s1) (d2 s2)
       d3' = Map.unionWith (<>) (d3 s1) (d3 s2)
+
+instance (Ord a, Ord b, Ord c) => Monoid (Relation3 a b c) where
+  mempty = Relation3 mempty mempty mempty

lib/unison-util-relation/src/Unison/Util/Relation4.hs

@@ -186,13 +186,12 @@ insertAll ::
 insertAll f r = foldl' (\r x -> uncurry4 insert x r) r f
 
 instance (Ord a, Ord b, Ord c, Ord d) => Semigroup (Relation4 a b c d) where
-  (<>) = mappend
-
-instance (Ord a, Ord b, Ord c, Ord d) => Monoid (Relation4 a b c d) where
-  mempty = Relation4 mempty mempty mempty mempty
-  s1 `mappend` s2 = Relation4 d1' d2' d3' d4'
+  s1 <> s2 = Relation4 d1' d2' d3' d4'
     where
       d1' = Map.unionWith (<>) (d1 s1) (d1 s2)
       d2' = Map.unionWith (<>) (d2 s1) (d2 s2)
       d3' = Map.unionWith (<>) (d3 s1) (d3 s2)
       d4' = Map.unionWith (<>) (d4 s1) (d4 s2)
+
+instance (Ord a, Ord b, Ord c, Ord d) => Monoid (Relation4 a b c d) where
+  mempty = Relation4 mempty mempty mempty mempty

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

@@ -30,6 +30,8 @@ import Unison.Type (Type)
 import qualified Unison.Type as Type
 import Unison.Var (Var)
 import qualified Unison.Var as Var
+import Data.Sequence (Seq)
+import qualified Data.Maybe as Maybe
 
 lookupDeclRef :: Text -> Reference
 lookupDeclRef str
@@ -102,48 +104,48 @@ constructorId ref name = do
 noneId, someId, okConstructorId, failConstructorId, docBlobId, docLinkId, docSignatureId, docSourceId, docEvaluateId, docJoinId, linkTermId, linkTypeId, eitherRightId, eitherLeftId :: ConstructorId
 isPropagatedConstructorId, isTestConstructorId, bufferModeNoBufferingId, bufferModeLineBufferingId, bufferModeBlockBufferingId, bufferModeSizedBlockBufferingId :: ConstructorId
 seqViewEmpty, seqViewElem :: ConstructorId
-Just noneId = constructorId optionalRef "Optional.None"
-Just someId = constructorId optionalRef "Optional.Some"
+noneId = Maybe.fromJust $ constructorId optionalRef "Optional.None"
+someId = Maybe.fromJust $ constructorId optionalRef "Optional.Some"
 
-Just isPropagatedConstructorId = constructorId isPropagatedRef "IsPropagated.IsPropagated"
+isPropagatedConstructorId = Maybe.fromJust $ constructorId isPropagatedRef "IsPropagated.IsPropagated"
 
-Just isTestConstructorId = constructorId isTestRef "IsTest.IsTest"
+isTestConstructorId = Maybe.fromJust $ constructorId isTestRef "IsTest.IsTest"
 
-Just okConstructorId = constructorId testResultRef "Test.Result.Ok"
+okConstructorId = Maybe.fromJust $ constructorId testResultRef "Test.Result.Ok"
 
-Just failConstructorId = constructorId testResultRef "Test.Result.Fail"
+failConstructorId = Maybe.fromJust $ constructorId testResultRef "Test.Result.Fail"
 
-Just docBlobId = constructorId docRef "Doc.Blob"
+docBlobId = Maybe.fromJust $ constructorId docRef "Doc.Blob"
 
-Just docLinkId = constructorId docRef "Doc.Link"
+docLinkId = Maybe.fromJust $ constructorId docRef "Doc.Link"
 
-Just docSignatureId = constructorId docRef "Doc.Signature"
+docSignatureId = Maybe.fromJust $ constructorId docRef "Doc.Signature"
 
-Just docSourceId = constructorId docRef "Doc.Source"
+docSourceId = Maybe.fromJust $ constructorId docRef "Doc.Source"
 
-Just docEvaluateId = constructorId docRef "Doc.Evaluate"
+docEvaluateId = Maybe.fromJust $ constructorId docRef "Doc.Evaluate"
 
-Just docJoinId = constructorId docRef "Doc.Join"
+docJoinId = Maybe.fromJust $ constructorId docRef "Doc.Join"
 
-Just linkTermId = constructorId linkRef "Link.Term"
+linkTermId = Maybe.fromJust $ constructorId linkRef "Link.Term"
 
-Just linkTypeId = constructorId linkRef "Link.Type"
+linkTypeId = Maybe.fromJust $ constructorId linkRef "Link.Type"
 
-Just eitherRightId = constructorId eitherRef "Either.Right"
+eitherRightId = Maybe.fromJust $ constructorId eitherRef "Either.Right"
 
-Just eitherLeftId = constructorId eitherRef "Either.Left"
+eitherLeftId = Maybe.fromJust $ constructorId eitherRef "Either.Left"
 
-Just seqViewEmpty = constructorId seqViewRef "SeqView.VEmpty"
+seqViewEmpty = Maybe.fromJust $ constructorId seqViewRef "SeqView.VEmpty"
 
-Just seqViewElem = constructorId seqViewRef "SeqView.VElem"
+seqViewElem = Maybe.fromJust $ constructorId seqViewRef "SeqView.VElem"
 
-Just bufferModeNoBufferingId = constructorId bufferModeRef "io2.BufferMode.NoBuffering"
+bufferModeNoBufferingId = Maybe.fromJust $ constructorId bufferModeRef "io2.BufferMode.NoBuffering"
 
-Just bufferModeLineBufferingId = constructorId bufferModeRef "io2.BufferMode.LineBuffering"
+bufferModeLineBufferingId = Maybe.fromJust $ constructorId bufferModeRef "io2.BufferMode.LineBuffering"
 
-Just bufferModeBlockBufferingId = constructorId bufferModeRef "io2.BufferMode.BlockBuffering"
+bufferModeBlockBufferingId = Maybe.fromJust $ constructorId bufferModeRef "io2.BufferMode.BlockBuffering"
 
-Just bufferModeSizedBlockBufferingId = constructorId bufferModeRef "io2.BufferMode.SizedBlockBuffering"
+bufferModeSizedBlockBufferingId = Maybe.fromJust $ constructorId bufferModeRef "io2.BufferMode.SizedBlockBuffering"
 
 okConstructorReferent, failConstructorReferent :: Referent.Referent
 okConstructorReferent = Referent.Con (ConstructorReference testResultRef okConstructorId) CT.Data
@@ -183,7 +185,9 @@ builtinDataDecls = rs1 ++ rs
         ] of
       Right a -> a
       Left e -> error $ "builtinDataDecls: " <> show e
-    [(_, linkRef, _)] = rs1
+    linkRef = case rs1 of
+                [(_, linkRef, _)] -> linkRef
+                _ -> error "builtinDataDecls: Expected a single linkRef"
     v = Var.named
     var name = Type.var () (v name)
     arr = Type.arrow'
@@ -405,30 +409,44 @@ builtinEffectDecls =
         [ ((), v "Exception.raise", Type.forall () (v "x") (failureType () `arr` self (var "x")))
         ]
 
+pattern UnitRef :: Reference
 pattern UnitRef <- (unUnitRef -> True)
 
+pattern PairRef :: Reference
 pattern PairRef <- (unPairRef -> True)
 
+pattern EitherRef :: Reference
 pattern EitherRef <- ((==) eitherRef -> True)
 
+pattern OptionalRef :: Reference
 pattern OptionalRef <- (unOptionalRef -> True)
 
+pattern OptionalNone' :: ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern OptionalNone' <- Term.Constructor' (ConstructorReference OptionalRef ((==) noneId -> True))
 
+pattern OptionalSome' :: ABT.Term (Term.F typeVar typeAnn patternAnn) v a
+                      -> ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern OptionalSome' d <- Term.App' (Term.Constructor' (ConstructorReference OptionalRef ((==) someId -> True))) d
 
+pattern TupleType' :: Var v => [Type v a] -> Type v a
 pattern TupleType' ts <- (unTupleType -> Just ts)
 
+pattern TupleTerm' :: [Term2 vt at ap v a] -> Term2 vt at ap v a
 pattern TupleTerm' xs <- (unTupleTerm -> Just xs)
 
+pattern TuplePattern :: [Pattern.Pattern loc] -> Pattern.Pattern loc
 pattern TuplePattern ps <- (unTuplePattern -> Just ps)
 
+pattern EitherLeft' :: Term2 vt at ap v a -> Term2 vt at ap v a
 pattern EitherLeft' tm <- (unLeftTerm -> Just tm)
 
+pattern EitherRight' :: Term2 vt at ap v a -> Term2 vt at ap v a
 pattern EitherRight' tm <- (unRightTerm -> Just tm)
 
+pattern EitherLeftId :: ConstructorId
 pattern EitherLeftId <- ((==) eitherLeftId -> True)
 
+pattern EitherRightId :: ConstructorId
 pattern EitherRightId <- ((==) eitherRightId -> True)
 
 unLeftTerm,
@@ -445,42 +463,68 @@ unLeftTerm t = case t of
   _ -> Nothing
 
 -- some pattern synonyms to make pattern matching on some of these constants more pleasant
+pattern DocRef :: Reference
 pattern DocRef <- ((== docRef) -> True)
 
+pattern DocJoin :: Seq (ABT.Term (Term.F typeVar typeAnn patternAnn) v a)
+                -> ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern DocJoin segs <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocJoinId)) (Term.List' segs)
 
+pattern DocBlob :: Text -> ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern DocBlob txt <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocBlobId)) (Term.Text' txt)
 
+pattern DocLink :: ABT.Term (Term.F typeVar typeAnn patternAnn) v a
+                -> ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern DocLink link <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocLinkId)) link
 
+pattern DocSource :: ABT.Term (Term.F typeVar typeAnn patternAnn) v a
+                  -> ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern DocSource link <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocSourceId)) link
 
+pattern DocSignature :: ABT.Term (Term.F typeVar typeAnn patternAnn) v a
+                     -> ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern DocSignature link <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocSignatureId)) link
 
+pattern DocEvaluate :: ABT.Term (Term.F typeVar typeAnn patternAnn) v a
+                    -> ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern DocEvaluate link <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocEvaluateId)) link
 
+pattern Doc :: ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern Doc <- Term.App' (Term.Constructor' (ConstructorReference DocRef _)) _
 
+pattern DocSignatureId :: ConstructorId
 pattern DocSignatureId <- ((== docSignatureId) -> True)
 
+pattern DocBlobId :: ConstructorId
 pattern DocBlobId <- ((== docBlobId) -> True)
 
+pattern DocLinkId :: ConstructorId
 pattern DocLinkId <- ((== docLinkId) -> True)
 
+pattern DocSourceId :: ConstructorId
 pattern DocSourceId <- ((== docSourceId) -> True)
 
+pattern DocEvaluateId :: ConstructorId
 pattern DocEvaluateId <- ((== docEvaluateId) -> True)
 
+pattern DocJoinId :: ConstructorId
 pattern DocJoinId <- ((== docJoinId) -> True)
 
+pattern LinkTermId :: ConstructorId
 pattern LinkTermId <- ((== linkTermId) -> True)
 
+pattern LinkTypeId :: ConstructorId
 pattern LinkTypeId <- ((== linkTypeId) -> True)
 
+pattern LinkRef :: Reference
 pattern LinkRef <- ((== linkRef) -> True)
 
+
+pattern LinkTerm :: ABT.Term (Term.F typeVar typeAnn patternAnn) v a -> ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern LinkTerm tm <- Term.App' (Term.Constructor' (ConstructorReference LinkRef LinkTermId)) tm
 
+pattern LinkType :: ABT.Term (Term.F typeVar typeAnn patternAnn) v a
+                 -> ABT.Term (Term.F typeVar typeAnn patternAnn) v a
 pattern LinkType ty <- Term.App' (Term.Constructor' (ConstructorReference LinkRef LinkTypeId)) ty
 
 unitType,

parser-typechecker/src/Unison/Codebase/Branch/BranchDiff.hs

@@ -57,5 +57,4 @@ instance Semigroup BranchDiff where
       }
 
 instance Monoid BranchDiff where
-  mappend = (<>)
   mempty = BranchDiff mempty mempty mempty mempty mempty

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

@@ -28,11 +28,7 @@ instance (Ord v, Functor m) => Functor (CodeLookup v m) where
       md (Right d) = Right (f <$> d)
 
 instance Monad m => Semigroup (CodeLookup v m a) where
-  (<>) = mappend
-
-instance Monad m => Monoid (CodeLookup v m a) where
-  mempty = CodeLookup (const $ pure Nothing) (const $ pure Nothing)
-  c1 `mappend` c2 = CodeLookup tm ty
+  c1 <> c2 = CodeLookup tm ty
     where
       tm id = do
         o <- getTerm c1 id
@@ -41,6 +37,9 @@ instance Monad m => Monoid (CodeLookup v m a) where
         o <- getTypeDeclaration c1 id
         case o of Nothing -> getTypeDeclaration c2 id; Just _ -> pure o
 
+instance Monad m => Monoid (CodeLookup v m a) where
+  mempty = CodeLookup (const $ pure Nothing) (const $ pure Nothing)
+
 -- todo: can this be implemented in terms of TransitiveClosure.transitiveClosure?
 -- todo: add some tests on this guy?
 transitiveDependencies ::

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

@@ -127,7 +127,6 @@ instance Semigroup Patch where
       (_typeEdits a <> _typeEdits b)
 
 instance Monoid Patch where
-  mappend = (<>)
   mempty = Patch mempty mempty
 
 instance Semigroup PatchDiff where
@@ -140,5 +139,4 @@ instance Semigroup PatchDiff where
       }
 
 instance Monoid PatchDiff where
-  mappend = (<>)
   mempty = PatchDiff mempty mempty mempty mempty

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

@@ -277,6 +277,7 @@ toName' = \case
   AbsolutePath' p -> Name.makeAbsolute <$> toName (unabsolute p)
   RelativePath' p -> Name.makeRelative <$> toName (unrelative p)
 
+pattern Empty :: Path
 pattern Empty = Path Seq.Empty
 
 pattern AbsolutePath' :: Absolute -> Path'

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

@@ -157,8 +157,9 @@ evaluateTerm' codeLookup cache ppe rt tm = do
       r <- evaluateWatches (void codeLookup) ppe cache rt (void tuf)
       pure $
         r <&> \(_, map) ->
-          let [(_loc, _kind, _hash, _src, value, _isHit)] = Map.elems map
-           in value
+          case Map.elems map of
+          [(_loc, _kind, _hash, _src, value, _isHit)] -> value
+          _ -> error "evaluateTerm': Pattern mismatch on watch results"
 
 evaluateTerm ::
   (Var v, Monoid a) =>