summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-09-02 21:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-09-02 21:29:00 (GMT)
commitb30e19bb10b8e49c82a578b5a12d348e94989cc3 (patch)
tree2be7647de822e032b016fc88443ac1b737352b14
parente1f3c26bb8330dc4d13df8914cf1427cc952d425 (diff)
version 0.5.50.5.5
-rw-r--r--examples/failing/DuplicateTypeVars.purs3
-rw-r--r--examples/failing/TopLevelCaseNoArgs.purs4
-rw-r--r--examples/passing/DeepArrayBinder.purs16
-rw-r--r--examples/passing/NegativeBinder.purs7
-rw-r--r--examples/passing/OperatorAssociativity.purs15
-rw-r--r--prelude/prelude.purs2
-rw-r--r--psc-make/Main.hs30
-rw-r--r--psc/Main.hs34
-rw-r--r--psci/Main.hs14
-rw-r--r--purescript.cabal4
-rw-r--r--src/Language/PureScript.hs24
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs24
-rw-r--r--src/Language/PureScript/Constants.hs5
-rw-r--r--src/Language/PureScript/Optimizer.hs2
-rw-r--r--src/Language/PureScript/Optimizer/Inliner.hs7
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs10
-rw-r--r--src/Language/PureScript/Optimizer/Unused.hs22
-rw-r--r--src/Language/PureScript/Options.hs1
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs9
-rw-r--r--src/Language/PureScript/Pretty/Common.hs2
-rw-r--r--src/Language/PureScript/Pretty/JS.hs2
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs2
-rw-r--r--src/Language/PureScript/TypeChecker.hs19
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs7
-rw-r--r--tests/Main.hs8
26 files changed, 190 insertions, 85 deletions
diff --git a/examples/failing/DuplicateTypeVars.purs b/examples/failing/DuplicateTypeVars.purs
new file mode 100644
index 0000000..15340f0
--- /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
index 0000000..c8979c4
--- /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
index 0000000..5ed5726
--- /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
index 0000000..d5dfe1b
--- /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
index 0000000..e0036c5
--- /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
index 1c1788f..1043e07 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -923,7 +923,7 @@ module Control.Monad.ST where
\ 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
index bb0ecb0..e8c936d 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -34,9 +34,6 @@ import qualified Language.PureScript as P
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,21 +66,28 @@ instance P.MonadMake Make where
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 @@ verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
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 @@ termInfo = defTI
main :: IO ()
main = do
- prelude <- preludeFilename
+ prelude <- P.preludeFilename
run (term prelude, termInfo)
diff --git a/psc/Main.hs b/psc/Main.hs
index e70b068..438facd 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -33,9 +33,6 @@ import qualified Language.PureScript as P
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 @@ readInput (Just input) = fmap collect $ forM input $ \inputFile -> do
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 @@ compile opts input output externs = do
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 :: Term Bool
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 @@ termInfo = defTI
main :: IO ()
main = do
- prelude <- preludeFilename
+ prelude <- P.preludeFilename
run (term prelude, termInfo)
diff --git a/psci/Main.hs b/psci/Main.hs
index 99d68e4..c05908e 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -117,12 +117,6 @@ getHistoryFilename :: IO FilePath
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 :: P.Expr -> PSCI ()
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 :: P.Expr -> PSCI ()
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 @@ handleKindOf typ = do
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 @@ loadUserConfig = do
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
index 5d683da..0022710 100644
--- 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 @@ library
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
index c2b2872..fb7eb5c 100644
--- 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.Supply as P
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 @@ import System.FilePath (pathSeparator)
--
-- * 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 @@ compile' env opts ms = do
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 @@ class MonadMake m where
-- 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 @@ make outputDir opts ms = do
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 @@ importPrim = addDefaultImport (ModuleName [ProperName C.prim])
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
index 47a0703..5faf3e8 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -27,7 +27,7 @@ import Data.Maybe (catMaybes, fromJust)
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 @@ varToJs m qual = qualifiedToJS m id qual
-- 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 @@ binderToJs m e varName done (ArrayBinder bs) = do
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
index d2c5a75..b51ed9a 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -153,6 +153,11 @@ mkFn = "mkFn"
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
index 9ffc4b0..fb4eacc 100644
--- a/src/Language/PureScript/Optimizer.hs
+++ b/src/Language/PureScript/Optimizer.hs
@@ -57,6 +57,8 @@ optimize opts | optionsNoOptimizations opts = id
, 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
index cdcca29..2664afb 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -49,8 +49,7 @@ etaConvert = everywhereOnJS convert
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 @@ unThunk = everywhereOnJS convert
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 @@ inlineCommonOperators = applyAll $
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
index 6d27a6b..9571bad 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -60,7 +60,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
-- 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 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
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 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
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
index c0de762..33a233d 100644
--- 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 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)
| 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
index 9aadedb..a271c34 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -61,6 +61,7 @@ data Options = Options {
-- Verbose error message
--
, optionsVerboseErrors :: Bool
+
} deriving Show
-- |
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 9c79a55..d226961 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -24,7 +24,9 @@ module Language.PureScript.Parser.Declarations (
) 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 :: P.Parsec String ParseState Binder
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
index 014ba38..380d77e 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -65,5 +65,5 @@ prettyPrintMany f xs = do
--
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
index 7933302..fc4ea0b 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -190,7 +190,7 @@ unary op str = Wrap match (++)
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
index 44bd0d3..2a215b8 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -87,6 +87,8 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do
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
index 5aacf86..6a8f59b 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -26,8 +26,11 @@ import Language.PureScript.TypeChecker.Types as T
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 @@ addTypeClassDictionaries entries =
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 _ _ [] = return []
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 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re
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 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re
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 @@ typeCheckAll mainModuleName moduleName (PositionedDeclaration pos d : rest) =
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
index f44c1b4..26551a9 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -73,7 +73,7 @@ instance Unifiable Check Kind where
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
index bfbe16a..0c1e72b 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -357,12 +357,12 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
-- 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
@@ -393,6 +393,9 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
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
index 4d8e306..debd733 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -27,12 +27,8 @@ import System.Process
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 @@ compile opts inputFiles = do
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 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
main :: IO ()
main = do
- prelude <- preludeFilename
+ prelude <- P.preludeFilename
putStrLn "Compiling Prelude"
preludeResult <- compile (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) [prelude]
case preludeResult of