From 5d4d760caa14a7e272a3ceeab14cf5f9739109f3 Mon Sep 17 00:00:00 2001 From: Martin Zeller Date: Fri, 1 Apr 2016 20:01:35 +0200 Subject: [PATCH 1/7] Change to Lua --- psc/Main.hs | 4 +- src/Control/Monad/Supply/Class.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 97 +++++--- src/Language/PureScript/CodeGen/JS/AST.hs | 63 +---- src/Language/PureScript/CodeGen/JS/Common.hs | 225 ++++++------------ .../CodeGen/JS/Optimizer/Inliner.hs | 10 +- .../CodeGen/JS/Optimizer/MagicDo.hs | 1 + src/Language/PureScript/Make.hs | 16 +- src/Language/PureScript/Names.hs | 9 +- src/Language/PureScript/Parser/JS.hs | 11 +- src/Language/PureScript/Pretty/JS.hs | 82 +++---- 11 files changed, 194 insertions(+), 326 deletions(-) diff --git a/psc/Main.hs b/psc/Main.hs index fc90127404..f49aded7d0 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -80,7 +80,7 @@ compile PSCMakeOptions{..} = do when (null input && not pscmJSONErrors) $ do hPutStrLn stderr "psc: No input files." exitFailure - let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input + let (jsFiles, pursFiles) = partition (isSuffixOf ".lua") input moduleFiles <- readInput (InputOptions pursFiles) inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile) @@ -124,7 +124,7 @@ inputForeignFile :: Parser FilePath inputForeignFile = strOption $ short 'f' <> long "ffi" - <> help "The input .js file(s) providing foreign import implementations" + <> help "The input .lua file(s) providing foreign import implementations" outputDirectory :: Parser FilePath outputDirectory = strOption $ diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index 8621e2e2db..e5d2c6d139 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 d4a1e8fc02..64ed1b3f36 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -15,13 +15,12 @@ module Language.PureScript.CodeGen.JS import Prelude () import Prelude.Compat -import Data.List ((\\), delete, intersect) +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.Arrow ((&&&)) import Control.Monad (replicateM, forM, void) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader (MonadReader, asks) @@ -61,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. -- @@ -111,7 +117,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = importToJs mnLookup mn' = do path <- asks optionsRequirePath let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromMaybe ".." path runModuleName mn')] + let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromMaybe "" path runModuleName' "_" mn')] withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) -- | @@ -156,7 +162,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 @@ -209,15 +215,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]) @@ -227,9 +229,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]) @@ -254,20 +256,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])) [] @@ -318,7 +334,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 @@ -331,7 +347,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] @@ -342,7 +358,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 ++ ": " @@ -382,7 +401,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 @@ -450,3 +469,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 dd9a69a4dd..b0979dd967 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -25,17 +25,9 @@ data UnaryOperator -- | Not -- | - -- Bitwise negation - -- - | BitwiseNot - -- | -- Numeric unary \'plus\' -- | Positive - -- | - -- Constructor - -- - | JSNew deriving (Show, Read, Eq) -- | @@ -63,6 +55,10 @@ data BinaryOperator -- | Modulus -- | + -- String concatenation + -- + | Concat + -- | -- Generic equality test -- | EqualTo @@ -94,30 +90,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) -- | @@ -209,18 +181,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 @@ -269,9 +229,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 @@ -303,9 +260,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 @@ -337,10 +291,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 @@ -368,10 +319,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 @@ -396,9 +344,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 720d829aea..7246a5d237 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -12,7 +12,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: @@ -25,7 +25,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 (Op op) = concatMap identCharToString op identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" @@ -42,29 +42,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. @@ -79,153 +79,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 bcc2b395b3..36ee6b6513 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -100,7 +100,7 @@ inlineCommonValues = everywhereOnJS convert fnDivide = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)] fnMultiply = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, (C.*)), (C.dataSemiring, C.mul)] fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (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 @@ -162,14 +162,6 @@ inlineCommonOperators = applyAll $ , binary booleanAlgebraBoolean opConj And , binary booleanAlgebraBoolean opDisj Or , unary booleanAlgebraBoolean 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 30edbf0af9..71db9200c2 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -71,6 +71,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/Make.hs b/src/Language/PureScript/Make.hs index ddc0d109ac..251d4e1985 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -314,7 +314,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do let filePath = runModuleName mn - jsFile = outputDir filePath "index.js" + jsFile = outputDir filePath "init.lua" externsFile = outputDir filePath "externs.json" min <$> getTimestamp jsFile <*> getTimestamp externsFile @@ -326,25 +326,25 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = 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 -> return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"] + | otherwise -> 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) @@ -358,7 +358,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 99a55c771f..e89228009d 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -36,8 +36,8 @@ data Ident runIdent :: Ident -> String runIdent (Ident i) = i runIdent (Op op) = op -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 (Op op) = '(' : op ++ ")" @@ -80,8 +80,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/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs index 9defab4d44..a2a8a7a1ca 100644 --- a/src/Language/PureScript/Parser/JS.hs +++ b/src/Language/PureScript/Parser/JS.hs @@ -25,12 +25,11 @@ import Prelude.Compat hiding (lex) import Control.Monad (forM_, when, msum) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Char (isSpace) import Data.Function (on) import Data.List (sortBy, groupBy) import Language.PureScript.Errors import Language.PureScript.Names -import Language.PureScript.Parser.Common -import Language.PureScript.Parser.Lexer import qualified Data.Map as M import qualified Text.Parsec as PS @@ -56,5 +55,9 @@ findModuleName :: [String] -> Maybe ModuleName findModuleName = msum . map parseComment where parseComment :: String -> Maybe ModuleName - parseComment s = either (const Nothing) Just $ - lex "" s >>= runTokenParser "" (symbol' "//" *> reserved "module" *> moduleName <* PS.eof) + parseComment s = either (const Nothing) Just $ PS.parse + (PS.string "--" *> PS.spaces *> PS.string "module" *> PS.spaces *> moduleName <* PS.eof) + "" s + +moduleName :: PS.Parsec String () ModuleName +moduleName = moduleNameFromString <$> PS.many (PS.satisfy (not . isSpace)) diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 5477361640..6110274ad1 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -52,35 +52,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 @@ -91,19 +87,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 @@ -111,7 +107,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 ] @@ -119,24 +115,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 ] @@ -214,18 +206,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 @@ -257,7 +237,7 @@ prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen prettyStatements sts = do jss <- forM sts prettyPrintJS' indentString <- currentIndent - return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss + return $ intercalate (emit "\n") $ map (indentString <>) jss -- | -- Generate a pretty-printed string representing a Javascript expression @@ -288,15 +268,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 "*" @@ -304,20 +281,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 ] ] From d8a8624fffc525570770d51c7880620a2306214d Mon Sep 17 00:00:00 2001 From: Martin Zeller Date: Mon, 4 Apr 2016 16:17:08 +0200 Subject: [PATCH 2/7] Fix dependency already built error Fix #6 --- src/Language/PureScript/Make.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 251d4e1985..56a090f9a8 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -313,14 +313,14 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do - let filePath = runModuleName mn + 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 () From 49e36ec3af768e6e289e2079c3ad9bca4fc31b77 Mon Sep 17 00:00:00 2001 From: Martin Zeller Date: Mon, 4 Apr 2016 20:00:25 +0200 Subject: [PATCH 3/7] Don't use .create when passing constructors --- src/Language/PureScript/CodeGen/JS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 64ed1b3f36..e8ee2db37b 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -207,7 +207,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 From 45242c43dc6908d681f7c84692336dd7e5ec29c6 Mon Sep 17 00:00:00 2001 From: Martin Zeller Date: Mon, 4 Apr 2016 20:00:47 +0200 Subject: [PATCH 4/7] Separate statements with ; This is necessary to disambiguate between print("asd") (function() --stuff end)() Print get's called and print's return value gets called and print("asd"); (function() --stuff end)() print gets called and the iife gets called --- src/Language/PureScript/Pretty/JS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 6110274ad1..9bb73488e3 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -237,7 +237,7 @@ prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen prettyStatements sts = do jss <- forM sts prettyPrintJS' indentString <- currentIndent - return $ intercalate (emit "\n") $ map (indentString <>) jss + return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss -- | -- Generate a pretty-printed string representing a Javascript expression From 2b143834dacff31e0774387f00fd6f594f2d091d Mon Sep 17 00:00:00 2001 From: Martin Zeller Date: Mon, 18 Apr 2016 19:45:55 +0200 Subject: [PATCH 5/7] Fix Inliner using addition instead of concat Fix #7 --- src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 36ee6b6513..1f303691d6 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -157,7 +157,7 @@ inlineCommonOperators = applyAll $ , binary ordString opGreaterThan GreaterThan , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo - , binary semigroupString opAppend Add + , binary semigroupString opAppend Concat , binary booleanAlgebraBoolean opConj And , binary booleanAlgebraBoolean opDisj Or From dc1a5ab62f1a9127e1db86c7445103321ded7275 Mon Sep 17 00:00:00 2001 From: Martin Zeller Date: Fri, 22 Apr 2016 17:10:13 +0200 Subject: [PATCH 6/7] Change PSCI to work with Lua --- psci/PSCi.hs | 11 +++++++---- psci/PSCi/IO.hs | 2 +- psci/PSCi/Module.hs | 12 ++++++------ 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index fc9f695ce0..ab7b485ab6 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -199,13 +199,16 @@ handleExpression val = do case e of Left errs -> PSCI $ printErrors errs Right _ -> do - psciIO $ writeFile indexFile "require('$PSCI')['$main']();" + psciIO $ writeFile indexFile "package.path = './.psci_modules/node_modules/?/init.lua;'\ + \.. './.psci_modules/node_modules/?.lua;'\ + \.. package.path\n\ + \require('PSCI')['$main']();" process <- psciIO findNodeProcess result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process case result of Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err - Nothing -> PSCI $ outputStrLn "Couldn't find node.js" + Nothing -> PSCI $ outputStrLn "Couldn't find lua" -- | -- Takes a list of declarations and updates the environment, then run a make. If the declaration fails, @@ -289,7 +292,7 @@ handleTypeOf val = do case e of Left errs -> PSCI $ printErrors errs Right env' -> - case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of + case M.lookup (P.ModuleName [P.ProperName "PSCI"], P.Ident "it") (P.names env') of Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty Nothing -> PSCI $ outputStrLn "Could not find type" @@ -327,7 +330,7 @@ handleKindOf :: P.Type -> PSCI () handleKindOf typ = do st <- PSCI $ lift get let m = createTemporaryModuleForKind st typ - mName = P.ModuleName [P.ProperName "$PSCI"] + mName = P.ModuleName [P.ProperName "PSCI"] e <- psciIO . runMake $ make st [m] case e of Left errs -> PSCI $ printErrors errs diff --git a/psci/PSCi/IO.hs b/psci/PSCi/IO.hs index fea644a448..af20c968a8 100644 --- a/psci/PSCi/IO.hs +++ b/psci/PSCi/IO.hs @@ -38,7 +38,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/psci/PSCi/Module.hs b/psci/PSCi/Module.hs index bda5116f4c..ceb56b3358 100644 --- a/psci/PSCi/Module.hs +++ b/psci/PSCi/Module.hs @@ -11,7 +11,7 @@ import Control.Monad -- | The name of the PSCI support module supportModuleName :: P.ModuleName -supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"] +supportModuleName = P.ModuleName [P.ProperName "PSCI", P.ProperName "Support"] -- | Support module, contains code to evaluate terms supportModule :: P.Module @@ -33,7 +33,7 @@ supportModule = , " eval :: a -> Eff (console :: CONSOLE) Unit" , "" , "instance evalShow :: (Show a) => Eval a where" - , " eval = print" + , " eval = log <<< show" , "" , "instance evalEff :: (Eval a) => Eval (Eff eff a) where" , " eval x = unsafeInterleaveEff x >>= eval" @@ -66,7 +66,7 @@ loadAllModules files = do createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val = let - moduleName = P.ModuleName [P.ProperName "$PSCI"] + moduleName = P.ModuleName [P.ProperName "PSCI"] trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval")) mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val @@ -82,7 +82,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ = let - moduleName = P.ModuleName [P.ProperName "$PSCI"] + moduleName = P.ModuleName [P.ProperName "PSCI"] itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ in P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing @@ -93,7 +93,7 @@ createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBin createTemporaryModuleForImports :: PSCiState -> P.Module createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = let - moduleName = P.ModuleName [P.ProperName "$PSCI"] + moduleName = P.ModuleName [P.ProperName "PSCI"] in P.Module (P.internalModuleSourceSpan "") [] moduleName (importDecl `map` imports) Nothing @@ -101,7 +101,7 @@ importDecl :: ImportedModule -> P.Declaration importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False indexFile :: FilePath -indexFile = ".psci_modules" ++ pathSeparator : "index.js" +indexFile = ".psci_modules" ++ pathSeparator : "init.lua" modulesDir :: FilePath modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" From c37375871e7292e2dc2fceb795cfcbc52c24adbe Mon Sep 17 00:00:00 2001 From: Martin Zeller Date: Thu, 7 Jul 2016 18:48:43 +0200 Subject: [PATCH 7/7] Fix a comment still mentioning .js --- src/Language/PureScript/Make.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 124cdf11ec..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