module UtilLanguage where

import Data.Char(digitToInt)
import Data.Functor.Identity(Identity)
import Text.Parsec
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (haskellStyle)
import Text.ParserCombinators.Parsec

utilDef :: P.LanguageDef st
utilDef = haskellStyle
  {
--  , P.commentStart   = "{-"
--  , P.commentEnd     = "-}"
--  , P.commentLine    = "--"
--  , P.nestedComments = True
    P.identStart  = letter <|> oneOf "_"
  , P.identLetter = alphaNum <|> oneOf "_'"
  , P.opStart     = P.opLetter utilDef
  , P.opLetter    = oneOf ":!#$%&*+./<=>?@\\^|-~"
  , P.reservedNames  = [
         "let", "letrec", "val", "fn", "in",
         "if", "then", "else",
         "letLocal", "letGlobal",
         "class", "method",
         "begin", "end", "while", "do",
         -- "getX", "setX", "getY", "setY", "getZ", "setZ",
         -- "write", "read",
         "try", "catch", -- "fail",
         "break", "continue", "goto", -- "abort", "callcc",
         "amb", "or", "uniq"]
  , P.reservedOpNames = ["=", "\\", "->", "<-", "@", ":",
         "+", "-", "*", "/", "%",
         "==", "/=", ">", ">=", "<", "<=",
         "++", "&&", "||"]
--  , P.caseSensitve = True       
  }

utilParser :: P.TokenParser st
utilParser  = P.makeTokenParser utilDef

parens      = P.parens utilParser
identifier  = P.identifier utilParser
lexeme      = P.lexeme utilParser
symbol      = P.symbol utilParser
whiteSpace  = P.whiteSpace utilParser
reserved    = P.reserved utilParser
decimal     = P.decimal utilParser
reservedOp  = P.reservedOp utilParser
semi        = P.semi utilParser
stringLiteral  = P.stringLiteral utilParser
hexadecimal    = P.hexadecimal utilParser
octal          = P.octal utilParser


-- rewritten to return Rational
type Numeric = Rational -- 無限精度有理数を使用する場合
-- type Numeric = Double   -- 倍精度浮動小数点数を使用する場合


naturalOrFloat :: ParsecT String u Identity (Either Integer Numeric)
naturalOrFloat  = lexeme (natFloat) <?> "number"

-- floats
natFloat        = do char '0'
                     zeroNumFloat
                 <|> decimalFloat

zeroNumFloat    = do n <- hexadecimal <|> octal
                     return (Left n)
                <|> decimalFloat
                <|> fractFloat 0
                <|> return (Left 0)


decimalFloat    = do n <- decimal
                     option (Left n)
                            (fractFloat n)

fractFloat n    = do f <- fractExponent n
                     return (Right f)

-- rewritten to return Rational
fractExponent n = do fract <- fraction
                     expo  <- option 1.0 exponent'
                     return ((fromInteger n + fract) * expo)
                <|>
                  do expo <- exponent'
                     return ((fromInteger n) * expo)

fraction        = do char '.'
                     digits <- many1 digit <?> "fraction"
                     return (foldr op 0.0 digits)
                  <?> "fraction"
                where
                  op d f    = (f + fromIntegral (digitToInt d)) / 10.0

exponent'       = do oneOf "eE"
                     f <- sign
                     e <- decimal <?> "exponent"
                     return (power (f e))
                  <?> "exponent"
                where
                   power e  | e < 0      = 1.0 / power (-e)
                            | otherwise  = fromInteger (10 ^ e)

sign            =   (char '-' >> return negate)
                <|> (char '+' >> return id)
                <|> return id