content: module RestyScript.Parser where
  
  import RestyScript.AST
  import Text.ParserCombinators.Parsec
  import Text.ParserCombinators.Parsec.Expr
  import Monad (liftM)
  
  unescapes :: [(Char, Char)]
  unescapes = zipWith pair "bnfrt" "\b\n\f\r\t"
      where pair a b = (a, b)
  
  quotedChar :: Char -> Parser Char
  quotedChar c = do c <- char '\\' >> anyChar
                    return $ case lookup c unescapes of
                              Just r -> r
                              Nothing -> c
             <|> noneOf [c]
             <|> do try (string [c,c])
                    return c
  
  parens :: Parser a -> Parser a
  parens = between (char '(' >> spaces) (char ')' >> spaces)
  
  keyword :: String -> Parser String
  keyword s = try (do string s
                      notFollowedBy alphaNum
                      return s)
  
  symbol :: Parser String
  symbol = do char '"'
              s <- word
              char '"'
              return s
       <|> word
  
  word :: Parser String
  word = do x <- letter
            xs <- many (alphaNum <|> char '_')
            return (x:xs)
  
  listSep :: Parser ()
  listSep = opSep ","
  
  parseWhere :: Parser RSVal
  parseWhere = do keyword "where" >> many1 space
                  cond <- parseExpr
                  return $ Where cond
           <?> "where clause"
  
  parseExpr :: Parser RSVal
  parseExpr = buildExpressionParser opTable parseArithAtom
          <?> "expression"
  
  opTable = [
              [ op "::" TypeCast AssocNone ],
              [  preOp "-" Minus, preOp "+" Plus ],
              [
                  arithOp "^"
                  ],
              [
                  arithOp "*", arithOp "/", arithOp "%"
                  ],
              [
                  arithOp "+", arithOp "-"
                  ],
              [
                  arithOp "||"
                  ],
              [
                  relOp "@@", relOp "@>", relOp "@<", relOp "~", relOp "@",
                  relOp "<<=", relOp "<<", relOp ">>=", relOp ">>",
                  relOp ">=", relOp ">",
                  relOp "<=", relOp "<>", relOp "<",
                  relOp "=", relOp "!=", relOp' "like",
                  relOp' "is not",
                  relOp' "is"
                  ],
              [   preOp' "not" Not ],
              [
                  op' "and" And AssocLeft
                  ],
              [
                  op' "or" Or AssocLeft
                  ]
              ]
        where
          preOp s f
              = Prefix (do { reservedOp s; spaces; return f} <?> "operator")
          preOp' s f
              = Prefix (do { reservedWord s; spaces; return f} <?> "operator")
  
          op s f assoc
             = Infix (do { reservedOp s; spaces; return f} <?> "operator") assoc
          op' s f assoc
             = Infix (do { reservedWord s; spaces; return f} <?> "operator") assoc
          relOp s
             = op s (Compare s) AssocNone
          relOp' s
             = op' s (Compare s) AssocNone
          arithOp s
             = op s (Arith s) AssocLeft
  
  reservedWord :: String -> Parser String
  reservedWord s = try(do string s; notFollowedBy alphaNum; spaces; return s)
  
  reservedOp :: String -> Parser String
  reservedOp s = try(do string s; spaces; return s)
  
  opSep :: String -> Parser ()
  opSep op = string op >> spaces
  
  parseArithAtom :: Parser RSVal
  parseArithAtom = parseNumber
               <|> parseString
               <|> parseBool
               <|> parseNull
               <|> parseDistinct
               <|> try (parseVerbatimString)
               <|> try (do {
                  r <- parseVariable;
                  notFollowedBy (char '.' <|> char '(');
                  return r })
               <|> try (parseFuncCall)
               <|> try(parseArrayIndex)
               <|> parseColumn
               <|> parens parseExpr
  
  parseArrayIndex :: Parser RSVal
  parseArrayIndex = do
      array <- (parseColumn <|> parens parseExpr)
      ind   <- between (char '[' >> spaces) (char ']' >> spaces) parseExpr
      return $ ArrayIndex array ind
  
  parseBool :: Parser RSVal
  parseBool = (keyword "true" >> spaces >> return RSTrue)
          <|> (keyword "false" >> spaces >> return RSFalse)
  
  parseNull :: Parser RSVal
  parseNull = keyword "null" >> spaces >> return Null
  
  parseDistinct :: Parser RSVal
  parseDistinct = do
      mod <- (keyword "distinct" <|> keyword "all")
      spaces
      cols <- sepBy1 parseExpr listSep
      spaces
      return $ case mod of
          "distinct" -> Distinct cols
          otherwise -> All cols
  
  parseFuncCall :: Parser RSVal
  parseFuncCall = do f <- parseIdent
                     args <- parens parseArgs
                     return $ FuncCall f args
  
  
  parseArgs :: Parser [RSVal]
  parseArgs = do v <- parseAnyColumn
                 return [v]
          <|> sepBy parseExpr listSep
  
  parseAnyColumn :: Parser RSVal
  parseAnyColumn = do char '*'
                      spaces
                      return AnyColumn
  
  parseVariable :: Parser RSVal
  parseVariable = do char '$'
                     pos <- getPosition
                     prefix <- option "" $ string "_"
                     v <- symbol
                     spaces
                     return $ Variable pos $ prefix ++ v
  
  parseNumber :: Parser RSVal
  parseNumber = try (parseFloat)
            <|> parseInteger
            <?> "number"
  
  parseInteger :: Parser RSVal
  parseInteger = do digits <- many1 digit
                    spaces
                    return $ Integer $ read digits
  
  parseFloat :: Parser RSVal
  parseFloat = do int <- many1 digit
                  dec <- char '.' >> many digit
                  spaces
                  return $ Float $
                     read (int ++ "." ++ noEmpty dec)
           <|> do dec <- char '.' >> many1 digit
                  spaces
                  return $ Float $ read ("0." ++ dec)
           <?> "floating-point number"
      where noEmpty s = if s == "" then "0" else s
  
  parseString :: Parser RSVal
  parseString = do s <- between (char '\'') (char '\'')
                           $ many $ quotedChar '\''
                   spaces
                   return $ String s
            <?> "string"
  
  parseVerbatimString :: Parser RSVal
  parseVerbatimString = do delim <- char '$' >> option "" identifier
                           char '$'
                           str <- manyTill anyChar (try (char '$' >> string delim >> char '$'))
                           spaces
                           -- char '$' >> string delim >> char '$'
                           return $ String str
  
  identifier :: Parser String
  identifier = do c <- letter <|> char '_'
                  s <- many (alphaNum <|> char '_')
                  return (c : s)
  
  parseColumn :: Parser RSVal
  parseColumn = do a <- parseIdent
                   spaces
                   b <- option Empty (char '.' >> spaces >> parseIdent)
                   return $ case b of
                      Empty -> Column a
                      otherwise -> QualifiedColumn a b
            <?> "column"
  
  parseModel :: Parser RSVal
  parseModel = liftM Model parseIdent
  
  parseIdent :: Parser RSVal
  parseIdent = do s <- symbol
                  spaces
                  return $ Symbol s
           <|> do char '"'
                  s <- symbol
                  char '"' >> spaces
                  return $ Symbol s
           <|> parseVariable
           <?> "identifier entry"
  
  