summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2013-11-02 07:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-11-02 07:29:00 (GMT)
commitf4bc720caa8f6e1a5c8649971294ad622a788be3 (patch)
tree9c9167a966d74e69194fbf47c3344714107db543
parent80582a7aacfe263c5d6c9edab330e46abd9ec86d (diff)
version 0.1.20.1.2
-rw-r--r--purescript.cabal45
-rw-r--r--src/Language/PureScript.hs3
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs236
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs45
-rw-r--r--src/Language/PureScript/Optimize.hs92
-rw-r--r--src/Language/PureScript/Pretty.hs1
-rw-r--r--src/Language/PureScript/Pretty/JS.hs144
-rw-r--r--src/Language/PureScript/Pretty/Values.hs2
-rw-r--r--src/Main.hs2
9 files changed, 377 insertions, 193 deletions
diff --git a/purescript.cabal b/purescript.cabal
index b832813..2a3f6f5 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -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 @@ maintainer: Phil Freeman <paf31@cantab.net>
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 @@ library
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 @@ executable psc
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,
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index ae6b8ed..1542f7b 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -23,4 +23,7 @@ import Language.PureScript.Parser as P
import Language.PureScript.CodeGen as P
import Language.PureScript.TypeChecker as P
import Language.PureScript.Pretty as P
+import Language.PureScript.Optimize as P
+
+
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 33f94c2..97a72f4 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -13,6 +13,7 @@
-----------------------------------------------------------------------------
module Language.PureScript.CodeGen.JS (
+ module AST,
declToJs
) where
@@ -20,7 +21,7 @@ import Data.Char
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.Names
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 -> 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 "||" ]
- ]
-
-binderToJs :: String -> String -> Binder -> Gen String
+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
+
+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 -> [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
-
-elseStatementToJs :: ElseStatement -> String
-elseStatementToJs (Else sts) = " else {" ++ intercalate ";" (map statementToJs sts) ++ "}"
-elseStatementToJs (ElseIf ifst) = " else " ++ ifStatementToJs ifst
+ done' = [JSIfElse (valueToJs cond) (JSBlock done) Nothing]
+
+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)
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
new file mode 100644
index 0000000..e7b342d
--- /dev/null
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -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)
diff --git a/src/Language/PureScript/Optimize.hs b/src/Language/PureScript/Optimize.hs
new file mode 100644
index 0000000..ac45274
--- /dev/null
+++ b/src/Language/PureScript/Optimize.hs
@@ -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
diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs
index 279959e..a5c03c5 100644
--- a/src/Language/PureScript/Pretty.hs
+++ b/src/Language/PureScript/Pretty.hs
@@ -17,6 +17,7 @@ module Language.PureScript.Pretty (module P) where
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
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
new file mode 100644
index 0000000..63ab54d
--- /dev/null
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -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 "||" ]
+ ]
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 801711c..d30c63e 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -112,7 +112,7 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue
, [ 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 "<=" ]
diff --git a/src/Main.hs b/src/Main.hs
index c54343d..25e058a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -40,7 +40,7 @@ compile inputFiles outputFile externsFile = do
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