Fri Oct 14 16:20:26 WEST 2005 Malcolm.Wallace@cs.york.ac.uk
* all parser combinators now from HaXml
Move from using several different sets of parser combinators to
exclusively use only those in HaXml-1.14. Ditch class Read for Palettes,
and now use class Parse from module Text.ParserCombinators.TextParser.
Ditch class Haskell2XmlNew, and now go with class XmlContent.
{
hunk ./Makefile 23
- src/Shape.hs src/Palette.hs \
- src/Parse.hs src/InfoKind.hs \
+ src/Shape.hs src/Palette.hs src/InfoKind.hs \
hunk ./Makefile 112
-src/GUIEvents.o : src/Parse.hi
hunk ./Makefile 149
+src/Constants.o : src/Colors.hi
hunk ./Makefile 157
-src/NetworkUI.o : src/Parse.hi
hunk ./Makefile 186
-src/NetworkControl.o : src/Parse.hi
hunk ./Makefile 199
-src/ContextMenu.o : src/Parse.hi
hunk ./Makefile 220
-src/Parse.o : src/Parse.hs
hunk ./Makefile 221
-src/InfoKind.o : src/Parse.hi
hunk ./Makefile 235
-src/FPTC/Expressions.o : src/Parse.hi
hunk ./Makefile 238
-src/FPTC/FaultSpec.o : src/Parse.hi
hunk ./src/Colors.hs 4
+import Text.ParserCombinators.TextParser
hunk ./src/Colors.hs 8
+
+instance Parse Colour where
+ parse = do { isWord "RGB"
+ ; return RGB `apply` parse `apply` parse `apply` parse
+ }
hunk ./src/ContextMenu.hs 15
-import Parse
+import Text.ParserCombinators.TextParser
hunk ./src/FPTC/Expressions.hs 3
-import Parse
+import Text.ParserCombinators.TextParser
hunk ./src/FPTC/Expressions.hs 8
-import Text.XML.HaXml.Haskell2XmlNew
+import Text.XML.HaXml.XmlContent
hunk ./src/FPTC/Expressions.hs 34
+{-
hunk ./src/FPTC/Expressions.hs 48
+-}
hunk ./src/FPTC/Expressions.hs 50
-
-instance Parse String where
- parse = word
hunk ./src/FPTC/Expressions.hs 53
- ; bracketSep (isWord "[") (isWord ",") (isWord "]") parse
+ ; bracketSep (isWord "[") (isWord ",") (isWord "]") word
hunk ./src/FPTC/Expressions.hs 56
+ parse = fmap FaultTransform $ many1 parse
hunk ./src/FPTC/Expressions.hs 68
+{-
hunk ./src/FPTC/Expressions.hs 78
+-}
hunk ./src/FPTC/Expressions.hs 81
- `Parse.onfail`
- (fmap (:[]) $ parse `addToErr` "lhs of FPTC clause")
- ; isWord "->" `Parse.onfail` fail "missing ->"
+ `onFail`
+ fmap (:[]) parse
+ `adjustErr` ("On lhs of FPTC clause\n"++)
+ ; isWord "->" `onFail` fail "missing ->"
hunk ./src/FPTC/Expressions.hs 86
- `Parse.onfail`
- (fmap (:[]) $ parse `addToErr` "rhs of FPTC clause")
+ `onFail`
+ fmap (:[]) parse
+ `adjustErr` ("On rhs of FPTC clause\n"++)
hunk ./src/FPTC/Expressions.hs 112
-instance Haskell2XmlNew FaultTransform where
+instance HTypeable FaultTransform where
hunk ./src/FPTC/Expressions.hs 114
+instance XmlContent FaultTransform where
hunk ./src/FPTC/Expressions.hs 116
- parseContents = fmap FaultTransform $ nonemptylist parseContents
-instance Haskell2XmlNew FaultClause where
+ parseContents = fmap FaultTransform $ many1 parseContents
+
+instance HTypeable FaultClause where
hunk ./src/FPTC/Expressions.hs 120
+instance XmlContent FaultClause where
hunk ./src/FPTC/Expressions.hs 125
- { ps <- element' ["Pattern"] $ nonemptylist parseContents
- ; qs <- element' ["Result"] $ nonemptylist parseContents
+ { ps <- inElement "Pattern" $ many1 parseContents
+ ; qs <- inElement "Result" $ many1 parseContents
hunk ./src/FPTC/Expressions.hs 129
-instance Haskell2XmlNew FaultModel where
+
+instance HTypeable FaultModel where
hunk ./src/FPTC/Expressions.hs 132
+instance XmlContent FaultModel where
hunk ./src/FPTC/Expressions.hs 136
- { fs <- element' ["FaultModel"] $ nonemptylist parseContents
+ { fs <- inElement "FaultModel" $ many1 parseContents
hunk ./src/FPTC/FaultSpec.hs 3
-import Parse
+import Text.ParserCombinators.TextParser
hunk ./src/FPTC/FaultSpec.hs 7
-import Text.XML.HaXml.Haskell2XmlNew as XML
+import Text.XML.HaXml.XmlContent as XML
hunk ./src/FPTC/FaultSpec.hs 38
-instance Read Fault
hunk ./src/FPTC/FaultSpec.hs 40
- `Parse.onfail`
+ `onFail`
hunk ./src/FPTC/FaultSpec.hs 42
- `Parse.onfail`
+ `onFail`
hunk ./src/FPTC/FaultSpec.hs 46
-instance Read (Spec a)
hunk ./src/FPTC/FaultSpec.hs 47
-{-
- parse s = case head (lex s) of
- ("",t) -> (Left "lexer ran out of input", t)
- ("_",t) -> (Right Wildcard, t)
- ("{",_) -> mapFst (either (Left . ("In a set, "++))
- (Right . Or)) $ parse s
- (_,_) -> mapFst (either (Left . ("When expecting a failure name or variable, "++))
- (Right . A)) $ parse s
--}
hunk ./src/FPTC/FaultSpec.hs 48
- `Parse.onfail`
+ `onFail`
hunk ./src/FPTC/FaultSpec.hs 50
- `Parse.onfail`
+ `onFail`
hunk ./src/FPTC/FaultSpec.hs 52
- `Parse.addToErr` "looking for _, {}, *, or fault"
+ `adjustErr` (++"\nlooking for _, {}, *, or fault")
hunk ./src/FPTC/FaultSpec.hs 54
---instance Read (Set a)
hunk ./src/FPTC/FaultSpec.hs 58
-{-
-instance Read Fault where
- readsPrec _ t = case head (lex t) of
- ("",_) -> []
- ("*",x) -> [(Normal, x)]
- ([c],x) -> [(Var c, x)]
- (s,x) -> [(Fault s, x)]
-instance (Read a, Ord a) => Read (Spec a) where
- readsPrec _ t = case head (lex t) of
- ("",_) -> []
- ("_",x) -> [ (Wildcard, x) ]
- ("{",_) -> [ (Or s, y) | (s,y) <- reads t ]
- (_,_) -> [ (A a, y) | (a,y) <- reads t ]
--- following only needed <= ghc 6.4.x, <= nhc98-1.18
-instance (Read a, Ord a) => Read (Set a) where
- readsPrec _ r = [ (Set.fromList xs, t)
- | (xs,t) <- readSequence "{" "," "}" r ]
--}
hunk ./src/FPTC/FaultSpec.hs 59
-instance Haskell2XmlNew Fault where
+instance HTypeable Fault where
hunk ./src/FPTC/FaultSpec.hs 63
+instance XmlContent Fault where
hunk ./src/FPTC/FaultSpec.hs 74
-instance (Haskell2XmlNew a, Ord a) => Haskell2XmlNew (Spec a) where
- toHType _ = let a = Defined "a" [] [] in
- Defined "Spec" [a] [ Constr "A" [a] [a]
- , Constr "Wildcard" [] []
- , Constr "Or" [a]
- [Defined "Set" [a] []] ]
+instance (HTypeable a) => HTypeable (Spec a) where
+ toHType x = Defined "Spec" [ha] [ Constr "A" [ha] [ha]
+ , Constr "Wildcard" [] []
+ , Constr "Or" [ha] [hb] ]
+ where ha = toHType $ (\ (A a)->a) $ x
+ hb = toHType $ (\ (Or a)->a) $ x
+instance (XmlContent a, Ord a) => XmlContent (Spec a) where
hunk ./src/FPTC/FaultSpec.hs 91
-instance (Haskell2XmlNew a, Ord a) => Haskell2XmlNew (Set a) where
- toHType _ = Defined "Set" [Defined "a" [] []] []
+instance (HTypeable a) => HTypeable (Set a) where
+ toHType s = Defined "Set" [toHType x] []
+ where x = head (Set.toList s)
+instance (XmlContent a, Ord a) => XmlContent (Set a) where
hunk ./src/FPTC/FaultSpec.hs 96
- parseContents = fmap Set.fromList (list parseContents)
+ parseContents = fmap Set.fromList (many parseContents)
hunk ./src/GUIEvents.hs 12
-import Parse
+import Text.ParserCombinators.TextParser
hunk ./src/InfoKind.hs 3
-import Parse
-import Text.XML.HaXml.Haskell2XmlNew
+import Text.ParserCombinators.TextParser
+import Text.XML.HaXml.XmlContent
hunk ./src/InfoKind.hs 12
-
-class (Eq a, Show a, Parse a, Haskell2XmlNew a) => InfoKind a g | a -> g where
+class (Eq a, Show a, Parse a, XmlContent a) => InfoKind a g | a -> g where
hunk ./src/Math.hs 18
+import Text.ParserCombinators.TextParser
hunk ./src/Math.hs 29
+
+instance Parse DoublePoint where
+ parse = do { isWord "DoublePoint"
+ ; return DoublePoint `apply` parse `apply` parse
+ }
hunk ./src/NetworkControl.hs 28
-import Parse
+import Text.ParserCombinators.TextParser as Parse
hunk ./src/NetworkControl.hs 275
- case Parse.runParser Parse.parse newInfo of
- (Right x, s) ->
+ case Parse.runParser Parse.parse () newInfo of
+ (Right x, _, s) ->
hunk ./src/NetworkControl.hs 292
- (Left err,s) -> errorDialog theFrame "Edit warning"
- ("Cannot parse entered text."
- ++"\nReason: "++err
- ++"\nRemaining text: "++s)
+ (Left err, _, s) -> errorDialog theFrame "Edit warning"
+ ("Cannot parse entered text."
+ ++"\nReason: "++err
+ ++"\nRemaining text: "++s)
hunk ./src/NetworkControl.hs 308
- case Parse.runParser Parse.parse newInfo of
- (Right x, s) ->
+ case Parse.runParser Parse.parse () newInfo of
+ (Right x, _, s) ->
hunk ./src/NetworkControl.hs 318
- (Left err,s) -> errorDialog theFrame "Edit warning"
- ("Cannot parse entered text."
- ++"\nReason: "++err
- ++"\nRemaining text: "++s)
+ (Left err, _, s) -> errorDialog theFrame "Edit warning"
+ ("Cannot parse entered text."
+ ++"\nReason: "++err
+ ++"\nRemaining text: "++s)
hunk ./src/NetworkFile.hs 15
-import Text.XML.HaXml.Haskell2XmlNew as XML
+import Text.XML.HaXml.XmlContent as XML
hunk ./src/NetworkFile.hs 23
-import List(nub)
+import List(nub,isPrefixOf)
hunk ./src/NetworkFile.hs 26
-toString :: (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+toString :: (InfoKind n g, InfoKind e g, XmlContent g) =>
hunk ./src/NetworkFile.hs 38
-fromString :: (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+fromString :: (InfoKind n g, InfoKind e g, XmlContent g) =>
hunk ./src/NetworkFile.hs 44
- case runXMLParser parseContents [CElem e noPos] of
- Left err -> Left err -- secondary (typeful) parse error
- Right (v,_) -> Right (v,[],False)
+ case runParser parseContents () [CElem e noPos] of
+ (Left err, _, _) -> Left err -- secondary (typeful) parse error
+ (Right v, _, _) -> Right (v,[],False)
hunk ./src/NetworkFile.hs 86
-instance (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
- Haskell2XmlNew (Network g n e) where
- toHType _ =
- Defined "Network" []
- [Constr "Network" [] []]
+instance HTypeable (Network g n e) where
+ toHType _ = Defined "Network" [] [Constr "Network" [] []]
+instance (InfoKind n g, InfoKind e g, XmlContent g) =>
+ XmlContent (Network g n e) where
hunk ./src/NetworkFile.hs 104
- { element' ["Network"] $ do
- { w <- element' ["Width"] $ fmap read XML.text
- ; h <- element' ["Height"] $ fmap read XML.text
- ; i <- element' ["Info"] $ parseContents
- ; ns <- element' ["Nodes"] $ nonemptylist parseContents
- ; es <- element' ["Edges"] $ nonemptylist parseContents
+ { inElement "Network" $ do
+ { w <- inElement "Width" $ fmap read XML.text
+ ; h <- inElement "Height" $ fmap read XML.text
+ ; i <- inElement "Info" $ parseContents
+ ; ns <- inElement "Nodes" $ many1 parseContents
+ ; es <- inElement "Edges" $ many1 parseContents
hunk ./src/NetworkFile.hs 118
-instance (InfoKind n g) => Haskell2XmlNew (AssocN n) where
- toHType _ =
- Defined "Node" []
- [Constr "Node" [] []]
+peekAttributes :: String -> XMLParser [(String,AttValue)]
+peekAttributes t =
+ do{ (p, e@(Elem _ as _)) <- posnElement [t]
+ ; reparse [CElem e p]
+ ; return as
+ }
+
+instance HTypeable (AssocN n) where
+ toHType _ = Defined "Node" [] [Constr "Node" [] []]
+instance (InfoKind n g) => XmlContent (AssocN n) where
hunk ./src/NetworkFile.hs 131
- { [("id",n)] <- peekAttributes ["Node"]
+ { [("id",n)] <- peekAttributes "Node"
hunk ./src/NetworkFile.hs 139
-instance (InfoKind e g) => Haskell2XmlNew (AssocE e) where
- toHType _ =
- Defined "Edge" []
- [Constr "Edge" [] []]
+instance HTypeable (AssocE e) where
+ toHType _ = Defined "Edge" [] [Constr "Edge" [] []]
+instance (InfoKind e g) => XmlContent (AssocE e) where
hunk ./src/NetworkFile.hs 145
- { [("id",n)] <- peekAttributes ["Edge"]
+ { [("id",n)] <- peekAttributes "Edge"
hunk ./src/NetworkFile.hs 153
-instance (InfoKind n g) => Haskell2XmlNew (Node n) where
- toHType _ =
- Defined "Node" []
- [Constr "Node" [] []]
+instance HTypeable (Node n) where
+ toHType _ = Defined "Node" [] [Constr "Node" [] []]
+instance (InfoKind n g) => XmlContent (Node n) where
hunk ./src/NetworkFile.hs 166
- { element' ["Node"] $ do
+ { inElement "Node" $ do
hunk ./src/NetworkFile.hs 168
- ; n <- element' ["Name"] $ XML.text
- ; a <- element' ["LabelAbove"] $ fmap read XML.text
- ; s <- element' ["Shape"] $ parseContents
- ; i <- element' ["Info"] $ parseContents
+ ; n <- inElement "Name" $ XML.text
+ ; a <- inElement "LabelAbove" $ fmap read XML.text
+ ; s <- inElement "Shape" $ parseContents
+ ; i <- inElement "Info" $ parseContents
hunk ./src/NetworkFile.hs 178
-instance Haskell2XmlNew DoublePoint where
- toHType _ =
- Defined "DoublePoint" []
- [Constr "X" [] [],
- Constr "Y" [] []]
+instance HTypeable DoublePoint where
+ toHType _ = Defined "DoublePoint" [] [Constr "X" [] [], Constr "Y" [] []]
+instance XmlContent DoublePoint where
hunk ./src/NetworkFile.hs 186
- { x <- element' ["X"] $ fmap read XML.text
- ; y <- element' ["Y"] $ fmap read XML.text
+ { x <- inElement "X" $ fmap read XML.text
+ ; y <- inElement "Y" $ fmap read XML.text
hunk ./src/NetworkFile.hs 191
-instance InfoKind e g => Haskell2XmlNew (Edge e) where
- toHType _ =
- Defined "Edge" []
- [Constr "Edge" [] []]
+instance HTypeable (Edge e) where
+ toHType _ = Defined "Edge" [] [Constr "Edge" [] []]
+instance InfoKind e g => XmlContent (Edge e) where
hunk ./src/NetworkFile.hs 203
- { element' ["Edge"] $ do
- { f <- element' ["From"] $ fmap read XML.text
- ; t <- element' ["To"] $ fmap read XML.text
- ; v <- element' ["Via"] $ list parseContents
- ; i <- element' ["Info"] $ parseContents
+ { inElement "Edge" $ do
+ { f <- inElement "From" $ fmap read XML.text
+ ; t <- inElement "To" $ fmap read XML.text
+ ; v <- inElement "Via" $ many parseContents
+ ; i <- inElement "Info" $ parseContents
hunk ./src/NetworkFile.hs 213
-instance Haskell2XmlNew Colour where
- toHType v =
- Defined "Colour" []
- [Constr "RGB" [] [toHType aa,toHType ab,toHType ac]]
- where
- (RGB aa ab ac) = v
+instance HTypeable Colour where
+ toHType v = Defined "Colour" []
+ [Constr "RGB" [] [toHType aa,toHType ab,toHType ac]]
+ where (RGB aa ab ac) = v
+instance XmlContent Colour where
hunk ./src/NetworkFile.hs 219
- { element' ["RGB"] $ do
+ { inElement "RGB" $ do
hunk ./src/NetworkFile.hs 231
-instance Haskell2XmlNew Shape where
- toHType v =
- Defined "Shape" []
- [Constr "Circle" [] [toHType aa,toHType ab],
- Constr "Polygon" [] [toHType ac,toHType ad],
- Constr "Lines" [] [toHType ae,toHType af],
- Constr "Composite" [] [toHType ag]]
+instance HTypeable Shape where
+ toHType v = Defined "Shape" []
+ [Constr "Circle" [] [toHType aa,toHType ab]
+ ,Constr "Polygon" [] [toHType ac,toHType ad]
+ ,Constr "Lines" [] [toHType ae,toHType af]
+ ,Constr "Composite" [] [toHType ag]]
hunk ./src/NetworkFile.hs 242
+instance XmlContent Shape where
hunk ./src/NetworkFile.hs 277
-instance Haskell2XmlNew ShapeStyle where
- toHType v =
- Defined "ShapeStyle" []
- [Constr "ShapeStyle" [] [toHType aa,toHType ab,toHType ac]]
- where
- (ShapeStyle aa ab ac) = v
+instance HTypeable ShapeStyle where
+ toHType v = Defined "ShapeStyle" []
+ [Constr "ShapeStyle" [] [toHType aa,toHType ab,toHType ac]]
+ where (ShapeStyle aa ab ac) = v
+instance XmlContent ShapeStyle where
hunk ./src/NetworkFile.hs 283
- { element' ["ShapeStyle"] $ do
+ { inElement "ShapeStyle" $ do
hunk ./src/NetworkUI.hs 21
-import Text.XML.HaXml.Haskell2XmlNew (Haskell2XmlNew)
-import Parse
+import Text.XML.HaXml.XmlContent (XmlContent)
+import Text.ParserCombinators.TextParser as Parse
hunk ./src/NetworkUI.hs 52
-create :: (Analysis g n e, Haskell2XmlNew g, Parse g, Show g, Read n) =>
+create :: (Analysis g n e, XmlContent g, Parse g, Show g) =>
hunk ./src/NetworkUI.hs 285
-openItem :: (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+openItem :: (InfoKind n g, InfoKind e g, XmlContent g) =>
hunk ./src/NetworkUI.hs 300
-openNetworkFile :: (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+openNetworkFile :: (InfoKind n g, InfoKind e g, XmlContent g) =>
hunk ./src/NetworkUI.hs 356
-openPalette :: (InfoKind n g, Read n) => Frame () -> State g n e -> IO ()
+openPalette :: (InfoKind n g, Parse n) => Frame () -> State g n e -> IO ()
hunk ./src/NetworkUI.hs 370
-openPaletteFile :: (InfoKind n g, Read n) =>
+openPaletteFile :: (InfoKind n g, Parse n) =>
hunk ./src/NetworkUI.hs 381
- ; case reads contents of {
- [] -> ioError (userError ("Cannot parse shape palette file: "++fname));
- ((p,_):_) -> setPalette p state
+ ; case (\ (a,_,_)->a) (runParser parse () contents) of {
+ Left msg -> ioError (userError ("Cannot parse shape palette file: "
+ ++fname++"\n\t"++msg));
+ Right p -> setPalette p state
hunk ./src/NetworkUI.hs 401
-saveToDisk :: (InfoKind n g, InfoKind e g, Haskell2XmlNew g) =>
+saveToDisk :: (InfoKind n g, InfoKind e g, XmlContent g) =>
hunk ./src/Palette.hs 5
+import Text.ParserCombinators.TextParser as Parse
hunk ./src/Palette.hs 22
+
+instance Parse a => Parse (Palette a) where
+ parse = do{ isWord "Palette"; fmap Palette $ parse }
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 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 Parse a => Parse (Maybe a) where
- parse = fmap Just parse `onfail` return Nothing
--- 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
-
rmfile ./src/Parse.hs
hunk ./src/Shape.hs 8
+import Text.ParserCombinators.TextParser
hunk ./src/Shape.hs 22
--- not currently used
hunk ./src/Shape.hs 28
+
+instance Parse Shape where
+ parse = oneOf
+ [ do{ isWord "Circle"
+ ; return Circle
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapeRadius"
+ `discard` isWord "}"
+ }
+ , do{ isWord "Polygon"
+ ; return Polygon
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapePerimeter"
+ `discard` isWord "}"
+ }
+ , do{ isWord "Lines"
+ ; return Lines
+ `discard` isWord "{" `apply` field "shapeStyle"
+ `discard` isWord "," `apply` field "shapePerimeter"
+ `discard` isWord "}"
+ }
+ , do{ isWord "Composite"
+ ; return Composite
+ `discard` isWord "{" `apply` field "shapeSegments"
+ `discard` isWord "}"
+ }
+ ] `adjustErr` (++"\nexpected a Shape (Circle,Polygon,Lines,Composite)")
+
+instance Parse ShapeStyle where
+ parse = do{ isWord "ShapeStyle"
+ ; return ShapeStyle
+ `discard` isWord "{" `apply` field "styleStrokeWidth"
+ `discard` isWord "," `apply` field "styleStrokeColour"
+ `discard` isWord "," `apply` field "styleFill"
+ `discard` isWord "}"
+ }
}