0ca3eaa · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Runtime type checks for basic types

0ca3eaaPhil Freeman13 years ago

purescript.cabal+7−8

compare with golang

unifiedsplit

@@ -1,5 +1,5 @@

1name: purescript

2−version: 0.2.7

2+version: 0.2.8

3cabal-version: >=1.8

4build-type: Simple

5license: MIT

@@ -17,9 +17,10 @@ library

17 build-depends: base >=4 && <5, cmdtheline -any, containers -any,

18 directory -any, filepath -any, mtl -any, parsec -any, syb -any,

19 transformers -any, utf8-string -any

20− exposed-modules: Data.Generics.Extras Language.PureScript

20+ exposed-modules: Language.PureScript.Options Data.Generics.Extras

21+ Language.PureScript Language.PureScript.CodeGen

21− Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs

22+ Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS

22− Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST

23+ Language.PureScript.CodeGen.JS.AST

23 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations

24 Language.PureScript.CodeGen.Monad Language.PureScript.Declarations

24 Language.PureScript.Kinds Language.PureScript.Names

25 Language.PureScript.Kinds Language.PureScript.Names

25 Language.PureScript.Operators Language.PureScript.Optimize

26 Language.PureScript.Operators Language.PureScript.Optimize

@@ -36,11 +37,9 @@ library

36 Language.PureScript.TypeChecker.Synonyms

37 Language.PureScript.TypeChecker.Synonyms

37 Language.PureScript.TypeChecker.Types Language.PureScript.Types

38 Language.PureScript.TypeChecker.Types Language.PureScript.Types

38 Language.PureScript.Unknown Language.PureScript.Values Main

39 Language.PureScript.Unknown Language.PureScript.Values Main

39− Language.PureScript.CaseDeclarations

40+ Language.PureScript.CaseDeclarations Language.PureScript.DoNotation

40− Language.PureScript.DoNotation

41 Language.PureScript.TypeDeclarations

42− Language.PureScript.BindingGroups

42+ Language.PureScript.BindingGroups Language.PureScript.Scope

43− Language.PureScript.Scope

44 exposed: True

43 exposed: True

45 buildable: True

44 buildable: True

46 hs-source-dirs: src

45 hs-source-dirs: src

src/Language/PureScript.hs+4−3

@@ -29,12 +29,13 @@ import Language.PureScript.CaseDeclarations as P

29import Language.PureScript.TypeDeclarations as P

30import Language.PureScript.BindingGroups as P

31import Language.PureScript.DoNotation as P

32+import Language.PureScript.Options as P

33import Data.List (intercalate)

34import Data.List (intercalate)

34import Control.Monad (forM_, (>=>))

35import Control.Monad (forM_, (>=>))

36−compile :: [Module] -> Either String (String, String, Environment)

37+compile :: Options -> [Module] -> Either String (String, String, Environment)

37−compile ms = do

38+compile opts ms = do

38 bracketted <- rebracket ms

39 bracketted <- rebracket ms

39 desugared <- desugarDo

40 desugared <- desugarDo

40 >=> desugarCasesModule

41 >=> desugarCasesModule

@@ -42,6 +43,6 @@ compile ms = do

42 >=> (return . createBindingGroupsModule)

43 >=> (return . createBindingGroupsModule)

43 $ bracketted

44 $ bracketted

