src/Darcs/Bug.lhs

   1 % Reporting bugs in darcs.  See also impossible.h.
   2
   3 \begin{code}
   4 module Darcs.Bug ( _bug, _bugDoc, _impossible, _fromJust
   5                  ) where
   6
   7 import System.IO.Unsafe ( unsafePerformIO )
   8 import Text.Regex ( matchRegex, mkRegex )
   9
  10 import Autoconf( darcs_version )
  11 import Printer ( Doc, errorDoc, text, ($$), (<+>) )
  12
  13 type BugStuff = (String, Int, String, String)
  14 type FetchUrl = String -> IO String
  15
  16 _bug :: FetchUrl -> BugStuff -> String -> a
  17 _bug fetchUrl bs s = _bugDoc fetchUrl bs (text s)
  18
  19 _bugDoc :: FetchUrl -> BugStuff -> Doc -> a
  20 _bugDoc fetchUrl bs s =
  21     errorDoc $ text "bug in darcs!" $$ s <+> text ("at "++_bugLoc bs) $$
  22     unsafePerformIO ((mkms . lines) `fmap` (fetchUrl "http://darcs.net/maintenance"
  23                                             `catch` \_ -> return ""))
  24     where mkms [] = text "I'm unable to check http://darcs.net/maintenance to see if this version is supported."
  25                     $$ text "If it is supported, please report this to bugs@darcs.net"
  26                     $$ text "If possible include the output of 'darcs --exact-version'."
  27           mkms (a:b:r) = case matchRegex (mkRegex a) darcs_version of
  28                          Nothing -> mkms r
  29                          Just _ -> case reads b of
  30                                    [(m,"")] -> text m
  31                                    _ -> mkms r
  32           mkms [_] = mkms []
  33
  34 _bugLoc :: BugStuff -> String
  35 _bugLoc (file, line, date, time) = file++":"++show line++" compiled "++time++" "++date
  36
  37 _impossible :: FetchUrl -> BugStuff -> a
  38 _impossible fetchUrl bs = _bug fetchUrl bs $ "Impossible case at "++_bugLoc bs
  39
  40 _fromJust :: FetchUrl -> BugStuff -> Maybe a -> a
  41 _fromJust fetchUrl bs mx =
  42   case mx of Nothing -> _bug fetchUrl bs $ "fromJust error at "++_bugLoc bs
  43              Just x  -> x
  44 \end{code}