Permalink
Browse files

rudimentary interface parser

  • Loading branch information...
0 parents commit d84b43d925882b0ecf46a38a661940d3e8b00d2f Arjun Guha committed Dec 11, 2008
Showing with 223 additions and 0 deletions.
  1. +3 −0 .gitignore
  2. +27 −0 JsContracts.cabal
  3. +31 −0 Setup.lhs
  4. +101 −0 src/JsContracts/Parser.hs
  5. +17 −0 src/JsContracts/Types.hs
  6. +16 −0 src/Test/Parser.hs
  7. +28 −0 src/Test/basic.jsi
@@ -0,0 +1,3 @@
+dist/
+*~
+.DS_Store
@@ -0,0 +1,27 @@
+Name: JsContracts
+Version: 0.1
+Cabal-Version: >= 1.2
+Copyright: Copyright (c) 2008 Arjun Guha
+License: LGPL
+License-file: LICENSE
+Author: Arjun Guha
+Maintainer: Arjun Guha <arjun@cs.brown.edu>
+Homepage: http://www.cs.brown.edu/research/plt/
+Stability: provisional
+Category: Language
+Build-Type: Custom
+Synopsis: JavaScript analysis tools
+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.10.0
+ ghc-options:
+ -fwarn-incomplete-patterns
+ Extensions:
+ Exposed-Modules:
+ JsContracts.Parser
+ JsContracts.Types
@@ -0,0 +1,31 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> import qualified Data.List as L
+> import System.Directory
+> import System.Process (runCommand,waitForProcess)
+
+> isHaskellFile file = ".lhs" `L.isSuffixOf` file || ".hs" `L.isSuffixOf` file
+
+> moduleName file = "Test." ++ m where
+> m = L.takeWhile (\ch -> ch /= '.') file
+
+> testMain _ _ _ _ = do
+> files <- getDirectoryContents "src/Test"
+> 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 src && ghc -XNoMonomorphismRestriction -fglasgow-exts " ++
+> "-package HUnit -package WebBits -e \"" ++ testExpr ++
+> " >> return ()\" " ++ moduleLine
+> putStrLn "Testing command is:"
+> putStrLn cmd
+> putStrLn "\nLoading tests..."
+> handle <- runCommand cmd
+> waitForProcess handle
+> putStrLn "Testing complete. Errors reported above (if any)."
+
+
+> main = defaultMainWithHooks (simpleUserHooks { runTests = testMain })
@@ -0,0 +1,101 @@
+module JsContracts.Parser
+ ( interface
+ , parseInterface
+ ) where
+
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Expr
+import Text.ParserCombinators.Parsec.Pos
+import WebBits.JavaScript.Lexer
+import WebBits.JavaScript.Parser (parseSimpleExpr', ParsedExpression,
+ parseBlockStmt)
+import JsContracts.Types
+
+{-
+ interface = interfaceItem *
+
+ interfaceItem = identifier :: contract;
+ | blockStmt
+
+ function = nonFunction * -> function
+ | nonFunction
+
+ nonFunction = flat
+ | object
+ | ( function )
+
+ 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 [] result)
+ [arg] -> (do reserved "->"
+ result <- function
+ return (FunctionContract pos [arg] result)) <|>
+ return arg -- nonfunction
+ args' -> do
+ result <- function
+ return (FunctionContract pos args' result)
+
+nonFunction = parens function <|> object <|> flat
+
+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
+ expr <- jsExpr <?> "JavaScript expression"
+ return (FlatContract pos expr)
+
+export :: CharParser st Export
+export = do
+ id <- identifier
+ reservedOp "::"
+ ctc <- contract
+ return (Export id ctc)
+
+interface :: CharParser st [InterfaceItem]
+interface =
+ (do e <- export
+ reservedOp ";"
+ rest <- interface
+ return $ (InterfaceExport e):rest) <|>
+ (do stmt <- parseBlockStmt
+ rest <- interface
+ return $ (InterfaceStatement stmt):rest) <|>
+ (return [])
+
+
+parseInterface :: String -> IO [InterfaceItem]
+parseInterface filename = do
+ chars <- readFile filename
+ case parse interface filename chars of
+ Left err -> fail (show err)
+ Right exports -> return exports
@@ -0,0 +1,17 @@
+module JsContracts.Types where
+
+import Text.ParserCombinators.Parsec.Pos (SourcePos)
+import WebBits.JavaScript.Parser (ParsedExpression, ParsedStatement)
+
+data Contract
+ = FlatContract SourcePos ParsedExpression
+ | FunctionContract SourcePos [Contract] Contract
+ | ObjectContract SourcePos [(String,Contract)]
+ | NoContract SourcePos
+ deriving (Show)
+
+data Export = Export String Contract deriving (Show)
+
+data InterfaceItem = InterfaceExport Export
+ | InterfaceStatement ParsedStatement
+ deriving (Show)
@@ -0,0 +1,16 @@
+module Test.Parser where
+
+import Test.HUnit.Base
+import Test.HUnit.Text
+import JsContracts.Parser
+
+testParsing = TestLabel "test parsing a file" $ TestCase $ do
+ parseInterface "Test/basic.jsi"
+ return ()
+
+
+allTests = TestList
+ [ testParsing
+ ]
+
+main = return allTests
@@ -0,0 +1,28 @@
+{
+ function isNumber(x) {
+ return typeof(x) == "number";
+ }
+
+ function isString(x) {
+ return typeof(x) == "string";
+ }
+}
+
+thunk :: -> isNumber;
+add1 :: isNumber -> isNumber;
+sub1 :: isNumber -> isNumber;
+thunk2 :: -> isString;
+add :: isNumber isNumber -> isNumber;
+div :: isNumber function(x) { x != 0; } -> isNumber;
+makeCoords :: isNumber isNumber -> { x: isNumber, y: isNumber };
+
+{
+ function a(x) {
+ return false; // lol
+ }
+
+ b = a;
+}
+
+
+map :: (a -> b) -> list -> list;

0 comments on commit d84b43d

Please sign in to comment.