44 (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls

45 (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls

45− let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared

46+ let js = prettyPrintJS . map (optimize opts) . concatMap (flip (moduleToJs opts) env) $ desugared

46 let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared

47 let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared

47 return (js, exts, env)

48 return (js, exts, env)

src/Language/PureScript/CodeGen/JS.hs+76−44

@@ -30,31 +30,33 @@ import Language.PureScript.Scope

30import Language.PureScript.Declarations

31import Language.PureScript.Pretty.Common

32import Language.PureScript.CodeGen.Monad

33+import Language.PureScript.Options

33import Language.PureScript.CodeGen.JS.AST as AST

34import Language.PureScript.CodeGen.JS.AST as AST

34import Language.PureScript.TypeChecker.Monad (NameKind(..))

35import Language.PureScript.TypeChecker.Monad (NameKind(..))

36+import Language.PureScript.Types

36−moduleToJs :: Module -> Environment -> [JS]

38+moduleToJs :: Options -> Module -> Environment -> [JS]

37−moduleToJs (Module pname@(ProperName name) decls) env =

39+moduleToJs opts (Module pname@(ProperName name) decls) env =

38 [ JSVariableIntroduction (Ident name) Nothing

40 [ JSVariableIntroduction (Ident name) Nothing

39 , JSApp (JSFunction Nothing [Ident name]

41 , JSApp (JSFunction Nothing [Ident name]

40− (JSBlock (concat $ mapMaybe (\decl -> declToJs (ModuleName pname) decl env) decls)))

42+ (JSBlock (concat $ mapMaybe (\decl -> declToJs opts (ModuleName pname) decl env) decls)))

41 [JSAssignment (JSAssignVariable (Ident name))

43 [JSAssignment (JSAssignVariable (Ident name))

42 (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]

44 (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]

43 ]

45 ]

45−declToJs :: ModuleName -> Declaration -> Environment -> Maybe [JS]

47+declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

46−declToJs mp (ValueDeclaration ident _ _ val) e =

48+declToJs opts mp (ValueDeclaration ident _ _ val) e =

47− Just [ JSVariableIntroduction ident (Just (valueToJs mp e val)),

49+ Just [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),

48 setProperty (identToJs ident) (JSVar ident) mp ]

50 setProperty (identToJs ident) (JSVar ident) mp ]

49−declToJs mp (BindingGroupDeclaration vals) e =

51+declToJs opts mp (BindingGroupDeclaration vals) e =

50 Just $ concatMap (\(ident, val) ->

52 Just $ concatMap (\(ident, val) ->

51− [ JSVariableIntroduction ident (Just (valueToJs mp e val)),

53+ [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),

52 setProperty (identToJs ident) (JSVar ident) mp ]

54 setProperty (identToJs ident) (JSVar ident) mp ]

53 ) vals

55 ) vals

54−declToJs mp (ExternMemberDeclaration member ident _) _ =

56+declToJs _ mp (ExternMemberDeclaration member ident _) _ =

55 Just [ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]),

57 Just [ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]),

56 setProperty (show ident) (JSVar ident) mp ]

58 setProperty (show ident) (JSVar ident) mp ]

57−declToJs mp (DataDeclaration _ _ ctors) _ =

59+declToJs _ mp (DataDeclaration _ _ ctors) _ =

58 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->

60 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->

59 let

61 let

60 ctorJs =

62 ctorJs =

@@ -65,31 +67,61 @@ declToJs mp (DataDeclaration _ _ ctors) _ =

65 (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))

67 (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))

66 , ("value", JSVar (Ident "value")) ])])

68 , ("value", JSVar (Ident "value")) ])])

67 in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]

69 in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]

68−declToJs _ _ _ = Nothing

70+declToJs _ _ _ _ = Nothing

70setProperty :: String -> JS -> ModuleName -> JS

72setProperty :: String -> JS -> ModuleName -> JS

71setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val

73setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val

73−valueToJs :: ModuleName -> Environment -> Value -> JS

75+valueToJs :: Options -> ModuleName -> Environment -> Value -> JS

74−valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n

76+valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n

75−valueToJs _ _ (StringLiteral s) = JSStringLiteral s

77+valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s

76−valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b

78+valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b

77−valueToJs m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m e) xs)

79+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)

78−valueToJs m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m e)) ps)

80+valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)

79−valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)]

81+valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]

80−valueToJs _ _ (Constructor name) = qualifiedToJS runProperName name

82+valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name

81−valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) []

83+valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []

82−valueToJs m e (Case values binders) = runGen (bindersToJs m e binders (map (valueToJs m e) values))

84+valueToJs opts m e (Case values binders) = runGen (bindersToJs opts m e binders (map (valueToJs opts m e) values))

