Skip to content

Commit b39c400

Browse files
paf31paf31
committed
1 parent 79fcdf4 commit b39c400

File tree

11 files changed

+114
-86
lines changed

11 files changed

+114
-86
lines changed

‎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: 8 additions & 8 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 False False False Nothing False 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
@@ -276,7 +276,7 @@ handleDeclaration :: P.Expr -> PSCI ()
276276
handleDeclaration value = do
277277
st <- PSCI $ lift get
278278
let m = createTemporaryModule True st value
279-
e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
279+
e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
280280
case e of
281281
Left err -> PSCI $ outputStrLn err
282282
Right _ -> do
@@ -295,7 +295,7 @@ handleTypeOf :: P.Expr -> PSCI ()
295295
handleTypeOf value = do
296296
st <- PSCI $ lift get
297297
let m = createTemporaryModule False st value
298-
e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
298+
e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
299299
case e of
300300
Left err -> PSCI $ outputStrLn err
301301
Right env' ->
@@ -311,7 +311,7 @@ handleKindOf typ = do
311311
st <- PSCI $ lift get
312312
let m = createTemporaryModuleForKind st typ
313313
mName = P.ModuleName [P.ProperName "$PSCI"]
314-
e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
314+
e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
315315
case e of
316316
Left err -> PSCI $ outputStrLn err
317317
Right env' ->
@@ -374,12 +374,12 @@ handleCommand _ = PSCI $ outputStrLn "Unknown command"
374374
singleLineFlag :: Cmd.Term Bool
375375
singleLineFlag = Cmd.value $ Cmd.flag $ (Cmd.optInfo ["single-line-mode"])
376376
{ Cmd.optName = "Single-line mode"
377-
, Cmd.optDoc = "Run in single-line mode"
377+
, Cmd.optDoc = "Run in single-line mode"
378378
}
379379

380380
inputFiles :: Cmd.Term [FilePath]
381381
inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"
382-
, Cmd.posDoc = "Optional .purs files to load on start"
382+
, Cmd.posDoc = "Optional .purs files to load on start"
383383
}
384384

385385
loadUserConfig :: IO (Maybe [Command])

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

‎src/Language/PureScript/Optimizer.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -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
5353
optimize opts | optionsNoOptimizations opts = id
5454
| otherwise = untilFixedPoint (applyAll
5555
[ collapseNestedBlocks

‎src/Language/PureScript/Optimizer/MagicDo.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ import Language.PureScript.Names
2828

2929
import qualified Language.PureScript.Constants as C
3030

31-
magicDo :: Options -> JS -> JS
31+
magicDo :: Options mode -> JS -> JS
3232
magicDo opts | optionsNoMagicDo opts = id
3333
| otherwise = inlineST . magicDo'
3434

‎src/Language/PureScript/Optimizer/TCO.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -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
2525
tco opts | optionsNoTco opts = id
2626
| otherwise = tco'
2727

0 commit comments

Comments
 (0)