Fri Sep 30 16:48:29 WEST 2005 Malcolm.Wallace@cs.york.ac.uk
* split InfoKind class, introduce Parse class
The InfoKind class was trying to do too much. Split off the parsing bit
into a new class Parse, as a replacement for the Read class where that
was previously used. Should give better error messages.
{
hunk ./Makefile 23
- src/Shape.hs src/Palette.hs src/InfoKind.hs \
+ src/Shape.hs src/Palette.hs \
+ src/Parse.hs src/InfoKind.hs \
hunk ./Makefile 176
+src/NetworkControl.o : src/Parse.hi
hunk ./Makefile 211
+src/Parse.o : src/Parse.hs
hunk ./Makefile 213
+src/InfoKind.o : src/Parse.hi
hunk ./src/InfoKind.hs 3
+import Parse
hunk ./src/InfoKind.hs 11
-class (Eq a, Read a, Show a, Haskell2XmlNew a) => InfoKind a where
+class (Eq a, Show a, Parse a, Haskell2XmlNew a) => InfoKind a where
hunk ./src/InfoKind.hs 13
- parse :: String -> Either String a -- alternative to read?
- splat :: Maybe a -> String -- alternative to show?
- check :: Maybe a -> [String] -- returns warnings
+ check :: String -> a -> [String] -- returns warnings
+ -- ^ first arg is label of blob, for error reporting
hunk ./src/InfoKind.hs 19
- check Nothing = ["Info field is missing"]
- check (Just _) = []
+ check _ () = []
+-- Assume that info is mandatory, but not supplied a priori.
+instance InfoKind a => InfoKind (Maybe a) where
+ blank = Nothing
+ check n Nothing = ["No info value stored with "++n]
+ check n (Just a) = check n a
+
hunk ./src/InfoKind.hs 28
--- Possible instances for other simple types.
-instance InfoKind String where
- blank = ""
-instance InfoKind Int where
- blank = 0
-instance InfoKind Double where
- blank = 0
--}
+class (Eq a, Parse a, Show a, Haskell2XmlNew a) => InfoKind a g where
+ -- g is global datatype possibly related to a.
+ blank :: a
+ check :: String -> g -> a -> [String]
+ -- in the case of a==FaultTransform, g==[String] meaning all faults.
+ -- no parse or splat, use Parse and Show instances instead.
hunk ./src/InfoKind.hs 35
--- Example of an aggregated instance
-instance InfoKind a => InfoKind [a] where
- blank = [blank]
+class (Eq c, Parse c, Show c, Haskell2XmlNew c
+ , Eq g, Parse g, Show g, Haskell2XmlNew g,
+ , Eq e, Parse e, Show e, Haskell2XmlNew e) => InfoKind c g e where
+-- c = component info type
+-- g = global info type
+-- e = edge info type
+-}
hunk ./src/NetworkControl.hs 27
+import Parse
hunk ./src/NetworkControl.hs 274
- case reads newInfo of
- [(x,"")] ->
- do{ PD.updateDocument "edit node info"
+ case Parse.runParser Parse.parse newInfo of
+ (Right x, s) ->
+ do{ when (not (null s)) $
+ errorDialog theFrame "Edit warning"
+ ("Excess text after parsed value."
+ ++"\nRemaining text: "++s)
+ ; case check (Node.getName (getNode nodeNr network)) (Just x) of
+ [] -> return ()
+ e -> errorDialog theFrame "Validity warning"
+ ("Validity check fails:\n"
+ ++unlines e)
+ ; PD.updateDocument "edit node info"
hunk ./src/NetworkControl.hs 290
- _ -> errorDialog theFrame "Edit warning"
- ("Cannot parse entered text")
+ (Left err,s) -> errorDialog theFrame "Edit warning"
+ ("Cannot parse entered text."
+ ++"\nReason: "++err
+ ++"\nRemaining text: "++s)
addfile ./src/Parse.hs
hunk ./src/Parse.hs 1
+module Parse where
+
+import Char (isSpace)
+
+-- | The @Parser@ datatype is a fairly generic parsing monad with error
+-- reporting. Used in the @Parse@ class, it is intended as a more
+-- flexible replacement for the @Read@ class.
+data Parser t a = P ([t] -> (Either String a, [t]))
+runParser :: Parser t a -> [t] -> (Either String a, [t])
+runParser (P p) = p
+instance Functor (Parser t) where
+ fmap f (P p) = P (\ts-> case p ts of
+ (Left msg, ts') -> (Left msg, ts')
+ (Right x, ts') -> (Right (f x), ts'))
+instance Monad (Parser t) where
+ return x = P (\ts-> (Right x, ts))
+ (P f) >>= g = P (\ts-> case f ts of
+ (Left msg, ts') -> (Left msg, ts')
+ (Right x, ts') -> let (P g') = g x in g' ts')
+ fail s = P (\ts-> (Left s, ts))
+
+-- The class @Parse@ is a replacement for @Read@. 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 Read a => Parse a where
+ parse :: Parser Char a
+ -- default method re-uses the Read class, but custom instances ought to
+ -- use more intelligence.
+ parse = P (\ts-> case reads ts of
+ [] -> (Left "no parse", ts)
+ [(a,xs)] -> (Right a, xs)
+ _ -> (Left "ambiguous parse", ts) )
+
+instance Parse () where
+ parse = P p
+ where p [] = (Left "no input: expected a ()", [])
+ p ('(':cs) = case dropWhile isSpace cs of
+ (')':s) -> (Right (), s)
+ _ -> (Left "Expected ) after (", cs)
+ p (c:cs) | isSpace c = p cs
+ | otherwise = (Left ("Expected a (), got "++show c), c:cs)
+instance (Read a, Parse a) => Parse (Maybe a) where
+ parse = P p
+ where p [] = (Left "no input: expected a Maybe value", [])
+ p ts = case reads ts of
+ [] -> (Left "no parse, expected a Maybe", ts)
+ [(a,xs)] -> (Right a, xs)
+ _ -> (Left "ambiguous parse for Maybe", ts)
+
+
+-- * Some combinators helpful for parsing
+
+-- | One lexical chunk
+word :: Parser Char String
+word = P (\s-> case lex s of
+ [("",s')] -> (Left "no input?", s')
+ ((x,s'):_) -> (Right x, s') )
+
+addToErr :: Parser t a -> String -> Parser t a
+(P p) `addToErr` m = P (\ts-> case p ts of
+ (Left msg, ts') -> (Left (m++"\n\t"++msg), ts')
+ right -> right )
+
+infixl 6 `onfail`
+onfail :: Parser t a -> Parser t a -> Parser t a
+(P p) `onfail` (P q) = P (\ts-> case p ts of
+ (Left _, _) -> q ts
+ right -> right )
+
+isWord :: String -> Parser Char ()
+isWord w = do { w' <- word
+ ; if w'==w then return () else fail ("expected "++w++" got "++w')
+ }
+
+many :: Parser t a -> Parser t [a]
+many p = do { x <- p
+ ; xs <- many p `onfail` return []
+ ; return (x:xs)
+ }
+ `onfail` return []
+
+many1 :: Parser t a -> Parser t [a]
+many1 p = do { x <- p
+ ; xs <- many p
+ ; return (x:xs)
+ }
+ `addToErr` ("when looking for at least one:")
+
+bracketSep :: Parser t bra -> Parser t sep -> Parser t ket
+ -> Parser t a -> Parser t [a]
+bracketSep bra sep ket p =
+ do { bra `addToErr` "missing opening bracket"
+ ; x <- p `addToErr` "after first bracket in a group"
+ ; xs <- many (do {sep; p})
+ ; ket `addToErr` "when looking for closing bracket"
+ ; return (x:xs)
+ }
+
+bracket :: Parser t bra -> Parser t ket -> Parser t a -> Parser t a
+bracket bra ket p = do
+ do { bra `addToErr` "missing opening bracket"
+ ; x <- p
+ ; ket `addToErr` "missing closing bracket"
+ ; return x
+ }
+
+optionParens :: Parser Char a -> Parser Char a
+optionParens p = bracket (isWord "(") (isWord ")") p `onfail` p
+
}