diff --git a/examples/failing/DuplicateTypeVars.purs b/examples/failing/DuplicateTypeVars.purs new file mode 100644 --- /dev/null +++ b/examples/failing/DuplicateTypeVars.purs @@ -0,0 +1,3 @@ +module Main where + +type Foo a a = a diff --git a/examples/failing/TopLevelCaseNoArgs.purs b/examples/failing/TopLevelCaseNoArgs.purs new file mode 100644 --- /dev/null +++ b/examples/failing/TopLevelCaseNoArgs.purs @@ -0,0 +1,4 @@ +module Main where + foo :: Number + foo = 1 + foo = 2 diff --git a/examples/passing/DeepArrayBinder.purs b/examples/passing/DeepArrayBinder.purs new file mode 100644 --- /dev/null +++ b/examples/passing/DeepArrayBinder.purs @@ -0,0 +1,16 @@ +module Main where + +import Control.Monad.Eff + +match2 :: [Number] -> Number +match2 (x : y : xs) = x * y + match2 xs +match2 _ = 0 + +foreign import explode + "function explode() {\ + \ throw new Error('Incorrect result');\ + \}" :: forall eff a. Eff eff a + +main = case match2 [1, 2, 3, 4, 5, 6, 7, 8, 9] of + 100 -> Debug.Trace.trace "Done" + _ -> explode diff --git a/examples/passing/NegativeBinder.purs b/examples/passing/NegativeBinder.purs new file mode 100644 --- /dev/null +++ b/examples/passing/NegativeBinder.purs @@ -0,0 +1,7 @@ +module Main where + +test :: Number -> Boolean +test -1 = false +test _ = true + +main = Debug.Trace.trace "Done" diff --git a/examples/passing/OperatorAssociativity.purs b/examples/passing/OperatorAssociativity.purs new file mode 100644 --- /dev/null +++ b/examples/passing/OperatorAssociativity.purs @@ -0,0 +1,15 @@ +module Main where + +import Control.Monad.Eff + +bug :: Number -> Number -> Number +bug a b = 0 - (a - b) + +foreign import explode + "function explode() {\ + \ throw new Error('Assertion failed!');\ + \}":: forall eff a. Eff eff a + +main = case bug 0 2 of + 2 -> Debug.Trace.trace "Done!" + _ -> explode diff --git a/prelude/prelude.purs b/prelude/prelude.purs --- a/prelude/prelude.purs +++ b/prelude/prelude.purs @@ -923,7 +923,7 @@ \ return arr[i];\ \ };\ \ };\ - \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a + \}" :: forall a h r. STArray h a -> Number -> Eff (st :: ST h | r) a foreign import pokeSTArray "function pokeSTArray(arr) {\ \ return function(i) {\ diff --git a/psc-make/Main.hs b/psc-make/Main.hs --- a/psc-make/Main.hs +++ b/psc-make/Main.hs @@ -34,9 +34,6 @@ import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U -preludeFilename :: IO FilePath -preludeFilename = Paths.getDataFileName "prelude/prelude.purs" - readInput :: [FilePath] -> IO (Either ParseError [(FilePath, P.Module)]) readInput input = fmap collect $ forM input $ \inputFile -> do text <- U.readFile inputFile @@ -69,22 +66,29 @@ liftError = either throwError return progress = makeIO . U.putStrLn -compile :: FilePath -> P.Options -> [FilePath] -> IO () -compile outputDir opts input = do - modules <- readInput input +compile :: FilePath -> [FilePath] -> FilePath -> P.Options -> Bool -> IO () +compile prelude input outputDir opts usePrefix = do + modules <- readInput allInputFiles case modules of Left err -> do U.print err exitFailure Right ms -> do - e <- runMake $ P.make outputDir opts ms + e <- runMake $ P.make outputDir opts ms prefix case e of Left err -> do U.putStrLn err exitFailure Right _ -> do exitSuccess + where + prefix = if usePrefix + then ["Generated by psc-make version " ++ showVersion Paths.version] + else [] + allInputFiles | P.optionsNoPrelude opts = input + | otherwise = prelude : input + mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -123,14 +127,12 @@ options :: Term P.Options options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> pure Nothing <*> pure [] <*> pure [] <*> verboseErrors -inputFilesAndPrelude :: FilePath -> Term [FilePath] -inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles - where - combine True input = prelude : input - combine False input = input +noPrefix :: Term Bool +noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ]) + { optDoc = "Do not include comment header"} term :: FilePath -> Term (IO ()) -term prelude = compile <$> outputDirectory <*> options <*> inputFilesAndPrelude prelude +term prelude = compile prelude <$> inputFiles <*> outputDirectory <*> options <*> (not <$> noPrefix) termInfo :: TermInfo termInfo = defTI @@ -141,5 +143,5 @@ main :: IO () main = do - prelude <- preludeFilename + prelude <- P.preludeFilename run (term prelude, termInfo) diff --git a/psc/Main.hs b/psc/Main.hs --- a/psc/Main.hs +++ b/psc/Main.hs @@ -33,9 +33,6 @@ import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U -preludeFilename :: IO FilePath -preludeFilename = Paths.getDataFileName "prelude/prelude.purs" - readInput :: Maybe [FilePath] -> IO (Either ParseError [(FilePath, P.Module)]) readInput Nothing = do text <- getContents @@ -47,15 +44,15 @@ collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)] collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e) -compile :: P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO () -compile opts input output externs = do - modules <- readInput input +compile :: FilePath -> P.Options -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO () +compile prelude opts stdin input output externs usePrefix = do + modules <- readInput stdInOrInputFiles case modules of Left err -> do U.hPutStr stderr $ show err exitFailure Right ms -> do - case P.compile opts (map snd ms) of + case P.compile opts (map snd ms) prefix of Left err -> do U.hPutStrLn stderr err exitFailure @@ -67,6 +64,14 @@ Just path -> mkdirp path >> U.writeFile path exts Nothing -> return () exitSuccess + where + stdInOrInputFiles :: Maybe [FilePath] + stdInOrInputFiles | stdin = Nothing + | P.optionsNoPrelude opts = Just input + | otherwise = Just $ prelude : input + prefix = if usePrefix + then ["Generated by psc version " ++ showVersion Paths.version] + else [] mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -127,18 +132,15 @@ verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ]) { optDoc = "Display verbose error messages" } +noPrefix :: Term Bool +noPrefix = value $ flag $ (optInfo ["no-prefix" ]) + { optDoc = "Do not include comment header"} + options :: Term P.Options options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> (Just <$> browserNamespace) <*> dceModules <*> codeGenModules <*> verboseErrors -stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath]) -stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles - where - combine False True input = Just (prelude : input) - combine False False input = Just input - combine True _ _ = Nothing - term :: FilePath -> Term (IO ()) -term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile +term prelude = compile prelude <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix) termInfo :: TermInfo termInfo = defTI @@ -149,6 +151,6 @@ main :: IO () main = do - prelude <- preludeFilename + prelude <- P.preludeFilename run (term prelude, termInfo) diff --git a/psci/Main.hs b/psci/Main.hs --- a/psci/Main.hs +++ b/psci/Main.hs @@ -117,12 +117,6 @@ getHistoryFilename = getUserConfigFile "purescript" "psci_history" -- | --- Grabs the filename where prelude is. --- -getPreludeFilename :: IO FilePath -getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs" - --- | -- Loads a file for use with imports. -- loadModule :: FilePath -> IO (Either String [P.Module]) @@ -282,7 +276,7 @@ handleDeclaration value = do st <- PSCI $ lift get let m = createTemporaryModule True st value - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) [] case e of Left err -> PSCI $ outputStrLn err Right _ -> do @@ -301,7 +295,7 @@ handleTypeOf value = do st <- PSCI $ lift get let m = createTemporaryModule False st value - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) [] case e of Left err -> PSCI $ outputStrLn err Right env' -> @@ -317,7 +311,7 @@ st <- PSCI $ lift get let m = createTemporaryModuleForKind st typ mName = P.ModuleName [P.ProperName "$PSCI"] - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) [] case e of Left err -> PSCI $ outputStrLn err Right env' -> @@ -400,7 +394,7 @@ loop :: [FilePath] -> IO () loop files = do config <- loadUserConfig - preludeFilename <- getPreludeFilename + preludeFilename <- P.preludeFilename filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . loadModule $ file) (preludeFilename : files) let modulesOrFirstError = fmap concat $ sequence filesAndModules case modulesOrFirstError of diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.5.4.1 +version: 0.5.5 cabal-version: >=1.8 build-type: Custom license: MIT @@ -88,7 +88,7 @@ exposed: True buildable: True hs-source-dirs: src - other-modules: + other-modules: Paths_purescript ghc-options: -Wall -O2 executable psc diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -module Language.PureScript (module P, compile, compile', MonadMake(..), make) where +module Language.PureScript (module P, compile, compile', MonadMake(..), make, preludeFilename) where import Language.PureScript.Types as P import Language.PureScript.Kinds as P @@ -34,6 +34,7 @@ import Language.PureScript.Renamer as P import qualified Language.PureScript.Constants as C +import qualified Paths_purescript as Paths import Data.List (find, sortBy, groupBy, intercalate) import Data.Time.Clock @@ -66,11 +67,11 @@ -- -- * Pretty-print the generated Javascript -- -compile :: Options -> [Module] -> Either String (String, String, Environment) +compile :: Options -> [Module] -> [String] -> Either String (String, String, Environment) compile = compile' initEnvironment -compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment) -compile' env opts ms = do +compile' :: Environment -> Options -> [Module] -> [String] -> Either String (String, String, Environment) +compile' env opts ms prefix = do (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else (map importPrelude ms) (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent @@ -83,7 +84,8 @@ let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs Globals opts m env') modulesToCodeGen let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen js' <- generateMain env' opts js - return (prettyPrintJS js', exts, env') + let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js'] + return (pjs, exts, env') where mainModuleIdent = moduleNameFromString <$> optionsMain opts @@ -168,8 +170,8 @@ -- If timestamps have not changed, the externs file can be used to provide the module's types without -- having to typecheck the module again. -- -make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment -make outputDir opts ms = do +make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> [String] -> m Environment +make outputDir opts ms prefix = do let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms) (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms) @@ -216,8 +218,9 @@ let mod' = Module moduleName' regrouped exps let [renamed] = renameInModules [mod'] - js <- prettyPrintJS <$> moduleToJs CommonJS opts renamed env' - let exts = moduleToPs renamed env' + pjs <- prettyPrintJS <$> moduleToJs CommonJS opts renamed env' + let js = unlines $ map ("// " ++) prefix ++ [pjs] + let exts = unlines $ map ("-- " ++ ) prefix ++ [moduleToPs renamed env'] lift $ writeTextFile jsFile js lift $ writeTextFile externsFile exts @@ -261,3 +264,6 @@ importPrelude :: Module -> Module importPrelude = addDefaultImport (ModuleName [ProperName C.prelude]) + +preludeFilename :: IO FilePath +preludeFilename = Paths.getDataFileName "prelude/prelude.purs" 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 @@ -27,7 +27,7 @@ import Data.Function (on) import Data.List (nub, (\\), delete, sortBy) -import Control.Monad (replicateM, forM) +import Control.Monad (foldM, replicateM, forM) import Control.Applicative import Language.PureScript.Names @@ -307,6 +307,7 @@ -- variable that may have a qualified name. -- qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS +qualifiedToJS _ f (Qualified (Just (ModuleName [ProperName mn])) a) | mn == C.prim = JSVar . runIdent $ f a qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m')) qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a) @@ -391,18 +392,27 @@ done'' <- go done' (index + 1) bs' js <- binderToJs m e elVar done'' binder return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js) -binderToJs m e varName done (ConsBinder headBinder tailBinder) = do - headVar <- freshName +binderToJs m e varName done binder@(ConsBinder _ _) = do + let (headBinders, tailBinder) = uncons [] binder + numberOfHeadBinders = fromIntegral $ length headBinders + js1 <- foldM (\done' (headBinder, index) -> do + headVar <- freshName + jss <- binderToJs m e headVar done' headBinder + return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..]) tailVar <- freshName - js1 <- binderToJs m e headVar done headBinder js2 <- binderToJs m e tailVar js1 tailBinder - return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock - ( JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar varName))) : - JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left 1)])) : + return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock + ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) : js2 )) Nothing] + where + uncons :: [Binder] -> Binder -> ([Binder], Binder) + uncons acc (ConsBinder h t) = uncons (h : acc) t + uncons acc (PositionedBinder _ b) = uncons acc b + uncons acc tailBinder = (reverse acc, tailBinder) binderToJs m e varName done (NamedBinder ident binder) = do js <- binderToJs m e varName done binder return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js) binderToJs m e varName done (PositionedBinder _ binder) = binderToJs m e varName done binder + diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -153,6 +153,11 @@ runFn :: String runFn = "runFn" +-- Prim values + +undefined :: String +undefined = "undefined" + -- Type Class Dictionary Names monadEffDictionary :: String diff --git a/src/Language/PureScript/Optimizer.hs b/src/Language/PureScript/Optimizer.hs --- a/src/Language/PureScript/Optimizer.hs +++ b/src/Language/PureScript/Optimizer.hs @@ -57,6 +57,8 @@ , tco opts , magicDo opts , removeCodeAfterReturnStatements + , removeUnusedArg + , removeUndefinedApp , unThunk , etaConvert , evaluateIifes diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs --- a/src/Language/PureScript/Optimizer/Inliner.hs +++ b/src/Language/PureScript/Optimizer/Inliner.hs @@ -49,8 +49,7 @@ not (any (`isRebound` block) (map JSVar idents)) && not (any (`isRebound` block) args) = JSBlock (map (replaceIdents (zip idents args)) body) - convert (JSFunction Nothing [arg] (JSBlock [JSReturn (JSApp fn@JSVar{} [JSObjectLiteral []])])) - | arg == C.__unused = fn + convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn convert js = js unThunk :: JS -> JS @@ -59,7 +58,7 @@ convert :: JS -> JS convert (JSBlock []) = JSBlock [] convert (JSBlock jss) = - case (last jss) of + case last jss of JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body _ -> JSBlock jss convert js = js @@ -154,7 +153,7 @@ convert other = other isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName isOp _ = False - isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) [JSObjectLiteral []]) = prelude == C.prelude && prop == dictName + isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) []) = prelude == C.prelude && prop == dictName isOpDict _ _ = False mkFn :: Int -> JS -> JS mkFn 0 = everywhereOnJS convert diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs --- a/src/Language/PureScript/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/Optimizer/MagicDo.hs @@ -60,7 +60,7 @@ -- Desugar pure convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val -- Desugar >> - convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind && isJSReturn (last js) && arg == C.__unused = + convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind && isJSReturn (last js) = let JSReturn ret = last js in JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : init js ++ [JSReturn (JSApp ret [])] ) -- Desugar >>= @@ -69,10 +69,10 @@ JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : init js ++ [JSReturn (JSApp ret [])] ) -- Desugar untilE convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f = - JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) [] + JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) [] -- Desugar whileE convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f = - JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) [] + JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) [] convert other = other -- Check if an expression represents a monomorphic call to >>= for the Eff monad isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True @@ -99,8 +99,8 @@ isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name' isEffFunc _ _ = False -- Check if an expression represents the Monad Eff dictionary - isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = True - isEffDict name (JSApp (JSAccessor prop (JSVar eff)) [JSObjectLiteral []]) = eff == C.eff && prop == name + isEffDict name (JSApp (JSVar ident) []) | ident == name = True + isEffDict name (JSApp (JSAccessor prop (JSVar eff)) []) = eff == C.eff && prop == name isEffDict _ _ = False -- Remove __do function applications which remain after desugaring undo :: JS -> JS diff --git a/src/Language/PureScript/Optimizer/Unused.hs b/src/Language/PureScript/Optimizer/Unused.hs --- a/src/Language/PureScript/Optimizer/Unused.hs +++ b/src/Language/PureScript/Optimizer/Unused.hs @@ -13,13 +13,17 @@ -- ----------------------------------------------------------------------------- -module Language.PureScript.Optimizer.Unused ( - removeCodeAfterReturnStatements -) where +module Language.PureScript.Optimizer.Unused + ( removeCodeAfterReturnStatements + , removeUnusedArg + , removeUndefinedApp + ) where import Language.PureScript.CodeGen.JS.AST import Language.PureScript.Optimizer.Common +import qualified Language.PureScript.Constants as C + removeCodeAfterReturnStatements :: JS -> JS removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go) where @@ -28,3 +32,15 @@ | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret] isJSReturn (JSReturn _) = True isJSReturn _ = False + +removeUnusedArg :: JS -> JS +removeUnusedArg = everywhereOnJS convert + where + convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body + convert js = js + +removeUndefinedApp :: JS -> JS +removeUndefinedApp = everywhereOnJS convert + where + convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn [] + convert js = js diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -61,6 +61,7 @@ -- Verbose error message -- , optionsVerboseErrors :: Bool + } deriving Show -- | diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -24,7 +24,9 @@ ) where import Data.Maybe (isJust, fromMaybe) + import Control.Applicative +import Control.Arrow ((+++)) import Language.PureScript.Parser.State import Language.PureScript.Parser.Common @@ -365,7 +367,12 @@ parseBooleanBinder = BooleanBinder <$> booleanLiteral parseNumberBinder :: P.Parsec String ParseState Binder -parseNumberBinder = NumberBinder <$> C.integerOrFloat +parseNumberBinder = NumberBinder <$> (C.lexeme sign <*> C.integerOrFloat) + where + sign :: P.Parsec String ParseState (Either Integer Double -> Either Integer Double) + sign = (P.char '-' >> return (negate +++ negate)) + <|> (P.char '+' >> return id) + <|> return id parseVarBinder :: P.Parsec String ParseState Binder parseVarBinder = VarBinder <$> C.parseIdent diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -65,5 +65,5 @@ -- prettyPrintObjectKey :: String -> String prettyPrintObjectKey s | s `elem` reservedPsNames = show s - | head s `elem` opChars = show s + | any (`elem` opChars) s = show s | otherwise = s diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -190,7 +190,7 @@ match' _ = Nothing binary :: BinaryOperator -> String -> Operator PrinterState JS String -binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2) +binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2) where match :: Pattern PrinterState JS (JS, JS) match = mkPattern match' diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -87,6 +87,8 @@ let tuples = map toTuple ds unless (all ((== length bs) . length . fst) tuples) $ throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing + unless (not $ null bs) $ + throwError $ mkErrorStack ("Top level case disallowed in declaration " ++ show ident) Nothing caseDecl <- makeCaseDeclaration ident tuples return [caseDecl] toDecls (PositionedDeclaration pos d : ds) = do diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -26,8 +26,11 @@ import Language.PureScript.TypeChecker.Synonyms as T import Data.Maybe +import Data.List (nub, (\\)) import Data.Monoid ((<>)) +import Data.Foldable (for_) import qualified Data.Map as M + import Control.Monad.State import Control.Monad.Error @@ -87,6 +90,13 @@ let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ] in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } } +checkDuplicateTypeArguments :: [String] -> Check () +checkDuplicateTypeArguments args = for_ firstDup $ \dup -> + throwError . strMsg $ "Duplicate type argument '" ++ dup ++ "'" + where + firstDup :: Maybe String + firstDup = listToMaybe $ args \\ nub args + checkTypeClassInstance :: ModuleName -> Type -> Check () checkTypeClassInstance _ (TypeVar _) = return () checkTypeClassInstance _ (TypeConstructor ctor) = do @@ -114,6 +124,7 @@ typeCheckAll mainModuleName moduleName (d@(DataDeclaration dtype name args dctors) : rest) = do rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do when (dtype == Newtype) $ checkNewtype dctors + checkDuplicateTypeArguments args ctorKind <- kindsOf True moduleName name args (concatMap snd dctors) addDataType moduleName dtype name args dctors ctorKind ds <- typeCheckAll mainModuleName moduleName rest @@ -128,9 +139,11 @@ let syns = mapMaybe toTypeSynonym tys let dataDecls = mapMaybe toDataDecl tys (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) - forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> + forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do + checkDuplicateTypeArguments args addDataType moduleName dtype name args dctors ctorKind - forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> + forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do + checkDuplicateTypeArguments args addTypeSynonym moduleName name args ty kind ds <- typeCheckAll mainModuleName moduleName rest return $ d : ds @@ -143,6 +156,7 @@ toDataDecl _ = Nothing typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do + checkDuplicateTypeArguments args kind <- kindsOf False moduleName name args [ty] addTypeSynonym moduleName name args ty kind ds <- typeCheckAll mainModuleName moduleName rest @@ -213,3 +227,4 @@ rethrowWithPosition pos $ do (d' : rest') <- typeCheckAll mainModuleName moduleName (d : rest) return (PositionedDeclaration pos d' : rest') + diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -73,7 +73,7 @@ kindOf :: ModuleName -> Type -> Check Kind kindOf _ ty = rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $ - fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty + fmap (starIfUnknown . tidyUp) . liftUnify $ infer ty where tidyUp (k, sub) = sub $? k diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -357,12 +357,12 @@ -- Turn a DictionaryValue into a Expr dictionaryValueToValue :: DictionaryValue -> Expr dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName - dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral []) + dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) valUndefined dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts) dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) = App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index) (dictionaryValueToValue dict)) - (ObjectLiteral []) + valUndefined -- Ensure that a substitution is valid verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)] verifySubstitution subst = do @@ -392,6 +392,9 @@ dictTrace (DependentDictionaryValue fnName dicts) = DependentDictionaryValue fnName $ map dictTrace dicts dictTrace (SubclassDictionaryValue dict _ _) = dictTrace dict dictTrace other = other + + valUndefined :: Expr + valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) -- | -- Check all values in a list pairwise match a predicate diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -27,12 +27,8 @@ import System.FilePath (pathSeparator) import System.Directory (getCurrentDirectory, getTemporaryDirectory, getDirectoryContents, findExecutable) import Text.Parsec (ParseError) -import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U -preludeFilename :: IO FilePath -preludeFilename = Paths.getDataFileName "prelude/prelude.purs" - readInput :: [FilePath] -> IO (Either ParseError [P.Module]) readInput inputFiles = fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do text <- U.readFile inputFile @@ -44,7 +40,7 @@ case modules of Left parseError -> return (Left $ show parseError) - Right ms -> return $ P.compile opts ms + Right ms -> return $ P.compile opts ms [] assert :: FilePath -> P.Options -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO () assert preludeExterns opts inputFile f = do @@ -80,7 +76,7 @@ main :: IO () main = do - prelude <- preludeFilename + prelude <- P.preludeFilename putStrLn "Compiling Prelude" preludeResult <- compile (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) [prelude] case preludeResult of