ghc/tests/programs/galois_raytrace/Parse.hs

   1 -- Copyright (c) 2000 Galois Connections, Inc.
   2 -- All rights reserved.  This software is distributed as
   3 -- free software under the license in the file "LICENSE",
   4 -- which is included in the distribution.
   5
   6 module Parse where
   7
   8 import Char
   9 import Parsec hiding (token)
  10
  11 import Data
  12
  13
  14 program :: Parser Code
  15 program =
  16   do { whiteSpace
  17      ; ts <- tokenList
  18      ; eof
  19      ; return ts
  20      }
  21
  22 tokenList :: Parser Code
  23 tokenList = many token <?> "list of tokens"
  24
  25 token :: Parser GMLToken
  26 token =
  27        do { ts <- braces   tokenList          ; return (TBody ts) }
  28   <|>  do { ts <- brackets tokenList          ; return (TArray ts) }
  29   <|> (do { s  <- gmlString                   ; return (TString s) } <?> "string")
  30   <|> (do { t <- pident False                 ; return t }           <?> "identifier")
  31   <|> (do { char '/'   -- No whitespace after slash
  32           ; t <- pident True                  ; return t } <?> "binding identifier")
  33   <|> (do { n <- number                       ; return n } <?> "number")
  34
  35 pident :: Bool -> Parser GMLToken
  36 pident rebind =
  37   do { id <- ident
  38      ; case (lookup id opTable) of
  39        Nothing -> if rebind then return (TBind id) else return (TId id)
  40        Just t  -> if rebind then error ("Attempted rebinding of identifier " ++ id) else return t
  41      }
  42
  43 ident :: Parser String
  44 ident = lexeme $
  45   do { l <- letter
  46      ; ls <- many (satisfy (\x -> isAlphaNum x || x == '-' || x == '_'))
  47      ; return (l:ls)
  48      }
  49
  50 gmlString :: Parser String
  51 gmlString = lexeme $ between (char '"') (char '"') (many (satisfy (\x -> isPrint x && x /= '"')))
  52
  53 -- Tests for numbers
  54 -- Hugs breaks on big exponents (> ~40)
  55 test_number = "1234 -1234 1 -0 0" ++
  56               " 1234.5678 -1234.5678 1234.5678e12 1234.5678e-12 -1234.5678e-12" ++
  57               " -1234.5678e12 -1234.5678E-12 -1234.5678E12" ++
  58               " 1234e11 1234E33 -1234e33 1234e-33" ++
  59               " 123e 123.4e 123ee 123.4ee 123E 123.4E 123EE 123.4EE"
  60
  61
  62 -- Always int or real
  63 number :: Parser GMLToken
  64 number = lexeme $
  65   do { s <- optSign
  66      ; n <- decimal
  67      ;     do { string "."
  68               ; m <- decimal
  69               ; e <- option "" exponent'
  70               ; return (TReal (read (s ++ n ++ "." ++ m ++ e)))  -- FIXME: Handle error conditions
  71               }
  72        <|> do { e <- exponent'
  73               ; return (TReal (read (s ++ n ++ ".0" ++ e)))
  74               }
  75        <|> do { return (TInt (read (s ++ n))) }
  76      }
  77
  78 exponent' :: Parser String
  79 exponent' = try $
  80   do { e <- oneOf "eE"
  81      ; s <- optSign
  82      ; n <- decimal
  83      ; return (e:s ++ n)
  84      }
  85
  86 decimal = many1 digit
  87
  88 optSign :: Parser String
  89 optSign = option "" (string "-")
  90
  91
  92 ------------------------------------------------------
  93 -- Library for tokenizing.
  94
  95 braces   p = between (symbol "{") (symbol "}") p
  96 brackets p = between (symbol "[") (symbol "]") p
  97
  98 symbol name = lexeme (string name)
  99
 100 lexeme p = do{ x <- p; whiteSpace; return x  }
 101
 102 whiteSpace  = skipMany (simpleSpace <|> oneLineComment <?> "")
 103   where simpleSpace = skipMany1 (oneOf " \t\n\r\v")
 104         oneLineComment =
 105             do{ string "%"
 106               ; skipMany (noneOf "\n\r\v")
 107               ; return ()
 108               }
 109
 110
 111 ------------------------------------------------------------------------------
 112
 113 rayParse :: String -> Code
 114 rayParse is = case (parse program "<stdin>" is) of
 115               Left err -> error (show err)
 116               Right x  -> x
 117
 118 rayParseF :: String -> IO Code
 119 rayParseF file =
 120   do { r <- parseFromFile program file
 121      ; case r of
 122        Left err -> error (show err)
 123        Right x  -> return x
 124      }
 125
 126 run :: String -> IO ()
 127 run is = case (parse program "" is) of
 128          Left err -> print err
 129          Right x  -> print x
 130
 131 runF :: IO ()
 132 runF =
 133   do { r <- parseFromFile program "simple.gml"
 134      ; case r of
 135        Left err -> print err
 136        Right x  -> print x
 137      }