caa1dc6 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #601 from purescript/flight_work

caa1dc6Phil Freeman12 years ago

docgen/Main.hs+2−1

compare with golang

unifiedsplit

@@ -144,7 +144,8 @@ renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do

144 let exported = filter (isDctorExported name exps . fst) ctors

145 atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")

146 forM_ exported $ \(ctor, tys) ->

147+ let ctorTy = foldr P.function (P.TypeConstructor (P.Qualified Nothing name)) tys

147− atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> prettyPrintType' ty ++ " -> ") tys ++ typeName

148+ in atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ prettyPrintType' ctorTy

148renderDeclaration n _ (P.ExternDataDeclaration name kind) =

149renderDeclaration n _ (P.ExternDataDeclaration name kind) =

149 atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind

150 atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind

150renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do

151renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do

examples/failing/MultipleErrors.pursnew file+9

@@ -0,0 +1,9 @@

1+module MultipleErrors where

3+foo :: Number -> Number

4+foo 0 = "Test"

5+foo n = bar (n - 1)

7+bar :: Number -> Number

8+bar 0 = "Test"

9+bar n = foo (n - 1)

examples/passing/IfThenElseMaybe.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+data Maybe a = Nothing | Just a

5+test1 = if true then Just 10 else Nothing

7+test2 = if true then Nothing else Just 10

9+main = Debug.Trace.trace "Done"

psc-make/Main.hs+6−5

@@ -12,7 +12,7 @@

12--

13-----------------------------------------------------------------------------

15−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

15+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}

17module Main where

@@ -66,7 +66,7 @@ instance P.MonadMake Make where

66 liftError = either throwError return

67 progress = makeIO . U.putStrLn

69−compile :: FilePath -> [FilePath] -> FilePath -> P.Options -> Bool -> IO ()

69+compile :: FilePath -> [FilePath] -> FilePath -> P.Options P.Make -> Bool -> IO ()

70compile prelude input outputDir opts usePrefix = do

71 modules <- readInput allInputFiles

72 case modules of

@@ -81,7 +81,7 @@ compile prelude input outputDir opts usePrefix = do

81 exitFailure

82 Right _ -> do

83 exitSuccess

84− where

84+ where

85 prefix = if usePrefix

86 then ["Generated by psc-make version " ++ showVersion Paths.version]

87 else []

@@ -124,8 +124,8 @@ verboseErrors :: Term Bool

124verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])

125 { optDoc = "Display verbose error messages" }

126

127−options :: Term P.Options

127+options :: Term (P.Options P.Make)

128−options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> pure Nothing <*> pure [] <*> pure [] <*> verboseErrors

128+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> verboseErrors <*> pure P.MakeOptions

129

130noPrefix :: Term Bool

131noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ])

@@ -145,3 +145,4 @@ main :: IO ()

145main = do

146 prelude <- P.preludeFilename

147 run (term prelude, termInfo)

148+

psc/Main.hs+8−5

@@ -12,7 +12,7 @@

12--

13-----------------------------------------------------------------------------

15−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

15+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}

17module Main where

@@ -44,7 +44,7 @@ readInput (Just input) = fmap collect $ forM input $ \inputFile -> do

44 collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]

45 collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)

47−compile :: FilePath -> P.Options -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()

47+compile :: FilePath -> P.Options P.Compile -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()

48compile prelude opts stdin input output externs usePrefix = do

49 modules <- readInput stdInOrInputFiles

50 case modules of

@@ -70,7 +70,7 @@ compile prelude opts stdin input output externs usePrefix = do

70 | P.optionsNoPrelude opts = Just input

71 | otherwise = Just $ prelude : input

72 prefix = if usePrefix

73− then ["Generated by psc version " ++ showVersion Paths.version]

73+ then ["Generated by psc version " ++ showVersion Paths.version]

74 else []

76mkdirp :: FilePath -> IO ()

@@ -136,8 +136,10 @@ noPrefix :: Term Bool

136noPrefix = value $ flag $ (optInfo ["no-prefix" ])

137 { optDoc = "Do not include comment header"}

138

139−options :: Term P.Options

139+options :: Term (P.Options P.Compile)

140−options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> (Just <$> browserNamespace) <*> dceModules <*> codeGenModules <*> verboseErrors

140+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> verboseErrors <*> additionalOptions

141+ where

142+ additionalOptions = P.CompileOptions <$> browserNamespace <*> dceModules <*> codeGenModules

141

143

142term :: FilePath -> Term (IO ())

144term :: FilePath -> Term (IO ())

