module BrownPLT.JavaScript.Contracts.Compiler
( compile
, compile'
, compileFormatted
, compileRelease
) where
import Control.Monad
import qualified Data.Map as M
import Text.PrettyPrint.HughesPJ ( render, vcat )
import Text.ParserCombinators.Parsec.Pos (SourcePos)
import Paths_JsContracts
import System.FilePath ((</>))
import BrownPLT.JavaScript.Parser (ParsedExpression, ParsedStatement,
parseJavaScriptFromFile, parseScriptFromString )
import BrownPLT.JavaScript.Environment (env)
import BrownPLT.JavaScript.Syntax
import BrownPLT.JavaScript.PrettyPrint (renderStatements)
import BrownPLT.JavaScript.Contracts.Types
import BrownPLT.JavaScript.Contracts.Parser
import BrownPLT.JavaScript.Contracts.Template
exposeImplementation :: [String]
-> [ParsedStatement]
exposeImplementation names = map export names where
var n = VarRef noPos (Id noPos n)
undef = VarRef noPos (Id noPos "undefined")
export n = TryStmt noPos
(IfSingleStmt noPos (InfixExpr noPos OpStrictNEq (var n) undef)
(ExprStmt noPos $ AssignExpr noPos OpAssign
(DotRef noPos (ThisRef noPos) (Id noPos n))
(var n)))
[CatchClause noPos (Id noPos "_") (EmptyStmt noPos)]
Nothing
exportNamespace :: String
-> [ParsedStatement]
exportNamespace namespace = [decl,loop] where
ix = VarRef noPos (Id noPos "ix")
window_namespace =
(DotRef noPos (VarRef noPos (Id noPos "window"))
(Id noPos namespace))
decl = ExprStmt noPos $ AssignExpr noPos OpAssign window_namespace
(ObjectLit noPos [])
loop = ForInStmt noPos (ForInVar (Id noPos "ix"))
(VarRef noPos (Id noPos "impl")) $ ExprStmt noPos $
AssignExpr noPos OpAssign (BracketRef noPos window_namespace ix)
(BracketRef noPos (VarRef noPos (Id noPos "impl")) ix)
wrapImplementation :: [ParsedStatement] -> [String] -> [ParsedStatement]
wrapImplementation impl names =
[VarDeclStmt noPos [implDecl], ExprStmt noPos callThunkedImpl] where
implDecl = VarDecl noPos (Id noPos "impl") (Just $ ObjectLit noPos [])
implExport = exposeImplementation names
callThunkedImpl = CallExpr noPos
(DotRef noPos
(ParenExpr noPos $ FuncExpr noPos [Id noPos "impl"]
(BlockStmt noPos (impl ++ implExport)))
(Id noPos "apply"))
[VarRef noPos (Id noPos "impl")]
escapeGlobals :: [ParsedStatement] -> [String] -> [ParsedStatement]
escapeGlobals impl exportNames =
[VarDeclStmt noPos [VarDecl noPos (Id noPos s) Nothing] | s <- allGlobals]
where globalMap = snd (env M.empty impl)
allGlobals = M.keys globalMap
makeExportStatements :: InterfaceItem -> [ParsedStatement]
makeExportStatements (InterfaceExport id pos contract) =
[ ExprStmt noPos $ AssignExpr noPos OpAssign
(DotRef noPos (ThisRef noPos) (Id noPos id))
(compileContract id contract pos $
DotRef noPos (VarRef noPos (Id noPos "impl")) (Id noPos id))
]
makeExportStatements (InterfaceInstance id _ _) =
[ ExprStmt noPos $ AssignExpr noPos OpAssign
(DotRef noPos (ThisRef noPos) (Id noPos id))
(DotRef noPos (VarRef noPos (Id noPos "impl")) (Id noPos id))
]
makeExportStatements _ = [ ]
exportRelease :: InterfaceItem -> ParsedStatement
exportRelease (InterfaceExport id _ contract) =
ExprStmt noPos $ AssignExpr noPos OpAssign
(DotRef noPos (ThisRef noPos) (Id noPos id))
(DotRef noPos (VarRef noPos (Id noPos "impl")) (Id noPos id))
exportRelease _ = error "exportRelease: expected InterfaceItem"
compileAliases :: [InterfaceItem] -> [ParsedStatement]
compileAliases aliases = concatMap init aliases ++ concatMap def aliases where
init (InterfaceAlias id _) = templateStatements
$ renameVar "alias" id (stmtTemplate "var alias = { };")
init (InterfaceInstance id _ _) = templateStatements
$ renameVar "alias" id (stmtTemplate "var alias = { };")
init _ = []
def (InterfaceAlias id contract) = templateStatements
$ renameVar "alias" id
$ substVar "contract" (cc contract)
(stmtTemplate "(function() { var tmp = contract;\n \
\ alias.client = tmp.client;\n \
\ alias.flat = tmp.flat; \
\ alias.server = tmp.server; })(); \n")
def (InterfaceInstance id loc contract) = templateStatements
$ renameVar "alias" id
$ substVar "contract" (cc contract)
$ substVar "name" (StringLit noPos id)
$ substVar "constr" (DotRef noPos (VarRef noPos (Id noPos "impl"))
(Id noPos id))
(stmtTemplate "(function() { \
\ var tmp = contracts.instance(name)(constr,contract); \
\ alias.client = tmp.client; \
\ alias.flat = tmp.flat; \
\ alias.server = tmp.server; })(); ")
def _ = []
compile :: [ParsedStatement]
-> [InterfaceItem]
-> [ParsedStatement]
-> ParsedStatement
compile impl interface boilerplateStmts =
let exportStmts = concatMap makeExportStatements interface
exportNames = [n | InterfaceExport n _ _ <- interfaceExports]
instanceNames = [ n | InterfaceInstance n _ _
<- filter isInterfaceInstance interface ]
aliases = filter isInterfaceAlias interface
aliasStmts = compileAliases interface
wrappedImpl = wrapImplementation (escapeGlobals impl exportNames ++ impl)
(exportNames ++ instanceNames)
interfaceStmts = map interfaceStatement $
filter isInterfaceStatement interface
interfaceExports = filter isInterfaceExport interface
outerWrapper = ParenExpr noPos $ FuncExpr noPos [] $ BlockStmt noPos $
wrappedImpl ++ boilerplateStmts ++ interfaceStmts ++ aliasStmts ++
exportStmts
in ExprStmt noPos $ CallExpr noPos outerWrapper []
libraryHeader =
"(function () {\n \
\ var impl = { };\n \
\ (function() {\n"
compileRelease :: String
-> String
-> String
-> [InterfaceItem]
-> Maybe String
-> String
compileRelease rawImpl implSource boilerplate interface namespace =
libraryHeader ++ (renderStatements $ escapeGlobals impl exportNames)
++ rawImpl ++ exposeStatements ++ "\n}).apply(impl,[]);\n"
++ exportStatements ++ namespaceStatements ++ "\n})();" where
impl = case parseScriptFromString implSource rawImpl of
Left err -> error (show err)
Right (Script _ stmts) -> stmts
exports = filter isInterfaceExport interface
exportStatements = renderStatements (map exportRelease exports)
exportNames = [n | InterfaceExport n _ _ <- exports ]
instanceNames =
[n | InterfaceInstance n _ _ <- filter isInterfaceInstance interface]
exposeStatements = renderStatements
(exposeImplementation (exportNames ++ instanceNames))
namespaceStatements = case namespace of
Nothing -> ""
Just s -> renderStatements (exportNamespace s)
compileFormatted :: String
-> String
-> String
-> [InterfaceItem]
-> String
compileFormatted rawImpl implSource boilerplate interface =
libraryHeader ++ (renderStatements $ escapeGlobals impl exportNames)
++ rawImpl
++ exposeStatements ++ "\n}).apply(impl,[]);\n" ++ boilerplate
++ interfaceStatements
++ aliasStatements ++ exportStatements
++ "\n})();" where
impl = case parseScriptFromString implSource rawImpl of
Left err -> error (show err)
Right (Script _ stmts) -> stmts
exports = filter isInterfaceExport interface
exportStatements =
renderStatements (concatMap makeExportStatements interface)
exportNames = [n | InterfaceExport n _ _ <- exports ]
aliases = filter isInterfaceAlias interface
aliasStatements = renderStatements (compileAliases interface)
instanceNames =
[n | InterfaceInstance n _ _ <- filter isInterfaceInstance interface]
exposeStatements = renderStatements $
exposeImplementation (exportNames ++ instanceNames)
interfaceStatements = renderStatements $ map interfaceStatement $
filter isInterfaceStatement interface
compile' :: [ParsedStatement] -> [InterfaceItem] -> IO ParsedStatement
compile' impl iface = do
dataDir <- getDataDir
boilerplateStmts <- parseJavaScriptFromFile (dataDir</>"contracts.js")
return $ compile impl iface boilerplateStmts
compileContract :: String
-> Contract
-> SourcePos
-> ParsedExpression
-> ParsedExpression
compileContract exportId contract pos guardExpr =
CallExpr noPos (DotRef noPos (VarRef noPos (Id noPos "contracts"))
(Id noPos "guard"))
[cc contract, guardExpr, StringLit noPos exportId,
StringLit noPos "client", StringLit noPos (show (contractPos contract))]
where loc = "on " ++ exportId ++ ", defined at " ++ show pos
nc :: Contract
-> String
nc (FlatContract pos predExpr) =
"value that satisfies the predicate at " ++ show pos
cc :: Contract
-> ParsedExpression
cc ctc = case ctc of
FlatContract _ predExpr -> templateExpression
$ substVar "pred" predExpr
$ substVar "name" (StringLit noPos (nc ctc))
$ exprTemplate "contracts.flat(name)(pred)"
FunctionContract pos domainContracts (Just restContract) rangeContract ->
templateExpression
$ substVar "restArg" (cc restContract)
$ substVar "result" (cc rangeContract)
$ substVarList "fixedArgs"
(map cc domainContracts)
$ substVar "name" (StringLit noPos $ "function at " ++ show pos)
$ exprTemplate
"contracts.varArityFunc(name)([fixedArgs],restArg,result)"
FunctionContract pos domainContracts Nothing rangeContract ->
let isUndefined = DotRef noPos (VarRef noPos (Id noPos "contracts"))
(Id noPos "isUndefined")
in templateExpression
$ substVar "restArg" isUndefined
$ substVar "result" (cc rangeContract)
$ substVarList "fixedArgs" (map cc domainContracts)
$ substVar "name" (StringLit noPos $ "function at " ++ show pos)
$ exprTemplate
"contracts.varArityFunc(name)([fixedArgs],restArg,result)"
ConstructorContract pos constrName args -> CallExpr noPos
(CallExpr noPos
(VarRef noPos (Id noPos constrName))
[StringLit noPos constrName])
(map cc args)
FixedArrayContract pos elts -> templateExpression
$ substVarList "contracts" (map cc elts)
$ substVar "name" (StringLit noPos "fixed-array")
$ exprTemplate "contracts.fixedArray(name)(contracts)"
ArrayContract _ elt -> templateExpression
$ substVar "contract" (cc elt)
$ substVar "name" (StringLit noPos "array")
$ exprTemplate "contracts.unsizedArray(name)(contract)"
ObjectContract pos fields ->
let getField id = DotRef noPos (VarRef noPos $ Id noPos "val") (Id noPos id)
mkProp id = PropId noPos (Id noPos id)
fieldContract (id,contract) = (id, cc contract)
in templateExpression
$ substFieldList "fieldNames" (map fieldContract fields)
$ substVar "name" (StringLit noPos "name")
$ exprTemplate "contracts.obj(name)({ fieldNames: 42 })"
NamedContract _ nameRef ->
VarRef noPos (Id noPos nameRef)