ParseUtils.hs 11 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
47
-----------------------------------------------------------------------------
-- |
-- 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 (
	LineNo, PError(..), showError, myError, runP,
48
	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
60
61
62
63
64
65
  ) where

import Text.PrettyPrint.HughesPJ
import Distribution.License
import Distribution.Version
import Distribution.Extension
import Distribution.Package	( parsePackageName )
import Distribution.Compat.ReadP as ReadP hiding (get)
import Distribution.Setup(CompilerFlavor(..))
ijones's avatar
ijones committed
66
import Debug.Trace
simonmar's avatar
simonmar committed
67
68
69
70
71
72
73
74
75
76
77
import Data.Char

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

type LineNo = Int

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

78
79
80
81
82
83
84
85
data ParseResult a = ParseFailed PError | ParseOk a
        deriving Show

instance Monad ParseResult where
	return x = ParseOk x
	ParseFailed err >>= _ = ParseFailed err
	ParseOk x >>= f = f x
	fail s = ParseFailed (FromString s Nothing)
simonmar's avatar
simonmar committed
86

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

showError :: PError -> String
showError (AmbigousParse f n)     = "Line "++show n++": Ambigous parse in field '"++f++"'"
showError (NoParse f n)           = "Line "++show n++": Parse of field '"++f++"' failed"
showError (FromString s (Just n)) = "Line "++show n++": " ++ s
showError (FromString s Nothing)  = s

104
105
myError :: LineNo -> String -> ParseResult a
myError n s = ParseFailed $ FromString s (Just n)
simonmar's avatar
simonmar committed
106
107
108
109
110

data StanzaField a 
  = StanzaField 
      { fieldName     :: String
      , fieldGet      :: a -> Doc
111
      , fieldSet      :: LineNo -> String -> a -> ParseResult a
simonmar's avatar
simonmar committed
112
113
114
115
      }

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
116
   (\st -> showF (get st))
simonmar's avatar
simonmar committed
117
118
119
120
   (\lineNo val st -> do
       x <- runP lineNo name readF val
       return (set x st))

ijones's avatar
ijones committed
121
122
123
124
125
126
127
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
128
129
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
130
   (\st -> fsep (map showF (get st)))
