module BrownPLT.JavaScript.Contracts.Parser
( interface
, parseInterface
) where
import Control.Monad
import qualified Data.List as L
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Pos
import BrownPLT.JavaScript.Lexer
import BrownPLT.JavaScript.Parser (parseSimpleExpr', ParsedExpression,
parseBlockStmt)
import BrownPLT.JavaScript.Contracts.Types
jsExpr = parseSimpleExpr'
contract :: CharParser st Contract
contract = function
function :: CharParser st Contract
function = do
pos <- getPosition
args <- nonFunction `sepBy` whiteSpace
case args of
[] -> do
reserved "->"
result <- function
return (FunctionContract pos [] Nothing result)
[arg] -> (do reserved "->"
result <- function
return (FunctionContract pos [arg] Nothing result)) <|>
(do reserved "..."
reserved "->"
result <- function
return (FunctionContract pos [] (Just arg) result)) <|>
return arg
args' -> (do reserved "->"
result <- function
return (FunctionContract pos args' Nothing result)) <|>
(do reserved "..."
reserved "->" <?> "-> after ..."
result <- function
let (fixedArgs,[restArg]) = L.splitAt (length args' 1) args'
return (FunctionContract pos fixedArgs (Just restArg) result))
namedContract :: CharParser st Contract
namedContract = do
idFirst <- letter <|> oneOf "$_"
pos <- getPosition
idRest <- many1 (alphaNum <|> oneOf "$_")
let name = idFirst:idRest
let constr = do
args <- parens $ contract `sepBy1` comma
return (ConstructorContract pos name args)
let named = do
whiteSpace
return (NamedContract pos name)
constr <|> named
nonFunction = parens function <|> object <|> namedContract <|> array <|> flat
array :: CharParser st Contract
array = do
pos <- getPosition
reservedOp "["
elt1 <- contract
comma
let arbitrary = do
reservedOp "..."
reservedOp "]"
return (ArrayContract pos elt1)
let fixed = do
elts <- contract `sepBy` comma <?> "elements in an array contract"
reservedOp "]"
return (FixedArrayContract pos (elt1:elts))
arbitrary <|> fixed
field :: CharParser st (String,Contract)
field = do
id <- identifier
reservedOp ":"
ctc <- contract
return (id,ctc)
object :: CharParser st Contract
object = do
pos <- getPosition
fields <- braces $ field `sepBy1` (reservedOp ",")
return (ObjectContract pos fields)
flat :: CharParser st Contract
flat = do
pos <- getPosition
reservedOp ":"
expr <- jsExpr <?> "JavaScript expression"
return (FlatContract pos expr)
interfaceExport = do
reservedOp "::"
return $ \id ->
liftM2 (InterfaceExport id) getPosition contract
interfaceAlias = do
reservedOp "=" >> (return $ \id -> liftM (InterfaceAlias id) contract)
interfaceInstance = do
reserved "instance"
id <- identifier
pos <- getPosition
contract <- object
reservedOp ";"
return (InterfaceInstance id pos contract)
interfaceElement = interfaceExport <|> interfaceAlias
interface :: CharParser st [InterfaceItem]
interface = many $ interfaceInstance <|>
(stmt $ interfaceElement `fap` identifier) <|>
(liftM InterfaceStatement parseBlockStmt)
where stmt p = do { e <- p; reservedOp ";"; return e }
fap k m = do { e <- m; f <- k; f e }
parseInterface :: String -> IO [InterfaceItem]
parseInterface filename = do
chars <- readFile filename
let parser = do
whiteSpace
r <- interface
eof
return r
case parse parser filename chars of
Left err -> fail (show err)
Right exports -> return exports