143term prelude = compile prelude <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix)

145term prelude = compile prelude <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix)

@@ -154,3 +156,4 @@ main = do

154 prelude <- P.preludeFilename

156 prelude <- P.preludeFilename

155 run (term prelude, termInfo)

157 run (term prelude, termInfo)

156

158

159+

psci/Main.hs+4−3

@@ -13,7 +13,7 @@

13--

14-----------------------------------------------------------------------------

16−{-# LANGUAGE DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}

16+{-# LANGUAGE DataKinds, DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}

18module Main where

@@ -198,8 +198,8 @@ completion = completeWord Nothing " \t\n\r" findCompletions

198

199-- | Compilation options.

200--

201−options :: P.Options

201+options :: P.Options P.Make

202−options = P.Options False True False True Nothing True Nothing [] [] False

202+options = P.Options False False False False Nothing False False P.MakeOptions

203

204-- |

205-- PSCI monad

@@ -435,3 +435,4 @@ termInfo = Cmd.defTI

435

436main :: IO ()

437main = Cmd.run (term, termInfo)

438+

src/Language/PureScript.hs+14−12

@@ -13,6 +13,8 @@

13--

14-----------------------------------------------------------------------------

16+{-# LANGUAGE DataKinds #-}

17+

16module Language.PureScript (module P, compile, compile', MonadMake(..), make, preludeFilename) where

18module Language.PureScript (module P, compile, compile', MonadMake(..), make, preludeFilename) where

18import Language.PureScript.Types as P

20import Language.PureScript.Types as P

@@ -39,7 +41,7 @@ import qualified Paths_purescript as Paths

39import Data.List (find, sortBy, groupBy, intercalate)

41import Data.List (find, sortBy, groupBy, intercalate)

40import Data.Time.Clock

42import Data.Time.Clock

41import Data.Function (on)

43import Data.Function (on)

42−import Data.Maybe (fromJust, fromMaybe)

44+import Data.Maybe (fromMaybe)

43import Control.Monad.Error

45import Control.Monad.Error

44import Control.Monad.State.Lazy

46import Control.Monad.State.Lazy

45import Control.Arrow ((&&&))

47import Control.Arrow ((&&&))

@@ -67,21 +69,21 @@ import System.FilePath (pathSeparator)

67--

69--

68-- * Pretty-print the generated Javascript

70-- * Pretty-print the generated Javascript

69--

71--

70−compile :: Options -> [Module] -> [String] -> Either String (String, String, Environment)

72+compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)

71compile = compile' initEnvironment

73compile = compile' initEnvironment

73−compile' :: Environment -> Options -> [Module] -> [String] -> Either String (String, String, Environment)

75+compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)

74compile' env opts ms prefix = do

76compile' env opts ms prefix = do

75 (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else (map importPrelude ms)

77 (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else (map importPrelude ms)

76 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted

78 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted

77 (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent

79 (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent

78 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

80 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

79− let entryPoints = moduleNameFromString `map` optionsModules opts

81+ let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)

80 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped

82 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped

81 let renamed = renameInModules elim

83 let renamed = renameInModules elim

82− let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts

84+ let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)

83− let modulesToCodeGen = if null codeGenModules then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModules) renamed

85+ let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModuleNames) renamed

84− let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs Globals opts m env') modulesToCodeGen

86+ let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs opts m env') modulesToCodeGen

85 let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen

87 let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen

86 js' <- generateMain env' opts js

88 js' <- generateMain env' opts js

87 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']

89 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']

@@ -126,13 +128,13 @@ typeCheckModule mainModuleName (Module mn decls exps) = do

126 go _ = True

128 go _ = True

127

129

128

130

129−generateMain :: Environment -> Options -> [JS] -> Either String [JS]

131+generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]

130generateMain env opts js =

132generateMain env opts js =

131 case moduleNameFromString <$> optionsMain opts of

133 case moduleNameFromString <$> optionsMain opts of

132 Just mmi -> do

134 Just mmi -> do

133 when ((mmi, Ident C.main) `M.notMember` names env) $

135 when ((mmi, Ident C.main) `M.notMember` names env) $

134 Left $ show mmi ++ "." ++ C.main ++ " is undefined"

136 Left $ show mmi ++ "." ++ C.main ++ " is undefined"

135− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (fromJust (optionsBrowserNamespace opts))))) []]

137+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []]

136 _ -> return js

138 _ -> return js

137

139

138-- |

140-- |

@@ -170,7 +172,7 @@ class MonadMake m where

