% Reporting bugs in darcs. See also impossible.h.
\begin{code}
module Darcs.Bug ( _bug, _bugDoc,
_bugLoc, _impossible, _fromJust, _withBugLoc,
) where
import System.IO.Unsafe ( unsafePerformIO )
import Text.Regex ( matchRegex, mkRegex )
import HTTP ( fetchUrl )
import Autoconf( darcs_version )
import Printer ( Doc, errorDoc, text, ($$), (<+>) )
\end{code}
\begin{code}
_bug :: BugStuff -> String -> a
_bug bs s = _bugDoc bs (text s)
_bugDoc :: BugStuff -> Doc -> a
_bugDoc bs s = errorDoc $ text "bug in darcs!" $$ s <+> text ("at "++_bugLoc bs) $$
unsafePerformIO ((mkms . lines) `fmap` (fetchUrl "http://darcs.net/maintenance"
`catch` \_ -> return ""))
where mkms [] = text "I'm unable to check http://darcs.net/maintenance to see if this version is supported."
$$ text "If it is is supported, please report this to bugs@darcs.net"
$$ text "If possible include the output of 'darcs --exact-version'."
mkms (a:b:r) = case matchRegex (mkRegex a) darcs_version of
Nothing -> mkms r
Just _ -> case reads b of
[(m,"")] -> text m
_ -> mkms r
mkms [_] = mkms []
\end{code}
\begin{code}
type BugStuff = (String, Int, String, String)
_bugLoc :: BugStuff -> String
_bugLoc (file, line, date, time) = file++":"++show line++" compiled "++time++" "++date
_impossible :: BugStuff -> a
_impossible bs = _bug bs $ "Impossible case"++_bugLoc bs
_fromJust :: BugStuff -> Maybe a -> a
_fromJust bs mx =
case mx of Nothing -> _bug bs $ "fromJust error"++_bugLoc bs
Just x -> x
_withBugLoc :: BugStuff -> IO a -> IO a
_withBugLoc bs job = job `catch` \err -> error $ _bugLoc bs++"\n"++show err
\end{code}