83−valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el)

85+valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)

84−valueToJs m e (Accessor prop val) = JSAccessor prop (valueToJs m e val)

86+valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)

85−valueToJs m e (Indexer index val) = JSIndexer (valueToJs m e index) (valueToJs m e val)

87+valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)

86−valueToJs m e (App val args) = JSApp (valueToJs m e val) (map (valueToJs m e) args)

88+valueToJs opts m e (App val args) = JSApp (valueToJs opts m e val) (map (valueToJs opts m e) args)

89+valueToJs opts m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs opts m e val)])

87−valueToJs m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m e val)])

90+valueToJs opts m e (TypedValue (Abs args val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing args (JSBlock $ runtimeTypeChecks args ty ++ [JSReturn (valueToJs opts m e val)])

88−valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val)

91+valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)

89−valueToJs m e (Binary op v1 v2) = JSBinary op (valueToJs m e v1) (valueToJs m e v2)

92+valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)

90−valueToJs m e (Var ident) = varToJs m e ident

93+valueToJs _ m e (Var ident) = varToJs m e ident

91−valueToJs m e (TypedValue val _) = valueToJs m e val

94+valueToJs opts m e (TypedValue val _) = valueToJs opts m e val

92−valueToJs _ _ _ = error "Invalid argument to valueToJs"

95+valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

96+

97+runtimeTypeChecks :: [Ident] -> Type -> [JS]

98+runtimeTypeChecks args ty =

99+ let

100+ argTys = getFunctionArgumentTypes ty

101+ in

102+ concat $ zipWith argumentCheck (map JSVar args) argTys

103+ where

104+ getFunctionArgumentTypes :: Type -> [Type]

105+ getFunctionArgumentTypes (Function funArgs _) = funArgs

106+ getFunctionArgumentTypes (ForAll _ ty') = getFunctionArgumentTypes ty'

107+ getFunctionArgumentTypes _ = []

108+ argumentCheck :: JS -> Type -> [JS]

109+ argumentCheck val Number = [typeCheck val "number"]

110+ argumentCheck val String = [typeCheck val "string"]

111+ argumentCheck val Boolean = [typeCheck val "boolean"]

112+ argumentCheck val (Array _) = [arrayCheck val]

113+ argumentCheck val (Object row) =

114+ let

115+ (pairs, _) = rowToList row

116+ in

117+ typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs

118+ argumentCheck val (Function _ _) = [typeCheck val "function"]

119+ argumentCheck val (ForAll _ ty') = argumentCheck val ty'

120+ argumentCheck _ _ = []

121+ typeCheck :: JS -> String -> JS

122+ typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing

123+ arrayCheck :: JS -> JS

124+ arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar (Ident "Array"))) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing

125

94varToJs :: ModuleName -> Environment -> Qualified Ident -> JS

126varToJs :: ModuleName -> Environment -> Qualified Ident -> JS

95varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of

127varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of

@@ -107,17 +139,17 @@ qualifiedToJS :: (a -> String) -> Qualified a -> JS

107qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))

139qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))

108qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))

140qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))

109

141

110−bindersToJs :: ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS

142+bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS

111−bindersToJs m e binders vals = do

143+bindersToJs opts m e binders vals = do

112 setNextName $ firstUnusedName (binders, vals)

144 setNextName $ firstUnusedName (binders, vals)

113 valNames <- replicateM (length vals) fresh

145 valNames <- replicateM (length vals) fresh

114− jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs m e result)] bs grd

146+ jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m e result)] bs grd

115 return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

147 return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

116 vals

148 vals

117 where

149 where

118 go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]

150 go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]

119 go _ done [] Nothing = return done

151 go _ done [] Nothing = return done

120− go _ done [] (Just cond) = return [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]

152+ go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]

121 go (v:vs) done' (b:bs) grd = do

153 go (v:vs) done' (b:bs) grd = do

122 done'' <- go vs done' bs grd

154 done'' <- go vs done' bs grd

123 binderToJs m e v done'' b

155 binderToJs m e v done'' b

