caa1dc6 · rowtype-yoga/purescript-native

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

Merge pull request #601 from purescript/flight_work

Fix various bugs, add support for multiple errors

commitcaa1dc61271fd48dc83c52c1027a13638326353a authorPhil Freeman <paf31@cantab.net> dateFri 19 Sep 2014, 09:45 (12 years ago) parent531e1e3 d1cdc98

16 files changed+242−143

compare with golang

unifiedsplit

docgen/Main.hs+2−1

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

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

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

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

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

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

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

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

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

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

1212--

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

1616

1717module Main where

1818

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

6666 liftError = either throwError return

6767 progress = makeIO . U.putStrLn

6868

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

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

7070compile prelude input outputDir opts usePrefix = do

7171 modules <- readInput allInputFiles

7272 case modules of

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

8181 exitFailure

8282 Right _ -> do

8383 exitSuccess

84− where

84+ where

8585 prefix = if usePrefix

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

8787 else []

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

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

125125 { optDoc = "Display verbose error messages" }

126126

127−options :: Term P.Options

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

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

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

129129

130130noPrefix :: Term Bool

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

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

145145main = do

146146 prelude <- P.preludeFilename

147147 run (term prelude, termInfo)

148+

psc/Main.hs+8−5

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

1212--

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

1616

1717module Main where

1818

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

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

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

4646

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

4848compile prelude opts stdin input output externs usePrefix = do

4949 modules <- readInput stdInOrInputFiles

5050 case modules of

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

7070 | P.optionsNoPrelude opts = Just input

7171 | otherwise = Just $ prelude : input

7272 prefix = if usePrefix

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

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

7474 else []

7575

7676mkdirp :: FilePath -> IO ()

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

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

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

138138

139−options :: Term P.Options

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

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

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

141+ where

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

141143

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

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

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

154156 prelude <- P.preludeFilename

155157 run (term prelude, termInfo)

156158

159+

psci/Main.hs+4−3

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

1313--

1414-----------------------------------------------------------------------------

1515

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

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

1717

1818module Main where

1919

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

198198

199199-- | Compilation options.

200200--

201−options :: P.Options

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

201+options :: P.Options P.Make

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

203203

204204-- |

205205-- PSCI monad

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

435435

436436main :: IO ()

437437main = Cmd.run (term, termInfo)

438+

src/Language/PureScript.hs+14−12

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

1313--

1414-----------------------------------------------------------------------------

1515

16+{-# LANGUAGE DataKinds #-}

17+

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

1719

1820import Language.PureScript.Types as P

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

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

4042import Data.Time.Clock

4143import Data.Function (on)

42−import Data.Maybe (fromJust, fromMaybe)

44+import Data.Maybe (fromMaybe)

4345import Control.Monad.Error

4446import Control.Monad.State.Lazy

4547import Control.Arrow ((&&&))

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

6769--

6870-- * Pretty-print the generated Javascript

6971--

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

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

7173compile = compile' initEnvironment

7274

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

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

7476compile' env opts ms prefix = do

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

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

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

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

79− let entryPoints = moduleNameFromString `map` optionsModules opts

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

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

8183 let renamed = renameInModules elim

82− let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts

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

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

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

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

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

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

8688 js' <- generateMain env' opts js

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

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

126128 go _ = True

127129

128130

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

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

130132generateMain env opts js =

131133 case moduleNameFromString <$> optionsMain opts of

132134 Just mmi -> do

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

134136 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))))) []]

136138 _ -> return js

137139

138140-- |

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

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

171173-- having to typecheck the module again.

172174--

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

174176make outputDir opts ms prefix = do

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

176178

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

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

217219

218220 let mod' = Module moduleName' regrouped exps

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

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

220222

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

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

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

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

224226

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

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

1313--

1414-----------------------------------------------------------------------------

1515

