ParseUtils.hs 11.8 KB
Newer Older
simonmar's avatar
simonmar committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.ParseUtils
-- Copyright   :  (c) The University of Glasgow 2004
-- 
-- Maintainer  :  libraries@haskell.org
-- Stability   :  alpha
-- Portability :  portable
--
-- Utilities for parsing PackageDescription and InstalledPackageInfo.


{- All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of the University nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

-- This module is meant to be local-only to Distribution...

-- #hide
module Distribution.ParseUtils (
47
48
        LineNo, PError(..), locatedErrorMsg, showError, syntaxError, warning,
	runP, ParseResult(..),
simonmar's avatar
simonmar committed
49
	StanzaField(..), splitStanzas, Stanza, singleStanza,
ijones's avatar
ijones committed
50
	parseFilePathQ, parseTokenQ,
51
52
	parseModuleNameQ, parseDependency, parseOptVersion,
	parsePackageNameQ, parseVersionRangeQ,
53
	parseTestedWithQ, parseLicenseQ, parseExtensionQ, parseCommaList, parseOptCommaList,
ijones's avatar
ijones committed
54
55
	showFilePath, showToken, showTestedWith, showDependency, showFreeText,
	simpleField, listField, commaListField, optsField, 
56
	parseReadS, parseQuoted,
simonmar's avatar
simonmar committed
57
58
59
  ) where

import Text.PrettyPrint.HughesPJ
ijones's avatar
ijones committed
60
import Distribution.Compiler (CompilerFlavor)
simonmar's avatar
simonmar committed
61
62
63
64
import Distribution.License
import Distribution.Version
import Distribution.Package	( parsePackageName )
import Distribution.Compat.ReadP as ReadP hiding (get)
ijones's avatar
ijones committed
65
66
import Distribution.Compat.FilePath (platformPath)
import Control.Monad (liftM)
simonmar's avatar
simonmar committed
67
import Data.Char
ijones's avatar
ijones committed
68
import Language.Haskell.Extension (Extension)
simonmar's avatar
simonmar committed
69
70
71
72
73
74
75
76
77
78

-- -----------------------------------------------------------------------------

type LineNo = Int

data PError = AmbigousParse String LineNo
            | NoParse String LineNo
            | FromString String (Maybe LineNo)
        deriving Show

79
80
81
type PWarning = String

data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
82
83
84
        deriving Show

instance Monad ParseResult where
85
	return x = ParseOk [] x
86
	ParseFailed err >>= _ = ParseFailed err
87
88
89
	ParseOk ws x >>= f = case f x of
	                       ParseFailed err -> ParseFailed err
			       ParseOk ws' x' -> ParseOk (ws'++ws) x'
90
	fail s = ParseFailed (FromString s Nothing)
simonmar's avatar
simonmar committed
91

92
runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a
simonmar's avatar
simonmar committed
93
94
runP lineNo field p s =
  case [ x | (x,"") <- results ] of
95
    [a] -> ParseOk [] a
simonmar's avatar
simonmar committed
96
    []  -> case [ x | (x,ys) <- results, all isSpace ys ] of
97
             [a] -> ParseOk [] a
98
99
100
             []  -> ParseFailed (NoParse field lineNo)
             _   -> ParseFailed (AmbigousParse field lineNo)
    _   -> ParseFailed (AmbigousParse field lineNo)
simonmar's avatar
simonmar committed
101
102
  where results = readP_to_S p s

ijones's avatar
ijones committed
103
-- TODO: deprecated
simonmar's avatar
simonmar committed
104
showError :: PError -> String
ijones's avatar
ijones committed
105
106
107
108
showError e =
  case locatedErrorMsg e of
    (Just n,  s) -> "Line "++show n++": " ++ s
    (Nothing, s) -> s
simonmar's avatar
simonmar committed
109

ijones's avatar
ijones committed
110
111
locatedErrorMsg :: PError -> (Maybe LineNo, String)
locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambigous parse in field '"++f++"'")
112
locatedErrorMsg (NoParse f n)       = (Just n, "Parse of field '"++f++"' failed: ")
ijones's avatar
ijones committed
113
114
115
116
locatedErrorMsg (FromString s n)    = (n, s)

syntaxError :: LineNo -> String -> ParseResult a
syntaxError n s = ParseFailed $ FromString s (Just n)
simonmar's avatar
simonmar committed
117

118
119
120
warning :: String -> ParseResult ()
warning s = ParseOk [s] ()

simonmar's avatar
simonmar committed
121
122
123
124
data StanzaField a 
  = StanzaField 
      { fieldName     :: String
      , fieldGet      :: a -> Doc
125
      , fieldSet      :: LineNo -> String -> a -> ParseResult a
simonmar's avatar
simonmar committed
126
127
128
129
      }

simpleField :: String -> (a -> Doc) -> (ReadP a a) -> (b -> a) -> (a -> b -> b) -> StanzaField b
simpleField name showF readF get set = StanzaField name
ijones's avatar
ijones committed
130
   (\st -> showF (get st))
simonmar's avatar
simonmar committed
131
132
133
134
   (\lineNo val st -> do
       x <- runP lineNo name readF val
       return (set x st))

ijones's avatar
ijones committed
135
136
137
138
139
140
141
commaListField :: String -> (a -> Doc) -> (ReadP [a] a) -> (b -> [a]) -> ([a] -> b -> b) -> StanzaField b
commaListField name showF readF get set = StanzaField name
   (\st -> fsep (punctuate comma (map showF (get st))))
   (\lineNo val st -> do
       xs <- runP lineNo name (parseCommaList readF) val
       return (set xs st))

simonmar's avatar
simonmar committed
142
143
listField :: String -> (a -> Doc) -> (ReadP [a] a) -> (b -> [a]) -> ([a] -> b -> b) -> StanzaField b
listField name showF readF get set = StanzaField name
ijones's avatar
ijones committed
144
   (\st -> fsep (map showF (get st)))
simonmar's avatar
simonmar committed
145
   (\lineNo val st -> do
ijones's avatar
ijones committed
146
       xs <- runP lineNo name (parseOptCommaList readF) val
simonmar's avatar
simonmar committed
147
148
149
150
151
       return (set xs st))

optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> StanzaField b
optsField name flavor get set = StanzaField name
   (\st -> case lookup flavor (get st) of
ijones's avatar
ijones committed
152
        Just args -> hsep (map text args)
simonmar's avatar
simonmar committed
153
154
155
156
157
158
159
160
161
162
163
164
165
166
        Nothing   -> empty)
   (\_ val st -> 
       let
         old_val  = get st
         old_args = case lookup flavor old_val of
                       Just args -> args
                       Nothing   -> []
         val'     = filter (\(f,_) -> f/=flavor) old_val
       in return (set ((flavor,words val++old_args) : val') st))

type Stanza = [(LineNo,String,String)]

-- |Split a string into blank line-separated stanzas of
-- "Field: value" groups
167
splitStanzas :: String -> ParseResult [Stanza]
ijones's avatar
ijones committed
168
splitStanzas = mapM mkStanza . map merge . groupStanzas . filter validLine . zip [1..] . lines
simonmar's avatar
simonmar committed
169
170
171
172
173
174
175
176
  where validLine (_,s) = case dropWhile isSpace s of
                            '-':'-':_ -> False      -- Comment
                            _         -> True
        groupStanzas :: [(Int,String)] -> [[(Int,String)]]
        groupStanzas [] = []
        groupStanzas xs = let (ys,zs) = break allSpaces xs
                           in ys : groupStanzas (dropWhile allSpaces zs)

ijones's avatar
ijones committed
177
allSpaces :: (a, String) -> Bool
simonmar's avatar
simonmar committed
178
179
180
181
182
allSpaces (_,xs) = all isSpace xs

-- |Split a file into "Field: value" groups, but blank lines have no
-- significance, unlike 'splitStanzas'.  A field value may span over blank
-- lines.
183
singleStanza :: String -> ParseResult Stanza
ijones's avatar
ijones committed
184
singleStanza = mkStanza . merge . filter validLine . zip [1..] . lines
ijones's avatar
ijones committed
185
186
187
188
  where validLine (_,s) = case dropWhile isSpace s of
                            '-':'-':_ -> False      -- Comment
                            []        -> False      -- blank line
                            _         -> True
simonmar's avatar
simonmar committed
189

ijones's avatar
ijones committed
190
merge :: [(a, [Char])] -> [(a, [Char])]
simonmar's avatar
simonmar committed
191
192
193
194
195
196
197
merge ((n,x):(_,c:s):ys) 
  | c == ' ' || c == '\t' = case dropWhile isSpace s of
                               ('.':s') -> merge ((n,x++"\n"++s'):ys)
                               s'       -> merge ((n,x++"\n"++s'):ys)
merge ((n,x):ys) = (n,x) : merge ys
merge []         = []

ijones's avatar
ijones committed
198
199
200
201
202
mkStanza :: [(Int,String)] -> ParseResult Stanza
mkStanza []          = return []
mkStanza ((n,xs):ys) =
  case break (==':') xs of
    (fld', ':':val) -> do
ijones's avatar
ijones committed
203
       let fld'' = map toLower fld'
204
205
206
207
208
209
210
211
       fld <- case () of
                _ | fld'' == "hs-source-dir"
                           -> do warning "The field \"hs-source-dir\" is deprecated, please use hs-source-dirs."
                                 return "hs-source-dirs"
                  | fld'' == "other-files"
                           -> do warning "The field \"other-files\" is deprecated, please use extra-source-files."
                                 return "extra-source-files"
                  | otherwise -> return fld''
ijones's avatar
ijones committed
212
213
214
       ss <- mkStanza ys
       checkDuplField fld ss
       return ((n, fld, dropWhile isSpace val):ss)
ijones's avatar
ijones committed
215
    (_, _)       -> syntaxError n "Invalid syntax (no colon after field name)"
ijones's avatar
ijones committed
216
  where
ijones's avatar
ijones committed
217
218
    checkDuplField _ [] = return ()
    checkDuplField fld ((n',fld',_):xs')
ijones's avatar
ijones committed
219
      | fld' == fld = syntaxError (max n n') $ "The field "++fld++" was already defined on line " ++ show (min n n')
ijones's avatar
ijones committed
220
      | otherwise   = checkDuplField fld xs'
simonmar's avatar
simonmar committed
221
222

-- |parse a module name
223
parseModuleNameQ :: ReadP r String
ijones's avatar
ijones committed
224
225
parseModuleNameQ = parseQuoted modu <++ modu
 where modu = do 
226
227
228
	  c <- satisfy isUpper
	  cs <- munch (\x -> isAlphaNum x || x `elem` "_'.")
	  return (c:cs)
simonmar's avatar
simonmar committed
229

230
parseFilePathQ :: ReadP r FilePath
ijones's avatar
ijones committed
231
parseFilePathQ = liftM platformPath parseTokenQ
simonmar's avatar
simonmar committed
232
233
234
235
236

parseReadS :: Read a => ReadP r a
parseReadS = readS_to_P reads

parseDependency :: ReadP r Dependency
237
parseDependency = do name <- parsePackageNameQ
simonmar's avatar
simonmar committed
238
                     skipSpaces
239
                     ver <- parseVersionRangeQ <++ return AnyVersion
simonmar's avatar
simonmar committed
240
241
242
                     skipSpaces
                     return $ Dependency name ver

ijones's avatar
ijones committed
243
parsePackageNameQ :: ReadP r String
244
parsePackageNameQ = parseQuoted parsePackageName <++ parsePackageName 
ijones's avatar
ijones committed
245
246

parseVersionRangeQ :: ReadP r VersionRange
247
248
parseVersionRangeQ = parseQuoted parseVersionRange <++ parseVersionRange

simonmar's avatar
simonmar committed
249
parseOptVersion :: ReadP r Version
250
251
252
253
254
255
256
257
258
259
260
parseOptVersion = parseQuoted ver <++ ver
  where ver = parseVersion <++ return noVersion
	noVersion = Version{ versionBranch=[], versionTags=[] }

parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)
parseTestedWithQ = parseQuoted tw <++ tw
  where tw = do compiler <- parseReadS
		skipSpaces
		version <- parseVersionRange <++ return AnyVersion
		skipSpaces
		return (compiler,version)
simonmar's avatar
simonmar committed
261

262
263
parseLicenseQ :: ReadP r License
parseLicenseQ = parseQuoted parseReadS <++ parseReadS
simonmar's avatar
simonmar committed
264

265
266
267
268
-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a
-- because the "compat" version of ReadP isn't quite powerful enough.  In
-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a
-- Hence the trick above to make 'lic' polymorphic.
simonmar's avatar
simonmar committed
269

270
271
parseExtensionQ :: ReadP r Extension
parseExtensionQ = parseQuoted parseReadS <++ parseReadS
simonmar's avatar
simonmar committed
272

ijones's avatar
ijones committed
273
274
parseTokenQ :: ReadP r String
parseTokenQ = parseReadS <++ munch1 (\x -> not (isSpace x) && x /= ',')
simonmar's avatar
simonmar committed
275
276
277
278
279
280

parseCommaList :: ReadP r a -- ^The parser for the stuff between commas
               -> ReadP r [a]
parseCommaList p = sepBy p separator
    where separator = skipSpaces >> ReadP.char ',' >> skipSpaces

ijones's avatar
ijones committed
281
282
283
284
285
parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas
               -> ReadP r [a]
parseOptCommaList p = sepBy p separator
    where separator = skipSpaces >> optional (ReadP.char ',') >> skipSpaces

286
287
288
parseQuoted :: ReadP r a -> ReadP r a
parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p

simonmar's avatar
simonmar committed
289
290
291
292
-- --------------------------------------------
-- ** Pretty printing

showFilePath :: FilePath -> Doc
ijones's avatar
ijones committed
293
294
295
296
showFilePath = showToken

showToken :: String -> Doc
showToken str
297
298
 | not (any dodgy str) &&
   not (null str)       = text str
ijones's avatar
ijones committed
299
300
 | otherwise            = text (show str)
  where dodgy c = isSpace c || c == ','
simonmar's avatar
simonmar committed
301
302
303
304
305
306

showTestedWith :: (CompilerFlavor,VersionRange) -> Doc
showTestedWith (compiler,version) = text (show compiler ++ " " ++ showVersionRange version)

showDependency :: Dependency -> Doc
showDependency (Dependency name ver) = text name <+> text (showVersionRange ver)
307
308
309
310
311

-- | Pretty-print free-format text, ensuring that it is vertically aligned,
-- and with blank lines replaced by dots for correct re-parsing.
showFreeText :: String -> Doc
showFreeText s = vcat [text (if null l then "." else l) | l <- lines s]