170-- If timestamps have not changed, the externs file can be used to provide the module's types without

172-- If timestamps have not changed, the externs file can be used to provide the module's types without

171-- having to typecheck the module again.

173-- having to typecheck the module again.

172--

174--

173−make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> [String] -> m Environment

175+make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(FilePath, Module)] -> [String] -> m Environment

174make outputDir opts ms prefix = do

176make outputDir opts ms prefix = do

175 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)

177 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)

176

178

@@ -216,9 +218,9 @@ make outputDir opts ms prefix = do

216 regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

218 regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

217

219

218 let mod' = Module moduleName' regrouped exps

220 let mod' = Module moduleName' regrouped exps

219− let [renamed] = renameInModules [mod']

221+ let [renamed] = renameInModules [mod']

220

222

221− pjs <- prettyPrintJS <$> moduleToJs CommonJS opts renamed env'

223+ pjs <- prettyPrintJS <$> moduleToJs opts renamed env'

222 let js = unlines $ map ("// " ++) prefix ++ [pjs]

224 let js = unlines $ map ("// " ++) prefix ++ [pjs]

223 let exts = unlines $ map ("-- " ++ ) prefix ++ [moduleToPs renamed env']

225 let exts = unlines $ map ("-- " ++ ) prefix ++ [moduleToPs renamed env']

224

226

src/Language/PureScript/CodeGen/JS.hs+23−27

@@ -13,17 +13,16 @@

13--

14-----------------------------------------------------------------------------

16−{-# LANGUAGE DoAndIfThenElse #-}

16+{-# LANGUAGE GADTs, DoAndIfThenElse #-}

18module Language.PureScript.CodeGen.JS (

19 module AST,

20− ModuleType(..),

21 declToJs,

20 declToJs,

22 moduleToJs,

21 moduleToJs,

23 identNeedsEscaping

22 identNeedsEscaping

24) where

23) where

26−import Data.Maybe (catMaybes, fromJust)

25+import Data.Maybe (catMaybes)

27import Data.Function (on)

26import Data.Function (on)

28import Data.List (nub, (\\), delete, sortBy)

27import Data.List (nub, (\\), delete, sortBy)

@@ -42,40 +41,36 @@ import Language.PureScript.Supply

42import Language.PureScript.Traversals (sndM)

41import Language.PureScript.Traversals (sndM)

43import qualified Language.PureScript.Constants as C

42import qualified Language.PureScript.Constants as C

45−-- |

46−-- Different types of modules which are supported

47−--

48−data ModuleType = CommonJS | Globals

49−

50-- |

44-- |

51-- Generate code in the simplified Javascript intermediate representation for all declarations in a

45-- Generate code in the simplified Javascript intermediate representation for all declarations in a

52-- module.

46-- module.

53--

47--

54−moduleToJs :: (Functor m, Applicative m, Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]

48+moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module -> Environment -> SupplyT m [JS]

55−moduleToJs mt opts (Module name decls (Just exps)) env = do

49+moduleToJs opts (Module name decls (Just exps)) env = do

56− let jsImports = map (importToJs mt opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls

50+ let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls

57 jsDecls <- mapM (\decl -> declToJs opts name decl env) decls

51 jsDecls <- mapM (\decl -> declToJs opts name decl env) decls

58 let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls

52 let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls

59 let isModuleEmpty = null exps

53 let isModuleEmpty = null exps

60 let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized

54 let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized

61 let moduleExports = JSObjectLiteral $ concatMap exportToJs exps

55 let moduleExports = JSObjectLiteral $ concatMap exportToJs exps

62− return $ case mt of

56+ return $ case optionsAdditional opts of

63− CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]

57+ MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]

64− Globals | not isModuleEmpty ->

58+ CompileOptions ns _ _ | not isModuleEmpty ->

65− [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))

59+ [ JSVariableIntroduction ns

66− (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )

60+ (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )

67− , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))

61+ , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))

68 (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])

62 (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])

69 ]

63 ]

70 _ -> []

64 _ -> []

71−moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"

65+moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"

73−importToJs :: ModuleType -> Options -> ModuleName -> JS

67+importToJs :: Options mode -> ModuleName -> JS

68+importToJs opts mn =

74−importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)

69+ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)

75 where

70 where

76− moduleBody = case mt of

71+ moduleBody = case optionsAdditional opts of

77− CommonJS -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]

72+ MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]

78− Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))

73+ CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)

80imports :: Declaration -> [ModuleName]

