Utils.hs 2.04 KB
Newer Older
mnislaih's avatar
mnislaih committed
1
2
module Network.Hackage.CabalInstall.Utils where

3
import Distribution.Compat.ReadP (ReadP, readP_to_S)
4
import Distribution.ParseUtils
mnislaih's avatar
mnislaih committed
5
6
7
import Distribution.Verbosity
import Network.Hackage.CabalInstall.Types

8
9
import Control.Exception
import Control.Monad (foldM, guard)
10
11
import Data.Char (isSpace)
import Data.Maybe (listToMaybe)
12
import System.IO.Error (isDoesNotExistError)
13
import Text.PrettyPrint.HughesPJ
mnislaih's avatar
mnislaih committed
14
15


16
17
isVerbose cfg = configVerbose cfg >= verbose

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

readFileIfExists :: FilePath -> IO (Maybe String)
readFileIfExists path = 
    catchJust fileNotFoundExceptions 
                  (fmap Just (readFile path)) 
                  (\_ -> return Nothing)

fileNotFoundExceptions :: Exception -> Maybe IOError
fileNotFoundExceptions e = 
    ioErrors e >>= \ioe -> guard (isDoesNotExistError ioe) >> return ioe


showPError :: PError -> String
showPError err = let (ml,msg) = locatedErrorMsg err
                  in maybe "" (\l -> "On line " ++ show l ++ ": ") ml ++ msg



36
37
readPToMaybe :: ReadP r a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str, all isSpace s ]
38
39
40
41
42
43
44
45
46
47

ignoreWarnings :: ParseResult a -> ParseResult a
ignoreWarnings (ParseOk _ x) = ParseOk [] x
ignoreWarnings r = r 

parseBasicStanza :: [FieldDescr a] -> a -> String -> ParseResult a
parseBasicStanza fields empty inp = 
    readFields inp >>= foldM (setField fields) empty

setField :: [FieldDescr a]
48
49
50
         -> a
         -> Field
         -> ParseResult a
51
52
53
54
55
56
57
58
59
60
61
62
setField fs x (F line f val) =
    case lookupFieldDescr fs f of
      Nothing -> 
          do warning ("Unrecognized field " ++ f ++ " on line " ++ show line)
             return x
      Just (FieldDescr _ _ set) -> set line val x
setField _ x s = 
    do warning ("Unrecognized stanza on line " ++ show (lineNo s))
       return x

lookupFieldDescr :: [FieldDescr a] -> String -> Maybe (FieldDescr a)
lookupFieldDescr fs n = listToMaybe [f | f@(FieldDescr name _ _) <- fs, name == n]
63
64
65
66


showFields :: [FieldDescr a] -> a -> String
showFields fs x = render $ vcat [ text name <> text ":" <+> get x | FieldDescr name get _ <- fs]