content: module RestyScript.Parser.Action (
      readAction
  ) where
  
  import RestyScript.Parser
  import RestyScript.Parser.View
  import RestyScript.AST
  import Text.ParserCombinators.Parsec
  import Text.ParserCombinators.Parsec.Expr
  import Monad (liftM, msum)
  
  readAction :: String -> String -> Either ParseError RSVal
  readAction = parse parseAction
  
  parseAction :: Parser RSVal
  parseAction = do spaces
                   stmts <- sepEndBy1 parseStmt $ many1 (char ';' >> spaces)
                   eof
                   return $ Action stmts
  
  parseStmt :: Parser RSVal
  parseStmt = parseDelete
          <|> parseUpdate
          <|> parseHttp
          <|> parseView
          <?> "action statement"
  
  httpCmds = ["GET", "PUT", "DELETE", "POST"]
  
  parseHttp :: Parser RSVal
  parseHttp = do cmd <- msum $ map keyword httpCmds
                 spaces
                 url <- parseLitExpr
                 content <- option Empty parseJSON
                 return $ HttpCmd cmd url content
  
  litOpTable = [
       [Infix (do { reservedOp "||"; spaces; return Concat} <?> "operator") AssocLeft]
      ]
  
  parseLitExpr :: Parser RSVal
  parseLitExpr = buildExpressionParser litOpTable parseLitAtom
          <?> "literal expression"
  
  parseLitAtom :: Parser RSVal
  parseLitAtom = parseNumber
             <|> parseString
             <|> parseDString
             <|> try (parseVerbatimString)
             <|> parseVariable
             <|> parens parseLitExpr
  
  -- Double quoted strings in the context of HTTP commands
  parseDString :: Parser RSVal
  parseDString = do s <- between (char '"' >> spaces) (char '"' >> spaces)
                          $ many $ quotedChar '"'
                    spaces
                    return $ String s
  
  parseJSON :: Parser RSVal
  parseJSON = parseObject
          <|> parseArray
          <|> parseLitExpr
          <?> "JSON content"
  
  parseObject :: Parser RSVal
  parseObject = do obj <- between (char '{' >> spaces) (char '}' >> spaces)
                      $ sepBy1 parsePair (char ',' >> spaces)
                   spaces
                   return $ Object obj
  
  parsePair :: Parser RSVal
  parsePair = do key <- parseKey
                 char ':'
                 spaces
                 value <- parseJSON
                 return $ Pair key value
  
  parseKey :: Parser RSVal
  parseKey = parseLitExpr
         <|> liftM String symbol
         <?> "JSON hash key"
  
  parseArray :: Parser RSVal
  parseArray = do lst <- between (char '[' >> spaces) (char ']' >> spaces)
                      $ sepBy parseJSON (char ',' >> spaces)
                  spaces
                  return $ Array lst
  
  parseDelete :: Parser RSVal
  parseDelete = do keyword "delete" >> spaces >> keyword "from" >> spaces
                   model <- parseModel
                   cond <- parseWhere
                   return $ Delete model cond
            <?> "SQL delete statement"
  
  parseUpdate :: Parser RSVal
  parseUpdate = do keyword "update" >> spaces
                   model <- parseModel
                   assign <- keyword "set" >> spaces >> parseAssign
                   cond <- option Empty parseWhere
                   return $ Update model assign cond
            <?> "SQL update statement"
  
  parseAssign :: Parser RSVal
  parseAssign = do col <- parseColumn
                   char '=' >> spaces
                   expr <- parseExpr
                   return $ Assign col expr
            <?> "Column assignment"
  
  