/usr/lib/hugs/packages/HaXml/Text/ParserCombinators/TextParser.hs is in libhugs-haxml-bundled 98.200609.21-5.4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 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 158 159 160 161 162 163 164 165 | module Text.ParserCombinators.TextParser
( -- * The Parse class is a replacement for the Read class. It is a
-- specialisation of the (poly) Parser monad for String input.
TextParser -- synonym for Parser Char, i.e. string input, no state
, Parse(..) -- instances: (), (a,b), (a,b,c), Maybe a, Either a, [a],
-- Int, Integer, Float, Double, Char, Bool
, parseByRead -- :: Read a => String -> TextParser a
-- ** Combinators specific to string input, lexed haskell-style
, word -- :: TextParser String
, isWord -- :: String -> TextParser ()
, optionalParens -- :: TextParser a -> TextParser a
, field -- :: Parse a => String -> TextParser a
, constructors-- :: [(String,TextParser a)] -> TextParser a
, enumeration -- :: Show a => String -> [a] -> TextParser a
-- ** Re-export all the more general combinators too
, module Text.ParserCombinators.Poly
) where
import Char (isSpace)
import List (intersperse)
import Text.ParserCombinators.Poly
------------------------------------------------------------------------
-- | A synonym for Parser Char, i.e. string input (no state)
type TextParser a = Parser Char a
-- | The class @Parse@ is a replacement for @Read@, operating over String input.
-- Essentially, it permits better error messages for why something failed to
-- parse. It is rather important that @parse@ can read back exactly what
-- is generated by the corresponding instance of @show@.
class Parse a where
parse :: TextParser a
parseList :: TextParser [a] -- only to distinguish [] and ""
parseList = do { isWord "[]"; return [] }
`onFail`
do { isWord "["; isWord "]"; return [] }
`onFail`
bracketSep (isWord "[") (isWord ",") (isWord "]") parse
`adjustErr` ("Expected a list, but\n"++)
-- | If there already exists a Read instance for a type, then we can make
-- a Parser for it, but with only poor error-reporting.
parseByRead :: Read a => String -> TextParser a
parseByRead name =
P (\s-> case reads s of
[] -> (Left (False,"no parse, expected a "++name), s)
[(a,s')] -> (Right a, s')
_ -> (Left (False,"ambiguous parse, expected a "++name), s)
)
-- | One lexical chunk (Haskell-style lexing).
word :: TextParser String
word = P (\s-> case lex s of
[] -> (Left (False,"no input? (impossible)"), s)
[("",s')] -> (Left (False,"no input?"), s')
((x,s'):_) -> (Right x, s') )
-- | Ensure that the next input word is a given string. (Note the input
-- is lexed as haskell, so wordbreaks at spaces, symbols, etc.)
isWord :: String -> TextParser String
isWord w = do { w' <- word
; if w'==w then return w else fail ("expected "++w++" got "++w')
}
-- | Allow true string parens around an item.
optionalParens :: TextParser a -> TextParser a
optionalParens p = bracket (isWord "(") (isWord ")") p `onFail` p
-- | Deal with named field syntax.
field :: Parse a => String -> TextParser a
field name = do { isWord name; commit $ do { isWord "="; parse } }
-- | Parse one of a bunch of alternative constructors.
constructors :: [(String,TextParser a)] -> TextParser a
constructors cs = oneOf' (map cons cs)
where cons (name,p) =
( name
, do { isWord name
; p `adjustErrBad` (("got constructor, but within "
++name++",\n")++)
}
)
-- | Parse one of the given nullary constructors (an enumeration).
enumeration :: (Show a) => String -> [a] -> TextParser a
enumeration typ cs = oneOf (map (\c-> do { isWord (show c); return c }) cs)
`adjustErr`
(++("\n expected "++typ++" value ("++e++")"))
where e = concat (intersperse ", " (map show (init cs)))
++ ", or " ++ show (last cs)
------------------------------------------------------------------------
-- Instances for all the Standard Prelude types.
-- Basic types
instance Parse Int where
parse = parseByRead "Int"
instance Parse Integer where
parse = parseByRead "Integer"
instance Parse Float where
parse = parseByRead "Float"
instance Parse Double where
parse = parseByRead "Double"
instance Parse Char where
parse = parseByRead "Char"
-- parseList = bracket (isWord "\"") (satisfy (=='"'))
-- (many (satisfy (/='"')))
-- not totally correct for strings...
parseList = do { w <- word; if head w == '"' then return w
else fail "not a string" }
instance Parse Bool where
parse = enumeration "Bool" [False,True]
instance Parse Ordering where
parse = enumeration "Ordering" [LT,EQ,GT]
-- Structural types
instance Parse () where
parse = P p
where p [] = (Left (False,"no input: expected a ()"), [])
p ('(':cs) = case dropWhile isSpace cs of
(')':s) -> (Right (), s)
_ -> (Left (False,"Expected ) after ("), cs)
p (c:cs) | isSpace c = p cs
| otherwise = ( Left (False,"Expected a (), got "++show c)
, (c:cs))
instance (Parse a, Parse b) => Parse (a,b) where
parse = do{ isWord "(" `adjustErr` ("Opening a 2-tuple\n"++)
; x <- parse `adjustErr` ("In 1st item of a 2-tuple\n"++)
; isWord "," `adjustErr` ("Separating a 2-tuple\n"++)
; y <- parse `adjustErr` ("In 2nd item of a 2-tuple\n"++)
; isWord ")" `adjustErr` ("Closing a 2-tuple\n"++)
; return (x,y) }
instance (Parse a, Parse b, Parse c) => Parse (a,b,c) where
parse = do{ isWord "(" `adjustErr` ("Opening a 3-tuple\n"++)
; x <- parse `adjustErr` ("In 1st item of a 3-tuple\n"++)
; isWord "," `adjustErr` ("Separating(1) a 3-tuple\n"++)
; y <- parse `adjustErr` ("In 2nd item of a 3-tuple\n"++)
; isWord "," `adjustErr` ("Separating(2) a 3-tuple\n"++)
; z <- parse `adjustErr` ("In 3rd item of a 3-tuple\n"++)
; isWord ")" `adjustErr` ("Closing a 3-tuple\n"++)
; return (x,y,z) }
instance Parse a => Parse (Maybe a) where
parse = do { isWord "Nothing"; return Nothing }
`onFail`
do { isWord "Just"
; fmap Just $ optionalParens parse
`adjustErrBad` ("but within Just, "++)
}
`adjustErr` (("expected a Maybe (Just or Nothing)\n"++).indent 2)
instance (Parse a, Parse b) => Parse (Either a b) where
parse = constructors [ ("Left", do { fmap Left $ optionalParens parse } )
, ("Right", do { fmap Right $ optionalParens parse } )
]
instance Parse a => Parse [a] where
parse = parseList
------------------------------------------------------------------------
|