Skip to content

Commit caa1dc6

Browse files
paf31paf31
committed
Merge pull request purescript#601 from purescript/flight_work
Fix various bugs, add support for multiple errors
2 parents 531e1e3 + d1cdc98 commit caa1dc6

File tree

16 files changed

+242
-143
lines changed

16 files changed

+242
-143
lines changed

‎docgen/Main.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -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
148149
renderDeclaration n _ (P.ExternDataDeclaration name kind) =
149150
atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
150151
renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do

‎examples/failing/MultipleErrors.purs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
module MultipleErrors where
2+
3+
foo :: Number -> Number
4+
foo 0 = "Test"
5+
foo n = bar (n - 1)
6+
7+
bar :: Number -> Number
8+
bar 0 = "Test"
9+
bar n = foo (n - 1)

‎examples/passing/IfThenElseMaybe.purs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
module Main where
2+
3+
data Maybe a = Nothing | Just a
4+
5+
test1 = if true then Just 10 else Nothing
6+
7+
test2 = if true then Nothing else Just 10
8+
9+
main = Debug.Trace.trace "Done"

‎psc-make/Main.hs‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@
1212
--
1313
-----------------------------------------------------------------------------
1414

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

1717
module 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 ()
7070
compile 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
124124
verboseErrors = 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

130130
noPrefix :: Term Bool
131131
noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ])
@@ -145,3 +145,4 @@ main :: IO ()
145145
main = do
146146
prelude <- P.preludeFilename
147147
run (term prelude, termInfo)
148+

‎psc/Main.hs‎

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@
1212
--
1313
-----------------------------------------------------------------------------
1414

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

1717
module 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 ()
4848
compile 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

7676
mkdirp :: FilePath -> IO ()
@@ -136,8 +136,10 @@ noPrefix :: Term Bool
136136
noPrefix = 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

142144
term :: FilePath -> Term (IO ())
143145
term 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‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@
1313
--
1414
-----------------------------------------------------------------------------
1515

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

1818
module 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

436436
main :: IO ()
437437
main = Cmd.run (term, termInfo)
438+

‎src/Language/PureScript.hs‎

Lines changed: 14 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,8 @@
1313
--
1414
-----------------------------------------------------------------------------
1515

16+
{-# LANGUAGE DataKinds #-}
17+
1618
module Language.PureScript (module P, compile, compile', MonadMake(..), make, preludeFilename) where
1719

1820
import Language.PureScript.Types as P
@@ -39,7 +41,7 @@ import qualified Paths_purescript as Paths
3941
import Data.List (find, sortBy, groupBy, intercalate)
4042
import Data.Time.Clock
4143
import Data.Function (on)
42-
import Data.Maybe (fromJust, fromMaybe)
44+
import Data.Maybe (fromMaybe)
4345
import Control.Monad.Error
4446
import Control.Monad.State.Lazy
4547
import 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)
7173
compile = 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)
7476
compile' 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]
130132
generateMain 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
174176
make 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‎

Lines changed: 23 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -13,17 +13,16 @@
1313
--
1414
-----------------------------------------------------------------------------
1515

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

1818
module 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)
2726
import Data.Function (on)
2827
import Data.List (nub, (\\), delete, sortBy)
2928

@@ -42,40 +41,36 @@ import Language.PureScript.Supply
4241
import Language.PureScript.Traversals (sndM)
4342
import 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

8075
imports :: Declaration -> [ModuleName]
8176
imports (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])
9994
declToJs 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
194189
valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
195190
valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
196191
valueToJs _ _ _ (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
319314
bindersToJs 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
416411
binderToJs m e varName done (PositionedBinder _ binder) =
417412
binderToJs m e varName done binder
418413

414+

0 commit comments

Comments
 (0)