ParseUtils.hs 11.2 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 (
ijones's avatar
ijones committed
47
        LineNo, PError(..), locatedErrorMsg, showError, syntaxError, 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
  ) 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
import Debug.Trace
simonmar's avatar
simonmar committed
66
import Data.Char
ijones's avatar
ijones committed
67
import Language.Haskell.Extension (Extension)
simonmar's avatar
simonmar committed
68
69
70
71
72
73
74
75
76
77

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

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
  where results = readP_to_S p s

ijones's avatar
ijones committed
98
-- TODO: deprecated
simonmar's avatar
simonmar committed
99
showError :: PError -> String
ijones's avatar
ijones committed
100
101
102
103
showError e =
  case locatedErrorMsg e of
    (Just n,  s) -> "Line "++show n++": " ++ s
    (Nothing, s) -> s
simonmar's avatar
simonmar committed
104

ijones's avatar
ijones committed
105
106
107
108
109
110
111
locatedErrorMsg :: PError -> (Maybe LineNo, String)
locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambigous parse in field '"++f++"'")
locatedErrorMsg (NoParse f n)       = (Just n, "Parse of field '"++f++"' failed")
locatedErrorMsg (FromString s n)    = (n, s)

syntaxError :: LineNo -> String -> ParseResult a
syntaxError n s = ParseFailed $ FromString s (Just n)
simonmar's avatar
simonmar committed
112
113
114
115
116

data StanzaField a 
  = StanzaField 
      { fieldName     :: String
      , fieldGet      :: a -> Doc
117
      , fieldSet      :: LineNo -> String -> a -> ParseResult a
simonmar's avatar
simonmar committed
118
119
120
121
      }

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
122
   (\st -> showF (get st))
simonmar's avatar
simonmar committed
123
124
125
126
   (\lineNo val st -> do
       x <- runP lineNo name readF val
       return (set x st))

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

ijones's avatar
ijones committed
182
merge :: [(a, [Char])] -> [(a, [Char])]
simonmar's avatar
simonmar committed
183
184
185
186
187
188
189
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
190
191
192
193
194
mkStanza :: [(Int,String)] -> ParseResult Stanza
mkStanza []          = return []
mkStanza ((n,xs):ys) =
  case break (==':') xs of
    (fld', ':':val) -> do
ijones's avatar
ijones committed
195
196
197
198
       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
199
200
201
       ss <- mkStanza ys
       checkDuplField fld ss
       return ((n, fld, dropWhile isSpace val):ss)
ijones's avatar
ijones committed
202
    (_, _)       -> syntaxError n "Invalid syntax (no colon after field name)"
ijones's avatar
ijones committed
203
  where
ijones's avatar
ijones committed
204
205
    checkDuplField _ [] = return ()
    checkDuplField fld ((n',fld',_):xs')
ijones's avatar
ijones committed
206
      | fld' == fld = syntaxError (max n n') $ "The field "++fld++" was already defined on line " ++ show (min n n')
ijones's avatar
ijones committed
207
      | otherwise   = checkDuplField fld xs'
simonmar's avatar
simonmar committed
208
209

-- |parse a module name
210
parseModuleNameQ :: ReadP r String
ijones's avatar
ijones committed
211
212
parseModuleNameQ = parseQuoted modu <++ modu
 where modu = do 
213
214
215
	  c <- satisfy isUpper
	  cs <- munch (\x -> isAlphaNum x || x `elem` "_'.")
	  return (c:cs)
simonmar's avatar
simonmar committed
216

217
parseFilePathQ :: ReadP r FilePath
ijones's avatar
ijones committed
218
parseFilePathQ = parseTokenQ
simonmar's avatar
simonmar committed
219
220
221
222
223

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

parseDependency :: ReadP r Dependency
224
parseDependency = do name <- parsePackageNameQ
simonmar's avatar
simonmar committed
225
                     skipSpaces
226
                     ver <- parseVersionRangeQ <++ return AnyVersion
simonmar's avatar
simonmar committed
227
228
229
                     skipSpaces
                     return $ Dependency name ver

ijones's avatar
ijones committed
230
parsePackageNameQ :: ReadP r String
231
parsePackageNameQ = parseQuoted parsePackageName <++ parsePackageName 
ijones's avatar
ijones committed
232
233

parseVersionRangeQ :: ReadP r VersionRange
234
235
parseVersionRangeQ = parseQuoted parseVersionRange <++ parseVersionRange

simonmar's avatar
simonmar committed
236
parseOptVersion :: ReadP r Version
237
238
239
240
241
242
243
244
245
246
247
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
248

249
250
parseLicenseQ :: ReadP r License
parseLicenseQ = parseQuoted parseReadS <++ parseReadS
simonmar's avatar
simonmar committed
251

252
253
254
255
-- 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
256

257
258
parseExtensionQ :: ReadP r Extension
parseExtensionQ = parseQuoted parseReadS <++ parseReadS
simonmar's avatar
simonmar committed
259

ijones's avatar
ijones committed
260
261
parseTokenQ :: ReadP r String
parseTokenQ = parseReadS <++ munch1 (\x -> not (isSpace x) && x /= ',')
simonmar's avatar
simonmar committed
262
263
264
265
266
267

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
268
269
270
271
272
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

273
274
275
parseQuoted :: ReadP r a -> ReadP r a
parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p

simonmar's avatar
simonmar committed
276
277
278
279
-- --------------------------------------------
-- ** Pretty printing

showFilePath :: FilePath -> Doc
ijones's avatar
ijones committed
280
281
282
283
showFilePath = showToken

showToken :: String -> Doc
showToken str
284
285
 | not (any dodgy str) &&
   not (null str)       = text str
ijones's avatar
ijones committed
286
287
 | otherwise            = text (show str)
  where dodgy c = isSpace c || c == ','
simonmar's avatar
simonmar committed
288
289
290
291
292
293

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

showDependency :: Dependency -> Doc
showDependency (Dependency name ver) = text name <+> text (showVersionRange ver)
294
295
296
297
298

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