packages feed

purescript 0.1.1 → 0.1.2

raw patch · 9 files changed

+374/−190 lines, 9 files

Files

purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.1.1+version: 0.1.2 cabal-version: >=1.8 build-type: Simple license: MIT@@ -9,37 +9,28 @@ stability: experimental synopsis: PureScript Programming Language Compiler description: A small compile-to-JS language with extensible records and type-safe blocks+category: Language author: Phil Freeman <paf31@cantab.net> data-dir: ""-category: Language-+  library     build-depends: base >=4 && <5, syb -any, cmdtheline -any,                    containers -any, mtl -any, transformers -any, parsec -any,                    utf8-string -any-    exposed-modules: Main-                     Language.PureScript-                     Language.PureScript.Declarations-                     Language.PureScript.Names-                     Language.PureScript.Types-                     Language.PureScript.Values-                     Language.PureScript.Kinds-                     Language.PureScript.Pretty-                     Language.PureScript.Pretty.Common-                     Language.PureScript.Pretty.Values-                     Language.PureScript.Pretty.Types-                     Language.PureScript.Pretty.Kinds-                     Language.PureScript.CodeGen-                     Language.PureScript.CodeGen.Externs-                     Language.PureScript.CodeGen.JS-                     Language.PureScript.CodeGen.Monad-                     Language.PureScript.Parser+    exposed-modules: Language.PureScript.Optimize+                     Language.PureScript.Pretty.JS Language.PureScript.CodeGen.JS.AST+                     Main Language.PureScript Language.PureScript.Declarations+                     Language.PureScript.Names Language.PureScript.Types+                     Language.PureScript.Values Language.PureScript.Kinds+                     Language.PureScript.Pretty Language.PureScript.Pretty.Common+                     Language.PureScript.Pretty.Values Language.PureScript.Pretty.Types+                     Language.PureScript.Pretty.Kinds Language.PureScript.CodeGen+                     Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS+                     Language.PureScript.CodeGen.Monad Language.PureScript.Parser                      Language.PureScript.Parser.Common                      Language.PureScript.Parser.Declarations-                     Language.PureScript.Parser.Types-                     Language.PureScript.Parser.Values-                     Language.PureScript.Parser.State-                     Language.PureScript.Parser.Kinds+                     Language.PureScript.Parser.Types Language.PureScript.Parser.Values+                     Language.PureScript.Parser.State Language.PureScript.Parser.Kinds                      Language.PureScript.TypeChecker                      Language.PureScript.TypeChecker.Kinds                      Language.PureScript.TypeChecker.Monad@@ -48,8 +39,7 @@     exposed: True     buildable: True     hs-source-dirs: src-    other-modules:-+  executable psc     build-depends: base >=4 && <5, cmdtheline -any, containers -any,                    mtl -any, transformers -any, parsec -any, utf8-string -any,@@ -57,7 +47,8 @@     main-is: Main.hs     buildable: True     hs-source-dirs: src-+    other-modules: Language.PureScript.Optimize+  test-suite tests     build-depends: base >=4 && <5, syb -any, directory -any,                    filepath -any, containers -any, mtl -any, transformers -any,
src/Language/PureScript.hs view
@@ -23,4 +23,7 @@ import Language.PureScript.CodeGen as P import Language.PureScript.TypeChecker as P import Language.PureScript.Pretty as P+import Language.PureScript.Optimize as P++
src/Language/PureScript/CodeGen/JS.hs view
@@ -13,6 +13,7 @@ -----------------------------------------------------------------------------  module Language.PureScript.CodeGen.JS (+    module AST,     declToJs ) where @@ -20,7 +21,7 @@ import Data.Maybe (fromMaybe) import Data.List (intercalate) import qualified Control.Arrow as A-import Control.Arrow ((<+>))+import Control.Arrow ((<+>), second) import Control.Monad (forM) import Control.Applicative @@ -30,203 +31,110 @@ import Language.PureScript.Declarations import Language.PureScript.Pretty.Common import Language.PureScript.CodeGen.Monad+import Language.PureScript.CodeGen.JS.AST as AST -declToJs :: Declaration -> Maybe String-declToJs (ValueDeclaration ident (Abs args ret)) = Just $ "function " ++ identToJs ident ++ "(" ++ intercalate "," (map identToJs args) ++ ") { return " ++ valueToJs ret ++ "; }"-declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"+declToJs :: Declaration -> Maybe [JS]+declToJs (ValueDeclaration ident (Abs args ret)) = Just [JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs ret)])]+declToJs (ValueDeclaration ident val) = Just [JSVariableIntroduction ident (valueToJs val)] declToJs (DataDeclaration _ _ ctors) =-  Just $ flip concatMap ctors $ \(ctor, maybeTy) ->+  Just $ flip map ctors $ \(ctor, maybeTy) ->     case maybeTy of-      Nothing -> "var " ++ ctor ++ " =  { ctor: '" ++ ctor ++ "' };"-      Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"+      Nothing -> JSVariableIntroduction (Ident ctor) (JSObjectLiteral [ ("ctor", JSStringLiteral ctor) ])+      Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]+                  (JSBlock [JSReturn+                    (JSObjectLiteral [ ("ctor", JSStringLiteral ctor)+                                     , ("value", JSVar (Ident "value")) ])]) declToJs _ = Nothing -literals :: Pattern Value String-literals = Pattern $ A.Kleisli match-  where-  match (NumericLiteral n) = Just $ either show show n-  match (StringLiteral s) = Just $ show s-  match (BooleanLiteral True) = Just "true"-  match (BooleanLiteral False) = Just "false"-  match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]"-  match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"-  match (ObjectUpdate o ps) = Just $ "Object.extend("-    ++ valueToJs o ++ ", { "-    ++ intercalate ", " (map objectPropertyToJs ps) ++ " }"-  match (Constructor name) = Just name-  match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"-  match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++  ")(" ++ valueToJs value ++ ")"-    where-    bindersToJs ::  [(Binder, Value)] -> Gen String-    bindersToJs binders = do-      valName <- fresh-      jss <- forM binders $ \(binder, result) -> do-         let js = valueToJs result-         binderToJs valName ("return " ++ js ++ ";") binder-      return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }"-  match (Var ident) = Just (identToJs ident)-  match _ = Nothing--ifThenElse :: Pattern Value ((Value, Value), Value)-ifThenElse = Pattern $ A.Kleisli match-  where-  match (IfThenElse cond th el) = Just ((th, el), cond)-  match _ = Nothing--accessor :: Pattern Value (String, Value)-accessor = Pattern $ A.Kleisli match-  where-  match (Accessor prop val) = Just (prop, val)-  match _ = Nothing--indexer :: Pattern Value (String, Value)-indexer = Pattern $ A.Kleisli match-  where-  match (Indexer index val) = Just (valueToJs index, val)-  match _ = Nothing--app :: Pattern Value (String, Value)-app = Pattern $ A.Kleisli match-  where-  match (App val args) = Just (intercalate "," (map valueToJs args), val)-  match _ = Nothing--lam :: Pattern Value ([String], Value)-lam = Pattern $ A.Kleisli match-  where-  match (Abs args val) = Just (map identToJs args, val)-  match _ = Nothing--unary :: UnaryOperator -> String -> Operator Value String-unary op str = Wrap pattern (++)-  where-  pattern :: Pattern Value (String, Value)-  pattern = Pattern $ A.Kleisli match-    where-    match (Unary op' val) | op' == op = Just (str, val)-    match _ = Nothing--binary :: BinaryOperator -> String -> Operator Value String-binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)-  where-  pattern :: Pattern Value (Value, Value)-  pattern = Pattern $ A.Kleisli match-    where-    match (Binary op' v1 v2) | op' == op = Just (v1, v2)-    match _ = Nothing+valueToJs :: Value -> JS+valueToJs (NumericLiteral n) = JSNumericLiteral n+valueToJs (StringLiteral s) = JSStringLiteral s+valueToJs (BooleanLiteral b) = JSBooleanLiteral b+valueToJs (ArrayLiteral xs) = JSArrayLiteral (map valueToJs xs)+valueToJs (ObjectLiteral ps) = JSObjectLiteral (map (second valueToJs) ps)+valueToJs (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs o, JSObjectLiteral (map (second valueToJs) ps)]+valueToJs (Constructor name) = JSVar (Ident name)+valueToJs (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map statementToJs sts))) []+valueToJs (Case value binders) = runGen (bindersToJs binders (valueToJs value))+valueToJs (IfThenElse cond th el) = JSConditional (valueToJs cond) (valueToJs th) (valueToJs el)+valueToJs (Accessor prop val) = JSAccessor prop (valueToJs val)+valueToJs (Indexer index val) = JSIndexer (valueToJs index) (valueToJs val)+valueToJs (App val args) = JSApp (valueToJs val) (map valueToJs args)+valueToJs (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs val)])+valueToJs (Unary op val) = JSUnary op (valueToJs val)+valueToJs (Binary op v1 v2) = JSBinary op (valueToJs v1) (valueToJs v2)+valueToJs (Var ident) = JSVar ident+valueToJs (TypedValue val _) = valueToJs val -valueToJs :: Value -> String-valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue-  where-  matchValue :: Pattern Value String-  matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)-  operators :: OperatorTable Value String-  operators =-    OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]-                  , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]-                  , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]-                  , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }" ]-                  , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ valueToJs th ++ " : " ++ valueToJs el ]-                  , [ binary    LessThan             "<" ]-                  , [ binary    LessThanOrEqualTo    "<=" ]-                  , [ binary    GreaterThan          ">" ]-                  , [ binary    GreaterThanOrEqualTo ">=" ]-                  , [ unary     Not                  "!" ]-                  , [ unary     BitwiseNot           "~" ]-                  , [ unary     Negate               "-" ]-                  , [ binary    Multiply             "*" ]-                  , [ binary    Divide               "/" ]-                  , [ binary    Modulus              "%" ]-                  , [ binary    Concat               "+" ]-                  , [ binary    Add                  "+" ]-                  , [ binary    Subtract             "-" ]-                  , [ binary    ShiftLeft            "<<" ]-                  , [ binary    ShiftRight           ">>" ]-                  , [ binary    ZeroFillShiftRight   ">>>" ]-                  , [ binary    EqualTo              "===" ]-                  , [ binary    NotEqualTo           "!==" ]-                  , [ binary    BitwiseAnd           "&" ]-                  , [ binary    BitwiseXor           "^" ]-                  , [ binary    BitwiseOr            "|" ]-                  , [ binary    And                  "&&" ]-                  , [ binary    Or                   "||" ]-                    ]+bindersToJs ::  [(Binder, Value)] -> JS -> Gen JS+bindersToJs binders val = do+  valName <- fresh+  jss <- forM binders $ \(binder, result) -> binderToJs valName [JSReturn (valueToJs result)] binder+  return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))+                 [val] -binderToJs :: String -> String -> Binder -> Gen String+binderToJs :: String -> [JS] -> Binder -> Gen [JS] binderToJs varName done NullBinder = return done binderToJs varName done (StringBinder str) =-  return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"+  return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing] binderToJs varName done (NumberBinder num) =-  return $ "if (" ++ varName ++ " === " ++ either show show num ++ ") {" ++ done ++ " }"+  return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing] binderToJs varName done (BooleanBinder True) =-  return $ "if (" ++ varName ++ ") {" ++ done ++ " }"+  return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing] binderToJs varName done (BooleanBinder False) =-  return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"+  return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing] binderToJs varName done (VarBinder ident) =-  return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ done+  return (JSVariableIntroduction ident (JSVar (Ident varName)) : done) binderToJs varName done (NullaryBinder ctor) =-  return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"+  return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock done) Nothing] binderToJs varName done (UnaryBinder ctor b) = do   value <- fresh   js <- binderToJs value done b-  return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"+  return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral ctor)) (JSBlock (JSVariableIntroduction (Ident value) (JSAccessor "value" (JSVar (Ident varName))) : js)) Nothing] binderToJs varName done (ObjectBinder bs) = go done bs   where+  go :: [JS] -> [(String, Binder)] -> Gen [JS]   go done [] = return done   go done ((prop, binder):bs) = do     propVar <- fresh     done' <- go done bs     js <- binderToJs propVar done' binder-    return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js+    return (JSVariableIntroduction (Ident propVar) (JSAccessor prop (JSVar (Ident varName))) : js) binderToJs varName done (ArrayBinder bs rest) = do   js <- go done rest 0 bs-  return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }"+  return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]   where-  cmp = maybe "===" (const ">=") rest+  cmp :: BinaryOperator+  cmp = maybe EqualTo (const GreaterThanOrEqualTo) rest+  go :: [JS] -> Maybe Binder -> Integer -> [Binder] -> Gen [JS]   go done Nothing _ [] = return done   go done (Just binder) index [] = do     restVar <- fresh     js <- binderToJs restVar done binder-    return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js+    return (JSVariableIntroduction (Ident restVar) (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)]) : js)   go done rest index (binder:bs) = do     elVar <- fresh     done' <- go done rest (index + 1) bs     js <- binderToJs elVar done' binder-    return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js+    return (JSVariableIntroduction (Ident elVar) (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName))) : js) binderToJs varName done (NamedBinder ident binder) = do   js <- binderToJs varName done binder-  return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ js+  return (JSVariableIntroduction ident (JSVar (Ident varName)) : js) binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder   where-  done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"--objectPropertyToJs :: (String, Value) -> String-objectPropertyToJs (key, value) = key ++ ": " ++ valueToJs value--statementToJs :: Statement -> String-statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value-statementToJs (Assignment target value) = identToJs target ++ " = " ++ valueToJs value-statementToJs (While cond sts) = "while ("-  ++ valueToJs cond ++ ") {"-  ++ intercalate ";" (map statementToJs sts) ++ "}"-statementToJs (For ident start end sts) = "for (" ++-  identToJs ident ++ " = " ++ valueToJs start ++ ";"-  ++ identToJs ident ++ " < " ++ valueToJs end ++ ";"-  ++ identToJs ident ++ "++) {"-  ++ intercalate ";" (map statementToJs sts) ++ "}"-statementToJs (ForEach ident arr sts) = valueToJs arr-  ++ ".forEach(function(" ++ identToJs ident ++ ") {"-  ++ intercalate ";" (map statementToJs sts) ++ "})"-statementToJs (If ifst) = ifStatementToJs ifst-statementToJs (Return value) = "return " ++ valueToJs value--ifStatementToJs :: IfStatement -> String-ifStatementToJs (IfStatement cond thens elst) =-  "if ("-  ++ valueToJs cond ++ ") {"-  ++ intercalate ";" (map statementToJs thens) ++ "}"-  ++ maybe "" elseStatementToJs elst+  done' = [JSIfElse (valueToJs cond) (JSBlock done) Nothing] -elseStatementToJs :: ElseStatement -> String-elseStatementToJs (Else sts) = " else {" ++ intercalate ";" (map statementToJs sts) ++ "}"-elseStatementToJs (ElseIf ifst) = " else " ++ ifStatementToJs ifst+statementToJs :: Statement -> JS+statementToJs (VariableIntroduction ident value) = JSVariableIntroduction ident (valueToJs value)+statementToJs (Assignment target value) = JSAssignment target (valueToJs value)+statementToJs (While cond sts) = JSWhile (valueToJs cond) (JSBlock (map statementToJs sts))+statementToJs (For ident start end sts) = JSFor ident (valueToJs start) (valueToJs end) (JSBlock (map statementToJs sts))+statementToJs (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs arr)) [JSFunction Nothing [ident] (JSBlock (map statementToJs sts))]+statementToJs (If ifst) = ifToJs ifst+  where+  ifToJs :: IfStatement -> JS+  ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs cond) (JSBlock (map statementToJs thens)) (fmap elseToJs elses)+  elseToJs :: ElseStatement -> JS+  elseToJs (Else sts) = JSBlock (map statementToJs sts)+  elseToJs (ElseIf ifst) = ifToJs ifst+statementToJs (Return value) = JSReturn (valueToJs value)
+ src/Language/PureScript/CodeGen/JS/AST.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CodeGen.JS.AST+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Language.PureScript.CodeGen.JS.AST where++import Language.PureScript.Names+import Language.PureScript.Values++import Data.Data++data JS+  = JSNumericLiteral (Either Integer Double)+  | JSStringLiteral String+  | JSBooleanLiteral Bool+  | JSUnary UnaryOperator JS+  | JSBinary BinaryOperator JS JS+  | JSArrayLiteral [JS]+  | JSIndexer JS JS+  | JSObjectLiteral [(String, JS)]+  | JSAccessor String JS+  | JSFunction (Maybe Ident) [Ident] JS+  | JSApp JS [JS]+  | JSVar Ident+  | JSConditional JS JS JS+  | JSBlock [JS]+  | JSVariableIntroduction Ident JS+  | JSAssignment Ident JS+  | JSWhile JS JS+  | JSFor Ident JS JS JS+  | JSIfElse JS JS (Maybe JS)+  | JSReturn JS+  | JSThrow JS deriving (Show, Data, Typeable)
+ src/Language/PureScript/Optimize.hs view
@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Optimize+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Optimize (+    optimize+) where++import Data.Data+import Data.Generics++import Language.PureScript.Names+import Language.PureScript.CodeGen.JS.AST++optimize :: JS -> JS+optimize = removeUnusedVariables . unThunk . etaConvert . inlineVariables++replaceIdent :: (Data d) => Ident -> JS -> d -> d+replaceIdent var1 js = everywhere (mkT replace)+  where+  replace (JSVar var2) | var1 == var2 = js+  replace js = js++isReassigned :: (Data d) => Ident -> d -> Bool+isReassigned var1 = everything (||) (mkQ False check)+  where+  check :: JS -> Bool+  check (JSAssignment var2 _) | var1 == var2 = True+  check _ = False++isUsed :: (Data d) => Ident -> d -> Bool+isUsed var1 = everything (||) (mkQ False check)+  where+  check :: JS -> Bool+  check (JSVar var2) | var1 == var2 = True+  check (JSAssignment var2 _) | var1 == var2 = True+  check _ = False++shouldInline :: JS -> Bool+shouldInline (JSVar _) = True+shouldInline (JSNumericLiteral _) = True+shouldInline (JSStringLiteral _) = True+shouldInline (JSBooleanLiteral _) = True+shouldInline (JSAccessor _ val) = shouldInline val+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val+shouldInline _ = False++inlineVariables :: JS -> JS+inlineVariables = everywhere (mkT removeFromBlock)+  where+  removeFromBlock :: JS -> JS+  removeFromBlock (JSBlock sts) = JSBlock (go sts)+  removeFromBlock js = js+  go :: [JS] -> [JS]+  go [] = []+  go (JSVariableIntroduction var js : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)+  go (s:sts) = s : go sts++removeUnusedVariables :: JS -> JS+removeUnusedVariables = everywhere (mkT removeFromBlock)+  where+  removeFromBlock :: JS -> JS+  removeFromBlock (JSBlock sts) = JSBlock (go sts)+  removeFromBlock js = js+  go :: [JS] -> [JS]+  go [] = []+  go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts+  go (s:sts) = s : go sts++etaConvert :: JS -> JS+etaConvert = everywhere (mkT convert)+  where+  convert :: JS -> JS+  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [ident] (JSBlock body)) [arg])]) | shouldInline arg = JSBlock (replaceIdent ident arg body)+  convert js = js++unThunk :: JS -> JS+unThunk = everywhere (mkT convert)+  where+  convert :: JS -> JS+  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body+  convert js = js
src/Language/PureScript/Pretty.hs view
@@ -17,6 +17,7 @@ import Language.PureScript.Pretty.Kinds as P import Language.PureScript.Pretty.Values as P import Language.PureScript.Pretty.Types as P+import Language.PureScript.Pretty.JS as P
+ src/Language/PureScript/Pretty/JS.hs view
@@ -0,0 +1,144 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Pretty.JS+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Pretty.JS (+    prettyPrintJS+) where++import Language.PureScript.Names+import Language.PureScript.Values+import Language.PureScript.Pretty.Common+import Language.PureScript.CodeGen.JS.AST++import Data.List+import Data.Maybe (fromMaybe)+import qualified Control.Arrow as A+import Control.Arrow ((***), (<+>), first, second)++literals :: Pattern JS String+literals = Pattern $ A.Kleisli match+  where+  match (JSNumericLiteral n) = Just $ either show show n+  match (JSStringLiteral s) = Just $ show s+  match (JSBooleanLiteral True) = Just "true"+  match (JSBooleanLiteral False) = Just "false"+  match (JSArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintJS xs) ++ "]"+  match (JSObjectLiteral ps) = Just $ "{ " ++ intercalate ", " (map (\(key, value) -> key ++ ": " ++ prettyPrintJS value) ps) ++ " }"+  match (JSBlock sts) = Just $ "{ " ++ intercalate "; " (map prettyPrintJS sts) ++ " }"+  match (JSVar ident) = Just (identToJs ident)+  match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ " = " ++ prettyPrintJS value+  match (JSAssignment target value) = Just $ identToJs target ++ " = " ++ prettyPrintJS value+  match (JSWhile cond sts) = Just $ "while ("+    ++ prettyPrintJS cond ++ ") "+    ++ prettyPrintJS sts+  match (JSFor ident start end sts) = Just $ "for ("+    ++ identToJs ident ++ " = " ++ prettyPrintJS start ++ "; "+    ++ identToJs ident ++ " < " ++ prettyPrintJS end ++ "; "+    ++ identToJs ident ++ "++) "+    ++ prettyPrintJS sts+  match (JSIfElse cond thens elses) = Just $ "if ("+    ++ prettyPrintJS cond ++ ") "+    ++ prettyPrintJS thens+    ++ maybe "" ((" else " ++) . prettyPrintJS) elses+  match (JSReturn value) = Just $ "return " ++ prettyPrintJS value+  match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value+  match _ = Nothing++conditional :: Pattern JS ((JS, JS), JS)+conditional = Pattern $ A.Kleisli match+  where+  match (JSConditional cond th el) = Just ((th, el), cond)+  match _ = Nothing++accessor :: Pattern JS (String, JS)+accessor = Pattern $ A.Kleisli match+  where+  match (JSAccessor prop val) = Just (prop, val)+  match _ = Nothing++indexer :: Pattern JS (String, JS)+indexer = Pattern $ A.Kleisli match+  where+  match (JSIndexer index val) = Just (prettyPrintJS index, val)+  match _ = Nothing++lam :: Pattern JS ((Maybe Ident, [Ident]), JS)+lam = Pattern $ A.Kleisli match+  where+  match (JSFunction name args ret) = Just ((name, args), ret)+  match _ = Nothing++app :: Pattern JS (String, JS)+app = Pattern $ A.Kleisli match+  where+  match (JSApp val args) = Just (intercalate "," (map prettyPrintJS args), val)+  match _ = Nothing++unary :: UnaryOperator -> String -> Operator JS String+unary op str = Wrap pattern (++)+  where+  pattern :: Pattern JS (String, JS)+  pattern = Pattern $ A.Kleisli match+    where+    match (JSUnary op' val) | op' == op = Just (str, val)+    match _ = Nothing++binary :: BinaryOperator -> String -> Operator JS String+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)+  where+  pattern :: Pattern JS (JS, JS)+  pattern = Pattern $ A.Kleisli match+    where+    match (JSBinary op' v1 v2) | op' == op = Just (v1, v2)+    match _ = Nothing++prettyPrintJS :: JS -> String+prettyPrintJS = fromMaybe (error "Incomplete pattern") . pattern matchValue+  where+  matchValue :: Pattern JS String+  matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)+  operators :: OperatorTable JS String+  operators =+    OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]+                  , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]+                  , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]+                  , [ Wrap lam $ \(name, args) ret -> "function "+                        ++ maybe "" identToJs name+                        ++ "(" ++ intercalate "," (map identToJs args) ++ ") "+                        ++ ret ]+                  , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS th ++ " : " ++ prettyPrintJS el ]+                  , [ binary    LessThan             "<" ]+                  , [ binary    LessThanOrEqualTo    "<=" ]+                  , [ binary    GreaterThan          ">" ]+                  , [ binary    GreaterThanOrEqualTo ">=" ]+                  , [ unary     Not                  "!" ]+                  , [ unary     BitwiseNot           "~" ]+                  , [ unary     Negate               "-" ]+                  , [ binary    Multiply             "*" ]+                  , [ binary    Divide               "/" ]+                  , [ binary    Modulus              "%" ]+                  , [ binary    Concat               "+" ]+                  , [ binary    Add                  "+" ]+                  , [ binary    Subtract             "-" ]+                  , [ binary    ShiftLeft            "<<" ]+                  , [ binary    ShiftRight           ">>" ]+                  , [ binary    ZeroFillShiftRight   ">>>" ]+                  , [ binary    EqualTo              "===" ]+                  , [ binary    NotEqualTo           "!==" ]+                  , [ binary    BitwiseAnd           "&" ]+                  , [ binary    BitwiseXor           "^" ]+                  , [ binary    BitwiseOr            "|" ]+                  , [ binary    And                  "&&" ]+                  , [ binary    Or                   "||" ]+                    ]
src/Language/PureScript/Pretty/Values.hs view
@@ -112,7 +112,7 @@                   , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]                   , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]                   , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]-                  , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ prettyPrintValue val ++ "; }" ]+                  , [ Split lam $ \args val -> "\\" ++ intercalate ", " args ++ " -> " ++ prettyPrintValue val ]                   , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]                   , [ binary    LessThan             "<" ]                   , [ binary    LessThanOrEqualTo    "<=" ]
src/Main.hs view
@@ -40,7 +40,7 @@           U.putStrLn typeError           exitFailure         Right (_, env) -> do-          let js = intercalate "\n" $ mapMaybe declToJs decls+          let js = intercalate "; " . map (prettyPrintJS . optimize) . concat . mapMaybe (declToJs) $ decls           case outputFile of             Just path -> U.writeFile path js             Nothing -> U.putStrLn js