diff --git a/purescript.cabal b/purescript.cabal --- 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 @@ 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 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, diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -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 + + diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- 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.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) diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs new file mode 100644 --- /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 +-- 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 --- /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 +-- 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 --- a/src/Language/PureScript/Pretty.hs +++ b/src/Language/PureScript/Pretty.hs @@ -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 diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs new file mode 100644 --- /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 +-- 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 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -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 "<=" ] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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