1 files changed, 137 insertions, 0 deletions
diff --git a/testsuite/tests/programs/galois_raytrace/Parse.hs b/testsuite/tests/programs/galois_raytrace/Parse.hs
new file mode 100644
index 0000000000..931655c16e
--- /dev/null
+++ b/testsuite/tests/programs/galois_raytrace/Parse.hs
@@ -0,0 +1,137 @@
+-- Copyright (c) 2000 Galois Connections, Inc.
+-- All rights reserved.  This software is distributed as
+-- free software under the license in the file "LICENSE",
+-- which is included in the distribution.
+
+module Parse where
+
+import Char
+import Text.ParserCombinators.Parsec hiding (token)
+
+import Data
+
+
+program :: Parser Code
+program =
+  do { whiteSpace
+     ; ts <- tokenList
+     ; eof
+     ; return ts
+     }
+
+tokenList :: Parser Code
+tokenList = many token <?> "list of tokens"
+
+token :: Parser GMLToken
+token =
+       do { ts <- braces   tokenList          ; return (TBody ts) } 
+  <|>  do { ts <- brackets tokenList          ; return (TArray ts) }
+  <|> (do { s  <- gmlString                   ; return (TString s) } <?> "string")
+  <|> (do { t <- pident False                 ; return t }           <?> "identifier")
+  <|> (do { char '/'   -- No whitespace after slash
+          ; t <- pident True                  ; return t } <?> "binding identifier")
+  <|> (do { n <- number                       ; return n } <?> "number")
+
+pident :: Bool -> Parser GMLToken
+pident rebind =
+  do { id <- ident
+     ; case (lookup id opTable) of
+       Nothing -> if rebind then return (TBind id) else return (TId id)
+       Just t  -> if rebind then error ("Attempted rebinding of identifier " ++ id) else return t
+     }
+
+ident :: Parser String
+ident = lexeme $
+  do { l <- letter
+     ; ls <- many (satisfy (\x -> isAlphaNum x || x == '-' || x == '_'))
+     ; return (l:ls)
+     }
+
+gmlString :: Parser String
+gmlString = lexeme $ between (char '"') (char '"') (many (satisfy (\x -> isPrint x && x /= '"')))
+
+-- Tests for numbers
+-- Hugs breaks on big exponents (> ~40)
+test_number = "1234 -1234 1 -0 0" ++
+              " 1234.5678 -1234.5678 1234.5678e12 1234.5678e-12 -1234.5678e-12" ++
+              " -1234.5678e12 -1234.5678E-12 -1234.5678E12" ++
+              " 1234e11 1234E33 -1234e33 1234e-33" ++
+              " 123e 123.4e 123ee 123.4ee 123E 123.4E 123EE 123.4EE"
+              
+
+-- Always int or real
+number :: Parser GMLToken
+number = lexeme $
+  do { s <- optSign
+     ; n <- decimal
+     ;     do { string "."
+              ; m <- decimal
+              ; e <- option "" exponent'
+              ; return (TReal (read (s ++ n ++ "." ++ m ++ e)))  -- FIXME: Handle error conditions
+              }
+       <|> do { e <- exponent'
+              ; return (TReal (read (s ++ n ++ ".0" ++ e)))
+              }
+       <|> do { return (TInt (read (s ++ n))) }
+     }
+
+exponent' :: Parser String
+exponent' = try $
+  do { e <- oneOf "eE"
+     ; s <- optSign
+     ; n <- decimal
+     ; return (e:s ++ n)
+     }
+
+decimal = many1 digit
+
+optSign :: Parser String
+optSign = option "" (string "-")
+
+
+------------------------------------------------------
+-- Library for tokenizing.
+
+braces   p = between (symbol "{") (symbol "}") p
+brackets p = between (symbol "[") (symbol "]") p
+
+symbol name = lexeme (string name)
+
+lexeme p = do{ x <- p; whiteSpace; return x  }
+
+whiteSpace  = skipMany (simpleSpace <|> oneLineComment <?> "")
+  where simpleSpace = skipMany1 (oneOf " \t\n\r\v")    
+        oneLineComment =
+            do{ string "%"
+              ; skipMany (noneOf "\n\r\v")
+              ; return ()
+              }
+
+
+------------------------------------------------------------------------------
+
+rayParse :: String -> Code
+rayParse is = case (parse program "<stdin>" is) of
+              Left err -> error (show err)
+              Right x  -> x
+
+rayParseF :: String -> IO Code
+rayParseF file =
+  do { r <- parseFromFile program file
+     ; case r of
+       Left err -> error (show err)
+       Right x  -> return x
+     }
+
+run :: String -> IO ()
+run is = case (parse program "" is) of
+         Left err -> print err
+         Right x  -> print x
+
+runF :: IO ()
+runF =
+  do { r <- parseFromFile program "simple.gml"
+     ; case r of
+       Left err -> print err
+       Right x  -> print x
+     }