-- | 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, ELambda, and ECall.

module Language.Sifflet.Parser
    (parseExpr
    , parseValue
    , parseLiteral
    , parseTest
    , parseSuccFail
    , parseTypedInput2, parseTypedInputs2
    , parseTypedInput3, parseTypedInputs3
    , nothingBut
    , expr, list
    , value, typedValue
    , bool, qchar, qstring, integer, double
    , number
    )

where

import Text.ParserCombinators.Parsec

import Data.Number.Sifflet
import Language.Sifflet.Expr
import Language.Sifflet.Util

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

-- | Parse a Sifflet literal expression and return its Value
parseValue :: String -> SuccFail Value
parseValue s =
    -- take a shortcut here?
    -- case parseExpr s of -- stringToExpr s of
    --   Succ expr -> exprToValue expr
    --   Fail errmsg -> Fail errmsg
    parseLiteral s >>= exprToValue

parseLiteral :: String -> SuccFail Expr
parseLiteral s = 
    -- parseValue s >>= valueToLiteral
    case parseExpr s of
      Succ e -> if exprIsLiteral e
                   then Succ e
                   else Fail $ 
                     "parseLiteral: expr is non-literal" ++ show e
      Fail errmsg -> Fail errmsg

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

-- | Try to parse an input value of a specific type
parseTypedInput2 :: (String, Type) -> SuccFail Value
parseTypedInput2 (str, vartype) =
    parseSuccFail (nothingBut (typedValue vartype)) str

-- | Try to parse input values of specific types
parseTypedInputs2 :: [String]   -- ^ input strings
                  -> [Type]   -- ^ expected types
                  -> SuccFail [Value]
parseTypedInputs2 strs vartypes = 
    mapM parseTypedInput2 (zip strs vartypes)

-- | Try to parse an input value for a named variable of a specific type
parseTypedInput3 :: (String, String, Type) -> SuccFail Value
parseTypedInput3 (s, varname, vartype) =
    case parseSuccFail (nothingBut (typedValue vartype)) s of
      Fail msg -> Fail ("For variable " ++ varname ++ ":\n" ++ msg)
      Succ v -> Succ v

-- | Try to parse input values for named variables of specific types
parseTypedInputs3 :: [String]   -- ^ inputs
                  -> [String]   -- ^ variable names
                  -> [Type]   -- ^ variable types
                  -> SuccFail [Value]
parseTypedInputs3 strs varnames vartypes =
    mapM parseTypedInput3 (zip3 strs varnames vartypes)

-- | 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 -- actually only a literal
-- or a list of literals.
expr :: Parser Expr
expr = -- (try (list expr >>= return . EList)) <|>
       (bool >>= return . EBool) <|>
       (qchar >>= return . EChar) <|>
       (qstring >>= return . EString) <|>
       try (double >>= return . ENumber . Inexact) <|>
       (integer >>= return . ENumber . Exact) <|>
       (list expr >>= return . EList)
       
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"               -- ???



          
-- | Parser for a Value of any primitive or (concrete) list type

value :: Parser Value
value = (bool >>= return . VBool) <|>
        (qchar >>= return .VChar) <|>
        (qstring >>= return . VString) <|>
        try (double >>= return . VNumber . Inexact) <|>
        (integer >>= return . VNumber . Exact) <|>
        (list value >>= return . VList)

-- | Parser for a value with a specific primitive or concrete list type 
-- expected.

typedValue :: Type -> Parser Value
typedValue t = 
    (case t of
       TypeCons "Bool" [] -> bool >>= return . VBool
       TypeCons "Char" [] -> qchar >>= return . VChar
       TypeCons "String" [] -> qstring >>= return . VString
       TypeCons "Num" [] -> number >>= return . VNumber
       TypeCons "List" [e] -> list (typedValue e) >>= return . VList
       TypeCons "Function" _argTypes -> 
           fail $ "Sorry, but you cannot input a function here.\n\n" ++
                    "Note to developer: typedValue needs access to the " ++
                    "global environment in order to look up function names."
       TypeCons _ _ -> 
           fail $ "Sorry, but you cannot input that type of value here.\n\n" ++
                    "Note to developer: typedValue needs to implement " ++
                    "the type " ++ show t
       TypeVar _ -> value -- can't check, so just accept anything
    )
    <?> typeName t

-- | A name for the type, for use in parser error reporting
typeName :: Type -> String
typeName t =
    let cerr cname = 
            error ("typeName: improper " ++ cname ++ " type construction")
        primitive tname args =
            case args of
              [] -> tname
              _ -> cerr tname
    in case t of 
         TypeVar tvn -> tvn -- could be more specific!
         TypeCons "Bool" ts -> primitive "boolean" ts
         TypeCons "Char" ts -> 
             primitive "character" ts -- "character (in single quotes)"
         TypeCons "Num" ts -> primitive "number" ts
         TypeCons "String" ts -> 
             primitive "string" ts -- "string (in double quotes)"
         TypeCons "List" [e] -> "list of " ++ typeName e
         TypeCons "List" _ -> cerr "List"
         TypeCons "Function" [_, _] -> "function" -- ???
         TypeCons "Function" _ -> cerr "Function"
         TypeCons tname texprs -> tname ++ " " ++ show (map typeName texprs)

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


-- 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 typeChar
                      
-- 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 typeString

-- 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 \\"
                   )
       )

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 is a Sifflet Number, which is exact unless it contains
-- a decimal point.
-- To avoid consuming "123" from "123." and interpreting it as an exact
-- number, we MUST try to parse double before integer.
number :: Parser Number
number = (try (double >>= return . Inexact) <|> 
          (integer >>= return . Exact))
         <?> typeName typeNum