@@ -175,16 +207,16 @@ binderToJs m e varName done (NamedBinder ident binder) = do

175 js <- binderToJs m e varName done binder

207 js <- binderToJs m e varName done binder

176 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)

208 return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)

177

209

178−statementToJs :: ModuleName -> Environment -> Statement -> JS

210+statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS

179−statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))

211+statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))

180−statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value)

212+statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs opts m e value)

181−statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts))

213+statementToJs opts m e (While cond sts) = JSWhile (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) sts))

182−statementToJs m e (For ident start end sts) = JSFor ident (valueToJs m e start) (valueToJs m e end) (JSBlock (map (statementToJs m e) sts))

214+statementToJs opts m e (For ident start end sts) = JSFor ident (valueToJs opts m e start) (valueToJs opts m e end) (JSBlock (map (statementToJs opts m e) sts))

183−statementToJs m e (If ifst) = ifToJs ifst

215+statementToJs opts m e (If ifst) = ifToJs ifst

184 where

216 where

185 ifToJs :: IfStatement -> JS

217 ifToJs :: IfStatement -> JS

186− ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m e cond) (JSBlock (map (statementToJs m e) thens)) (fmap elseToJs elses)

218+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) thens)) (fmap elseToJs elses)

187 elseToJs :: ElseStatement -> JS

219 elseToJs :: ElseStatement -> JS

188− elseToJs (Else sts) = JSBlock (map (statementToJs m e) sts)

220+ elseToJs (Else sts) = JSBlock (map (statementToJs opts m e) sts)

189 elseToJs (ElseIf elif) = ifToJs elif

221 elseToJs (ElseIf elif) = ifToJs elif

190−statementToJs m e (Return value) = JSReturn (valueToJs m e value)

222+statementToJs opts m e (Return value) = JSReturn (valueToJs opts m e value)

src/Language/PureScript/CodeGen/JS/AST.hs+2−1

@@ -42,7 +42,8 @@ data JS

42 | JSFor Ident JS JS JS

43 | JSIfElse JS JS (Maybe JS)

44 | JSReturn JS

45+ | JSThrow JS

45− | JSThrow JS deriving (Show, Data, Typeable)

46+ | JSTypeOf JS deriving (Show, Data, Typeable)

47data JSAssignment

48data JSAssignment

48 = JSAssignVariable Ident

49 = JSAssignVariable Ident

src/Language/PureScript/Optimize.hs+19−2

@@ -22,9 +22,10 @@ import Data.Generics

23import Language.PureScript.Names

24import Language.PureScript.CodeGen.JS.AST

25+import Language.PureScript.Options

26−optimize :: JS -> JS

27+optimize :: Options -> JS -> JS

27−optimize = removeUnusedVariables . unThunk . etaConvert . inlineVariables

28+optimize opts = tco opts . removeUnusedVariables . unThunk . etaConvert . inlineVariables

29replaceIdent :: (Data d) => Ident -> JS -> d -> d

30replaceIdent :: (Data d) => Ident -> JS -> d -> d

30replaceIdent var1 js = everywhere (mkT replace)

31replaceIdent var1 js = everywhere (mkT replace)

@@ -101,3 +102,19 @@ unThunk = everywhere (mkT convert)

101 convert :: JS -> JS

102 convert :: JS -> JS

102 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body

103 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body

103 convert js = js

104 convert js = js

105+

106+tco :: Options -> JS -> JS

107+tco opts | optionsTco opts = tco'

108+ | otherwise = id

109+

110+tco' :: JS -> JS

111+tco' = everywhere (mkT convert)

112+ where

113+ convert :: JS -> JS

114+ convert (JSVariableIntroduction name (Just (JSFunction Nothing args body)))

115+ | isTailCall name body = (JSVariableIntroduction name (Just (JSFunction Nothing args (toLoop name args body))))

116+ convert js = js

117+ isTailCall :: Ident -> JS -> Bool

118+ isTailCall _ _ = False

119+ toLoop :: Ident -> [Ident] -> JS -> JS

