From 2490fa65eeba52699a7c0e303aa5cb9b78c2b1cf Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Niklas=20Hamb=C3=BCchen?= <mail@nh2.me>
Date: Fri, 17 Apr 2020 20:49:23 +0200
Subject: [PATCH] Compile against GHC 8.8

---
 Setup.hs                           | 15 ---------------
 src/Darcs/Patch/Depends.hs         |  2 +-
 src/Darcs/Patch/Match.hs           | 12 ++++++------
 src/Darcs/Patch/PatchInfoAnd.hs    |  2 +-
 src/Darcs/Patch/Prim/V1/Apply.hs   |  6 +++---
 src/Darcs/Patch/Prim/V1/Commute.hs |  1 +
 src/Darcs/Patch/ReadMonads.hs      |  1 +
 src/Darcs/Patch/V1/Commute.hs      |  1 +
 src/Darcs/Repository/Diff.hs       |  2 +-
 src/Darcs/Repository/Match.hs      |  2 +-
 src/Darcs/Util/Tree/Monad.hs       |  4 ++--
 12 files changed, 30 insertions(+), 42 deletions(-)

diff --git a/Setup.hs b/Setup.hs
index f5cc3e8..05caac4 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -75,21 +75,6 @@
   postInst = \ _ flags pkg lbi ->
              installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest,
 
