ParseUtils.hs 11.3 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 Distribution.Compat.FilePath (platformPath)
ijones's avatar
ijones committed
66
import Debug.Trace
ijones's avatar
ijones committed
67
import Control.Monad (liftM)
simonmar's avatar
simonmar committed
68
import Data.Char
ijones's avatar
ijones committed
69
import Language.Haskell.Extension (Extension)
simonmar's avatar
simonmar committed
70
71
72
73
74
75
76
77
78
79

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

type LineNo = Int

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

80
81
82
83
84
85
86
87
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
88

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

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

ijones's avatar
ijones committed
107
108
109
110
111
112
113
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
114
115
116
117
118

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

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

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

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

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

219
parseFilePathQ :: ReadP r FilePath
ijones's avatar
ijones committed
220
parseFilePathQ = liftM platformPath parseTokenQ
simonmar's avatar
simonmar committed
221
222
223
224
225

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

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

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

parseVersionRangeQ :: ReadP r VersionRange
236
237
parseVersionRangeQ = parseQuoted parseVersionRange <++ parseVersionRange

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

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

254
255
256
257
-- 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
258

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

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

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
270
271
272
273
274
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

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

simonmar's avatar
simonmar committed
278
279
280
281
-- --------------------------------------------
-- ** Pretty printing

showFilePath :: FilePath -> Doc
ijones's avatar
ijones committed
282
283
284
285
showFilePath = showToken

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

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

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

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