simonmar's avatar
simonmar committed
131
   (\lineNo val st -> do
ijones's avatar
ijones committed
132
       xs <- runP lineNo name (parseOptCommaList readF) val
simonmar's avatar
simonmar committed
133
134
135
136
137
       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
138
        Just args -> hsep (map text args)
simonmar's avatar
simonmar committed
139
140
141
142
143
144
145
146
147
148
149
150
151
152
        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
153
splitStanzas :: String -> ParseResult [Stanza]
ijones's avatar
ijones committed
154
splitStanzas = mapM mkStanza . map merge . groupStanzas . filter validLine . zip [1..] . lines
simonmar's avatar
simonmar committed
155
156
157
158
159
160
161
162
  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
163
allSpaces :: (a, String) -> Bool
simonmar's avatar
simonmar committed
164
165
166
167
168
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.
169
singleStanza :: String -> ParseResult Stanza
ijones's avatar
ijones committed
170
singleStanza = mkStanza . merge . filter validLine . zip [1..] . lines
ijones's avatar
ijones committed
171
172
173
174
  where validLine (_,s) = case dropWhile isSpace s of
                            '-':'-':_ -> False      -- Comment
                            []        -> False      -- blank line
                            _         -> True
simonmar's avatar
simonmar committed
175

ijones's avatar
ijones committed
176
merge :: [(a, [Char])] -> [(a, [Char])]
simonmar's avatar
simonmar committed
177
178
179
180
181
182
183
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
184
185
186
187
188
mkStanza :: [(Int,String)] -> ParseResult Stanza
mkStanza []          = return []
mkStanza ((n,xs):ys) =
  case break (==':') xs of
    (fld', ':':val) -> do
ijones's avatar
ijones committed
189
190
191
192
       let fld'' = map toLower fld'
           fld | fld'' == "hs-source-dir"
                           = trace "The field \"hs-source-dir\" is deprecated, please use hs-source-dirs." "hs-source-dirs"
               | otherwise = fld''
ijones's avatar
ijones committed
193
194
195
196
197
       ss <- mkStanza ys
       checkDuplField fld ss
       return ((n, fld, dropWhile isSpace val):ss)
    (_, _)       -> fail $ "Line "++show n++": Invalid syntax (no colon after field name)"
  where
ijones's avatar
ijones committed
198
199
    checkDuplField _ [] = return ()
    checkDuplField fld ((n',fld',_):xs')
ijones's avatar
ijones committed
200
201
      | fld' == fld = fail ("The field "++fld++" is defined on both line "++show n++" and "++show n')
      | otherwise   = checkDuplField fld xs'
simonmar's avatar
simonmar committed
202
203

-- |parse a module name
204
parseModuleNameQ :: ReadP r String
ijones's avatar
ijones committed
205
206
parseModuleNameQ = parseQuoted modu <++ modu
 where modu = do 
207
208
209
	  c <- satisfy isUpper
	  cs <- munch (\x -> isAlphaNum x || x `elem` "_'.")
	  return (c:cs)
simonmar's avatar
simonmar committed
210

211
parseFilePathQ :: ReadP r FilePath
ijones's avatar
ijones committed
212
parseFilePathQ = parseTokenQ
simonmar's avatar
simonmar committed
213
214
215
216
217

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

parseDependency :: ReadP r Dependency
218
parseDependency = do name <- parsePackageNameQ
simonmar's avatar
simonmar committed
219
                     skipSpaces
220
                     ver <- parseVersionRangeQ <++ return AnyVersion
simonmar's avatar
simonmar committed
221
222
223
                     skipSpaces
                     return $ Dependency name ver

ijones's avatar
ijones committed
224
parsePackageNameQ :: ReadP r String
225
parsePackageNameQ = parseQuoted parsePackageName <++ parsePackageName 
ijones's avatar
ijones committed
226
227

parseVersionRangeQ :: ReadP r VersionRange
228
229
parseVersionRangeQ = parseQuoted parseVersionRange <++ parseVersionRange

simonmar's avatar
simonmar committed
230
parseOptVersion :: ReadP r Version
231
232
233
234
235
236
237
238
239
240
241
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
242

243
244
parseLicenseQ :: ReadP r License
parseLicenseQ = parseQuoted parseReadS <++ parseReadS
simonmar's avatar
simonmar committed
245

246
247
248
249
-- 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
250

251
252
parseExtensionQ :: ReadP r Extension
parseExtensionQ = parseQuoted parseReadS <++ parseReadS
simonmar's avatar
simonmar committed
253

ijones's avatar
ijones committed
254
255
parseTokenQ :: ReadP r String
parseTokenQ = parseReadS <++ munch1 (\x -> not (isSpace x) && x /= ',')
simonmar's avatar
simonmar committed
256
257
258
259
260
261

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
262
263
264
265
266
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

267
268
269
parseQuoted :: ReadP r a -> ReadP r a
parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p

simonmar's avatar
simonmar committed
270
271
272
273
-- --------------------------------------------
-- ** Pretty printing

showFilePath :: FilePath -> Doc
ijones's avatar
ijones committed
274
275
276
277
showFilePath = showToken

showToken :: String -> Doc
showToken str
278
279
 | not (any dodgy str) &&
   not (null str)       = text str
ijones's avatar
ijones committed
280
281
 | otherwise            = text (show str)
  where dodgy c = isSpace c || c == ','
simonmar's avatar
simonmar committed
282
283
284
285
286
287

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

showDependency :: Dependency -> Doc
showDependency (Dependency name ver) = text name <+> text (showVersionRange ver)
288
289
290
291
292

-- | 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]