purescript 0.5.5 → 0.5.6

raw patch · 27 files changed

+483/−283 lines, 27 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• docgen/Main.hs +2/−1
• examples/failing/InstanceExport.purs +15/−0
• examples/failing/MultipleErrors.purs +9/−0
• examples/failing/OverlappingArguments.purs +3/−0
• examples/failing/OverlappingBinders.purs +4/−0
• examples/passing/BlockString.purs +12/−0
• examples/passing/IfThenElseMaybe.purs +9/−0
• prelude/prelude.purs +9/−9
• psc-make/Main.hs +6/−5
• psc/Main.hs +8/−5
• psci/Main.hs +22/−14
• purescript.cabal +1/−1
• src/Language/PureScript.hs +38/−15
• src/Language/PureScript/CodeGen/JS.hs +23/−27
• src/Language/PureScript/Errors.hs +28/−16
• src/Language/PureScript/Optimizer.hs +1/−1
• src/Language/PureScript/Optimizer/MagicDo.hs +1/−1
• src/Language/PureScript/Optimizer/TCO.hs +1/−1
• src/Language/PureScript/Options.hs +39/−17
• src/Language/PureScript/Parser/Common.hs +3/−1
• src/Language/PureScript/Sugar/CaseDeclarations.hs +3/−1
• src/Language/PureScript/Sugar/TypeClasses.hs +26/−14
• src/Language/PureScript/TypeChecker.hs +116/−100
• src/Language/PureScript/TypeChecker/Monad.hs +18/−2
• src/Language/PureScript/TypeChecker/Types.hs +71/−45
• src/Language/PureScript/TypeClassDictionaries.hs +4/−0
• tests/Main.hs +11/−7

@@ -144,7 +144,8 @@   let exported = filter (isDctorExported name exps . fst) ctors   atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")   forM_ exported $ \(ctor, tys) ->-    atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> prettyPrintType' ty ++ " -> ") tys ++ typeName+    let ctorTy = foldr P.function (P.TypeConstructor (P.Qualified Nothing name)) tys+    in atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ prettyPrintType' ctorTy renderDeclaration n _ (P.ExternDataDeclaration name kind) =   atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do

@@ -0,0 +1,15 @@+module InstanceExport (S(..), f) where++newtype S = S String++class F a where+  f :: a -> String++instance fs :: F S where+  f (S s) = s++module Test where++import InstanceExport++test = f $ S "Test"

@@ -0,0 +1,9 @@+module MultipleErrors where++foo :: Number -> Number+foo 0 = "Test"+foo n = bar (n - 1)++bar :: Number -> Number+bar 0 = "Test"+bar n = foo (n - 1)

@@ -0,0 +1,3 @@+module OverlappingArguments where++f x x = x

@@ -0,0 +1,4 @@+module OverlappingBinders where++f x = case x of+  (y:y@(z:zs)) -> y

@@ -0,0 +1,12 @@+module Main where++foreign import foo """+  function foo(s) {+    return s;+  }+""" :: String -> String++bar :: String -> String+bar _ = foo "test"++main = Debug.Trace.trace "Done"

@@ -0,0 +1,9 @@+module Main where++data Maybe a = Nothing | Just a++test1 = if true then Just 10 else Nothing++test2 = if true then Nothing else Just 10++main = Debug.Trace.trace "Done"

@@ -66,7 +66,7 @@    foreign import cons     "function cons(e) {\-    \  return function (l) {\+    \  return function(l) {\     \    return [e].concat(l);\     \  };\     \}" :: forall a. a -> [a] -> [a]@@ -97,8 +97,8 @@     show = showNumberImpl    foreign import showArrayImpl-    "function showArrayImpl (f) {\-    \  return function (xs) {\+    "function showArrayImpl(f) {\+    \  return function(xs) {\     \    var ss = [];\     \    for (var i = 0, l = xs.length; i < l; i++) {\     \      ss[i] = f(xs[i]);\@@ -327,10 +327,10 @@    foreign import unsafeCompareImpl     "function unsafeCompareImpl(lt) {\-    \  return function (eq) {\-    \    return function (gt) {\-    \      return function (x) {\-    \        return function (y) {\+    \  return function(eq) {\+    \    return function(gt) {\+    \      return function(x) {\+    \        return function(y) {\     \          return x < y ? lt : x > y ? gt : eq;\     \        };\     \      };\@@ -803,7 +803,7 @@    foreign import untilE "function untilE(f) {\                         \  return function() {\-                        \    while (!f()) { }\+                        \    while (!f());\                         \    return {};\                         \  };\                         \}" :: forall e. Eff e Boolean -> Eff e Unit@@ -878,7 +878,7 @@   foreign import data STArray :: * -> * -> *    foreign import newSTRef "function newSTRef(val) {\-                          \  return function () {\+                          \  return function() {\                           \    return { value: val };\                           \  };\                           \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

@@ -12,7 +12,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}  module Main where @@ -66,7 +66,7 @@   liftError = either throwError return   progress = makeIO . U.putStrLn -compile :: FilePath -> [FilePath] -> FilePath -> P.Options -> Bool -> IO ()+compile :: FilePath -> [FilePath] -> FilePath -> P.Options P.Make -> Bool -> IO () compile prelude input outputDir opts usePrefix = do   modules <- readInput allInputFiles   case modules of@@ -81,7 +81,7 @@           exitFailure         Right _ -> do           exitSuccess-  where +  where     prefix = if usePrefix                then ["Generated by psc-make version " ++ showVersion Paths.version]                else []@@ -124,8 +124,8 @@ verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])      { optDoc = "Display verbose error messages" } -options :: Term P.Options-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> pure Nothing <*> pure [] <*> pure [] <*> verboseErrors+options :: Term (P.Options P.Make)+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> verboseErrors <*> pure P.MakeOptions  noPrefix :: Term Bool noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ])@@ -145,3 +145,4 @@ main = do   prelude <- P.preludeFilename   run (term prelude, termInfo)+