75imports :: Declaration -> [ModuleName]

81imports (ImportDeclaration mn _ _) = [mn]

76imports (ImportDeclaration mn _ _) = [mn]

@@ -95,7 +90,7 @@ imports other =

95-- |

90-- |

96-- Generate code in the simplified Javascript intermediate representation for a declaration

91-- Generate code in the simplified Javascript intermediate representation for a declaration

97--

92--

98−declToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])

93+declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])

99declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do

94declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do

100 js <- valueToJs opts mp e val

95 js <- valueToJs opts mp e val

101 return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]

96 return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]

@@ -190,7 +185,7 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

190-- |

185-- |

191-- Generate code in the simplified Javascript intermediate representation for a value or expression.

186-- Generate code in the simplified Javascript intermediate representation for a value or expression.

192--

187--

193−valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Expr -> SupplyT m JS

188+valueToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> Expr -> SupplyT m JS

194valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n

189valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n

195valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s

190valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s

196valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b

191valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b

@@ -315,7 +310,7 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

315-- Generate code in the simplified Javascript intermediate representation for pattern match binders

310-- Generate code in the simplified Javascript intermediate representation for pattern match binders

316-- and guards.

311-- and guards.

317--

312--

318−bindersToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS

313+bindersToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS

319bindersToJs opts m e binders vals = do

314bindersToJs opts m e binders vals = do

320 valNames <- replicateM (length vals) freshName

315 valNames <- replicateM (length vals) freshName

321 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

316 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

@@ -405,7 +400,7 @@ binderToJs m e varName done binder@(ConsBinder _ _) = do

405 ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :

400 ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :

406 js2

401 js2

407 )) Nothing]

402 )) Nothing]

408− where

403+ where

409 uncons :: [Binder] -> Binder -> ([Binder], Binder)

404 uncons :: [Binder] -> Binder -> ([Binder], Binder)

410 uncons acc (ConsBinder h t) = uncons (h : acc) t

405 uncons acc (ConsBinder h t) = uncons (h : acc) t

411 uncons acc (PositionedBinder _ b) = uncons acc b

406 uncons acc (PositionedBinder _ b) = uncons acc b

@@ -416,3 +411,4 @@ binderToJs m e varName done (NamedBinder ident binder) = do

416binderToJs m e varName done (PositionedBinder _ binder) =

411binderToJs m e varName done (PositionedBinder _ binder) =

417 binderToJs m e varName done binder

412 binderToJs m e varName done binder

418

413

414+

src/Language/PureScript/Errors.hs+28−16

@@ -16,7 +16,7 @@

17module Language.PureScript.Errors where

19−import Data.List (intercalate)

19+import Data.List (intersperse, intercalate)

20import Data.Monoid

22import Control.Monad.Error

@@ -41,25 +41,35 @@ data ErrorSource

41-- |

42-- Compilation errors

43--

44−data CompileError = CompileError {

44+data CompileError

45+ = CompileError

45− -- |

46+ { -- |

46− -- Error message

47+ -- Error message

47− --

48+ --

48− compileErrorMessage :: String

49+ compileErrorMessage :: String

49− -- |

50+ -- |

50− -- The value where the error occurred

51+ -- The value where the error occurred

51− --

52+ --

52− , compileErrorValue :: Maybe ErrorSource

53+ , compileErrorValue :: Maybe ErrorSource

53− -- |

54+ -- |

54− -- Optional source position information

55+ -- Optional source position information

55− --

56+ --

56− , compileErrorPosition :: Maybe SourcePos

57+ , compileErrorPosition :: Maybe SourcePos

58+ }

57− } deriving (Show)

59+ deriving (Show)

59-- |

61-- |

60-- A stack trace for an error

62-- A stack trace for an error

61--

63--

64+data ErrorStack

62−newtype ErrorStack = ErrorStack { runErrorStack :: [CompileError] } deriving (Show, Monoid)

65+ = ErrorStack { runErrorStack :: [CompileError] }

66+ | MultipleErrors [ErrorStack] deriving (Show)

67+

68+instance Monoid ErrorStack where

69+ mempty = ErrorStack []

70+ mappend (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)

71+ mappend (MultipleErrors es) x = MultipleErrors [ e <> x | e <- es ]

72+ mappend x (MultipleErrors es) = MultipleErrors [ x <> e | e <- es ]

64instance Error ErrorStack where

74instance Error ErrorStack where

65 strMsg s = ErrorStack [CompileError s Nothing Nothing]

75 strMsg s = ErrorStack [CompileError s Nothing Nothing]

