1 files changed, 98 insertions, 0 deletions
diff --git a/testsuite/tests/programs/andy_cherry/Parser.hs b/testsuite/tests/programs/andy_cherry/Parser.hs
new file mode 100644
index 0000000000..6dddb64a0e
--- /dev/null
+++ b/testsuite/tests/programs/andy_cherry/Parser.hs
@@ -0,0 +1,98 @@
+
+ module Parser (pgnLexer,pgnParser) where
+
+ import GenUtils
+ import DataTypes
+ import Data.Char -- 1.3
+
+
+
+ pgnLexer :: String -> [Token]
+ pgnLexer ('.':r) = PeriodToken  : pgnLexer r
+ pgnLexer ('*':r) = AsterixToken : pgnLexer r
+ pgnLexer ('[':r) = LeftSBToken  : pgnLexer r
+ pgnLexer (']':r) = RightSBToken : pgnLexer r
+ pgnLexer ('(':r) = LeftRBToken  : pgnLexer r
+ pgnLexer (')':r) = RightRBToken : pgnLexer r
+ pgnLexer ('<':r) = LeftABToken  : pgnLexer r
+ pgnLexer ('>':r) = RightABToken : pgnLexer r
+ pgnLexer ('"':r) = readString r ""
+ pgnLexer ('{':r) = readComment r ""
+ pgnLexer ('$':r) = readNAG r ""
+ pgnLexer ('!':'?':r) = mkNAGToken 5 : pgnLexer r
+ pgnLexer ('!':'!':r) = mkNAGToken 3 : pgnLexer r
+ pgnLexer ('!':r)     = mkNAGToken 1 : pgnLexer r
+ pgnLexer ('?':'?':r) = mkNAGToken 4 : pgnLexer r
+ pgnLexer ('?':'!':r) = mkNAGToken 6 : pgnLexer r
+ pgnLexer ('?':r)     = mkNAGToken 2 : pgnLexer r
+ pgnLexer ('%':r) = pgnLexer (dropWhile (/= '\n') r)
+ pgnLexer (c:r)
+       | isSpace c = pgnLexer r
+       | isAlpha c || isDigit c = pgnSymbolLexer r [c]
+       | otherwise = error ("Error lexing: " ++ takeWhile (/= '\n') (c:r))
+ pgnLexer [] = []
+
+ pgnSymbolLexer (c:r) sym 
+       | isAlpha c 
+       || isDigit c 
+       || elem c "_+#=:-/" = pgnSymbolLexer r (c:sym)
+ pgnSymbolLexer r sym 
+       | all isDigit sym = IntToken (read (reverse sym)) : pgnLexer r
+ pgnSymbolLexer r sym   = SymbolToken (reverse sym) : pgnLexer r
+
+ readString ('\\':'\\':r) str = readString r ('\\':str)
+ readString ('\\':'"':r) str = readString r ('"':str)
+ readString ('"':r) str     = StringToken (reverse str) : pgnLexer r
+ readString (c:r) str       = readString r (c:str)
+
+ readComment ('}':r) str = CommentToken (revwords str []) : pgnLexer r
+ readComment (c:r) str = readComment r (c:str)
+
+ revwords (c:r) wds
+    | isSpace c = revwords r wds
+    | otherwise = revwords' r [c] wds
+ revwords [] wds = wds
+ revwords' (c:r) wd wds 
+    | isSpace c = revwords r (wd:wds)
+    | otherwise = revwords' r (c:wd) wds
+ revwords' [] wd wds = wd : wds
+
+ readNAG (c:r) str
+       | isDigit c = readNAG r (c:str)
+ readNAG r str = mkNAGToken (read (reverse str)) : pgnLexer r
+
+ mkNAGToken 1 = NAGAnnToken 1 "!" 
+ mkNAGToken 2 = NAGAnnToken 2 "?" 
+ mkNAGToken 3 = NAGAnnToken 3 "!!"
+ mkNAGToken 4 = NAGAnnToken 4 "??"
+ mkNAGToken 5 = NAGAnnToken 5 "!?"
+ mkNAGToken 6 = NAGAnnToken 6 "?!"
+ mkNAGToken n = NAGToken n
+
+
+
+
+ pgnParser :: (Int -> Bool) -> String -> [AbsGame]
+ pgnParser fn str = 
+       [ game | (no,game) <- zip [1..] (parseTags (pgnLexer str) id),
+                fn no]
+
+ type FL a = [a] -> [a]
+
+ parseTags :: [Token] -> FL TagStr -> [AbsGame]
+ parseTags (LeftSBToken:SymbolToken sym:StringToken str:RightSBToken:rest) 
+           other_tags = parseTags rest (other_tags . ((:) (TagStr sym str)))
+ parseTags toks@(LeftSBToken:_) _
+       = error ("BAD Token:" ++ unwords (map userFormat (take 10 toks)))
+ parseTags toks tags = parseToks toks id tags
+
+ parseToks :: [Token] 
+       -> FL Token 
+       -> FL TagStr
+       -> [AbsGame]
+ parseToks next@(LeftSBToken:_)     = \ toks tags ->
+       Game (tags []) (toks []) : parseTags next id
+ parseToks (tk:r)                    = pushToken tk r 
+ parseToks [] = \ toks tags -> [Game (tags []) (toks [])]
+
+ pushToken tok r toks = parseToks r (toks . ((:) tok))