@@ -12,7 +12,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}  module Main where @@ -44,7 +44,7 @@   collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]   collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e) -compile :: FilePath -> P.Options -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()+compile :: FilePath -> P.Options P.Compile -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO () compile prelude opts stdin input output externs usePrefix = do   modules <- readInput stdInOrInputFiles   case modules of@@ -70,7 +70,7 @@                     | P.optionsNoPrelude opts = Just input                     | otherwise = Just $ prelude : input   prefix = if usePrefix-              then ["Generated by psc version " ++ showVersion Paths.version]                    +              then ["Generated by psc version " ++ showVersion Paths.version]               else []  mkdirp :: FilePath -> IO ()@@ -136,8 +136,10 @@ 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+options :: Term (P.Options P.Compile)+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> verboseErrors <*> additionalOptions+  where+  additionalOptions = P.CompileOptions <$> browserNamespace <*> dceModules <*> codeGenModules  term :: FilePath -> Term (IO ()) term prelude = compile prelude <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix)@@ -153,4 +155,5 @@ main = do   prelude <- P.preludeFilename   run (term prelude, termInfo)+ 

@@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DataKinds, DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}  module Main where @@ -198,8 +198,8 @@  -- | Compilation options. ---options :: P.Options-options = P.Options False True False True Nothing True Nothing [] [] False+options :: P.Options P.Make+options = P.Options False False False False Nothing False False P.MakeOptions  -- | -- PSCI monad@@ -276,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@@ -295,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' ->@@ -311,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' ->@@ -329,13 +329,13 @@ -- | -- Parses the input and returns either a Metacommand or an expression. ---getCommand :: InputT (StateT PSCiState IO) (Either ParseError (Maybe Command))-getCommand = do+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either ParseError (Maybe Command))+getCommand singleLineMode = do   firstLine <- getInputLine "> "   case firstLine of     Nothing -> return (Right Nothing)     Just "" -> return (Right Nothing)-    Just s@ (':' : _) -> return . either Left (Right . Just) $ parseCommand s -- The start of a command+    Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s     Just s -> either Left (Right . Just) . parseCommand <$> go [s]   where     go :: [String] -> InputT (StateT PSCiState IO) String@@ -371,9 +371,16 @@ handleCommand (KindOf typ) = handleKindOf typ handleCommand _ = PSCI $ outputStrLn "Unknown command" +singleLineFlag :: Cmd.Term Bool+singleLineFlag = Cmd.value $ Cmd.flag $ (Cmd.optInfo ["single-line-mode"])+                                                { Cmd.optName = "Single-line mode"+                                                , Cmd.optDoc = "Run in single-line mode"+                                                }+ inputFiles :: Cmd.Term [FilePath] inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"-                                                     , Cmd.posDoc = "Optional .purs files to load on start" }+                                                     , Cmd.posDoc = "Optional .purs files to load on start"+                                                     }  loadUserConfig :: IO (Maybe [Command]) loadUserConfig = do@@ -391,8 +398,8 @@ -- | -- The PSCI main loop. ---loop :: [FilePath] -> IO ()-loop files = do+loop :: Bool -> [FilePath] -> IO ()+loop singleLineMode files = do   config <- loadUserConfig   preludeFilename <- P.preludeFilename   filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . loadModule $ file) (preludeFilename : files)@@ -409,7 +416,7 @@       where         go :: InputT (StateT PSCiState IO) ()         go = do-          c <- getCommand+          c <- getCommand singleLineMode           case c of             Left err -> outputStrLn (show err) >> go             Right Nothing -> go@@ -417,7 +424,7 @@             Right (Just c') -> runPSCI (handleCommand c') >> go  term :: Cmd.Term (IO ())-term = loop <$> inputFiles+term = loop <$> singleLineFlag <*> inputFiles  termInfo :: Cmd.TermInfo termInfo = Cmd.defTI@@ -428,3 +435,4 @@  main :: IO () main = Cmd.run (term, termInfo)+

@@ -1,5 +1,5 @@ name: purescript-version: 0.5.5+version: 0.5.6 cabal-version: >=1.8 build-type: Custom license: MIT

