purescript 0.5.4.1 → 0.5.5

raw patch · 26 files changed

+190/−85 lines, 26 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/failing/DuplicateTypeVars.purs +3/−0
• examples/failing/TopLevelCaseNoArgs.purs +4/−0
• examples/passing/DeepArrayBinder.purs +16/−0
• examples/passing/NegativeBinder.purs +7/−0
• examples/passing/OperatorAssociativity.purs +15/−0
• prelude/prelude.purs +1/−1
• psc-make/Main.hs +16/−14
• psc/Main.hs +18/−16
• psci/Main.hs +4/−10
• purescript.cabal +2/−2
• src/Language/PureScript.hs +15/−9
• src/Language/PureScript/CodeGen/JS.hs +17/−7
• src/Language/PureScript/Constants.hs +5/−0
• src/Language/PureScript/Optimizer.hs +2/−0
• src/Language/PureScript/Optimizer/Inliner.hs +3/−4
• src/Language/PureScript/Optimizer/MagicDo.hs +5/−5
• src/Language/PureScript/Optimizer/Unused.hs +19/−3
• src/Language/PureScript/Options.hs +1/−0
• src/Language/PureScript/Parser/Declarations.hs +8/−1
• src/Language/PureScript/Pretty/Common.hs +1/−1
• src/Language/PureScript/Pretty/JS.hs +1/−1
• src/Language/PureScript/Sugar/CaseDeclarations.hs +2/−0
• src/Language/PureScript/TypeChecker.hs +17/−2
• src/Language/PureScript/TypeChecker/Kinds.hs +1/−1
• src/Language/PureScript/TypeChecker/Types.hs +5/−2
• tests/Main.hs +2/−6

@@ -0,0 +1,3 @@+module Main where++type Foo a a = a

@@ -0,0 +1,4 @@+module Main where+  foo :: Number+  foo = 1+  foo = 2

@@ -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

@@ -0,0 +1,7 @@+module Main where++test :: Number -> Boolean+test -1 = false+test _  = true++main = Debug.Trace.trace "Done"

@@ -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

@@ -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) {\

@@ -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)

@@ -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) 

@@ -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

@@ -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

@@ -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"

@@ -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+

@@ -153,6 +153,11 @@ runFn :: String runFn = "runFn" +-- Prim values++undefined :: String+undefined = "undefined"+ -- Type Class Dictionary Names  monadEffDictionary :: String

@@ -57,6 +57,8 @@   , tco opts   , magicDo opts   , removeCodeAfterReturnStatements+  , removeUnusedArg+  , removeUndefinedApp   , unThunk   , etaConvert   , evaluateIifes

@@ -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

@@ -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

@@ -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

@@ -61,6 +61,7 @@     -- Verbose error message     --   , optionsVerboseErrors :: Bool+   } deriving Show  -- |

@@ -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

@@ -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

@@ -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'

@@ -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

@@ -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')+

@@ -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 

@@ -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

@@ -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