16−{-# LANGUAGE DoAndIfThenElse #-}

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

1717

1818module Language.PureScript.CodeGen.JS (

1919 module AST,

20− ModuleType(..),

2120 declToJs,

2221 moduleToJs,

2322 identNeedsEscaping

2423) where

2524

26−import Data.Maybe (catMaybes, fromJust)

25+import Data.Maybe (catMaybes)

2726import Data.Function (on)

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

2928

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

4241import Language.PureScript.Traversals (sndM)

4342import qualified Language.PureScript.Constants as C

4443

45−-- |

46−-- Different types of modules which are supported

47−--

48−data ModuleType = CommonJS | Globals

49−

5044-- |

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

5246-- module.

5347--

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

55−moduleToJs mt 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

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

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

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

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

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

5953 let isModuleEmpty = null exps

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

6155 let moduleExports = JSObjectLiteral $ concatMap exportToJs exps

62− return $ case mt of

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

64− Globals | not isModuleEmpty ->

65− [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))

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

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

56+ return $ case optionsAdditional opts of

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

58+ CompileOptions ns _ _ | not isModuleEmpty ->

59+ [ JSVariableIntroduction ns

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

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

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

6963 ]

7064 _ -> []

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

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

7266

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

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

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

68+importToJs opts mn =

69+ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)

7570 where

76− moduleBody = case mt of

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

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

71+ moduleBody = case optionsAdditional opts of

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

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

7974

8075imports :: Declaration -> [ModuleName]

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

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

9590-- |

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

9792--

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

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

10095 js <- valueToJs opts mp e val

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

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

190185-- |

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

192187--

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

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

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

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

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

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

316311-- and guards.

317312--

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

319314bindersToJs opts m e binders vals = do

320315 valNames <- replicateM (length vals) freshName

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

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

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

406401 js2

407402 )) Nothing]

408− where

403+ where

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

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

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

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

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

417412 binderToJs m e varName done binder

418413

414+

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

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

1616

1717module Language.PureScript.Errors where

1818

19−import Data.List (intercalate)

19+import Data.List (intersperse, intercalate)

2020import Data.Monoid

2121

2222import Control.Monad.Error

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

4141-- |

4242-- Compilation errors

4343--

44−data CompileError = CompileError {

45− -- |

46− -- Error message

47− --

48− compileErrorMessage :: String

49− -- |

50− -- The value where the error occurred

51− --

52− , compileErrorValue :: Maybe ErrorSource

53− -- |

54− -- Optional source position information

55− --

56− , compileErrorPosition :: Maybe SourcePos

57− } deriving (Show)

44+data CompileError

45+ = CompileError

46+ { -- |

47+ -- Error message

48+ --

49+ compileErrorMessage :: String

50+ -- |

51+ -- The value where the error occurred

52+ --

53+ , compileErrorValue :: Maybe ErrorSource

54+ -- |

55+ -- Optional source position information

56+ --

57+ , compileErrorPosition :: Maybe SourcePos

58+ }

59+ deriving (Show)

5860

5961-- |

6062-- A stack trace for an error

6163--

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

64+data ErrorStack

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 ]

6373

6474instance Error ErrorStack where

6575 strMsg s = ErrorStack [CompileError s Nothing Nothing]

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

8090 in case length es' of