@@ -13,6 +13,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-}+ module Language.PureScript (module P, compile, compile', MonadMake(..), make, preludeFilename) where  import Language.PureScript.Types as P@@ -39,15 +41,18 @@ import Data.List (find, sortBy, groupBy, intercalate) import Data.Time.Clock import Data.Function (on)-import Data.Maybe (fromJust, fromMaybe)+import Data.Maybe (listToMaybe, fromMaybe) import Control.Monad.Error import Control.Monad.State.Lazy import Control.Arrow ((&&&)) import Control.Applicative import qualified Data.Map as M import qualified Data.Set as S-import System.FilePath (pathSeparator) +import System.FilePath ((</>), pathSeparator)+import System.Directory (getHomeDirectory, doesFileExist)+import System.Environment.XDG.BaseDir (getUserConfigDir)+ -- | -- Compile a collection of modules --@@ -67,21 +72,21 @@ -- --  * Pretty-print the generated Javascript ---compile :: Options -> [Module] -> [String] -> Either String (String, String, Environment)+compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment) compile = compile' initEnvironment -compile' :: Environment -> Options -> [Module] -> [String] -> Either String (String, String, Environment)+compile' :: Environment -> Options Compile -> [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   regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated-  let entryPoints = moduleNameFromString `map` optionsModules opts+  let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)   let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped   let renamed = renameInModules elim-  let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts-  let modulesToCodeGen = if null codeGenModules then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModules) renamed-  let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs Globals opts m env') modulesToCodeGen+  let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)+  let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModuleNames) renamed+  let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs opts m env') modulesToCodeGen   let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen   js' <- generateMain env' opts js   let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']@@ -92,7 +97,7 @@ typeCheckModule :: Maybe ModuleName -> Module -> Check Module typeCheckModule mainModuleName (Module mn decls exps) = do   modify (\s -> s { checkCurrentModule = Just mn })-  decls' <- typeCheckAll mainModuleName mn decls+  decls' <- typeCheckAll mainModuleName mn exps decls   mapM_ checkTypesAreExported exps'   return $ Module mn decls' exps   where@@ -126,13 +131,13 @@     go _ = True  -generateMain :: Environment -> Options -> [JS] -> Either String [JS]+generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS] generateMain env opts js =   case moduleNameFromString <$> optionsMain opts of     Just mmi -> do       when ((mmi, Ident C.main) `M.notMember` names env) $         Left $ show mmi ++ "." ++ C.main ++ " is undefined"-      return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (fromJust (optionsBrowserNamespace opts))))) []]+      return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []]     _ -> return js  -- |@@ -170,7 +175,7 @@ -- 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)] -> [String] -> m Environment+make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(FilePath, Module)] -> [String] -> m Environment make outputDir opts ms prefix = do   let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms) @@ -216,9 +221,9 @@     regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated      let mod' = Module moduleName' regrouped exps-    let [renamed] = renameInModules [mod'] +    let [renamed] = renameInModules [mod'] -    pjs <- prettyPrintJS <$> moduleToJs CommonJS opts renamed env'+    pjs <- prettyPrintJS <$> moduleToJs opts renamed env'     let js = unlines $ map ("// " ++) prefix ++ [pjs]     let exts = unlines $ map ("-- " ++ ) prefix ++ [moduleToPs renamed env'] @@ -266,4 +271,22 @@ importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])  preludeFilename :: IO FilePath-preludeFilename = Paths.getDataFileName "prelude/prelude.purs"+preludeFilename = fromMaybe missingPrelude . listToMaybe <$> do+  fs <- sequence [xdsPrelude, homePrelude, cabalPrelude]+  filterM doesFileExist fs+  where+  missingPrelude :: FilePath+  missingPrelude = error "No Prelude found in user home, XDS user config directory or cabal path."++  xdsPrelude :: IO FilePath+  xdsPrelude = do+    configDir <- getUserConfigDir "purescript"+    return $ configDir </> "prelude" </> "prelude.purs"++  homePrelude :: IO FilePath+  homePrelude = do+    homeDir <- getHomeDirectory+    return $ homeDir </> ".purescript" </> "prelude" </> "prelude.purs"++  cabalPrelude :: IO FilePath+  cabalPrelude = Paths.getDataFileName "prelude/prelude.purs"