-  sDistHook = \ pkg lbi hooks flags -> do
-    let pkgVer = packageVersion pkg
-        verb = fromFlag $ sDistVerbosity flags
-    x <- versionPatches verb pkgVer
-    y <- context verb
-    rewriteFileEx silent "release/distributed-version" $ show x
-    rewriteFileEx silent "release/distributed-context" $ show y
-    putStrLn "about to hand over"
-    let pkg' = pkg { library = sanity (library pkg) }
-        sanity (Just lib) = Just $ lib { libBuildInfo = sanity' $ libBuildInfo lib }
-        sanity _ = error "eh"
-        sanity' bi = bi { otherModules = [ m | m <- otherModules bi, toFilePath m /= "Version" ] }
-
-    sDistHook simpleUserHooks pkg' lbi hooks flags
-             ,
   postConf = \_ _ _ _ -> return () --- Usually this checked for external C
              --- dependencies, but we already have performed such
              --- check in the confHook
--- a/darcs.cabal	1970-01-01 01:00:01.000000000 +0100
+++ b/darcs.cabal	2020-04-18 10:26:07.605129733 +0200
@@ -1,6 +1,5 @@
 Name:           darcs
 version:        2.14.2
-x-revision: 1
 License:        GPL-2
 License-file:   COPYING
 Author:         David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net>
@@ -75,7 +74,7 @@
   description: Use libcurl for HTTP support.
 
 -- in future this could extend to any other external libraries,
--- e.g. libiconv 
+-- e.g. libiconv
 flag pkgconfig
   description: Use pkgconfig to configure libcurl
   default: False
@@ -113,7 +112,7 @@
 -- ----------------------------------------------------------------------
 
 custom-setup
-    setup-depends: base      >= 4.9 && < 4.13,
+    setup-depends: base      >= 4.9 && <5,
                    Cabal     >= 1.24,
                    process   >= 1.2.3.0 && < 1.7,
                    filepath  >= 1.4.1 && < 1.5.0.0,
@@ -381,7 +380,7 @@
     else
       build-depends:  unix >= 2.7.1.0 && < 2.8
 
-    build-depends:    base              >= 4.9 && < 4.13,
+    build-depends:    base              >= 4.9 && <5,
                       stm               >= 2.1 && < 2.6,
                       binary            >= 0.5 && < 0.10,
                       containers        >= 0.5.6.2 && < 0.7,
@@ -402,19 +401,19 @@
                       tar               >= 0.5 && < 0.6,
                       data-ordlist      == 0.4.*,
                       attoparsec        >= 0.13.0.1 && < 0.14,
-                      zip-archive       >= 0.3 && < 0.5,
+                      zip-archive       >= 0.3 && <1,
                       async             >= 2.0.2 && < 2.3,
-                      sandi             >= 0.4 && < 0.6,
+                      sandi             >= 0.4 && <1,
                       unix-compat       >= 0.4.2 && < 0.6,
                       bytestring        >= 0.10.6 && < 0.11,
                       old-time          >= 1.1.0.3 && < 1.2,
                       time              >= 1.5.0.1 && < 1.10,
-                      text              >= 1.2.1.3 && < 1.3,
+                      text              >= 1.2.1.3 && <2,
                       directory         >= 1.2.6.2 && < 1.4,
                       process           >= 1.2.3.0 && < 1.7,
                       array             >= 0.5.1.0 && < 0.6,
                       random            >= 1.1 && < 1.2,
-                      hashable          >= 1.2.3.3 && < 1.3,
+                      hashable          >= 1.2.3.3 && <2,
                       mmap              >= 0.5.9 && < 0.6,
                       zlib              >= 0.6.1.2 && < 0.7.0.0,
                       network-uri       == 2.6.*,
@@ -443,7 +442,7 @@
 
     -- The terminfo package cannot be built on Windows.
     if flag(terminfo) && !os(windows)
-      build-depends:  terminfo >= 0.4.0.2 && < 0.5
+      build-depends:  terminfo >= 0.4.0.2 && <1
       cpp-options:    -DHAVE_TERMINFO
 
     default-extensions:
@@ -500,7 +499,7 @@
   cc-options:       -D_REENTRANT
 
   build-depends:    darcs,
-                    base              >= 4.9 && < 4.13
+                    base              >= 4.9 && <5
 
 -- ----------------------------------------------------------------------
 -- unit test driver
@@ -518,7 +517,7 @@
     build-depends:  Win32 >= 2.3.1 && < 2.4
 
   build-depends:    darcs,
-                    base         >= 4.9 && < 4.13,
+                    base         >= 4.9 && <5,
                     array        >= 0.5.1.0 && < 0.6,
                     bytestring   >= 0.10.6 && < 0.11,
                     cmdargs      >= 0.10.10 && < 0.11,
@@ -527,15 +526,15 @@
                     mtl          >= 2.2.1 && < 2.3,
                     shelly       >= 1.6.8 && < 1.9,
                     split        >= 0.2.2 && < 0.3,
-                    text         >= 1.2.1.3 && < 1.3,
+                    text         >= 1.2.1.3 && <2,
                     directory    >= 1.2.6.2 && < 1.4,
                     FindBin      >= 0.0.5 && < 0.1,
-                    QuickCheck   >= 2.8.2 && < 2.13,
+                    QuickCheck   >= 2.8.2 && <3,
                     HUnit        >= 1.3 && < 1.7,
                     test-framework             >= 0.8.1.1 && < 0.9,
                     test-framework-hunit       >= 0.3.0.2 && < 0.4,
                     test-framework-quickcheck2 >= 0.3.0.3 && < 0.4,
-                    zip-archive  >= 0.3 && < 0.5
+                    zip-archive  >= 0.3 && <1
 
   -- https://github.com/yesodweb/Shelly.hs/issues/177
   if os(windows)
diff --git a/src/Darcs/Patch/Depends.hs b/src/Darcs/Patch/Depends.hs
index 8531294..a4c71cb 100644
--- a/src/Darcs/Patch/Depends.hs
+++ b/src/Darcs/Patch/Depends.hs
@@ -251,7 +251,7 @@ splitOnTag _ (PatchSet NilRL NilRL) = Nothing
 unwrapOneTagged :: (Monad m) => PatchSet rt p wX wY -> m (PatchSet rt p wX wY)
 unwrapOneTagged (PatchSet (ts :<: Tagged t _ tps) ps) =
     return $ PatchSet ts (tps :<: t +<+ ps)
-unwrapOneTagged _ = fail "called unwrapOneTagged with no Tagged's in the set"
+unwrapOneTagged _ = error "called unwrapOneTagged with no Tagged's in the set"
 
 -- | @getUncovered ps@ returns the 'PatchInfo' for all the patches in
 --   @ps@ that are not depended on by anything else *through explicit
diff --git a/src/Darcs/Patch/Match.hs b/src/Darcs/Patch/Match.hs
index aba6c7a..2b6f53a 100644
--- a/src/Darcs/Patch/Match.hs
+++ b/src/Darcs/Patch/Match.hs
@@ -421,7 +421,7 @@ getNonrangeMatchS fs repo =
         Just m -> if nonrangeMatcherIsTag fs
                         then getTagS m repo
                         else getMatcherS Exclusive m repo
-        Nothing -> fail "Pattern not specified in getNonrangeMatch."
+        Nothing -> error "Pattern not specified in getNonrangeMatch."
 
 -- | @firstMatch fs@ tells whether @fs@ implies a "first match", that
 -- is if we match against patches from a point in the past on, rather
@@ -441,7 +441,7 @@ getFirstMatchS fs repo =
      Just (_,b) -> unpullLastN repo b -- b is chronologically earlier than a
      Nothing    ->
       case firstMatcher fs of
-               Nothing -> fail "Pattern not specified in getFirstMatchS."
+               Nothing -> error "Pattern not specified in getFirstMatchS."
                Just m -> if firstMatcherIsTag fs
                          then getTagS m repo
                          else getMatcherS Inclusive m repo
@@ -462,7 +462,7 @@ checkMatchSyntax :: [MatchFlag] -> IO ()
 checkMatchSyntax opts =
  case getMatchPattern opts of
   Nothing -> return ()
-  Just p  -> either fail (const $ return ()) (parseMatch p::Either String (MatchFun rt DummyPatch))
+  Just p  -> either error (const $ return ()) (parseMatch p::Either String (MatchFun rt DummyPatch))
 
 getMatchPattern :: [MatchFlag] -> Maybe String
 getMatchPattern [] = Nothing
@@ -718,7 +718,7 @@ getMatcherS :: (ApplyMonad (ApplyState p) m, Matchable p) =>
 getMatcherS ioe m repo =
     if matchExists m repo
     then applyInvToMatcher ioe m repo
-    else fail $ "Couldn't match pattern "++ show m
+    else error $ "Couldn't match pattern "++ show m
 
 getTagS :: (ApplyMonad (ApplyState p) m, MonadProgress m, Matchable p) =>
              Matcher rt p -> PatchSet rt p Origin wX -> m ()
diff --git a/src/Darcs/Patch/PatchInfoAnd.hs b/src/Darcs/Patch/PatchInfoAnd.hs
index 2da7ec8..1147410 100644
--- a/src/Darcs/Patch/PatchInfoAnd.hs
+++ b/src/Darcs/Patch/PatchInfoAnd.hs
@@ -167,7 +167,7 @@ conscientiously er (PIAP pinf hp) =
 
 -- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a
 -- monad instead of erroring.
-hopefullyM :: Monad m => PatchInfoAnd rt p wA wB -> m (WrappedNamed rt p wA wB)
+hopefullyM :: MonadFail m => PatchInfoAnd rt p wA wB -> m (WrappedNamed rt p wA wB)
 hopefullyM (PIAP pinf hp) = case hopefully2either hp of
                               Right p -> return p
                               Left e -> fail $ renderString
diff --git a/src/Darcs/Patch/Prim/V1/Apply.hs b/src/Darcs/Patch/Prim/V1/Apply.hs
index bea7e41..7984d21 100644
--- a/src/Darcs/Patch/Prim/V1/Apply.hs
+++ b/src/Darcs/Patch/Prim/V1/Apply.hs
@@ -41,13 +41,13 @@ instance Apply Prim where
     apply (FP f (TokReplace t o n)) = mModifyFilePS f doreplace
         where doreplace fc =
                   case tryTokReplace t (BC.pack o) (BC.pack n) fc of
-                  Nothing -> fail $ "replace patch to " ++ fn2fp f
+                  Nothing -> error $ "replace patch to " ++ fn2fp f
                              ++ " couldn't apply."
                   Just fc' -> return fc'
     apply (FP f (Binary o n)) = mModifyFilePS f doapply
         where doapply oldf = if o == oldf
                              then return n
-                             else fail $ "binary patch to " ++ fn2fp f
+                             else error $ "binary patch to " ++ fn2fp f
                                   ++ " couldn't apply."
     apply (DP d AddDir) = mCreateDirectory d
     apply (DP d RmDir) = mRemoveDirectory d
@@ -115,7 +115,7 @@ applyHunk f h fc =
   case applyHunkLines h fc of
     Right fc' -> return fc'
     Left msg ->
-      fail $
+      error $
       "### Error applying:\n" ++ renderHunk h ++
       "\n### to file " ++ fn2fp f ++ ":\n" ++ BC.unpack fc ++
       "### Reason: " ++ msg
diff --git a/src/Darcs/Patch/Prim/V1/Commute.hs b/src/Darcs/Patch/Prim/V1/Commute.hs
index 7639dbd..e1432e6 100644
--- a/src/Darcs/Patch/Prim/V1/Commute.hs
+++ b/src/Darcs/Patch/Prim/V1/Commute.hs
@@ -58,6 +58,7 @@ instance  Monad Perhaps where
     Failed   >>= _      =  Failed
     Unknown  >>= _      =  Unknown
     return              =  Succeeded
+instance  MonadFail Perhaps where
     fail _              =  Unknown
 
 instance Alternative Perhaps where
diff --git a/src/Darcs/Patch/ReadMonads.hs b/src/Darcs/Patch/ReadMonads.hs
index 62a4f81..e1cb149 100644
--- a/src/Darcs/Patch/ReadMonads.hs
+++ b/src/Darcs/Patch/ReadMonads.hs
@@ -237,6 +237,7 @@ failSM _ = SM (\_ -> Nothing)
 instance Monad SM where
     (>>=)  = bindSM
     return = returnSM
+instance MonadFail SM where
     fail   = failSM
 
 instance ParserM SM where
diff --git a/src/Darcs/Patch/V1/Commute.hs b/src/Darcs/Patch/V1/Commute.hs
index 0bb41a3..c6c3382 100644
--- a/src/Darcs/Patch/V1/Commute.hs
+++ b/src/Darcs/Patch/V1/Commute.hs
@@ -93,6 +93,7 @@ instance  Monad Perhaps where
     Failed   >>= _      =  Failed
     Unknown  >>= _      =  Unknown
     return              =  Succeeded
+instance  MonadFail Perhaps where
     fail _              =  Unknown
 
 instance Alternative Perhaps where
diff --git a/src/Darcs/Repository/Diff.hs b/src/Darcs/Repository/Diff.hs
index 8078d49..e0e2341 100644
--- a/src/Darcs/Repository/Diff.hs
+++ b/src/Darcs/Repository/Diff.hs
@@ -138,7 +138,7 @@ treeDiff da ft t1 t2 = do
         do rmDirP <- diff p (Removed subtree)
            addFileP <- diff p (Changed (File emptyBlob) b')
            return $ joinGap (+>+) rmDirP addFileP
-    diff p _ = fail $ "Missing case at path " ++ show p
+    diff p _ = error $ "Missing case at path " ++ show p
 
     text_diff p a b
         | BL.null a && BL.null b = emptyGap NilFL
diff --git a/src/Darcs/Repository/Match.hs b/src/Darcs/Repository/Match.hs
index 08c9f13..f33cabe 100644
--- a/src/Darcs/Repository/Match.hs
+++ b/src/Darcs/Repository/Match.hs
@@ -60,7 +60,7 @@ getNonrangeMatch :: (ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPat
 getNonrangeMatch r = withRecordedMatch r . getMatch where
   getMatch fs = case hasIndexRange fs of
     Just (n, m) | n == m -> applyNInv (n-1)
-                | otherwise -> fail "Index range is not allowed for this command."
+                | otherwise -> error "Index range is not allowed for this command."
     _ -> getNonrangeMatchS fs
 
 getOnePatchset :: (IsRepoType rt, RepoPatch p)
diff --git a/src/Darcs/Util/Tree/Monad.hs b/src/Darcs/Util/Tree/Monad.hs
index 0e01d9b..296fdc4 100644
--- a/src/Darcs/Util/Tree/Monad.hs
+++ b/src/Darcs/Util/Tree/Monad.hs
@@ -216,7 +216,7 @@ instance (Monad m) => TreeRO (TreeMonad m) where
            t <- gets tree
            let f = findFile t p'
            case f of
-             Nothing -> fail $ "No such file " ++ show p'
+             Nothing -> error $ "No such file " ++ show p'
              Just x -> lift (readBlob x)
 
     currentDirectory = ask
@@ -251,7 +251,7 @@ instance (Monad m) => TreeRW (TreeMonad m) where
            let item = find tr from'
                found_to = find tr to'
            unless (isNothing found_to) $
-                  fail $ "Error renaming: destination " ++ show to ++ " exists."
+                  error $ "Error renaming: destination " ++ show to ++ " exists."
            unless (isNothing item) $ do
                   modifyItem from Nothing
                   modifyItem to item
-- 
2.23.1