-- | A parser for Sifflet input values.
-- This is not a parser for all Sifflet expressions,
-- but just those that might be input in textual form
-- through the function call dialog that asks for the argument values.
-- So, it is limited (deliberately) to "data" types of expressions:
-- that is, Exprs using the constructors:
--    ELit
--    EList
-- That means excluding Exprs constructed with EUndefined,
-- ESymbol, EIf, and ECall.

module Sifflet.Language.Parser
    (parseExpr, parseInput
    -- , parseInputAsValue
    , parseTest
    , parseSuccFail, nothingBut
    , expr, list, literal
    , value, typedValue
    , bool, qchar, qstring, integer, double
    , number
    )

where

import Text.ParserCombinators.Parsec

import Sifflet.Language.Expr
import Sifflet.Util


-- | Parse a Sifflet data literal (number, string, char, bool, or list)
parseExpr :: String -> SuccFail Expr
parseExpr = parseSuccFail expr

-- | Parse a Sifflet input containing exactly one data expression
-- possibly flanked by white space
parseInput :: String -> SuccFail Expr
parseInput = parseSuccFail input

parseSuccFail :: Parser a -> String -> SuccFail a
parseSuccFail p s =
    case parse p "user input" s of
      Left perr -> Fail (show perr)
      Right v -> Succ v


-- | Like expr, but consumes the entire input,
-- so there must not be any extraneous characters after the Expr.
input :: Parser Expr
input = nothingBut expr

-- | 'nothingBut p is like 'p', but consumes the entire input,
-- so there must be no extraneous characters (except space)
-- after whatever 'p' parses.
nothingBut :: Parser a -> Parser a
nothingBut p = (many space >> p) `prog1` (many space >> eof)

prog1 :: (Monad m) => m a -> m b -> m a
prog1 m1 m2 = m1 >>= (\ r -> m2 >> return r)

-- | Parse a Sifflet data expression
expr :: Parser Expr
expr = -- (try (list expr >>= return . EList)) <|>
       literal
       
list :: Parser a -> Parser [a]
list element = 
    let sep = try (skipMany space >> char ',' >> skipMany space)
    in (char '[' >> many space >> sepBy element sep)
       `prog1`
       (many space >> char ']')
       -- do I need (...) above?
       <?> "list"               -- ???


literal :: Parser Expr
literal = value >>= return . ELit

-- | Parser for a Value of any type (any VpType),
-- except that we cannot parse as VpTypeVar or VpTypeFunction.

value :: Parser Value
value = (bool >>= return . VBool) <|>
        (qchar >>= return .VChar) <|>
        (qstring >>= return . VStr) <|>
        try (double >>= return . VFloat) <|>
        (integer >>= return . VInt) <|>
        (list value >>= return . VList)

-- | Parser for a value with a specific VpType expected.
-- Again, we cannot do this for VpTypeVar (why not?)
-- or VpTypeFunctiopn

typedValue :: VpType -> Parser Value
typedValue t = 
    (case t of
       VpTypeBool -> bool >>= return . VBool
       VpTypeChar -> qchar >>= return . VChar
       VpTypeString -> qstring >>= return . VStr
       VpTypeNum -> do { en <- number;
                         case en of
                           Left x -> return (VFloat x)
                           Right i -> return (VInt i)
                       }
       VpTypeList e -> list (typedValue e) >>= return . VList
       VpTypeVar _ -> value -- can't check, so just accept anything
       VpTypeFunction _ _ -> 
           error "typedValue: not implemented for VpTypeFunction"
    )
    <?> typeName t

-- | A name for the type, for use in parser error reporting
typeName :: VpType -> String
typeName t =
    case t of 
      VpTypeBool -> "boolean" -- "boolean (True or False)"
      VpTypeChar -> "character" -- "character (in single quotes)"
      VpTypeNum -> "number"
      VpTypeString -> "string" -- "string (in double quotes)"
      VpTypeList e -> "list" ++ -- "list (in brackets)" ++
                      case e of
                        VpTypeVar _ -> ""
                        _ -> " of " ++ typeName e

      VpTypeVar _ -> "anything" -- could be more specific!
      VpTypeFunction _ _ -> "function" -- ???


bool :: Parser Bool
bool = (try (string "True" >> return True) <|>
        (string "False" >> return False))
       <?> typeName VpTypeBool


