diff --git a/JsContracts.cabal b/JsContracts.cabal new file mode 100644 --- /dev/null +++ b/JsContracts.cabal @@ -0,0 +1,46 @@ +Name: JsContracts +Version: 0.4 +Cabal-Version: >= 1.2.3 +Copyright: Copyright (c) 2008-2009 Arjun Guha and Spiridon Eliopoulos +License: BSD3 +License-file: LICENSE +Author: Arjun Guha and Spiridon Eliopoulos +Maintainer: Arjun Guha +Homepage: http://www.cs.brown.edu/research/plt/ +Stability: provisional +Category: Language +Build-Type: Custom +Synopsis: Design-by-contract for JavaScript +Data-Dir: data +Data-Files: + contracts.js +Description: + +Library + Hs-Source-Dirs: + src + Build-Depends: + base>=4, mtl>=1.1.0.1, parsec<3.0.0, pretty>=0.1, containers>=0.1, syb>=0.1, + WebBits>=0.15, filepath, directory + ghc-options: + -fwarn-incomplete-patterns + Extensions: + Exposed-Modules: + BrownPLT.JavaScript.Contracts + BrownPLT.JavaScript.Contracts.Interface + Other-Modules: + Paths_JsContracts + BrownPLT.JavaScript.Contracts.Parser + BrownPLT.JavaScript.Contracts.Types + BrownPLT.JavaScript.Contracts.Compiler + BrownPLT.JavaScript.Contracts.Template + +Executable jscc + Main-Is: Jscc.hs + Hs-Source-Dirs: src + Build-Depends: + base>=4, mtl>=1.1.0.1, parsec<3.0.0, pretty>=0.1, containers>=0.1, syb>=0.1, + WebBits>=0.15 + ghc-options: + -fwarn-incomplete-patterns + Extensions: diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2008-2009, Arjun Guha and Spiridon Eliopoulos. +All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Brown University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,28 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> import qualified Data.List as L +> import System.Directory +> import System.Process (runCommand,waitForProcess) +> import System.IO (hPutStrLn, stderr) + +> isHaskellFile file = ".lhs" `L.isSuffixOf` file || ".hs" `L.isSuffixOf` file + +> moduleName file = L.takeWhile (\ch -> ch /= '.') file + +> testMain _ _ _ _ = do +> files <- getDirectoryContents "tests" +> let tests = filter isHaskellFile files +> let testModules = map moduleName tests +> let testFuncs = map (++ ".main") testModules +> let testExpr = "sequence [ " ++ concat (L.intersperse "," testFuncs) ++ +> " ] >>= \\cases -> runTestTT (TestList cases)" +> let moduleLine = concat (L.intersperse " " testModules) +> let cmd = "cd tests && ghc -XNoMonomorphismRestriction -fglasgow-exts " ++ +> "-package HUnit -package WebBits -package parsec-2.1.0.1 -i../src:../dist/build/autogen -e \"" ++ +> testExpr ++ " >> return ()\" " ++ moduleLine +> handle <- runCommand cmd +> waitForProcess handle +> hPutStrLn stderr "Testing complete. Errors reported above (if any)." + + +> main = defaultMainWithHooks (simpleUserHooks { runTests = testMain }) diff --git a/data/contracts.js b/data/contracts.js new file mode 100644 --- /dev/null +++ b/data/contracts.js @@ -0,0 +1,329 @@ +var contracts = { }; + +contracts.map = function(f,arr) { + var dest = [ ]; + for (var i = 0; i < arr.length; i++) { + dest.push(f(arr[i])); + } + return dest; +}; + +contracts.zipWith = function(f,arr1,arr2) { + var dest = [ ]; + for (var i = 0; i < arr1.length; i++) { + dest.push(f(arr1[i],arr2[i])); + } + return dest; +}; + +contracts.blame = function(guilty,expected,received,message,loc) { + var guiltyMsg = typeof(guilty) == "string" + ? guilty : guilty.value; + var msg = guiltyMsg + " violated the contract at " + loc + "; expected " + + expected + " but received " + received + "; " + message; + var err = new Error(msg); + err.guilty = msg; + err.blamed = guiltyMsg; + err.expected = expected; + err.received = received; + err.guardLoc = loc; + try { console.log(err); } catch(_) { }; + throw err; +} + +// The type of a contract combinator is: name -> args ... -> contract +// +// name is a human-readable name for the contract. args .. are constructor- +// specified arguments and contract is the resulting contract. + + +contracts.flat = function(name) { + return function(pred) { + return { + flat: function(val) { return pred(val); }, + server: function(s,loc) { + return function(val) { + if (pred(val)) { + return val; + } + else { + contracts.blame(s,name,val,"does not satisfy the predicate",loc); + } + }; + }, + client: function(s,loc) { + return function(val) { return val; }; + } + }; + }; +}; + + +contracts.unsizedArray = function(name) { + return function(elt) { + return { + flat: function(val) { + return val instanceof Array; + for (var i = 0; i < val.length; i++) { + if (!(elt.flat(val[i]))) { return false; } + } + return true; + }, + server: function(s,loc) { + return function(val) { + if (val instanceof Array) { + return contracts.map(elt.server(s,loc),val); + } + else { + contracts.blame(s, name, val, "not an array",loc); + } + }; + }, + client: function(s,loc) { + return function(val) { + if (val instanceof Array) { + return contracts.map(elt.client(s,loc),val); + } + else { + return val; + } + } + } + }; + }; +}; + +contracts.fixedArray = function(name) { + return function() { + var elts = arguments; + return { + flat: function(val) { + if (!(val instanceof Array && val.length == elts.length)) { + return false; + } + for (var i = 0; i < val.length; i++) { + if (!elts[i].flat(val[i])) { return false; } + } + return true; + }, + server: function(s,loc) { + return function(val) { + if (val instanceof Array && val.length == elts.length) { + var result = [ ]; + for (var i = 0; i < elts.length; i++) { + result.push(elts[i].server(s,loc)(val[i])); + } + return result; + } + else { + contracts.blame(s,name,val,"not an array of the right size",loc); + } + }; + }, + client: function(s,loc) { + return function(val) { + if (val instanceof Array && val.length == elts.length) { + var result = [ ]; + for (var i = 0; i < elts.length; i++) { + result.push(elts[i].client(s,loc)(val[i])); + } + return result; + } + else { + return val; + } + } + } + }; + }; +}; + +contracts.isUndefined = contracts.flat(function(val) { + return val === undefined; +}); + +contracts.varArityFunc = function(name) { + return function(fixedArgs,restArgs,result) { + return { + isHigherOrder: true, + flat: function(val) { return typeof(val) == "function"; }, + server: function(s,loc) { + return function(proc) { + if (typeof(proc) == "function") { + return function() { + var guardedArgs = contracts.zipWith(function(ctc,arg) { + return ctc.client(s,loc)(arg); + }, fixedArgs, arguments); + for (var i = fixedArgs.length; i < arguments.length; i++) { + guardedArgs.push(restArgs.client(s,loc)(arguments[i])); + } + return result.server(s,loc)(proc.apply(this, guardedArgs)); + }; + } + else { contracts.blame(s,name, proc,"not a function",loc); } + } + }, + client: function(s,loc) { + return function(proc) { + if (typeof(proc) == "function") { + return function() { + var guardedArgs = contracts.zipWith(function(ctc,arg) { + return ctc.server(s,loc)(arg); + }, fixedArgs, arguments); + for (var i = fixedArgs.length; i < arguments.length; i++) { + guardedArgs.push(restArgs.server(s,loc)(arguments[i])); + } + return result.client(s,loc)(proc.apply(this, guardedArgs)); + }; + } + else { + return proc; + } + }; + } + }; + }; +}; + +// Ensures value is an instanceof constr before checking that its shape +// matches sig. constrId is a human-readable name for the constructor. +contracts.instance = function(name) { + return function(constr, sig) { + return { + flat: function(val) { + return (typeof(val) == "object" || typeof(val) == "function") && + (val instanceof constr) && sig.flat(val); + }, + server: function(s,loc) { return function(val) { + if ((typeof(val) == "object" || typeof(val) == "function") && + (val instanceof constr)) { + return sig.server(s,loc)(val); + } + else { + contracts.blame(s, name, val, "wrong instance",loc); + } + } }, + client: function(s,loc) { return function(val) { + if ((typeof(val) == "object" || typeof(val) == "function") && + (val instanceof constr)) { + return sig.client(s,loc)(val); + } + else { + return val; + } + } } + }; + }; +}; + +contracts.obj = function(name) { + return function(sig) { + return { + flat: function(val) { + for (var field in sig) { + if (!(sig[field].flat(val[field]))) { return false; } + } + return true; + }, + server: function(s,loc) { + return function (obj) { + var constr = function() { }; + constr.prototype = obj; + var guardedObj = new constr(); + + for (var field in sig) { + guardedObj[field] = sig[field].server(s,loc)(obj[field]); + } + return guardedObj; + }; + }, + client: function(s,loc) { + return function (obj) { + var constr = function() { }; + constr.prototype = obj; + var guardedObj = new constr(); + + for (var field in sig) { + guardedObj[field] = sig[field].client(s,loc)(obj[field]); + } + return guardedObj; + }; + } + }; + }; +}; + +// pos is the name of val. neg should be the name of the calling context. +// Since we do not rewrite call-sites, neg is simply "client". +// However, if ctc.isHigherOrder, we can determine the name of the calling +// context by examining the stack when val is called. +// if !ctc.isHigherOrder, the name of the calling context is the name of the +// definition point (neg) +contracts.guard = function(ctc,val,pos,neg,loc) { + if (ctc.isHigherOrder) { + if (typeof(val) != "function") { + contracts.blame(pos, "a function", proc, "not a function","guard"); + } + else { + var deferredNeg = { value: "not called" }; + var fn = ctc.client(deferredNeg,loc)(ctc.server(pos,loc)(val)); + return function() { + deferredNeg.value = contracts.stackTrace(); + return fn.apply(this,arguments); + }; + } + } + else { + return ctc.client(neg,loc)(ctc.server(pos,loc)(val)); + } +}; + +// Derived from http://eriwen.com/javascript/js-stack-trace/ +contracts.stackTrace = function() { + var callstack = []; + var isCallstackPopulated = false; + try { + i.dont.exist+=0; //does not exist - that's the point + } catch(e) { + if (e.stack) { //Firefox + var lines = e.stack.split("\n"); + for (var i = 0, len = lines.length; i < len; i++) { + if (lines[i].match(/^\s*[A-Za-z0-9\-_\$]+\(/)) { + callstack.push(lines[i]); + } + } + //Remove call to printStackTrace() + callstack.shift(); + isCallstackPopulated = true; + } + else if (window.opera && e.message) { //Opera + var lines = e.message.split("\n"); + for (var i = 0, len = lines.length; i < len; i++) { + if (lines[i].match(/^\s*[A-Za-z0-9\-_\$]+\(/)) { + var entry = lines[i]; + //Append next line also since it has the file info + if (lines[i+1]) { + entry += " at " + lines[i+1]; + i++; + } + callstack.push(entry); + } + } + //Remove call to printStackTrace() + callstack.shift(); + isCallstackPopulated = true; + } + } + if (!isCallstackPopulated) { //IE and Safari + var currentFunction = arguments.callee.caller; + while (currentFunction) { + var fn = currentFunction.toString(); + //If we can't get the function name set to "anonymous" + var fname = fn.substring(fn.indexOf("function") + 8, fn.indexOf("(")) || "anonymous"; + callstack.push(fname); + currentFunction = currentFunction.caller; + } + } + + return callstack.length == 0 ? "client" : callstack.join(" "); +}; diff --git a/src/BrownPLT/JavaScript/Contracts.hs b/src/BrownPLT/JavaScript/Contracts.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Contracts.hs @@ -0,0 +1,21 @@ +module BrownPLT.JavaScript.Contracts + ( Contract (..) + , InterfaceItem (..) + , compile + , compileFormatted + , compileRelease + , parseInterface + , getContractLibraryPath + ) where + +import System.FilePath +import Paths_JsContracts -- created by Cabal + +import BrownPLT.JavaScript.Contracts.Types +import BrownPLT.JavaScript.Contracts.Compiler +import BrownPLT.JavaScript.Contracts.Parser + +getContractLibraryPath :: IO FilePath +getContractLibraryPath = do + dataDir <- getDataDir + return $ dataDir "contracts.js" diff --git a/src/BrownPLT/JavaScript/Contracts/Compiler.hs b/src/BrownPLT/JavaScript/Contracts/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Contracts/Compiler.hs @@ -0,0 +1,314 @@ +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 -- created by Cabal +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 + + +-- Given the name foo, we get +-- +-- try { +-- // allow the implementation to export to this directly +-- if (this.foo !== undefined) { +-- this.foo = foo; +-- } +-- } +-- catch (_) { +-- // in case the local variable foo is undefined +-- } +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 + +-- Given a namespace, e.g. flapjax, we get +-- +-- window.flapjax = { }; +-- for (var ix in impl) { +-- window.flapjax[ix] = impl[ix]; } +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)) + ] +-- allows external code to use "instanceof 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" + + +-- Given source that reads: +-- +-- foo = contract; +-- ... +-- +-- Transform it to: +-- +-- var foo = { }; ... +-- (function() { +-- var tmp = contract; +-- foo.client = tmp.client; +-- foo.server = tmp.server; +-- })(); +-- +-- The names are first initialized to empty object to permit mutually-recursive +-- contract definitions. +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 -- same as above + $ 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] -- ^implementation + -> [InterfaceItem] -- ^the interface + -> [ParsedStatement] -- ^contract library + -> ParsedStatement -- ^encapsulated implementation +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 -- ^implementation + -> String -- ^implementation source + -> String -- ^contract library + -> [InterfaceItem] -- ^the interface + -> Maybe String -- ^the namespace name + -> String -- ^encapsulated implementation +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 -- ^implementation + -> String -- ^implementation source + -> String -- ^contract library + -> [InterfaceItem] -- ^the interface + -> String -- ^encapsulated implementation +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 -- ^export name + -> Contract -- ^ contract + -> SourcePos -- ^ location of export + -> 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 + + + +-- |contract name compiler +nc :: Contract + -> String +nc (FlatContract pos predExpr) = + "value that satisfies the predicate at " ++ show pos + +-- TODO: hygiene. Use an extended annotation (Either SourcePos ...) to +-- determine whether or not to substitute into a template. +-- |contract compiler + +cc :: Contract -- ^parsed contract + -> ParsedExpression -- ^contract in JavaScript +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)" + -- User-defined contract constructor + 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) diff --git a/src/BrownPLT/JavaScript/Contracts/Interface.hs b/src/BrownPLT/JavaScript/Contracts/Interface.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Contracts/Interface.hs @@ -0,0 +1,5 @@ +module BrownPLT.JavaScript.Contracts.Interface + ( module BrownPLT.JavaScript.Contracts.Types + ) where + +import BrownPLT.JavaScript.Contracts.Types diff --git a/src/BrownPLT/JavaScript/Contracts/Parser.hs b/src/BrownPLT/JavaScript/Contracts/Parser.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Contracts/Parser.hs @@ -0,0 +1,164 @@ +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 + +{- + interface = interfaceItem * + + interfaceItem = identifier :: contract; + | instance identifier object; + | identifier = contract; + | blockStmt + + function = nonFunction * -> function + | nonFunction + ... -> function + | nonFunction + + nonFunction = :flat + | contractLabel + | customConstructor(contract ,*) + | object + | ( function ) + | [ contract ,* ] -- fixed length array + | [ contract , ... ] -- arbitrary length array + + flat = jsExpr + + object = { identifier : contract ,* } + +-} + +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 -- nonfunction + 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 + -- same as JavaScript (from WebBits' lexer) + 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 diff --git a/src/BrownPLT/JavaScript/Contracts/Template.hs b/src/BrownPLT/JavaScript/Contracts/Template.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Contracts/Template.hs @@ -0,0 +1,134 @@ +module BrownPLT.JavaScript.Contracts.Template + ( JavaScriptTemplate + , exprTemplate + , stmtTemplate + , substVar + , substVarList + , substIdList + , substFieldList + , expandCall + , templateExpression + , noPos + , thunkExpr + , renderTemplate + , renameVar + , templateStatements + ) where + +import Data.Data +import Data.Generics +import Text.ParserCombinators.Parsec (parse, many1) +import Text.ParserCombinators.Parsec.Pos (initialPos, SourcePos) +import Text.PrettyPrint.HughesPJ (render) +import BrownPLT.JavaScript.PrettyPrint (renderExpression, renderStatements) +import BrownPLT.JavaScript.Parser +import BrownPLT.JavaScript.Syntax +import BrownPLT.JavaScript.Instances() +import BrownPLT.JavaScript.Crawl() -- hack for instance + +noPos :: SourcePos +noPos = initialPos "template" + +thunkExpr :: ParsedExpression -> ParsedExpression +thunkExpr expr = FuncExpr noPos [] (ReturnStmt noPos (Just expr)) + +-- We may extend this later so that template definitions explicitly +-- state their free identifiers +data JavaScriptTemplate + = ExpressionTemplate ParsedExpression + | StatementTemplate [ParsedStatement] + +exprTemplate :: String -> JavaScriptTemplate +exprTemplate str = case parse parseAssignExpr "expression template" str of + Left err -> error ("Error parsing template: " ++ show err ++ + "; template:\n\n" ++ str) + Right expr -> ExpressionTemplate expr + +stmtTemplate :: String -> JavaScriptTemplate +stmtTemplate str = case parse (many1 parseStatement) "statement template" str of + Left err -> error ("Error parsing template: " ++ show err ++ + "; template:\n\n" ++ str) + Right stmts -> StatementTemplate stmts + +renderTemplate :: JavaScriptTemplate -> String +renderTemplate (ExpressionTemplate expr) = renderExpression expr +renderTemplate (StatementTemplate stmts) = renderStatements stmts + +templateExpression :: JavaScriptTemplate -> ParsedExpression +templateExpression (ExpressionTemplate expr) = expr + +templateStatements :: JavaScriptTemplate -> [ParsedStatement] +templateStatements (StatementTemplate stmts) = stmts + +expandCall :: String -- ^function name to expand + -> ([ParsedExpression] -> [ParsedExpression]) -- ^argument expander + -> JavaScriptTemplate + -> JavaScriptTemplate +expandCall functionId expander (StatementTemplate body) = + StatementTemplate (everywhere (mkT subst) body) where + subst (CallExpr p1 fn@(VarRef p2 (Id p3 id')) args) + | id' == functionId = CallExpr p1 fn (expander args) + subst expr = expr + +renameVar :: String -- ^original id + -> String -- ^new id + -> JavaScriptTemplate + -> JavaScriptTemplate +renameVar idOld idNew body = + let -- explicit signatures needed for generics + substExpr :: ParsedExpression -> ParsedExpression + substExpr (VarRef p1 (Id p2 thisId)) + | thisId == idOld = VarRef p1 (Id p2 idNew) + substExpr v = v + substDecl :: VarDecl SourcePos -> VarDecl SourcePos + substDecl (VarDecl p1 (Id p2 thisId) val) + | thisId == idOld = VarDecl p1 (Id p2 idNew) val + substDecl v = v + in case body of + ExpressionTemplate body -> ExpressionTemplate $ + everywhere ((mkT substDecl) . (mkT substExpr)) body + StatementTemplate stmts -> StatementTemplate $ + everywhere (mkT substDecl . mkT substExpr) stmts + +substVar :: String -- ^free identifier + -> ParsedExpression -- ^expression to substitute + -> JavaScriptTemplate + -> JavaScriptTemplate +substVar id expr body = + let subst (VarRef _ (Id _ id')) | id' == id = expr + subst expr = expr + in case body of + ExpressionTemplate body -> + ExpressionTemplate (everywhere (mkT subst) body) + StatementTemplate stmts -> + StatementTemplate (everywhere (mkT subst) stmts) + +substVarList :: String -- ^identifier in a list + -> [ParsedExpression] -- ^list of expressions to substitute + -> JavaScriptTemplate + -> JavaScriptTemplate +substVarList id exprs (ExpressionTemplate body) = + ExpressionTemplate (everywhere (mkT subst) body) where + subst [VarRef _ (Id _ id')] | id' == id = exprs + subst lst = lst + +substIdList :: String -- ^identifier in a list + -> [String] -- ^list of identifiers to substitute + -> JavaScriptTemplate + -> JavaScriptTemplate +substIdList id ids (ExpressionTemplate body) = + ExpressionTemplate (everywhere (mkT subst) body) where + subst [Id _ id'] | id' == id = map (Id noPos) ids + subst lst = lst + +substFieldList :: String -- ^ placeholder field name + -> [(String,ParsedExpression)] -- ^list of fields + -> JavaScriptTemplate + -> JavaScriptTemplate +substFieldList fieldId fields (ExpressionTemplate body) = + ExpressionTemplate (everywhere (mkT subst) body) where + fields' = map (\(name,expr) -> (PropId noPos (Id noPos name),expr)) fields + subst [(PropId _ (Id _ id'), _)] | id' == fieldId = fields' + subst lst = lst + + diff --git a/src/BrownPLT/JavaScript/Contracts/Types.hs b/src/BrownPLT/JavaScript/Contracts/Types.hs new file mode 100644 --- /dev/null +++ b/src/BrownPLT/JavaScript/Contracts/Types.hs @@ -0,0 +1,45 @@ +module BrownPLT.JavaScript.Contracts.Types where + +import qualified Data.List as L +import Text.ParserCombinators.Parsec.Pos (SourcePos) +import BrownPLT.JavaScript.Parser (ParsedExpression, ParsedStatement) + +data Contract + = FlatContract SourcePos ParsedExpression + | NamedContract SourcePos String + | FunctionContract SourcePos [Contract] (Maybe Contract) Contract + | ConstructorContract SourcePos String [Contract] + | FixedArrayContract SourcePos [Contract] + | ArrayContract SourcePos Contract + | ObjectContract SourcePos [(String,Contract)] + deriving (Show) + + +contractPos :: Contract -> SourcePos +contractPos ctc = case ctc of + FlatContract p _ -> p + NamedContract p _ -> p + FunctionContract p _ _ _ -> p + ConstructorContract p _ _ -> p + FixedArrayContract p _ -> p + ArrayContract p _ -> p + ObjectContract p _ -> p + +data InterfaceItem + = InterfaceExport String SourcePos Contract + | InterfaceAlias String Contract + | InterfaceStatement { interfaceStatement :: ParsedStatement } + | InterfaceInstance String SourcePos Contract -- ^always an object contract + deriving (Show) + +isInterfaceStatement (InterfaceStatement _) = True +isInterfaceStatement _ = False + +isInterfaceExport (InterfaceExport{}) = True +isInterfaceExport _ = False + +isInterfaceAlias (InterfaceAlias{}) = True +isInterfaceAlias _ = False + +isInterfaceInstance (InterfaceInstance{}) = True +isInterfaceInstance _ = False diff --git a/src/Jscc.hs b/src/Jscc.hs new file mode 100644 --- /dev/null +++ b/src/Jscc.hs @@ -0,0 +1,100 @@ +-- JavaScript Contract Compiler +module Main where + +import System.Console.GetOpt +import System.Environment +import System.Directory +import System.FilePath +import System.Exit +import Control.Monad +import BrownPLT.JavaScript.Contracts +import Paths_JsContracts -- created by Cabal +import BrownPLT.JavaScript.Parser (parseJavaScriptFromFile) + +data Flag + = Help + | Release + | Debug + | Namespace String + | Interface String + deriving (Eq,Ord,Show) + + +options :: [ OptDescr Flag ] +options = + [ Option ['h'] ["help"] (NoArg Help) + "display this help message" + , Option ['r'] ["release"] (NoArg Release) + "encapsulate, ignoring all contracts" + , Option ['d'] ["debug"] (NoArg Debug) + "enable contracts and encapsulate (default)" + , Option ['n'] ["namespace"] (ReqArg Namespace "NAMESPACE") + "exports names to the namespace" + , Option ['i'] ["interface"] (ReqArg Interface "PATH") + "path to the interface; uses module.jsi by default" + ] + +usage = usageInfo + "Usage: jscc [options] module.js\nOptions:\n" options + +main = do + args <- getArgs + dataDir <- getDataDir + let (opts, nonOpts, errors) = getOpt RequireOrder options args + unless (null errors) $ do + mapM_ putStrLn errors + fail "jscc terminated" + checkHelp opts + (isDebugMode, opts) <- getDebugMode opts + (namespace, opts) <- getNamespace opts + (ifacePath, opts) <- getInterfacePath opts nonOpts + when (not $ null opts) $ do + putStrLn $ "spurious arguments: " ++ (show opts) + fail "jscc terminated" + case nonOpts of + [implPath] -> do + checkFile implPath + rawImpl <- readFile implPath + let boilerplatePath = dataDir "contracts.js" + rawBoilerplate <- readFile boilerplatePath + interface <- parseInterface ifacePath + let result = if isDebugMode + then compileFormatted rawImpl implPath rawBoilerplate + interface + else compileRelease rawImpl implPath rawBoilerplate + interface namespace + putStrLn result + return () + otherwise -> do + putStrLn "expected a single filename.js" + fail "jscc terminated" + +checkFile path = do + exists <- doesFileExist path + unless exists $ do + putStrLn $ "could not find the file: " ++ path + exitFailure + +getDebugMode (Release:rest) = return (False,rest) +getDebugMode (Debug:rest) = return (True,rest) +getDebugMode rest = return (True,rest) + +getNamespace ((Namespace s):rest) = return (Just s, rest) +getNamespace rest = return (Nothing,rest) + +checkHelp (Help:_) = do + putStrLn usage + exitSuccess +checkHelp _ = return () + +getInterfacePath :: [Flag] -> [String] -> IO (FilePath,[Flag]) +getInterfacePath (Interface path:rest) _ = do + checkFile path + return (path,rest) +getInterfacePath rest (implPath:_) = do + let path = addExtension (dropExtension implPath) "jsi" + checkFile path + return (path,rest) +getInterfacePath _ [] = do + putStrLn "Invalid arguments (use -h for help)" + exitFailure