diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index 524225c82d..f2579af11c 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -21,4 +21,4 @@ instance MonadSupply m => MonadSupply (StateT s m) where fresh = lift fresh freshName :: MonadSupply m => m String -freshName = fmap (('$' :) . show) fresh +freshName = fmap (('_' :) . show) fresh diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index dfc13018a2..b3320cb3fe 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -9,7 +9,12 @@ module Language.PureScript.CodeGen.JS import Prelude.Compat -import Control.Arrow ((&&&)) +import Data.List ((\\), delete, intersect, intersperse) +import Data.Maybe (isNothing, fromMaybe) +import qualified Data.Map as M +import qualified Data.Foldable as F +import qualified Data.Traversable as T + import Control.Monad (replicateM, forM, void) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader (MonadReader, asks) @@ -55,18 +60,25 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = optimized <- T.traverse (T.traverse optimize) jsDecls F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments - let strict = JSStringLiteral Nothing "use strict" - let header = if comments && not (null coms) then JSComment Nothing coms strict else strict - let foreign' = [JSVariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] - let moduleBody = header : foreign' ++ jsImports ++ concat optimized + let foreign' = [JSVariableIntroduction Nothing "_foreign" foreign_ | not $ null foreigns || isNothing foreign_] + let moduleBody = foreign' ++ jsImports ++ concat optimized + let moduleBody' = case moduleBody of + [] -> [] + (x:xs) -> if comments && not (null coms) + then (JSComment Nothing coms x):xs + else x:xs let foreignExps = exps `intersect` (fst `map` foreigns) let standardExps = exps \\ foreignExps - let exps' = JSObjectLiteral Nothing $ map (runIdent &&& JSVar Nothing . identToJs) standardExps - ++ map (runIdent &&& foreignIdent) foreignExps - return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps'] + let forwardDecls = [JSVariableIntroduction Nothing decl Nothing | decl <- (identToJs <$> standardExps)] + let exps' = [JSAssignment Nothing (JSIndexer Nothing (JSStringLiteral Nothing $ runIdent exp) (JSVar Nothing moduleName)) (JSVar Nothing $ identToJs exp) | exp <- standardExps] + ++ [JSAssignment Nothing (JSIndexer Nothing (JSStringLiteral Nothing $ runIdent exp) (JSVar Nothing moduleName)) (foreignIdent exp) | exp <- foreignExps] + return $ forwardDecls ++ moduleBody' ++ [JSVariableIntroduction Nothing moduleName (Just $ JSObjectLiteral Nothing [])] ++ exps' ++ [JSReturn Nothing $ JSVar Nothing moduleName] where + moduleName :: String + moduleName = runModuleName' "_" mn + -- | -- Extracts all declaration names from a binding group. -- @@ -104,7 +116,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS importToJs mnLookup mn' = do let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (".." runModuleName mn')] + let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (".." runModuleName' "_" mn')] withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) -- | @@ -149,7 +161,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e) nonRecToJS (ss, _, _, _) ident val = do js <- valueToJs val - withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js) + withPos ss $ JSAssignment Nothing (JSVar Nothing $ identToJs ident) js withPos :: Maybe SourceSpan -> JS -> m JS withPos (Just ss) js = do @@ -193,7 +205,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) = return $ JSAccessor Nothing "value" $ qualifiedToJS id name valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) = - return $ JSAccessor Nothing "create" $ qualifiedToJS id name + return $ qualifiedToJS id name valueToJs' (Accessor _ prop val) = accessorString prop <$> valueToJs val valueToJs' (ObjectUpdate _ o ps) = do @@ -201,15 +213,11 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = sts <- mapM (sndM valueToJs) ps extendObj obj sts valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = - let args = unAbs e - in return $ JSFunction Nothing Nothing (map identToJs args) (JSBlock Nothing $ map assign args) + return $ generateConstructor (unAbs e) where unAbs :: Expr Ann -> [Ident] unAbs (Abs _ arg val) = arg : unAbs val unAbs _ = [] - assign :: Ident -> JS - assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this")) - (var name) valueToJs' (Abs _ arg val) = do ret <- valueToJs val return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret]) @@ -219,9 +227,9 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = case f of Var (_, _, _, Just IsNewtype) _ -> return (head args') Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields -> - return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args' + return $ JSApp Nothing (qualifiedToJS id name) args' Var (_, _, _, Just IsTypeClassConstructor) name -> - return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args' + return $ JSApp Nothing (qualifiedToJS id name) args' _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f where unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann]) @@ -246,20 +254,34 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = JSObjectLiteral Nothing [("create", JSFunction Nothing Nothing ["value"] (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))]) - valueToJs' (Constructor _ _ (ProperName ctor) []) = - return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing []) - , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor)) - (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ] - valueToJs' (Constructor _ _ (ProperName ctor) fields) = - let constructor = - let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] - in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body) - createFn = - let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields) - in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields - in return $ iife ctor [ constructor - , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn - ] + valueToJs' (Constructor _ _ (ProperName _) []) = + return $ iife "constr" [ JSVariableIntroduction Nothing "constr" (Just emptyObj) + , JSAssignment Nothing (JSAccessor Nothing "value" constr) (setmetatable [emptyObj, constr]) + ] + valueToJs' (Constructor _ _ (ProperName ctor) fields) = return $ generateConstructor fields + + generateConstructor :: [Ident] -> JS + generateConstructor params = iife "constr" [ JSVariableIntroduction Nothing "constr" (Just emptyObj) + , setmetatable [constr, constr] + , JSAssignment Nothing (JSAccessor Nothing "__call" constr) $ JSFunction Nothing Nothing ("self":params') $ + JSBlock Nothing $ [ JSVariableIntroduction Nothing "ret" (Just $ setmetatable [emptyObj, constr]) + ] ++ map (uncurry $ assign "ret") (zip params_ params') ++ + [ JSReturn Nothing $ JSVar Nothing "ret" + ] + ] + where + params' = identToJs <$> params + params_ = runIdent <$> params + assign tbl nam val = JSAssignment Nothing (JSIndexer Nothing (JSStringLiteral Nothing nam) (JSVar Nothing tbl)) (JSVar Nothing val) + + constr :: JS + constr = JSVar Nothing "constr" + + emptyObj :: JS + emptyObj = JSObjectLiteral Nothing [] + + setmetatable :: [JS] -> JS + setmetatable = JSApp Nothing (JSVar Nothing "setmetatable") iife :: String -> [JS] -> JS iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) [] @@ -310,7 +332,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a) foreignIdent :: Ident -> JS - foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign") + foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "_foreign") -- | -- Generate code in the simplified Javascript intermediate representation for pattern match binders @@ -323,7 +345,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = jss <- forM binders $ \(CaseAlternative bs result) -> do ret <- guardsToJs result go valNames ret bs - return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames]))) + return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [throw $ failedPatternError valNames]))) [] where go :: [String] -> [JS] -> [Binder Ann] -> m [JS] @@ -334,7 +356,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = go _ _ _ = internalError "Invalid arguments to bindersToJs" failedPatternError :: [String] -> JS - failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)] + failedPatternError names = JSBinary Nothing Concat (JSStringLiteral Nothing failedPatternMessage) msg + where + errs = zipWith valueError names vals + msg = foldr1 (JSBinary Nothing Concat) $ intersperse (JSStringLiteral Nothing ", ") errs failedPatternMessage :: String failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": " @@ -374,7 +399,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = return $ case ctorType of ProductType -> js SumType -> - [JSIfElse Nothing (JSInstanceOf Nothing (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor)) + [JSIfElse Nothing (instanceOf (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor)) (JSBlock Nothing js) Nothing] where @@ -442,3 +467,9 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = then throwError . errorMessage $ IntOutOfRange i "JavaScript" minInt maxInt else return js go other = return other + + throw :: JS -> JS + throw js = JSApp Nothing (JSVar Nothing "error") [js] + + instanceOf :: JS -> JS -> JS + instanceOf obj clazz = JSBinary Nothing EqualTo (JSApp Nothing (JSVar Nothing "getmetatable") [obj]) clazz diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index abc722ea8e..5b9609c7f9 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -24,17 +24,9 @@ data UnaryOperator -- | Not -- | - -- Bitwise negation - -- - | BitwiseNot - -- | -- Numeric unary \'plus\' -- | Positive - -- | - -- Constructor - -- - | JSNew deriving (Show, Read, Eq) -- | @@ -62,6 +54,10 @@ data BinaryOperator -- | Modulus -- | + -- String concatenation + -- + | Concat + -- | -- Generic equality test -- | EqualTo @@ -93,30 +89,6 @@ data BinaryOperator -- Boolean or -- | Or - -- | - -- Bitwise and - -- - | BitwiseAnd - -- | - -- Bitwise or - -- - | BitwiseOr - -- | - -- Bitwise xor - -- - | BitwiseXor - -- | - -- Bitwise left shift - -- - | ShiftLeft - -- | - -- Bitwise right shift - -- - | ShiftRight - -- | - -- Bitwise right shift with zero-fill - -- - | ZeroFillShiftRight deriving (Show, Read, Eq) -- | @@ -208,18 +180,6 @@ data JS -- | JSReturn (Maybe SourceSpan) JS -- | - -- Throw statement - -- - | JSThrow (Maybe SourceSpan) JS - -- | - -- Type-Of operator - -- - | JSTypeOf (Maybe SourceSpan) JS - -- | - -- InstanceOf test - -- - | JSInstanceOf (Maybe SourceSpan) JS JS - -- | -- Labelled statement -- | JSLabel (Maybe SourceSpan) String JS @@ -268,9 +228,6 @@ withSourceSpan withSpan = go go (JSForIn _ name j1 j2) = JSForIn ss name j1 j2 go (JSIfElse _ j1 j2 j3) = JSIfElse ss j1 j2 j3 go (JSReturn _ js) = JSReturn ss js - go (JSThrow _ js) = JSThrow ss js - go (JSTypeOf _ js) = JSTypeOf ss js - go (JSInstanceOf _ j1 j2) = JSInstanceOf ss j1 j2 go (JSLabel _ name js) = JSLabel ss name js go (JSBreak _ s) = JSBreak ss s go (JSContinue _ s) = JSContinue ss s @@ -302,9 +259,6 @@ getSourceSpan = go go (JSForIn ss _ _ _) = ss go (JSIfElse ss _ _ _) = ss go (JSReturn ss _) = ss - go (JSThrow ss _) = ss - go (JSTypeOf ss _) = ss - go (JSInstanceOf ss _ _) = ss go (JSLabel ss _ _) = ss go (JSBreak ss _) = ss go (JSContinue ss _) = ss @@ -336,10 +290,7 @@ everywhereOnJS f = go go (JSForIn ss name j1 j2) = f (JSForIn ss name (go j1) (go j2)) go (JSIfElse ss j1 j2 j3) = f (JSIfElse ss (go j1) (go j2) (fmap go j3)) go (JSReturn ss js) = f (JSReturn ss (go js)) - go (JSThrow ss js) = f (JSThrow ss (go js)) - go (JSTypeOf ss js) = f (JSTypeOf ss (go js)) go (JSLabel ss name js) = f (JSLabel ss name (go js)) - go (JSInstanceOf ss j1 j2) = f (JSInstanceOf ss (go j1) (go j2)) go (JSComment ss com j) = f (JSComment ss com (go j)) go other = f other @@ -367,10 +318,7 @@ everywhereOnJSTopDownM f = f >=> go go (JSForIn ss name j1 j2) = JSForIn ss name <$> f' j1 <*> f' j2 go (JSIfElse ss j1 j2 j3) = JSIfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3 go (JSReturn ss j) = JSReturn ss <$> f' j - go (JSThrow ss j) = JSThrow ss <$> f' j - go (JSTypeOf ss j) = JSTypeOf ss <$> f' j go (JSLabel ss name j) = JSLabel ss name <$> f' j - go (JSInstanceOf ss j1 j2) = JSInstanceOf ss <$> f' j1 <*> f' j2 go (JSComment ss com j) = JSComment ss com <$> f' j go other = f other @@ -395,9 +343,6 @@ everythingOnJS (<>) f = go go j@(JSIfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2 go j@(JSIfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3 go j@(JSReturn _ j1) = f j <> go j1 - go j@(JSThrow _ j1) = f j <> go j1 - go j@(JSTypeOf _ j1) = f j <> go j1 go j@(JSLabel _ _ j1) = f j <> go j1 - go j@(JSInstanceOf _ j1 j2) = f j <> go j1 <> go j2 go j@(JSComment _ _ j1) = f j <> go j1 go other = f other diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 45b5391aa0..2725c63868 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -14,7 +14,7 @@ import Language.PureScript.Names moduleNameToJs :: ModuleName -> String moduleNameToJs (ModuleName pns) = let name = intercalate "_" (runProperName `map` pns) - in if nameIsJsBuiltIn name then "$$" ++ name else name + in if nameIsJsBuiltIn name then "__" ++ name else name -- | -- Convert an Ident into a valid Javascript identifier: @@ -27,7 +27,7 @@ moduleNameToJs (ModuleName pns) = -- identToJs :: Ident -> String identToJs (Ident name) - | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name + | nameIsJsReserved name || nameIsJsBuiltIn name = "__" ++ name | otherwise = concatMap identCharToString name identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" @@ -43,29 +43,29 @@ identNeedsEscaping s = s /= identToJs (Ident s) -- identCharToString :: Char -> String identCharToString c | isAlphaNum c = [c] -identCharToString '_' = "_" -identCharToString '.' = "$dot" -identCharToString '$' = "$dollar" -identCharToString '~' = "$tilde" -identCharToString '=' = "$eq" -identCharToString '<' = "$less" -identCharToString '>' = "$greater" -identCharToString '!' = "$bang" -identCharToString '#' = "$hash" -identCharToString '%' = "$percent" -identCharToString '^' = "$up" -identCharToString '&' = "$amp" -identCharToString '|' = "$bar" -identCharToString '*' = "$times" -identCharToString '/' = "$div" -identCharToString '+' = "$plus" -identCharToString '-' = "$minus" -identCharToString ':' = "$colon" -identCharToString '\\' = "$bslash" -identCharToString '?' = "$qmark" -identCharToString '@' = "$at" -identCharToString '\'' = "$prime" -identCharToString c = '$' : show (ord c) +identCharToString '_' = "_" +identCharToString '.' = "_dot" +identCharToString '$' = "_dollar" +identCharToString '~' = "_tilde" +identCharToString '=' = "_eq" +identCharToString '<' = "_less" +identCharToString '>' = "_greater" +identCharToString '!' = "_bang" +identCharToString '#' = "_hash" +identCharToString '%' = "_percent" +identCharToString '^' = "_up" +identCharToString '&' = "_amp" +identCharToString '|' = "_bar" +identCharToString '*' = "_times" +identCharToString '/' = "_div" +identCharToString '+' = "_plus" +identCharToString '-' = "_minus" +identCharToString ':' = "_colon" +identCharToString '\\' = "_bslash" +identCharToString '?' = "_qmark" +identCharToString '@' = "_at" +identCharToString '\'' = "_prime" +identCharToString c = '_' : show (ord c) -- | -- Checks whether an identifier name is reserved in Javascript. @@ -80,153 +80,80 @@ nameIsJsReserved name = nameIsJsBuiltIn :: String -> Bool nameIsJsBuiltIn name = name `elem` - [ "arguments" - , "Array" - , "ArrayBuffer" - , "Boolean" - , "DataView" - , "Date" - , "decodeURI" - , "decodeURIComponent" - , "encodeURI" - , "encodeURIComponent" - , "Error" - , "escape" - , "eval" - , "EvalError" - , "Float32Array" - , "Float64Array" - , "Function" - , "Infinity" - , "Int16Array" - , "Int32Array" - , "Int8Array" - , "Intl" - , "isFinite" - , "isNaN" - , "JSON" - , "Map" - , "Math" - , "NaN" - , "Number" - , "Object" - , "parseFloat" - , "parseInt" - , "Promise" - , "Proxy" - , "RangeError" - , "ReferenceError" - , "Reflect" - , "RegExp" - , "Set" - , "SIMD" - , "String" - , "Symbol" - , "SyntaxError" - , "TypeError" - , "Uint16Array" - , "Uint32Array" - , "Uint8Array" - , "Uint8ClampedArray" - , "undefined" - , "unescape" - , "URIError" - , "WeakMap" - , "WeakSet" + [ "collectgarbage" + , "coroutine" + , "pcall" + , "utf8" + , "error" + , "tostring" + , "package" + , "next" + , "assert" + , "io" + , "module" + , "ipairs" + , "loadstring" + , "select" + , "_VERSION" + , "xpcall" + , "debug" + , "loadfile" + , "load" + , "_G" + , "string" + , "type" + , "setmetatable" + , "bit32" + , "arg" + , "tonumber" + , "os" + , "print" + , "table" + , "pairs" + , "unpack" + , "rawget" + , "rawset" + , "dofile" + , "getmetatable" + , "rawequal" + , "rawlen" + , "require" + , "math" ] jsAnyReserved :: [String] jsAnyReserved = concat [ jsKeywords - , jsSometimesReserved - , jsFutureReserved - , jsFutureReservedStrict - , jsOldReserved , jsLiterals ] jsKeywords :: [String] jsKeywords = - [ "break" - , "case" - , "catch" - , "class" - , "const" - , "continue" - , "debugger" - , "default" - , "delete" + [ "and" + , "break" , "do" , "else" - , "export" - , "extends" - , "finally" + , "elseif" + , "end" , "for" , "function" + , "goto" , "if" - , "import" , "in" - , "instanceof" - , "new" + , "local" + , "not" + , "or" + , "repeat" , "return" - , "super" - , "switch" - , "this" - , "throw" - , "try" - , "typeof" - , "var" - , "void" + , "then" + , "until" , "while" - , "with" - ] - -jsSometimesReserved :: [String] -jsSometimesReserved = - [ "await" - , "let" - , "static" - , "yield" - ] - -jsFutureReserved :: [String] -jsFutureReserved = - [ "enum" ] - -jsFutureReservedStrict :: [String] -jsFutureReservedStrict = - [ "implements" - , "interface" - , "package" - , "private" - , "protected" - , "public" - ] - -jsOldReserved :: [String] -jsOldReserved = - [ "abstract" - , "boolean" - , "byte" - , "char" - , "double" - , "final" - , "float" - , "goto" - , "int" - , "long" - , "native" - , "short" - , "synchronized" - , "throws" - , "transient" - , "volatile" ] jsLiterals :: [String] jsLiterals = - [ "null" + [ "nil" , "true" , "false" ] diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index c46bc801c5..591c088231 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -98,7 +98,7 @@ inlineCommonValues = everywhereOnJS convert fnDivide = (C.dataEuclideanRing, C.div) fnMultiply = (C.dataSemiring, C.mul) fnSubtract = (C.dataRing, C.sub) - intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) + intOp ss op x y = JSApp ss (JSAccessor Nothing "floor" (JSVar Nothing "math")) [JSBinary ss op x y] inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS inlineOperator (m, op) f = everywhereOnJS convert @@ -154,19 +154,11 @@ inlineCommonOperators = applyAll $ , binary ordString opGreaterThan GreaterThan , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo - , binary semigroupString opAppend Add + , binary semigroupString opAppend Concat , binary heytingAlgebraBoolean opConj And , binary heytingAlgebraBoolean opDisj Or , unary heytingAlgebraBoolean opNot Not - - , binary' C.dataIntBits (C..|.) BitwiseOr - , binary' C.dataIntBits (C..&.) BitwiseAnd - , binary' C.dataIntBits (C..^.) BitwiseXor - , binary' C.dataIntBits C.shl ShiftLeft - , binary' C.dataIntBits C.shr ShiftRight - , binary' C.dataIntBits C.zshr ZeroFillShiftRight - , unary' C.dataIntBits C.complement BitwiseNot ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index 8fb82abb34..9419402670 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -73,6 +73,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert -- Remove __do function applications which remain after desugaring undo :: JS -> JS undo (JSReturn _ (JSApp _ (JSFunction _ (Just ident) [] body) [])) | ident == fnName = body + undo (JSFunction a (Just ident) [] body) | ident == fnName = JSFunction a Nothing [] body undo other = other applyReturns :: JS -> JS diff --git a/src/Language/PureScript/Interactive/IO.hs b/src/Language/PureScript/Interactive/IO.hs index e120ec3e85..aeb67af988 100644 --- a/src/Language/PureScript/Interactive/IO.hs +++ b/src/Language/PureScript/Interactive/IO.hs @@ -21,7 +21,7 @@ onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVar -- findNodeProcess :: IO (Maybe String) findNodeProcess = onFirstFileMatching findExecutable names - where names = ["nodejs", "node"] + where names = ["lua"] -- | -- Grabs the filename where the history is stored. diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 7192f749ab..829f0aadab 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -290,7 +290,7 @@ readTextFile :: FilePath -> Make String readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path -- | Infer the module name for a module by looking for the same filename with --- a .js extension. +-- a .lua extension. inferForeignModules :: forall m . MonadIO m @@ -301,7 +301,7 @@ inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath) inferForeignModule (Left _) = return Nothing inferForeignModule (Right path) = do - let jsFile = replaceExtension path "js" + let jsFile = replaceExtension path "lua" exists <- liftIO $ doesFileExist jsFile if exists then return (Just jsFile) @@ -328,40 +328,41 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do - let filePath = runModuleName mn - jsFile = outputDir filePath "index.js" + let filePath = runModuleName' "_" mn + jsFile = outputDir filePath "init.lua" externsFile = outputDir filePath "externs.json" min <$> getTimestamp jsFile <*> getTimestamp externsFile readExterns :: ModuleName -> Make (FilePath, Externs) readExterns mn = do - let path = outputDir runModuleName mn "externs.json" + let path = outputDir runModuleName' "_" mn "externs.json" (path, ) <$> readTextFile path codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () codegen m _ exts = do let mn = CF.moduleName m + let filePath = runModuleName' "_" mn foreignInclude <- case mn `M.lookup` foreigns of Just path | not $ requiresForeign m -> do tell $ errorMessage $ UnnecessaryFFIModule mn path return Nothing | otherwise -> do - checkForeignDecls m path - return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"] + -- TODO + --checkForeignDecls m path + return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing (filePath ++ "./foreign")] Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn | otherwise -> return Nothing rawJs <- J.moduleToJs m foreignInclude dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory sourceMaps <- lift $ asks optionsSourceMaps let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) - let filePath = runModuleName mn - jsFile = outputDir filePath "index.js" - mapFile = outputDir filePath "index.js.map" + let jsFile = outputDir filePath "init.lua" + mapFile = outputDir filePath "init.lua.map" externsFile = outputDir filePath "externs.json" - foreignFile = outputDir filePath "foreign.js" + foreignFile = outputDir filePath "foreign.lua" prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix] - js = unlines $ map ("// " ++) prefix ++ [pjs] + js = unlines $ map ("-- " ++) prefix ++ [pjs] mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" lift $ do writeTextFile jsFile (fromString $ js ++ mapRef) @@ -375,7 +376,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = sourceFile = case mappings of (SMap file _ _ : _) -> Just $ pathToDir makeRelative dir file _ -> Nothing - let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings = + let rawMapping = SourceMapping { smFile = "init.lua", smSourceRoot = Nothing, smMappings = map (\(SMap _ orig gen) -> Mapping { mapOriginal = Just $ convertPos $ add 0 (-1) orig , mapSourceFile = sourceFile diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 0f99ca980b..c864227e1b 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -68,8 +68,8 @@ data Ident runIdent :: Ident -> String runIdent (Ident i) = i -runIdent (GenIdent Nothing n) = "$" ++ show n -runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n +runIdent (GenIdent Nothing n) = "_" ++ show n +runIdent (GenIdent (Just name) n) = "_" ++ name ++ show n showIdent :: Ident -> String showIdent = runIdent @@ -131,8 +131,11 @@ coerceProperName = ProperName . runProperName newtype ModuleName = ModuleName [ProperName 'Namespace] deriving (Show, Read, Eq, Ord) +runModuleName' :: String -> ModuleName -> String +runModuleName' sep (ModuleName pns) = intercalate sep (runProperName `map` pns) + runModuleName :: ModuleName -> String -runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns) +runModuleName = runModuleName' "." moduleNameFromString :: String -> ModuleName moduleNameFromString = ModuleName . splitProperNames diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 2b089ea8c5..86e6e261d7 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -37,35 +37,31 @@ literals = mkPattern' match' match (JSBooleanLiteral _ True) = return $ emit "true" match (JSBooleanLiteral _ False) = return $ emit "false" match (JSArrayLiteral _ xs) = mconcat <$> sequence - [ return $ emit "[ " + [ return $ emit "{ " , intercalate (emit ", ") <$> forM xs prettyPrintJS' - , return $ emit " ]" + , return $ emit " }" ] match (JSObjectLiteral _ []) = return $ emit "{}" match (JSObjectLiteral _ ps) = mconcat <$> sequence [ return $ emit "{\n" , withIndent $ do - jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value + jss <- forM ps $ \(key, value) -> fmap ((emit key <> emit " = ") <>) . prettyPrintJS' $ value indentString <- currentIndent - return $ intercalate (emit ", \n") $ map (indentString <>) jss + return $ intercalate (emit ",\n") $ map (indentString <>) jss , return $ emit "\n" , currentIndent , return $ emit "}" ] - where - objectPropertyToString :: (Emit gen) => String -> gen - objectPropertyToString s | identNeedsEscaping s = emit $ show s - | otherwise = emit s match (JSBlock _ sts) = mconcat <$> sequence - [ return $ emit "{\n" + [ return $ emit "\n" , withIndent $ prettyStatements sts , return $ emit "\n" , currentIndent - , return $ emit "}" + , return $ emit "end" ] match (JSVar _ ident) = return $ emit ident match (JSVariableIntroduction _ ident value) = mconcat <$> sequence - [ return $ emit $ "var " ++ ident + [ return $ emit $ "local " ++ ident , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value ] match (JSAssignment _ target value) = mconcat <$> sequence @@ -76,19 +72,19 @@ literals = mkPattern' match' match (JSWhile _ cond sts) = mconcat <$> sequence [ return $ emit "while (" , prettyPrintJS' cond - , return $ emit ") " + , return $ emit ") do\n" , prettyPrintJS' sts ] match (JSFor _ ident start end sts) = mconcat <$> sequence - [ return $ emit $ "for (var " ++ ident ++ " = " + [ return $ emit $ "for " ++ ident ++ " = " , prettyPrintJS' start - , return $ emit $ "; " ++ ident ++ " < " + , return $ emit $ ", " , prettyPrintJS' end - , return $ emit $ "; " ++ ident ++ "++) " + , return $ emit $ " do" , prettyPrintJS' sts ] match (JSForIn _ ident obj sts) = mconcat <$> sequence - [ return $ emit $ "for (var " ++ ident ++ " in " + [ return $ emit $ "for (var " ++ ident ++ " in " , prettyPrintJS' obj , return $ emit ") " , prettyPrintJS' sts @@ -96,7 +92,7 @@ literals = mkPattern' match' match (JSIfElse _ cond thens elses) = mconcat <$> sequence [ return $ emit "if (" , prettyPrintJS' cond - , return $ emit ") " + , return $ emit ") then" , prettyPrintJS' thens , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses ] @@ -104,24 +100,20 @@ literals = mkPattern' match' [ return $ emit "return " , prettyPrintJS' value ] - match (JSThrow _ value) = mconcat <$> sequence - [ return $ emit "throw " - , prettyPrintJS' value - ] - match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl - match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl + match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl + match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl match (JSLabel _ lbl js) = mconcat <$> sequence - [ return $ emit $ lbl ++ ": " + [ return $ emit $ "" ++ lbl ++ ": " , prettyPrintJS' js ] match (JSComment _ com js) = fmap mconcat $ sequence $ [ return $ emit "\n" , currentIndent - , return $ emit "/**\n" + , return $ emit "--[[\n" ] ++ map asLine (concatMap commentLines com) ++ [ currentIndent - , return $ emit " */\n" + , return $ emit "--]]\n" , currentIndent , prettyPrintJS' js ] @@ -199,18 +191,6 @@ app = mkPattern' match return (intercalate (emit ", ") jss, val) match _ = mzero -typeOf :: Pattern PrinterState JS ((), JS) -typeOf = mkPattern match - where - match (JSTypeOf _ val) = Just ((), val) - match _ = Nothing - -instanceOf :: Pattern PrinterState JS (JS, JS) -instanceOf = mkPattern match - where - match (JSInstanceOf _ val ty) = Just (val, ty) - match _ = Nothing - unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen unary' op mkStr = Wrap match (<>) where @@ -273,15 +253,12 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ] , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ] , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ] - , [ unary JSNew "new " ] , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <> emit ("function " ++ fromMaybe "" name ++ "(" ++ intercalate ", " args ++ ") ") <> ret ] - , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ] - , [ unary Not "!" - , unary BitwiseNot "~" + , [ unary Not "not " , unary Positive "+" , negateOperator ] , [ binary Multiply "*" @@ -289,20 +266,15 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue , binary Modulus "%" ] , [ binary Add "+" , binary Subtract "-" ] - , [ binary ShiftLeft "<<" - , binary ShiftRight ">>" - , binary ZeroFillShiftRight ">>>" ] + , [ binary Concat ".." ] , [ binary LessThan "<" , binary LessThanOrEqualTo "<=" , binary GreaterThan ">" , binary GreaterThanOrEqualTo ">=" - , AssocR instanceOf $ \v1 v2 -> v1 <> emit " instanceof " <> v2 ] - , [ binary EqualTo "===" - , binary NotEqualTo "!==" ] - , [ binary BitwiseAnd "&" ] - , [ binary BitwiseXor "^" ] - , [ binary BitwiseOr "|" ] - , [ binary And "&&" ] - , [ binary Or "||" ] - , [ Wrap conditional $ \(ss, th, el) cond -> cond <> addMapping' ss <> emit " ? " <> prettyPrintJS1 th <> addMapping' ss <> emit " : " <> prettyPrintJS1 el ] + ] + , [ binary EqualTo "==" + , binary NotEqualTo "~=" ] + , [ binary And " and " ] + , [ binary Or " or " ] + , [ Wrap conditional $ \(ss, th, el) cond -> cond <> addMapping' ss <> emit " and " <> prettyPrintJS1 th <> addMapping' ss <> emit " or " <> prettyPrintJS1 el ] ]