-- quoted character 'c'
qchar :: Parser Char
qchar = 
    let sq = '\''           -- single quote character
    in (((char sq <?> "opening single quote") >> 
         (try escapedChar <|> noneOf [sq])) 
        `prog1`
        (char sq <?> "closing single quote")
       )
       <?> typeName VpTypeChar
                      
-- quoted string "c..."

qstring :: Parser String
qstring = 
    let dq = '\"'         -- double quote character
    in (char dq >> 
        many (escapedChar <|> noneOf [dq] <?> "")) 
       `prog1` 
       (char dq <?> "close of quotation")
       -- Do I need (...) above?
       <?> typeName VpTypeString

-- escapedChar recognizes the following escape sequences:
--  \t = tab
--  \n = newline
--  \r = carriage return
--  \\ = backslash
--  Anything else that begins with \ is an error.

escapedChar :: Parser Char
escapedChar = 
    let bs = '\\'       -- backslash character
    in char bs >> 
       (oneOf "ntr\\" <?> "n, t, r, or \\ to follow \\") >>=
       (\ c ->
            return (case c of
                      'n' -> '\n'
                      't' -> '\t'
                      'r' -> '\r'
                      '\\' -> '\\'
                      _ -> error "escapedChar: c MUST be n, t, r, or \\"
                   )
       )

       -- do { _ <- char bs;
       --      c <- oneOf "ntr\\"
       --           <?>
       --           "n, t, r, or \\ to follow \\";
       --      return (case c of
       --                'n' -> '\n'
       --                't' -> '\t'
       --                'r' -> '\r'
       --                '\\' -> '\\'
       --                _ -> error "escapedChar: c MUST be n, t, r, or \\"
       --             )
       --    }



data Sign = Minus | Plus

-- Integer ::= (+|-)? digit+

integer :: Parser Integer -- sign, digits
integer = do { s <- optSign;
               u <- unsignedInteger;
               return (applySign s u)
             }
          <?> "integer"

unsignedInteger :: Parser Integer
unsignedInteger = many1 digit >>= return . read

-- An optional + or - defaulting to +

optSign :: Parser Sign           -- 1: negative; 0: non-negative
optSign = try ( char '-' >> return Minus ) <|>
          try ( char '+' >> return Plus ) <|>
          return Plus

applySign :: (Num n) => Sign -> n -> n
applySign s x =
    case s of 
      Minus -> (- x)
      Plus -> x

-- A double (float) may begin with a sign (+ or -) and must contain
-- a decimal point along with at least one digit before and/or after
-- the decimal point.
-- So there are three cases:
-- [sign] digits '.' digits
-- [sign] digits '.'
-- [sign] '.' digits

double :: Parser Double

-- Double FAILS if there is a decimal point.
-- It succeeds in the following cases:

double = 
    let digits1 = many1 digit
        point = char '.'
        -- wpf: whole-part point fraction-part
        wpf = do { dd <- digits1;
                   dd' <- point >> digits1;
                   return (dd, dd')
                 }
        -- wp: whole-part point
        wp = do { dd <- digits1 `prog1` point;
                  return (dd, "0")
                }
        -- pf: point fraction-part
        pf = do { dd' <- point >> digits1;
                  return ("0", dd')
                }
        -- optional trailing exponent notation e.g. e-4
        scale = do { i <- oneOf "eE" >> integer;
                     return (10 ** fromIntegral i)
                   }
                <|> return 1

    in do { sign <- optSign
          ; (whole, frac) <- (try wpf <|>
                              try wp <|>
                              try pf)
          ; m <- scale;
          ; let w = read (whole ++ ".0") -- whole part as number
                f = read ("0." ++ frac)  -- frac part as number
          ; return (m * applySign sign (w + f))
          }
       <?> "real number"

-- A number may be either a double (with decimal point) or an integer (without).
-- To avoid consuming "123" from "123." and interpreting it as an integer,
-- we MUST try to parse double before integer.
number :: Parser (Either Double Integer)
number = (try (double >>= return . Left) <|> 
          (integer >>= return . Right))
         <?> typeName VpTypeNum

-- -- numberValue :: Parser Value
-- -- numberValue = do { x <- number;
-- --                    case x of
-- --             value :: Parser Value
-- value = (bool >>= return . VBool) <|>
--         (qchar >>= return . VChar)

--          Left dx -> return (VFloat dx)
-- --                      Right ix -> return (VInt ix)
-- --                  }
-- --               <?> typeName VpTypeNumber