120+ toLoop = undefined

src/Language/PureScript/Options.hsnew file+23

@@ -0,0 +1,23 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Options

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.Options where

16+

17+data Options = Options

18+ { optionsTco :: Bool

19+ , optionsPerformRuntimeTypeChecks :: Bool

20+ } deriving Show

21+

22+defaultOptions :: Options

23+defaultOptions = Options False False

src/Language/PureScript/Pretty/JS.hs+7

@@ -156,6 +156,12 @@ app = mkPattern' match

156 return (intercalate ", " jss, val)

157 match _ = mzero

158

159+typeOf :: Pattern PrinterState JS ((), JS)

160+typeOf = mkPattern match

161+ where

162+ match (JSTypeOf val) = Just ((), val)

163+ match _ = Nothing

164+

159unary :: UnaryOperator -> String -> Operator PrinterState JS String

165unary :: UnaryOperator -> String -> Operator PrinterState JS String

160unary op str = Wrap match (++)

166unary op str = Wrap match (++)

161 where

167 where

@@ -202,6 +208,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

202 , [ binary LessThanOrEqualTo "<=" ]

208 , [ binary LessThanOrEqualTo "<=" ]

203 , [ binary GreaterThan ">" ]

209 , [ binary GreaterThan ">" ]

204 , [ binary GreaterThanOrEqualTo ">=" ]

210 , [ binary GreaterThanOrEqualTo ">=" ]

211+ , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]

205 , [ unary Not "!" ]

212 , [ unary Not "!" ]

206 , [ unary BitwiseNot "~" ]

213 , [ unary BitwiseNot "~" ]

207 , [ unary Negate "-" ]

214 , [ unary Negate "-" ]

src/Main.hs+15−4

@@ -28,15 +28,15 @@ readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile

28 text <- U.readFile inputFile

29 return $ P.runIndentParser P.parseModules text

31−compile :: Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()

31+compile :: P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()

32−compile input output externs = do

32+compile opts input output externs = do

33 modules <- readInput input

34 case modules of

35 Left err -> do

36 U.print err

37 exitFailure

38 Right ms ->

39− case P.compile ms of

39+ case P.compile opts ms of

40 Left err -> do

41 U.putStrLn err

42 exitFailure

@@ -65,6 +65,17 @@ externsFile :: Term (Maybe FilePath)

65externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])

66 { optDoc = "The output .e.ps file" }

68+tco :: Term Bool

69+tco = value $ flag $ (optInfo [ "tco" ])

70+ { optDoc = "Perform tail call optimizations" }

71+

72+performRuntimeTypeChecks :: Term Bool

73+performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])

74+ { optDoc = "Generate runtime type checks" }

75+

76+options :: Term P.Options

77+options = P.Options <$> tco <*> performRuntimeTypeChecks

78+

68stdInOrInputFiles :: Term (Maybe [FilePath])

79stdInOrInputFiles :: Term (Maybe [FilePath])

69stdInOrInputFiles = combine <$> useStdIn <*> inputFiles

80stdInOrInputFiles = combine <$> useStdIn <*> inputFiles

70 where

81 where

@@ -72,7 +83,7 @@ stdInOrInputFiles = combine <$> useStdIn <*> inputFiles

72 combine True _ = Nothing

83 combine True _ = Nothing

74term :: Term (IO ())

85term :: Term (IO ())

75−term = compile <$> stdInOrInputFiles <*> outputFile <*> externsFile

86+term = compile <$> options <*> stdInOrInputFiles <*> outputFile <*> externsFile

77termInfo :: TermInfo

88termInfo :: TermInfo

78termInfo = defTI

89termInfo = defTI

tests/Main.hs+1−1

@@ -32,7 +32,7 @@ compile inputFile = do

32 Left parseError -> do

33 return (Left $ show parseError)

34 Right ms -> do

35− case P.compile ms of

35+ case P.compile P.defaultOptions ms of

36 Left typeError -> do

37 return (Left typeError)

38 Right (_, _, env) -> do