@@ -80,6 +90,8 @@ prettyPrintErrorStack printFullStack (ErrorStack es) =

80 in case length es' of

90 in case length es' of

81 1 -> showError (head es')

91 1 -> showError (head es')

82 _ -> showError (head es') ++ "\n" ++ showError (last es')

92 _ -> showError (head es') ++ "\n" ++ showError (last es')

93+prettyPrintErrorStack printFullStack (MultipleErrors es) =

94+ unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es

84stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a

96stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a

85stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right

97stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right

src/Language/PureScript/Optimizer.hs+1−1

@@ -49,7 +49,7 @@ import Language.PureScript.Optimizer.Blocks

49-- |

50-- Apply a series of optimizer passes to simplified Javascript code

51--

52−optimize :: Options -> JS -> JS

52+optimize :: Options mode -> JS -> JS

53optimize opts | optionsNoOptimizations opts = id

54 | otherwise = untilFixedPoint (applyAll

55 [ collapseNestedBlocks

src/Language/PureScript/Optimizer/MagicDo.hs+1−1

@@ -28,7 +28,7 @@ import Language.PureScript.Names

29import qualified Language.PureScript.Constants as C

31−magicDo :: Options -> JS -> JS

31+magicDo :: Options mode -> JS -> JS

32magicDo opts | optionsNoMagicDo opts = id

33 | otherwise = inlineST . magicDo'

src/Language/PureScript/Optimizer/TCO.hs+1−1

@@ -21,7 +21,7 @@ import Language.PureScript.CodeGen.JS.AST

21-- |

22-- Eliminate tail calls

23--

24−tco :: Options -> JS -> JS

24+tco :: Options mode -> JS -> JS

25tco opts | optionsNoTco opts = id

26 | otherwise = tco'

src/Language/PureScript/Options.hs+39−17

@@ -13,12 +13,37 @@

13--

14-----------------------------------------------------------------------------

16+{-# LANGUAGE GADTs, DataKinds, StandaloneDeriving #-}

17+

16module Language.PureScript.Options where

18module Language.PureScript.Options where

20+-- |

21+-- Indicates the mode of the compiler. Lifted using DataKinds to refine the Options type.

22+--

23+data Mode = Compile | Make

24+

25+-- |

26+-- Per-mode options

27+--

28+data ModeOptions mode where

29+ CompileOptions :: String -> [String] -> [String] -> ModeOptions Compile

30+ MakeOptions :: ModeOptions Make

31+

32+browserNamespace :: ModeOptions Compile -> String

33+browserNamespace (CompileOptions ns _ _) = ns

34+

35+entryPointModules :: ModeOptions Compile -> [String]

36+entryPointModules (CompileOptions _ ms _) = ms

37+

38+codeGenModules :: ModeOptions Compile -> [String]

39+codeGenModules (CompileOptions _ _ ms) = ms

40+

41+deriving instance Show (ModeOptions mode)

42+

18-- |

43-- |

19-- The data type of compiler options

44-- The data type of compiler options

20--

45--

21−data Options = Options {

46+data Options mode = Options {

22 -- |

47 -- |

23 -- Disable inclusion of the built in Prelude

48 -- Disable inclusion of the built in Prelude

24 --

49 --

@@ -44,28 +69,25 @@ data Options = Options {

44 -- Skip all optimizations

69 -- Skip all optimizations

45 --

70 --

46 , optionsNoOptimizations :: Bool

71 , optionsNoOptimizations :: Bool

47− -- |

48− -- Specify the namespace that PureScript modules will be exported to when running in the

49− -- browser.

50− --

51− , optionsBrowserNamespace :: Maybe String

52− -- |

53− -- The modules to keep while enabling dead code elimination

54− --

55− , optionsModules :: [String]

56− -- |

57− -- The modules to code gen

58− --

59− , optionsCodeGenModules :: [String]

60 -- |

72 -- |

61 -- Verbose error message

73 -- Verbose error message

62 --

74 --

63 , optionsVerboseErrors :: Bool

75 , optionsVerboseErrors :: Bool

64−

76+ -- |

77+ -- Specify the namespace that PureScript modules will be exported to when running in the

78+ -- browser.

79+ --

80+ , optionsAdditional :: ModeOptions mode

65 } deriving Show

81 } deriving Show

67-- |

83-- |

68-- Default compiler options

84-- Default compiler options

69--

85--

70−defaultOptions :: Options

86+defaultCompileOptions :: Options Compile

71−defaultOptions = Options False False False False Nothing False Nothing [] [] False

87+defaultCompileOptions = Options False False False False Nothing False False (CompileOptions "PS" [] [])

88+

89+-- |

90+-- Default make options

91+--

92+defaultMakeOptions :: Options Make

93+defaultMakeOptions = Options False False False False Nothing False False MakeOptions

src/Language/PureScript/TypeChecker/Monad.hs+18−2

@@ -28,6 +28,7 @@ import Language.PureScript.Options

28import Language.PureScript.Errors

30import Data.Maybe

31+import Data.Either (lefts, rights)

32import Control.Applicative

33import Control.Applicative

33import Control.Monad.State

34import Control.Monad.State

@@ -190,13 +191,13 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

190-- |

191-- |

191-- Run a computation in the Check monad, starting with an empty @Environment@

192-- Run a computation in the Check monad, starting with an empty @Environment@

192--

193--

193−runCheck :: Options -> Check a -> Either String (a, Environment)

194+runCheck :: Options mode -> Check a -> Either String (a, Environment)

194runCheck opts = runCheck' opts initEnvironment

195runCheck opts = runCheck' opts initEnvironment

195

196

196-- |

197-- |

197-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

198-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

198--

199--

199−runCheck' :: Options -> Environment -> Check a -> Either String (a, Environment)

200+runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment)

200runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do

201runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do

201 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

202 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

202 return (a, checkEnv s)

203 return (a, checkEnv s)

@@ -233,3 +234,18 @@ liftUnify unify = do

233 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

234 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

234 return (a, unifyCurrentSubstitution ust)

235 return (a, unifyCurrentSubstitution ust)

235

236

237+-- |

238+-- Typecheck in parallel

239+--

240+parU :: [a] -> (a -> UnifyT t Check b) -> UnifyT t Check [b]

241+parU xs f = forM xs (withError . f) >>= collectErrors

242+ where

243+ withError :: UnifyT t Check a -> UnifyT t Check (Either ErrorStack a)

244+ withError u = catchError (Right <$> u) (return . Left)

245+

246+ collectErrors :: [Either ErrorStack a] -> UnifyT t Check [a]

247+ collectErrors es = case lefts es of

248+ [err] -> throwError err

249+ [] -> return $ rights es

250+ errs -> throwError $ MultipleErrors errs

251+

src/Language/PureScript/TypeChecker/Types.hs+68−45

@@ -42,10 +42,11 @@ module Language.PureScript.TypeChecker.Types (

42-}

44import Data.List

45−import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)

45+import Data.Maybe (maybeToList, fromMaybe)

46import Data.Function (on)

47import Data.Ord (comparing)

48import Data.Monoid

49+import Data.Either (lefts, rights)

50import Language.PureScript.Declarations

51import Language.PureScript.Declarations

51import Language.PureScript.Types

52import Language.PureScript.Types

@@ -171,14 +172,16 @@ unifyRows r1 r2 =

171typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]

172typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]

172typesOf mainModuleName moduleName vals = do

173typesOf mainModuleName moduleName vals = do

173 tys <- fmap tidyUp . liftUnify $ do

174 tys <- fmap tidyUp . liftUnify $ do

174− (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

175+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

175− forM es $ \e -> do

176+ ds1 <- parU typed $ \e -> do

176− triple@(_, (_, ty)) <- typeForBindingGroupElement moduleName e dict untypedDict

177+ triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict

177− -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

178+ checkMain (fst e) ty

178− when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do

179− [eff, a] <- replicateM 2 fresh

180− ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a

181 return triple

179 return triple

180+ ds2 <- forM untyped $ \e -> do

181+ triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict

182+ checkMain (fst e) ty

183+ return triple

184+ return $ ds1 ++ ds2

182

185

183 forM tys $ \(ident, (val, ty)) -> do

186 forM tys $ \(ident, (val, ty)) -> do

184 -- Replace type class dictionary placeholders with actual dictionaries

187 -- Replace type class dictionary placeholders with actual dictionaries

@@ -193,17 +196,25 @@ typesOf mainModuleName moduleName vals = do

193 where

196 where

194 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

197 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

195 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

198 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

199+ -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

200+ checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do

201+ [eff, a] <- replicateM 2 fresh

202+ ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a

203+

204+type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

205+

206+type UntypedData = [(Ident, Type)]

196

207

197−typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, (Expr, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])

208+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)

198typeDictionaryForBindingGroup moduleName vals = do

209typeDictionaryForBindingGroup moduleName vals = do

199 let

210 let

200 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

211 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

201 es = map isTyped vals

212 es = map isTyped vals

202 -- Filter the typed and untyped declarations

213 -- Filter the typed and untyped declarations

203− typed = filter (isJust . snd . snd) es

214+ untyped = lefts es

204− untyped = filter (isNothing . snd . snd) es

215+ typed = rights es

205 -- Make a map of names to typed declarations

216 -- Make a map of names to typed declarations

206− typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed

217+ typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed

207

218

208 -- Create fresh unification variables for the types of untyped declarations

219 -- Create fresh unification variables for the types of untyped declarations

209 untypedNames <- replicateM (length untyped) fresh

220 untypedNames <- replicateM (length untyped) fresh

@@ -213,37 +224,33 @@ typeDictionaryForBindingGroup moduleName vals = do

213 untypedDict = zip (map fst untyped) untypedNames

224 untypedDict = zip (map fst untyped) untypedNames

214 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking

225 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking

215 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)