@@ -13,17 +13,16 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE GADTs, DoAndIfThenElse #-}  module Language.PureScript.CodeGen.JS (     module AST,-    ModuleType(..),     declToJs,     moduleToJs,     identNeedsEscaping ) where -import Data.Maybe (catMaybes, fromJust)+import Data.Maybe (catMaybes) import Data.Function (on) import Data.List (nub, (\\), delete, sortBy) @@ -43,39 +42,35 @@ import qualified Language.PureScript.Constants as C  -- |--- Different types of modules which are supported----data ModuleType = CommonJS | Globals---- | -- Generate code in the simplified Javascript intermediate representation for all declarations in a -- module. ---moduleToJs :: (Functor m, Applicative m, Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]-moduleToJs mt opts (Module name decls (Just exps)) env = do-  let jsImports = map (importToJs mt opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls+moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module -> Environment -> SupplyT m [JS]+moduleToJs opts (Module name decls (Just exps)) env = do+  let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls   jsDecls <- mapM (\decl -> declToJs opts name decl env) decls   let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls   let isModuleEmpty = null exps   let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized   let moduleExports = JSObjectLiteral $ concatMap exportToJs exps-  return $ case mt of-    CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]-    Globals | not isModuleEmpty ->-      [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))-                               (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )-      , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))+  return $ case optionsAdditional opts of+    MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]+    CompileOptions ns _ _ | not isModuleEmpty ->+      [ JSVariableIntroduction ns+                               (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )+      , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))                      (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])       ]     _ -> []-moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"+moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring" -importToJs :: ModuleType -> Options -> ModuleName -> JS-importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)+importToJs :: Options mode -> ModuleName -> JS+importToJs opts mn =+  JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)   where-  moduleBody = case mt of-    CommonJS -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]-    Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))+  moduleBody = case optionsAdditional opts of+    MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]+    CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)  imports :: Declaration -> [ModuleName] imports (ImportDeclaration mn _ _) = [mn]@@ -95,7 +90,7 @@ -- | -- Generate code in the simplified Javascript intermediate representation for a declaration ---declToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])+declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS]) declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do   js <- valueToJs opts mp e val   return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]@@ -190,7 +185,7 @@ -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression. ---valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Expr -> SupplyT m JS+valueToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> Expr -> SupplyT m JS valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b@@ -315,7 +310,7 @@ -- Generate code in the simplified Javascript intermediate representation for pattern match binders -- and guards. ---bindersToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS+bindersToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS bindersToJs opts m e binders vals = do   valNames <- replicateM (length vals) freshName   let assignments = zipWith JSVariableIntroduction valNames (map Just vals)@@ -405,7 +400,7 @@     ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :       js2     )) Nothing]-  where +  where   uncons :: [Binder] -> Binder -> ([Binder], Binder)   uncons acc (ConsBinder h t) = uncons (h : acc) t   uncons acc (PositionedBinder _ b) = uncons acc b@@ -415,4 +410,5 @@   return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js) binderToJs m e varName done (PositionedBinder _ binder) =   binderToJs m e varName done binder+ 

@@ -16,7 +16,7 @@  module Language.PureScript.Errors where -import Data.List (intercalate)+import Data.List (intersperse, intercalate) import Data.Monoid  import Control.Monad.Error@@ -41,26 +41,36 @@ -- | -- Compilation errors ---data CompileError = CompileError {-    -- |-    -- Error message-    ---    compileErrorMessage :: String-    -- |-    -- The value where the error occurred-    ---  , compileErrorValue :: Maybe ErrorSource-    -- |-    -- Optional source position information-    ---  , compileErrorPosition :: Maybe SourcePos-  } deriving (Show)+data CompileError+  = CompileError+      { -- |+        -- Error message+        --+        compileErrorMessage :: String+        -- |+        -- The value where the error occurred+        --+      , compileErrorValue :: Maybe ErrorSource+        -- |+        -- Optional source position information+        --+      , compileErrorPosition :: Maybe SourcePos+      }+  deriving (Show)  -- | -- A stack trace for an error ---newtype ErrorStack = ErrorStack { runErrorStack :: [CompileError] } deriving (Show, Monoid)+data ErrorStack+  = ErrorStack { runErrorStack :: [CompileError] }+  | MultipleErrors [ErrorStack] deriving (Show) +instance Monoid ErrorStack where+  mempty = ErrorStack []+  mappend (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)+  mappend (MultipleErrors es) x = MultipleErrors [ e <> x | e <- es ]+  mappend x (MultipleErrors es) = MultipleErrors [ x <> e | e <- es ]+ instance Error ErrorStack where   strMsg s = ErrorStack [CompileError s Nothing Nothing]   noMsg = ErrorStack []@@ -80,6 +90,8 @@       in case length es' of         1 -> showError (head es')         _ -> showError (head es') ++ "\n" ++ showError (last es')+prettyPrintErrorStack printFullStack (MultipleErrors es) =+  unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es  stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right

