content: -- 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 Data.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
       }
  