packages feed

JsContracts (empty) → 0.4

raw patch · 11 files changed

+1212/−0 lines, 11 filesdep +WebBitsdep +basedep +containersbuild-type:Customsetup-changed

Dependencies added: WebBits, base, containers, directory, filepath, mtl, parsec, pretty, syb

Files

+ JsContracts.cabal view
@@ -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 <arjun@cs.brown.edu>+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:
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -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 })
+ data/contracts.js view
@@ -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(" ");+};
+ src/BrownPLT/JavaScript/Contracts.hs view
@@ -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"
+ src/BrownPLT/JavaScript/Contracts/Compiler.hs view
@@ -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)
+ src/BrownPLT/JavaScript/Contracts/Interface.hs view
@@ -0,0 +1,5 @@+module BrownPLT.JavaScript.Contracts.Interface+  ( module BrownPLT.JavaScript.Contracts.Types+  ) where++import BrownPLT.JavaScript.Contracts.Types
+ src/BrownPLT/JavaScript/Contracts/Parser.hs view
@@ -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
+ src/BrownPLT/JavaScript/Contracts/Template.hs view
@@ -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+      +
+ src/BrownPLT/JavaScript/Contracts/Types.hs view
@@ -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
+ src/Jscc.hs view
@@ -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