@@ -49,7 +49,7 @@ -- | -- Apply a series of optimizer passes to simplified Javascript code ---optimize :: Options -> JS -> JS+optimize :: Options mode -> JS -> JS optimize opts | optionsNoOptimizations opts = id               | otherwise = untilFixedPoint (applyAll   [ collapseNestedBlocks

@@ -28,7 +28,7 @@  import qualified Language.PureScript.Constants as C -magicDo :: Options -> JS -> JS+magicDo :: Options mode -> JS -> JS magicDo opts | optionsNoMagicDo opts = id              | otherwise = inlineST . magicDo' 

@@ -21,7 +21,7 @@ -- | -- Eliminate tail calls ---tco :: Options -> JS -> JS+tco :: Options mode -> JS -> JS tco opts | optionsNoTco opts = id          | otherwise = tco' 

@@ -13,12 +13,37 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE GADTs, DataKinds, StandaloneDeriving #-}+ module Language.PureScript.Options where  -- |+-- Indicates the mode of the compiler. Lifted using DataKinds to refine the Options type.+--+data Mode = Compile | Make++-- |+-- Per-mode options+--+data ModeOptions mode where+  CompileOptions :: String -> [String] -> [String] -> ModeOptions Compile+  MakeOptions :: ModeOptions Make++browserNamespace :: ModeOptions Compile -> String+browserNamespace (CompileOptions ns _ _) = ns++entryPointModules :: ModeOptions Compile -> [String]+entryPointModules (CompileOptions _ ms _) = ms++codeGenModules :: ModeOptions Compile -> [String]+codeGenModules (CompileOptions _ _ ms) = ms++deriving instance Show (ModeOptions mode)++-- | -- The data type of compiler options ---data Options = Options {+data Options mode = Options {     -- |     -- Disable inclusion of the built in Prelude     --@@ -45,27 +70,24 @@     --   , optionsNoOptimizations :: Bool     -- |-    -- Specify the namespace that PureScript modules will be exported to when running in the-    -- browser.-    ---  , optionsBrowserNamespace :: Maybe String-    -- |-    -- The modules to keep while enabling dead code elimination-    ---  , optionsModules :: [String]-    -- |-    -- The modules to code gen-    ---  , optionsCodeGenModules :: [String]-    -- |     -- Verbose error message     --   , optionsVerboseErrors :: Bool-+    -- |+    -- Specify the namespace that PureScript modules will be exported to when running in the+    -- browser.+    --+  , optionsAdditional :: ModeOptions mode   } deriving Show  -- | -- Default compiler options ---defaultOptions :: Options-defaultOptions = Options False False False False Nothing False Nothing [] [] False+defaultCompileOptions :: Options Compile+defaultCompileOptions = Options False False False False Nothing False False (CompileOptions "PS" [] [])++-- |+-- Default make options+--+defaultMakeOptions :: Options Make+defaultMakeOptions = Options False False False False Nothing False False MakeOptions

@@ -155,7 +155,9 @@ -- Parse a string literal -- stringLiteral :: P.Parsec String u String-stringLiteral = PT.stringLiteral tokenParser+stringLiteral = lexeme blockString <|> PT.stringLiteral tokenParser+  where delimeter   = P.try (P.string "\"\"\"")+        blockString = delimeter >> P.manyTill P.anyChar delimeter  -- | -- Parse whitespace

@@ -20,7 +20,7 @@ ) where  import Data.Monoid ((<>))-import Data.List (groupBy)+import Data.List (nub, groupBy)  import Control.Applicative import Control.Monad ((<=<), forM, join, unless, replicateM)@@ -31,6 +31,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Supply+import Language.PureScript.TypeChecker.Monad (guardWith)  -- | -- Replace all top-level binders in a module with case expressions.@@ -82,6 +83,7 @@ toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do   let args = map (\(VarBinder arg) -> arg) bs       body = foldr (Abs . Left) val args+  guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args   return [ValueDeclaration ident nameKind [] Nothing body] toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do   let tuples = map toTuple ds

@@ -151,36 +151,46 @@ --   }; -} desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])-desugarDecl mn _ d@(TypeClassDeclaration name args implies members) = do-  modify (M.insert (mn, name) d)-  return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)-desugarDecl mn exps d@(TypeInstanceDeclaration name deps className tys members) = do-  desugared <- lift $ desugarCases members-  dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared-  let expRef = if isExportedClass className && all isExportedType (getConstructors `concatMap` tys)-               then Just $ TypeInstanceRef name-               else Nothing-  return $ (expRef, [d, dictDecl])+desugarDecl mn exps = go   where+  go d@(TypeClassDeclaration name args implies members) = do+    modify (M.insert (mn, name) d)+    return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)+  go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])+  go d@(TypeInstanceDeclaration name deps className tys members) = do+    desugared <- lift $ desugarCases members+    dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared+    return $ (expRef name className tys, [d, dictDecl])+  go (PositionedDeclaration pos d) = do+    (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d+    return (dr, map (PositionedDeclaration pos) ds)+  go other = return (Nothing, [other])++  expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef+  expRef name className tys+    | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name+    | otherwise = Nothing+   isExportedClass :: Qualified ProperName -> Bool   isExportedClass = isExported (elem . TypeClassRef)+   isExportedType :: Qualified ProperName -> Bool   isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)+   isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool   isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps   isExported _ _ = error "Names should have been qualified in name desugaring"+   matchesTypeRef :: ProperName -> DeclarationRef -> Bool   matchesTypeRef pn (TypeRef pn' _) = pn == pn'   matchesTypeRef _ _ = False+   getConstructors :: Type -> [Qualified ProperName]   getConstructors = everythingOnTypes (++) getConstructor+   getConstructor :: Type -> [Qualified ProperName]   getConstructor (TypeConstructor tcname) = [tcname]   getConstructor _ = []-desugarDecl mn exps (PositionedDeclaration pos d) = do-  (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d-  return (dr, map (PositionedDeclaration pos) ds)-desugarDecl _ _ other = return (Nothing, [other])  memberToNameAndType :: Declaration -> (Ident, Type) memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)@@ -275,3 +285,5 @@   typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val   typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)   typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"++