226 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)

216− return (es, dict, untypedDict)

227+ return (untyped, typed, dict, untypedDict)

217−

228+

218−typeForBindingGroupElement :: ModuleName -> (Ident, (Expr, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Expr, Type))

229+checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type))

219−typeForBindingGroupElement moduleName el dict untypedDict =

220− -- If the declaration is a function, it has access to other values in the binding group.

221− -- If not, the generated code might fail at runtime since those values might be undefined.

222− case el of

223− -- Typed declarations

224− (ident, (val', Just (ty, checkType))) -> do

230+checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do

225− -- Kind check

231+ -- Kind check

226− kind <- liftCheck $ kindOf moduleName ty

232+ kind <- liftCheck $ kindOf moduleName ty

227− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

233+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

228− -- Check the type with the new names in scope

234+ -- Check the type with the new names in scope

229− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

235+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

230− val'' <- if checkType

236+ val'' <- if checkType

231− then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'

237+ then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'

232− else return (TypedValue False val' ty')

238+ else return (TypedValue False val' ty')

233− return (ident, (val'', ty'))

239+ return (ident, (val'', ty'))

234− -- Untyped declarations

240+

235− (ident, (val', Nothing)) -> do

241+typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))

242+typeForBindingGroupElement (ident, val) dict untypedDict = do

236− -- Infer the type with the new names in scope

243+ -- Infer the type with the new names in scope

237− TypedValue _ val'' ty <- bindNames dict $ infer val'

244+ TypedValue _ val' ty <- bindNames dict $ infer val

238− ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

245+ ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

239− return (ident, (TypedValue True val'' ty, ty))

246+ return (ident, (TypedValue True val' ty, ty))

240

247

241-- |

248-- |

242-- Check if a value contains a type annotation

249-- Check if a value contains a type annotation

243--

250--

244−isTyped :: (Ident, Expr) -> (Ident, (Expr, Maybe (Type, Bool)))

251+isTyped :: (Ident, Expr) -> (Either (Ident, Expr) (Ident, (Expr, Type, Bool)))

245−isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))

252+isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))

246−isTyped (name, value) = (name, (value, Nothing))

253+isTyped (name, value) = Left (name, value)

247

254

248-- |

255-- |

249-- Map a function over type annotations appearing inside a value

256-- Map a function over type annotations appearing inside a value

@@ -655,8 +662,8 @@ infer' (IfThenElse cond th el) = do

655 cond' <- check cond tyBoolean

662 cond' <- check cond tyBoolean

656 v2@(TypedValue _ _ t2) <- infer th

663 v2@(TypedValue _ _ t2) <- infer th

657 v3@(TypedValue _ _ t3) <- infer el

664 v3@(TypedValue _ _ t3) <- infer el

658− t2 =?= t3

665+ (v2', v3', t) <- meet v2 v3 t2 t3

659− return $ TypedValue True (IfThenElse cond' v2 v3) t2

666+ return $ TypedValue True (IfThenElse cond' v2' v3') t

660infer' (Let ds val) = do

667infer' (Let ds val) = do

661 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer

668 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer

662 return $ TypedValue True (Let ds' val') valTy

669 return $ TypedValue True (Let ds' val') valTy

@@ -692,10 +699,10 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret

692 bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j

699 bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j

693inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

700inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

694 Just moduleName <- checkCurrentModule <$> get

701 Just moduleName <- checkCurrentModule <$> get

695− (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

702+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)

696− ds' <- forM es $ \e -> do

703+ ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

697− (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict

704+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

698− return $ (ident, LocalVariable, val')

705+ let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']

699 makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j

706 makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j

700inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do

707inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do

701 ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j

708 ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j

@@ -1119,6 +1126,22 @@ subsumes' val ty1 ty2 = do

1119 ty1 =?= ty2

1126 ty1 =?= ty2

1120 return val

1127 return val

1121

1128

1129+-- |

1130+-- Compute the meet of two types, i.e. the most general type which both types subsume.

1131+-- TODO: handle constrained types

1132+--

1133+meet :: Expr -> Expr -> Type -> Type -> UnifyT Type Check (Expr, Expr, Type)

1134+meet e1 e2 (ForAll ident t1 _) t2 = do

1135+ t1' <- replaceVarWithUnknown ident t1

1136+ meet e1 e2 t1' t2

1137+meet e1 e2 t1 (ForAll ident t2 _) = do

1138+ t2' <- replaceVarWithUnknown ident t2

1139+ meet e1 e2 t1 t2'

1140+meet e1 e2 t1 t2 = do

1141+ t1 =?= t2

1142+ return (e1, e2, t1)

1143+

1144+

1122

1145

1123

1146

1124

1147

tests/Main.hs+11−7

@@ -12,7 +12,7 @@

12--

13-----------------------------------------------------------------------------

15−{-# LANGUAGE DoAndIfThenElse #-}

15+{-# LANGUAGE DataKinds, DoAndIfThenElse #-}

17module Main (main) where

@@ -34,15 +34,15 @@ readInput inputFiles = fmap (fmap concat . sequence) $ forM inputFiles $ \inputF

34 text <- U.readFile inputFile

35 return $ P.runIndentParser inputFile P.parseModules text

37−compile :: P.Options -> [FilePath] -> IO (Either String (String, String, P.Environment))

37+compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))

38compile opts inputFiles = do

39 modules <- readInput inputFiles

40 case modules of

41 Left parseError ->

42 return (Left $ show parseError)

43− Right ms -> return $ P.compile opts ms []

43+ Right ms -> return $ P.compile opts ms []

45−assert :: FilePath -> P.Options -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()

45+assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()

46assert preludeExterns opts inputFile f = do

47 e <- compile opts [preludeExterns, inputFile]

48 maybeErr <- f e

@@ -53,7 +53,10 @@ assert preludeExterns opts inputFile f = do

53assertCompiles :: String -> FilePath -> FilePath -> IO ()

54assertCompiles preludeJs preludeExterns inputFile = do

55 putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"

56− let options = P.defaultOptions { P.optionsMain = Just "Main", P.optionsModules = ["Main"], P.optionsCodeGenModules = ["Main"], P.optionsBrowserNamespace = Just "Tests" }

56+ let options = P.defaultCompileOptions

57+ { P.optionsMain = Just "Main"

58+ , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]

59+ }

57 assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do

60 assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do

58 process <- findNodeProcess

61 process <- findNodeProcess

59 result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process

62 result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process

@@ -65,7 +68,7 @@ assertCompiles preludeJs preludeExterns inputFile = do

65assertDoesNotCompile :: FilePath -> FilePath -> IO ()

68assertDoesNotCompile :: FilePath -> FilePath -> IO ()

66assertDoesNotCompile preludeExterns inputFile = do

69assertDoesNotCompile preludeExterns inputFile = do

67 putStrLn $ "Assert " ++ inputFile ++ " does not compile"

70 putStrLn $ "Assert " ++ inputFile ++ " does not compile"

68− assert preludeExterns (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) inputFile $ \e ->

71+ assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e ->

69 case e of

72 case e of

70 Left _ -> return Nothing

73 Left _ -> return Nothing

71 Right _ -> return $ Just "Should not have compiled"

74 Right _ -> return $ Just "Should not have compiled"

@@ -78,7 +81,7 @@ main :: IO ()

78main = do

81main = do

79 prelude <- P.preludeFilename

82 prelude <- P.preludeFilename

80 putStrLn "Compiling Prelude"

83 putStrLn "Compiling Prelude"

81− preludeResult <- compile (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) [prelude]

84+ preludeResult <- compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) [prelude]

82 case preludeResult of

85 case preludeResult of

83 Left err -> putStrLn err >> exitFailure

86 Left err -> putStrLn err >> exitFailure

84 Right (preludeJs, exts, _) -> do

87 Right (preludeJs, exts, _) -> do

@@ -97,3 +100,4 @@ main = do

97 forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $

100 forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $

98 assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)

101 assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)

99 exitSuccess

102 exitSuccess

103+