ParseUtils.hs 10.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
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,
50
51
52
53
	parseFilePathQ, parseLibNameQ,
	parseModuleNameQ, parseDependency, parseOptVersion,
	parsePackageNameQ, parseVersionRangeQ,
	parseTestedWithQ, parseLicenseQ, parseExtensionQ, parseCommaList,
54
	showFilePath, showTestedWith, showDependency, showFreeText,
ijones's avatar
ijones committed
55
	simpleField, listField, optsField, 
56
	parseReadS, parseQuoted,
simonmar's avatar
simonmar committed
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
  ) 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(..))

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
111

data StanzaField a 
  = StanzaField 
      { fieldName     :: String
      , fieldShow     :: a -> Doc
      , fieldGet      :: a -> Doc
112
      , fieldSet      :: LineNo -> String -> a -> ParseResult a
simonmar's avatar
simonmar committed
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
      }

simpleField :: String -> (a -> Doc) -> (ReadP a a) -> (b -> a) -> (a -> b -> b) -> StanzaField b
simpleField name showF readF get set = StanzaField name
   (\st -> text name <> colon <+> showF (get st))
   (showF . get)
   (\lineNo val st -> do
       x <- runP lineNo name readF val
       return (set x st))

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

ijones's avatar
ijones committed
181
merge :: [(a, [Char])] -> [(a, [Char])]
simonmar's avatar
simonmar committed
182
183
184
185
186
187
188
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
189
190
191
192
193
194
195
196
197
198
199
mkStanza :: [(Int,String)] -> ParseResult Stanza
mkStanza []          = return []
mkStanza ((n,xs):ys) =
  case break (==':') xs of
    (fld', ':':val) -> do
       let fld = map toLower fld'
       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
200
201
    checkDuplField _ [] = return ()
    checkDuplField fld ((n',fld',_):xs')
ijones's avatar
ijones committed
202
203
      | 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
204
205

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

213
214
parseFilePathQ :: ReadP r FilePath
parseFilePathQ = parseReadS <++ (munch1 (\x -> isAlphaNum x || x `elem` "-+/_."))
simonmar's avatar
simonmar committed
215
216
217
218
219

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

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

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

parseVersionRangeQ :: ReadP r VersionRange
230
231
parseVersionRangeQ = parseQuoted parseVersionRange <++ parseVersionRange

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

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

248
249
250
251
-- 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
252

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

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

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

264
265
266
parseQuoted :: ReadP r a -> ReadP r a
parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p

simonmar's avatar
simonmar committed
267
268
269
270
271
-- --------------------------------------------
-- ** Pretty printing

showFilePath :: FilePath -> Doc
showFilePath fpath
272
273
274
275
276
277
	| all (\x -> isAlphaNum x || x `elem` "-+/_.") fpath = text (replaceSlash fpath)
	| otherwise = doubleQuotes (text (replaceSlash fpath))
        where
        replaceSlash s = case break (== '\\') s of
                         (a, (h:t)) -> a ++ (h:h:(replaceSlash t))
                         (a, []) -> a
simonmar's avatar
simonmar committed
278
279
280
281
282
283

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

showDependency :: Dependency -> Doc
showDependency (Dependency name ver) = text name <+> text (showVersionRange ver)
284
285
286
287
288

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