@@ -119,112 +119,128 @@ -- --  * Process module imports ---typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]-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-  return $ d : ds+typeCheckAll :: Maybe ModuleName -> ModuleName -> Maybe [DeclarationRef] -> [Declaration] -> Check [Declaration]+typeCheckAll mainModuleName moduleName exps = go   where-  checkNewtype :: [(ProperName, [Type])] -> Check ()-  checkNewtype [(_, [_])] = return ()-  checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"-  checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"-typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do-  rethrow (strMsg "Error in data binding group" <>) $ do-    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) -> do+  go :: [Declaration] -> Check [Declaration]+  go [] = return []+  go (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-    forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do+    ds <- go rest+    return $ d : ds+    where+    checkNewtype :: [(ProperName, [Type])] -> Check ()+    checkNewtype [(_, [_])] = return ()+    checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"+    checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"+  go (d@(DataBindingGroupDeclaration tys) : rest) = do+    rethrow (strMsg "Error in data binding group" <>) $ do+      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) -> do+        checkDuplicateTypeArguments args+        addDataType moduleName dtype name args dctors ctorKind+      forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do+        checkDuplicateTypeArguments args+        addTypeSynonym moduleName name args ty kind+    ds <- go rest+    return $ d : ds+    where+    toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)+    toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'+    toTypeSynonym _ = Nothing+    toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)+    toDataDecl (PositionedDeclaration _ d') = toDataDecl d'+    toDataDecl _ = Nothing+  go (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-  return $ d : ds-  where-  toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)-  toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'-  toTypeSynonym _ = Nothing-  toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)-  toDataDecl (PositionedDeclaration _ d') = toDataDecl d'-  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-  return $ d : ds-typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"-typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothing val : rest) = do-  d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do-    valueIsNotDefined moduleName name-    [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]-    addValue moduleName name ty nameKind-    return $ ValueDeclaration name nameKind [] Nothing val'-  ds <- typeCheckAll mainModuleName moduleName rest-  return $ d : ds-typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"-typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do-  d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do-    forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->+    ds <- go rest+    return $ d : ds+  go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"+  go (ValueDeclaration name nameKind [] Nothing val : rest) = do+    d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do       valueIsNotDefined moduleName name-    tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals-    vals' <- forM (zipWith (\(name, nameKind, _) (_, (val, ty)) -> (name, val, nameKind, ty)) vals tys) $ \(name, val, nameKind, ty) -> do+      [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]       addValue moduleName name ty nameKind-      return (name, nameKind, val)-    return $ BindingGroupDeclaration vals'-  ds <- typeCheckAll mainModuleName moduleName rest-  return $ d : ds-typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do-  env <- getEnv-  putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }-  ds <- typeCheckAll mainModuleName moduleName rest-  return $ d : ds-typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do-  rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do+      return $ ValueDeclaration name nameKind [] Nothing val'+    ds <- go rest+    return $ d : ds+  go (ValueDeclaration{} : _) = error "Binders were not desugared"+  go (BindingGroupDeclaration vals : rest) = do+    d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do+      forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->+        valueIsNotDefined moduleName name+      tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals+      vals' <- forM (zipWith (\(name, nameKind, _) (_, (val, ty)) -> (name, val, nameKind, ty)) vals tys) $ \(name, val, nameKind, ty) -> do+        addValue moduleName name ty nameKind+        return (name, nameKind, val)+      return $ BindingGroupDeclaration vals'+    ds <- go rest+    return $ d : ds+  go (d@(ExternDataDeclaration name kind) : rest) = do     env <- getEnv-    kind <- kindOf moduleName ty-    guardWith (strMsg "Expected kind *") $ kind == Star-    case M.lookup (moduleName, name) (names env) of-      Just _ -> throwError . strMsg $ show name ++ " is already defined"-      Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })-  ds <- typeCheckAll mainModuleName moduleName rest-  return $ d : ds-typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do-  ds <- typeCheckAll mainModuleName moduleName rest-  env <- getEnv-  guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env-  return $ d : ds-typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do-  tcds <- getTypeClassDictionaries-  let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) tcds-  addTypeClassDictionaries [ tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }-                           | tcd <- instances-                           , let (Qualified _ ident) = tcdName tcd-                           ]-  ds <- typeCheckAll mainModuleName currentModule rest-  return $ d : ds-typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args implies tys) : rest) = do-  addTypeClass moduleName pn args implies tys-  ds <- typeCheckAll mainModuleName moduleName rest-  return $ d : ds-typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do-  typeCheckAll mainModuleName moduleName (ExternInstanceDeclaration dictName deps className tys : rest)-typeCheckAll mainModuleName moduleName (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do-  mapM_ (checkTypeClassInstance moduleName) tys-  forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd-  addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]-  ds <- typeCheckAll mainModuleName moduleName rest-  return $ d : ds-typeCheckAll mainModuleName moduleName (PositionedDeclaration pos d : rest) =-  rethrowWithPosition pos $ do-    (d' : rest') <- typeCheckAll mainModuleName moduleName (d : rest)-    return (PositionedDeclaration pos d' : rest')+    putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }+    ds <- go rest+    return $ d : ds+  go (d@(ExternDeclaration importTy name _ ty) : rest) = do+    rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do+      env <- getEnv+      kind <- kindOf moduleName ty+      guardWith (strMsg "Expected kind *") $ kind == Star+      case M.lookup (moduleName, name) (names env) of+        Just _ -> throwError . strMsg $ show name ++ " is already defined"+        Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })+    ds <- go rest+    return $ d : ds+  go (d@(FixityDeclaration _ name) : rest) = do+    ds <- go rest+    env <- getEnv+    guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env+    return $ d : ds+  go (d@(ImportDeclaration importedModule _ _) : rest) = do+    tcds <- getTypeClassDictionaries+    let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in importedModule == mn) tcds+    addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }+                             | tcd <- instances+                             , tcdExported tcd+                             , let (Qualified _ ident) = tcdName tcd+                             ]+    ds <- go rest+    return $ d : ds+  go (d@(TypeClassDeclaration pn args implies tys) : rest) = do+    addTypeClass moduleName pn args implies tys+    ds <- go rest+    return $ d : ds+  go (TypeInstanceDeclaration dictName deps className tys _ : rest) = do+    go (ExternInstanceDeclaration dictName deps className tys : rest)+  go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do+    mapM_ (checkTypeClassInstance moduleName) tys+    forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd+    addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]+    ds <- go rest+    return $ d : ds+    where+    isInstanceExported :: Bool+    isInstanceExported = maybe True (any exportsInstance) exps +    +    exportsInstance :: DeclarationRef -> Bool+    exportsInstance (TypeInstanceRef name) | name == dictName = True+    exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r+    exportsInstance _ = False+    +  go (PositionedDeclaration pos d : rest) =+    rethrowWithPosition pos $ do+      (d' : rest') <- go (d : rest)+      return (PositionedDeclaration pos d' : rest')+++ 

@@ -28,6 +28,7 @@ import Language.PureScript.Errors  import Data.Maybe+import Data.Either (lefts, rights)  import Control.Applicative import Control.Monad.State@@ -190,13 +191,13 @@ -- | -- Run a computation in the Check monad, starting with an empty @Environment@ ---runCheck :: Options -> Check a -> Either String (a, Environment)+runCheck :: Options mode -> Check a -> Either String (a, Environment) runCheck opts = runCheck' opts initEnvironment  -- | -- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@. ---runCheck' :: Options -> Environment -> Check a -> Either String (a, Environment)+runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment) runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do   (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c   return (a, checkEnv s)@@ -232,4 +233,19 @@   (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify   modify $ \st' -> st' { checkNextVar = unifyNextVar ust }   return (a, unifyCurrentSubstitution ust)++-- |+-- Typecheck in parallel+--+parU :: [a] -> (a -> UnifyT t Check b) -> UnifyT t Check [b]+parU xs f = forM xs (withError . f) >>= collectErrors+  where+  withError :: UnifyT t Check a -> UnifyT t Check (Either ErrorStack a)+  withError u = catchError (Right <$> u) (return . Left)++  collectErrors :: [Either ErrorStack a] -> UnifyT t Check [a]+  collectErrors es = case lefts es of+    [err] -> throwError err+    [] -> return $ rights es+    errs -> throwError $ MultipleErrors errs 

@@ -42,10 +42,11 @@ -}  import Data.List-import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)+import Data.Maybe (maybeToList, fromMaybe) import Data.Function (on) import Data.Ord (comparing) import Data.Monoid+import Data.Either (lefts, rights)  import Language.PureScript.Declarations import Language.PureScript.Types@@ -171,14 +172,16 @@ typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))] typesOf mainModuleName moduleName vals = do   tys <- fmap tidyUp . liftUnify $ do-    (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals-    forM es $ \e -> do-      triple@(_, (_, ty)) <- typeForBindingGroupElement moduleName e dict untypedDict-      -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a-      when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do-        [eff, a] <- replicateM 2 fresh-        ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a+    (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals+    ds1 <- parU typed $ \e -> do+      triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict+      checkMain (fst e) ty       return triple+    ds2 <- forM untyped $ \e -> do+      triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict+      checkMain (fst e) ty+      return triple+    return $ ds1 ++ ds2    forM tys $ \(ident, (val, ty)) -> do     -- Replace type class dictionary placeholders with actual dictionaries@@ -193,17 +196,25 @@   where   -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values   tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts+  -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a+  checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do+    [eff, a] <- replicateM 2 fresh+    ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a -typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, (Expr, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])+type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)++type UntypedData = [(Ident, Type)]++typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData) typeDictionaryForBindingGroup moduleName vals = do   let     -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed     es = map isTyped vals     -- Filter the typed and untyped declarations-    typed = filter (isJust . snd . snd) es-    untyped = filter (isNothing . snd . snd) es+    untyped = lefts es+    typed = rights es     -- Make a map of names to typed declarations-    typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed+    typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed    -- Create fresh unification variables for the types of untyped declarations   untypedNames <- replicateM (length untyped) fresh@@ -213,37 +224,33 @@     untypedDict = zip (map fst untyped) untypedNames     -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking     dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)-  return (es, dict, untypedDict)+  return (untyped, typed, dict, untypedDict) -typeForBindingGroupElement :: ModuleName -> (Ident, (Expr, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Expr, Type))-typeForBindingGroupElement moduleName el dict untypedDict =-  -- If the declaration is a function, it has access to other values in the binding group.-  -- If not, the generated code might fail at runtime since those values might be undefined.-  case el of-    -- Typed declarations-    (ident, (val', Just (ty, checkType))) -> do-      -- Kind check-      kind <- liftCheck $ kindOf moduleName ty-      guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star-      -- Check the type with the new names in scope-      ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty-      val'' <- if checkType-               then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'-               else return (TypedValue False val' ty')-      return (ident, (val'', ty'))-    -- Untyped declarations-    (ident, (val', Nothing)) -> do-      -- Infer the type with the new names in scope-      TypedValue _ val'' ty <- bindNames dict $ infer val'-      ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)-      return (ident, (TypedValue True val'' ty, ty))+checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData ->  UnifyT Type Check (Ident, (Expr, Type))+checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do+  -- Kind check+  kind <- liftCheck $ kindOf moduleName ty+  guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star+  -- Check the type with the new names in scope+  ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty+  val'' <- if checkType+           then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'+           else return (TypedValue False val' ty')+  return (ident, (val'', ty')) +typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))+typeForBindingGroupElement (ident, val) dict untypedDict = do+  -- Infer the type with the new names in scope+  TypedValue _ val' ty <- bindNames dict $ infer val+  ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)+  return (ident, (TypedValue True val' ty, ty))+ -- | -- Check if a value contains a type annotation ---isTyped :: (Ident, Expr) -> (Ident, (Expr, Maybe (Type, Bool)))-isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))-isTyped (name, value) = (name, (value, Nothing))+isTyped :: (Ident, Expr) -> (Either (Ident, Expr) (Ident, (Expr, Type, Bool)))+isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))+isTyped (name, value) = Left (name, value)  -- | -- Map a function over type annotations appearing inside a value@@ -655,8 +662,8 @@   cond' <- check cond tyBoolean   v2@(TypedValue _ _ t2) <- infer th   v3@(TypedValue _ _ t3) <- infer el-  t2 =?= t3-  return $ TypedValue True (IfThenElse cond' v2 v3) t2+  (v2', v3', t) <- meet v2 v3 t2 t3+  return $ TypedValue True (IfThenElse cond' v2' v3') t infer' (Let ds val) = do   (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer   return $ TypedValue True (Let ds' val') valTy@@ -692,10 +699,10 @@   bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do   Just moduleName <- checkCurrentModule <$> get-  (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)-  ds' <- forM es $ \e -> do-    (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict-    return $ (ident, LocalVariable, val')+  (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)+  ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict+  ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict+  let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']   makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do   ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j@@ -778,6 +785,8 @@ checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative] checkBinders _ _ [] = return [] checkBinders nvals ret (CaseAlternative binders grd val : bs) = do+  guardWith (strMsg "Overlapping binders in case statement") $+    let ns = concatMap binderNames binders in length (nub ns) == length ns   Just moduleName <- checkCurrentModule <$> get   m1 <- M.unions <$> zipWithM inferBinder nvals binders   r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ do@@ -856,7 +865,7 @@     n <- liftCheck freshDictionaryName     return $ Ident $ "__dict_" ++ className ++ "_" ++ show n   val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->-    TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)+    TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)       constraints) $ check val ty   return $ TypedValue True (foldr (Abs . Left) val' dictNames) t check' val (SaturatedTypeSynonym name args) = do@@ -1118,6 +1127,23 @@ subsumes' val ty1 ty2 = do   ty1 =?= ty2   return val++-- |+-- Compute the meet of two types, i.e. the most general type which both types subsume.+-- TODO: handle constrained types+--+meet :: Expr -> Expr -> Type -> Type -> UnifyT Type Check (Expr, Expr, Type)+meet e1 e2 (ForAll ident t1 _) t2 = do+  t1' <- replaceVarWithUnknown ident t1+  meet e1 e2 t1' t2+meet e1 e2 t1 (ForAll ident t2 _) = do+  t2' <- replaceVarWithUnknown ident t2+  meet e1 e2 t1 t2'+meet e1 e2 t1 t2 = do+  t1 =?= t2+  return (e1, e2, t1)++   

@@ -46,6 +46,10 @@     -- The type of this dictionary     --     , tcdType :: TypeClassDictionaryType+    -- |+    -- Is this instance exported by its module?+    --+    , tcdExported :: Bool     } deriving (Show, Data, Typeable)  -- |

@@ -12,7 +12,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE DataKinds, DoAndIfThenElse #-}  module Main (main) where @@ -34,15 +34,15 @@   text <- U.readFile inputFile   return $ P.runIndentParser inputFile P.parseModules text -compile :: P.Options -> [FilePath] -> IO (Either String (String, String, P.Environment))+compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment)) compile opts inputFiles = do   modules <- readInput inputFiles   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 :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO () assert preludeExterns opts inputFile f = do   e <- compile opts [preludeExterns, inputFile]   maybeErr <- f e@@ -53,7 +53,10 @@ assertCompiles :: String -> FilePath -> FilePath -> IO () assertCompiles preludeJs preludeExterns inputFile = do   putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"-  let options = P.defaultOptions { P.optionsMain = Just "Main", P.optionsModules = ["Main"], P.optionsCodeGenModules = ["Main"], P.optionsBrowserNamespace = Just "Tests" }+  let options = P.defaultCompileOptions+                              { P.optionsMain = Just "Main"+                              , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]+                              }   assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do     process <- findNodeProcess     result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process@@ -65,7 +68,7 @@ assertDoesNotCompile :: FilePath -> FilePath -> IO () assertDoesNotCompile preludeExterns inputFile = do   putStrLn $ "Assert " ++ inputFile ++ " does not compile"-  assert preludeExterns (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) inputFile $ \e ->+  assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e ->     case e of       Left _ -> return Nothing       Right _ -> return $ Just "Should not have compiled"@@ -78,7 +81,7 @@ main = do   prelude <- P.preludeFilename   putStrLn "Compiling Prelude"-  preludeResult <- compile (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) [prelude]+  preludeResult <- compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) [prelude]   case preludeResult of     Left err -> putStrLn err >> exitFailure     Right (preludeJs, exts, _) -> do@@ -97,3 +100,4 @@       forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $         assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)       exitSuccess+