8191 1 -> showError (head es')

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

93+prettyPrintErrorStack printFullStack (MultipleErrors es) =

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

8395

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

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

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

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

4949-- |

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

5151--

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

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

5353optimize opts | optionsNoOptimizations opts = id

5454 | otherwise = untilFixedPoint (applyAll

5555 [ collapseNestedBlocks

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

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

2828

2929import qualified Language.PureScript.Constants as C

3030

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

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

3232magicDo opts | optionsNoMagicDo opts = id

3333 | otherwise = inlineST . magicDo'

3434

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

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

2121-- |

2222-- Eliminate tail calls

2323--

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

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

2525tco opts | optionsNoTco opts = id

2626 | otherwise = tco'

2727

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

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

1313--

1414-----------------------------------------------------------------------------

1515

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

17+

1618module Language.PureScript.Options where

1719

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+

1843-- |

1944-- The data type of compiler options

2045--

21−data Options = Options {

46+data Options mode = Options {

2247 -- |

2348 -- Disable inclusion of the built in Prelude

2449 --

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

4469 -- Skip all optimizations

4570 --

4671 , 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]

6072 -- |

6173 -- Verbose error message

6274 --

6375 , 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

6581 } deriving Show

6682

6783-- |

6884-- Default compiler options

6985--

70−defaultOptions :: Options

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

86+defaultCompileOptions :: Options Compile

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

2828import Language.PureScript.Errors

2929

3030import Data.Maybe

31+import Data.Either (lefts, rights)

3132

3233import Control.Applicative

3334import Control.Monad.State

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

190191-- |

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

192193--

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

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

194195runCheck opts = runCheck' opts initEnvironment

195196

196197-- |

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

198199--

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

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

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

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

202203 return (a, checkEnv s)

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

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

234235 return (a, unifyCurrentSubstitution ust)

235236

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 (

4242-}

4343

4444import Data.List

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

45+import Data.Maybe (maybeToList, fromMaybe)

4646import Data.Function (on)

4747import Data.Ord (comparing)

4848import Data.Monoid

49+import Data.Either (lefts, rights)

4950

5051import Language.PureScript.Declarations

5152import Language.PureScript.Types

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

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

172173typesOf mainModuleName moduleName vals = do

173174 tys <- fmap tidyUp . liftUnify $ do

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

175− forM es $ \e -> do

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

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

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

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

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

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

178+ checkMain (fst e) ty

181179 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

182185

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

184187 -- Replace type class dictionary placeholders with actual dictionaries

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

193196 where

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

195198 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)]

196207

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)

198209typeDictionaryForBindingGroup moduleName vals = do

199210 let

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

201212 es = map isTyped vals

202213 -- Filter the typed and untyped declarations

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

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

214+ untyped = lefts es

215+ typed = rights es

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

207218

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

209220 untypedNames <- replicateM (length untyped) fresh

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

213224 untypedDict = zip (map fst untyped) untypedNames

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

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

216− return (es, dict, untypedDict)

217−

218−typeForBindingGroupElement :: ModuleName -> (Ident, (Expr, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> 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

225− -- Kind check

226− kind <- liftCheck $ kindOf moduleName ty

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

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

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

230− val'' <- if checkType

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

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

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

234− -- Untyped declarations

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

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

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

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

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

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

228+

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

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

231+ -- Kind check

232+ kind <- liftCheck $ kindOf moduleName ty

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

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

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

236+ val'' <- if checkType

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

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

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

240+

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

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

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

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

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

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

240247

241248-- |

242249-- Check if a value contains a type annotation

243250--

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

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

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

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

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

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

247254

248255-- |

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

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

655662 cond' <- check cond tyBoolean

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

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

658− t2 =?= t3

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

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

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

660667infer' (Let ds val) = do

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

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

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

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

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

694701 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

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

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

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

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

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

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

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

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

11191126 ty1 =?= ty2

11201127 return val

11211128

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+

11221145

11231146

11241147

tests/Main.hs+11−7

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

1212--

1313-----------------------------------------------------------------------------

1414

15−{-# LANGUAGE DoAndIfThenElse #-}

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

1616

1717module Main (main) where

1818

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

3434 text <- U.readFile inputFile

3535 return $ P.runIndentParser inputFile P.parseModules text

3636

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

3838compile opts inputFiles = do

3939 modules <- readInput inputFiles

4040 case modules of

4141 Left parseError ->

4242 return (Left $ show parseError)

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

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

4444

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

4646assert preludeExterns opts inputFile f = do

4747 e <- compile opts [preludeExterns, inputFile]

4848 maybeErr <- f e

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

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

5454assertCompiles preludeJs preludeExterns inputFile = do

5555 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+ }

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

5861 process <- findNodeProcess

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

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

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

6669assertDoesNotCompile preludeExterns inputFile = do

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

6972 case e of

7073 Left _ -> return Nothing

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

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

7881main = do

7982 prelude <- P.preludeFilename

8083 putStrLn "Compiling Prelude"

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

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

8285 case preludeResult of

8386 Left err -> putStrLn err >> exitFailure

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

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

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

98101 assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)

99102 exitSuccess

103+