summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-04-12 22:33:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-12 22:33:00 (GMT)
commit50c471402cfc96ba0453f90e09dcb249169c65dd (patch)
tree3b6a503c065ed1e7e0d444e2001339ee94d575e6
parent85982d2ed8507b6dca3739512ce18853dcb8f707 (diff)
version 0.4.180.4.18
-rw-r--r--prelude/prelude.purs60
-rw-r--r--psc-make/Main.hs19
-rw-r--r--psc/Main.hs3
-rw-r--r--psci/Main.hs148
-rw-r--r--purescript.cabal12
-rw-r--r--src/Language/PureScript.hs68
-rw-r--r--src/Language/PureScript/CodeGen/Common.hs1
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs82
-rw-r--r--src/Language/PureScript/Constants.hs12
-rw-r--r--src/Language/PureScript/Names.hs4
-rw-r--r--src/Language/PureScript/Optimizer.hs6
-rw-r--r--src/Language/PureScript/Optimizer/Inliner.hs31
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs28
-rw-r--r--src/Language/PureScript/Options.hs4
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs10
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs6
-rw-r--r--src/Language/PureScript/Types.hs19
-rw-r--r--tests/Main.hs9
18 files changed, 311 insertions, 211 deletions
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 7426306..9001fbf 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -6,9 +6,6 @@ module Prelude where
const :: forall a b. a -> b -> a
const a _ = a
- on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
- on f g x y = g x `f` g y
-
asTypeOf :: forall a. a -> a -> a
asTypeOf x _ = x
@@ -39,11 +36,28 @@ module Prelude where
(#) :: forall a b. a -> (a -> b) -> b
(#) x f = f x
+ infixr 6 :
+
+ (:) :: forall a. a -> [a] -> [a]
+ (:) = cons
+
+ foreign import cons
+ "function cons(e) {\
+ \ return function (l) {\
+ \ return [e].concat(l);\
+ \ };\
+ \}" :: forall a. a -> [a] -> [a]
+
class Show a where
show :: a -> String
+ foreign import showStringImpl
+ "function showStringImpl(s) {\
+ \ return JSON.stringify(s);\
+ \}" :: String -> String
+
instance showString :: Show String where
- show s = s
+ show = showStringImpl
instance showBoolean :: Show Boolean where
show true = "true"
@@ -56,6 +70,20 @@ module Prelude where
instance showNumber :: Show Number where
show = showNumberImpl
+ foreign import showArrayImpl
+ "function showArrayImpl (f) {\
+ \ return function (xs) {\
+ \ var ss = [];\
+ \ for (var i = 0, l = xs.length; i < l; i++) {\
+ \ ss[i] = f(xs[i]);\
+ \ }\
+ \ return '[' + ss.join(',') + ']';\
+ \ };\
+ \}" :: forall a. (a -> String) -> [a] -> String
+
+ instance showArray :: (Show a) => Show [a] where
+ show = showArrayImpl show
+
infixl 4 <$>
class Functor f where
@@ -243,7 +271,7 @@ module Prelude where
foreign import numCompare
"function numCompare(n1) {\
\ return function(n2) {\
- \ return n1 < n2 ? module.LT : n1 > n2 ? module.GT : module.EQ;\
+ \ return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
\ };\
\}" :: Number -> Number -> Ordering
@@ -312,14 +340,6 @@ module Prelude where
zshr = numZshr
complement = numComplement
- infixl 8 !!
-
- foreign import (!!) "function $bang$bang(xs) {\
- \ return function(n) {\
- \ return xs[n];\
- \ };\
- \}" :: forall a. [a] -> Number -> a
-
infixr 2 ||
infixr 3 &&
@@ -369,6 +389,11 @@ module Prelude where
(++) :: forall s. (Semigroup s) => s -> s -> s
(++) = (<>)
+module Data.Function where
+
+ on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
+ on f g x y = g x `f` g y
+
module Data.Eq where
data Ref a = Ref a
@@ -380,6 +405,15 @@ module Data.Eq where
(==) = liftRef refEq
(/=) = liftRef refIneq
+module Prelude.Unsafe where
+
+ foreign import unsafeIndex
+ "function unsafeIndex(xs) {\
+ \ return function(n) {\
+ \ return xs[n];\
+ \ };\
+ \}" :: forall a. [a] -> Number -> a
+
module Control.Monad.Eff where
foreign import data Eff :: # ! -> * -> *
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index 8bd9c37..7792f89 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -67,16 +67,17 @@ instance P.MonadMake Make where
U.putStrLn $ "Writing " ++ path
U.writeFile path text
liftError = either throwError return
+ progress = makeIO . U.putStrLn
-compile :: P.Options -> [FilePath] -> IO ()
-compile opts input = do
+compile :: FilePath -> P.Options -> [FilePath] -> IO ()
+compile outputDir opts input = do
modules <- readInput input
case modules of
Left err -> do
U.print err
exitFailure
Right ms -> do
- e <- runMake $ P.make opts ms
+ e <- runMake $ P.make outputDir opts ms
case e of
Left err -> do
U.putStrLn err
@@ -91,6 +92,10 @@ inputFiles :: Term [FilePath]
inputFiles = value $ posAny [] $ posInfo
{ posDoc = "The input .ps files" }
+outputDirectory :: Term FilePath
+outputDirectory = value $ opt "output" $ (optInfo [ "o", "output" ])
+ { optDoc = "The output directory" }
+
noTco :: Term Bool
noTco = value $ flag $ (optInfo [ "no-tco" ])
{ optDoc = "Disable tail call optimizations" }
@@ -111,16 +116,12 @@ noOpts :: Term Bool
noOpts = value $ flag $ (optInfo [ "no-opts" ])
{ optDoc = "Skip the optimization phase." }
-browserNamespace :: Term String
-browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
- { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
-
verboseErrors :: Term Bool
verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
{ optDoc = "Display verbose error messages" }
options :: Term P.Options
-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure [] <*> verboseErrors
+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> pure Nothing <*> pure [] <*> pure [] <*> verboseErrors
inputFilesAndPrelude :: FilePath -> Term [FilePath]
inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
@@ -129,7 +130,7 @@ inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
combine False input = input
term :: FilePath -> Term (IO ())
-term prelude = compile <$> options <*> inputFilesAndPrelude prelude
+term prelude = compile <$> outputDirectory <*> options <*> inputFilesAndPrelude prelude
termInfo :: TermInfo
termInfo = defTI
diff --git a/psc/Main.hs b/psc/Main.hs
index 7d53f47..ecad91d 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -127,7 +127,7 @@ verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
{ optDoc = "Display verbose error messages" }
options :: Term P.Options
-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules <*> verboseErrors
+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> (Just <$> browserNamespace) <*> dceModules <*> codeGenModules <*> verboseErrors
stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
@@ -150,3 +150,4 @@ main :: IO ()
main = do
prelude <- preludeFilename
run (term prelude, termInfo)
+
diff --git a/psci/Main.hs b/psci/Main.hs
index 4fd50e2..dc82c18 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DoAndIfThenElse, FlexibleContexts #-}
+{-# LANGUAGE DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}
module Main where
@@ -24,29 +24,36 @@ import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Trans.State.Strict
+import Control.Monad.Error (ErrorT(..), MonadError)
+import Control.Monad.Error.Class (MonadError(..))
import Data.List (intercalate, isPrefixOf, nub, sortBy)
import Data.Maybe (mapMaybe)
import Data.Foldable (traverse_)
-import Data.Traversable (traverse)
import Data.Version (showVersion)
+import Data.Traversable (traverse)
import Parser
+import System.IO.Error (tryIOError)
import System.Console.Haskeline
-import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
+import System.Directory
+ (createDirectoryIfMissing, getModificationTime, doesFileExist,
+ findExecutable, getHomeDirectory, getCurrentDirectory)
+import System.Process (readProcessWithExitCode)
import System.Exit
import System.Environment.XDG.BaseDir
-import System.FilePath ((</>), isPathSeparator)
+import System.FilePath
+ (pathSeparator, takeDirectory, (</>), isPathSeparator)
import qualified System.Console.CmdTheLine as Cmd
-import System.Process
import Text.Parsec (ParseError)
import qualified Data.Map as M
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
-import qualified System.IO.UTF8 as U (print, readFile)
+import qualified System.IO.UTF8 as U
+ (writeFile, putStrLn, print, readFile)
-- |
-- The PSCI state.
@@ -57,7 +64,7 @@ import qualified System.IO.UTF8 as U (print, readFile)
data PSCiState = PSCiState
{ psciImportedFilenames :: [FilePath]
, psciImportedModuleNames :: [P.ModuleName]
- , psciLoadedModules :: [P.Module]
+ , psciLoadedModules :: [(FilePath, P.Module)]
, psciLetBindings :: [P.Value -> P.Value]
}
@@ -78,7 +85,7 @@ updateImports name st = st { psciImportedModuleNames = name : psciImportedModule
-- |
-- Updates the state to have more loaded files.
--
-updateModules :: [P.Module] -> PSCiState -> PSCiState
+updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState
updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
-- |
@@ -168,7 +175,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions
where
findCompletions :: String -> StateT PSCiState IO [Completion]
findCompletions str = do
- ms <- psciLoadedModules <$> get
+ ms <- map snd . psciLoadedModules <$> get
files <- listFiles str
let matches = filter (isPrefixOf str) (names ms)
return $ sortBy sorter $ map simpleCompletion matches ++ files
@@ -197,7 +204,39 @@ completion = completeWord Nothing " \t\n\r" findCompletions
-- | Compilation options.
--
options :: P.Options
-options = P.Options False True False True (Just "Main") True "PS" [] [] False
+options = P.Options False True False True Nothing True Nothing [] [] False
+
+-- |
+-- PSCI monad
+--
+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
+
+psciIO :: IO a -> PSCI a
+psciIO io = PSCI (lift (lift io))
+
+newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadError String)
+
+runMake :: Make a -> IO (Either String a)
+runMake = runErrorT . unMake
+
+makeIO :: IO a -> Make a
+makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
+
+instance P.MonadMake Make where
+ getTimestamp path = makeIO $ do
+ exists <- doesFileExist path
+ case exists of
+ True -> Just <$> getModificationTime path
+ False -> return Nothing
+ readTextFile path = makeIO $ U.readFile path
+ writeTextFile path text = makeIO $ do
+ mkdirp path
+ U.writeFile path text
+ liftError = either throwError return
+ progress s = unless (s == "Compiling Main") $ makeIO . U.putStrLn $ s
+
+mkdirp :: FilePath -> IO ()
+mkdirp = createDirectoryIfMissing True . takeDirectory
-- |
-- Makes a volatile module to execute the current expression.
@@ -217,34 +256,45 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB
in
P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing
+modulesDir :: FilePath
+modulesDir = "psci_modules" ++ pathSeparator : "node_modules"
+
+indexFile :: FilePath
+indexFile = "psci_modules" ++ pathSeparator : "index.js"
+
-- |
-- Takes a value declaration and evaluates it with the current state.
--
-handleDeclaration :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
-handleDeclaration value st = do
+handleDeclaration :: P.Value -> PSCI ()
+handleDeclaration value = do
+ st <- PSCI $ lift get
let m = createTemporaryModule True st value
- case P.compile options (psciLoadedModules st ++ [m]) of
- Left err -> outputStrLn err
- Right (js, _, _) -> do
- process <- lift . lift $ findNodeProcess
- result <- lift . lift $ traverse (\node -> readProcessWithExitCode node [] js) process
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)])
+ case e of
+ Left err -> PSCI $ outputStrLn err
+ Right _ -> do
+ psciIO $ writeFile indexFile $ "require('Main').main();"
+ process <- psciIO findNodeProcess
+ result <- psciIO $ traverse (\node -> readProcessWithExitCode node [indexFile] "") process
case result of
- Just (ExitSuccess, out, _) -> outputStrLn out
- Just (ExitFailure _, _, err) -> outputStrLn err
- Nothing -> outputStrLn "Couldn't find node.js"
+ Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out
+ Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err
+ Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
-- |
-- Takes a value and prints its type
--
-handleTypeOf :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
-handleTypeOf value st = do
+handleTypeOf :: P.Value -> PSCI ()
+handleTypeOf value = do
+ st <- PSCI $ lift get
let m = createTemporaryModule False st value
- case P.compile options { P.optionsMain = Nothing } (psciLoadedModules st ++ [m]) of
- Left err -> outputStrLn err
- Right (_, _, env') ->
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)])
+ case e of
+ Left err -> PSCI $ outputStrLn err
+ Right env' ->
case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of
- Just (ty, _) -> outputStrLn . P.prettyPrintType $ ty
- Nothing -> outputStrLn "Could not find type"
+ Just (ty, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
+ Nothing -> PSCI $ outputStrLn "Could not find type"
-- Commands
@@ -265,27 +315,31 @@ getCommand = do
-- |
-- Performs an action for each meta-command given, and also for expressions..
--
-handleCommand :: Command -> InputT (StateT PSCiState IO) ()
-handleCommand (Expression val) = lift get >>= handleDeclaration val
-handleCommand Help = outputStrLn helpMessage
-handleCommand (Import moduleName) = lift $ modify (updateImports moduleName)
-handleCommand (Let l) = lift $ modify (updateLets l)
+handleCommand :: Command -> PSCI ()
+handleCommand (Expression val) = handleDeclaration val
+handleCommand Help = PSCI $ outputStrLn helpMessage
+handleCommand (Import moduleName) = PSCI $ lift $ modify (updateImports moduleName)
+handleCommand (Let l) = PSCI $ lift $ modify (updateLets l)
handleCommand (LoadFile filePath) = do
- absPath <- lift . lift $ expandTilde filePath
- exists <- lift . lift $ doesFileExist absPath
+ absPath <- psciIO $ expandTilde filePath
+ exists <- psciIO $ doesFileExist absPath
if exists then do
- lift $ modify (updateImportedFiles absPath)
- either outputStrLn (lift . modify . updateModules) =<< (lift . lift $ loadModule absPath)
+ PSCI . lift $ modify (updateImportedFiles absPath)
+ m <- psciIO $ loadModule absPath
+ case m of
+ Left err -> PSCI $ outputStrLn err
+ Right mods -> PSCI . lift $ modify (updateModules (map ((,) absPath) mods))
else
- outputStrLn $ "Couldn't locate: " ++ filePath
+ PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
handleCommand Reset = do
- files <- psciImportedFilenames <$> lift get
- modulesOrFirstError <- fmap concat . sequence <$> mapM (lift . lift . loadModule) files
+ files <- psciImportedFilenames <$> PSCI (lift get)
+ filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . psciIO . loadModule $ file) files
+ let modulesOrFirstError = fmap concat $ sequence filesAndModules
case modulesOrFirstError of
- Left err -> lift . lift $ putStrLn err >> exitFailure
- Right modules -> lift $ put (PSCiState files defaultImports modules [])
-handleCommand (TypeOf val) = lift get >>= handleTypeOf val
-handleCommand _ = outputStrLn "Unknown command"
+ Left err -> psciIO $ putStrLn err >> exitFailure
+ Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules [])
+handleCommand (TypeOf val) = handleTypeOf val
+handleCommand _ = PSCI $ outputStrLn "Unknown command"
inputFiles :: Cmd.Term [FilePath]
inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"
@@ -311,7 +365,8 @@ loop :: [FilePath] -> IO ()
loop files = do
config <- loadUserConfig
preludeFilename <- getPreludeFilename
- modulesOrFirstError <- fmap concat . sequence <$> mapM loadModule (preludeFilename : files)
+ filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . loadModule $ file) (preludeFilename : files)
+ let modulesOrFirstError = fmap concat $ sequence filesAndModules
case modulesOrFirstError of
Left err -> putStrLn err >> exitFailure
Right modules -> do
@@ -319,7 +374,7 @@ loop files = do
let settings = defaultSettings {historyFile = Just historyFilename}
flip evalStateT (PSCiState (preludeFilename : files) defaultImports modules []) . runInputT (setComplete completion settings) $ do
outputStrLn prologueMessage
- traverse_ (mapM_ handleCommand) config
+ traverse_ (mapM_ (runPSCI . handleCommand)) config
go
where
go :: InputT (StateT PSCiState IO) ()
@@ -329,7 +384,7 @@ loop files = do
Left err -> outputStrLn (show err) >> go
Right Nothing -> go
Right (Just Quit) -> outputStrLn quitMessage
- Right (Just c') -> handleCommand c' >> go
+ Right (Just c') -> runPSCI (handleCommand c') >> go
term :: Cmd.Term (IO ())
term = loop <$> inputFiles
@@ -343,4 +398,3 @@ termInfo = Cmd.defTI
main :: IO ()
main = Cmd.run (term, termInfo)
-
diff --git a/purescript.cabal b/purescript.cabal
index 68ba2d3..91aec93 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.17.1
+version: 0.4.18
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -19,7 +19,7 @@ data-dir: ""
library
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
- directory >= 1.2, filepath -any, mtl -any, parsec -any, syb -any,
+ directory >= 1.2, filepath -any, mtl -any, parsec -any, syb >= 0.4.1 && < 0.5,
transformers -any, utf8-string -any,
pattern-arrows >= 0.0.2 && < 0.1,
monad-unify >= 0.2.1 && < 0.3,
@@ -87,7 +87,7 @@ library
executable psc
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
directory -any, filepath -any, mtl -any, parsec -any,
- purescript -any, syb -any, transformers -any, utf8-string -any
+ purescript -any, syb >= 0.4.1 && < 0.5, transformers -any, utf8-string -any
main-is: Main.hs
buildable: True
hs-source-dirs: psc
@@ -97,7 +97,7 @@ executable psc
executable psc-make
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
directory -any, filepath -any, mtl -any, parsec -any,
- purescript -any, syb -any, transformers -any, utf8-string -any
+ purescript -any, syb >= 0.4.1 && < 0.5, transformers -any, utf8-string -any
main-is: Main.hs
buildable: True
hs-source-dirs: psc-make
@@ -107,7 +107,7 @@ executable psc-make
executable psci
build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
mtl -any, parsec -any, haskeline -any, purescript -any,
- syb -any, transformers -any, utf8-string -any, process -any,
+ syb >= 0.4.1 && < 0.5, transformers -any, utf8-string -any, process -any,
xdg-basedir -any, cmdtheline -any
main-is: Main.hs
buildable: True
@@ -127,7 +127,7 @@ executable docgen
test-suite tests
build-depends: base >=4 && <5, containers -any, directory -any,
- filepath -any, mtl -any, parsec -any, purescript -any, syb -any,
+ filepath -any, mtl -any, parsec -any, purescript -any, syb >= 0.4.1 && < 0.5,
transformers -any, utf8-string -any, process -any
type: exitcode-stdio-1.0
main-is: Main.hs
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 09c6a9d..32c0960 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -37,7 +37,7 @@ import Data.List (find, sortBy, groupBy, intercalate)
import Data.Time.Clock
import Data.Function (on)
import Data.Generics (mkQ, everything)
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromJust, fromMaybe)
import Control.Monad.Error
import Control.Monad.State.Lazy
import Control.Arrow ((&&&))
@@ -78,10 +78,10 @@ compile' env opts ms = do
let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts
let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
- let js = mapMaybe (flip (moduleToJs opts) env') modulesToCodeGen
+ let js = concatMap (\m -> moduleToJs Globals opts m env') modulesToCodeGen
let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen
js' <- generateMain env' opts js
- return (prettyPrintJS [wrapExportsContainer opts js'], exts, env')
+ return (prettyPrintJS js', exts, env')
where
mainModuleIdent = moduleNameFromString <$> optionsMain opts
@@ -128,7 +128,7 @@ generateMain env opts js =
Just mmi -> do
when ((mmi, Ident C.main) `M.notMember` names env) $
Left $ show mmi ++ "." ++ C.main ++ " is undefined"
- return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar C._ps))) []]
+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (fromJust (optionsBrowserNamespace opts))))) []]
_ -> return js
-- |
@@ -155,6 +155,10 @@ class MonadMake m where
--
liftError :: Either String a -> m a
+ -- |
+ -- Respond to a progress update
+ --
+ progress :: String -> m ()
-- |
-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
@@ -162,17 +166,17 @@ class MonadMake m where
-- If timestamps have not changed, the externs file can be used to provide the module's types without
-- having to typecheck the module again.
--
-make :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] -> m ()
-make opts ms = do
+make :: (Functor m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment
+make outputDir opts ms = do
let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
(sorted, graph) <- liftError $ sortModules $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms)
toRebuild <- foldM (\s (Module moduleName' _ _) -> do
- let filePath = toFileName moduleName'
+ let filePath = runModuleName moduleName'
- jsFile = "js" ++ pathSeparator : filePath ++ ".js"
- externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
+ jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"
+ externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"
inputFile = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap
jsTimestamp <- getTimestamp jsFile
@@ -190,47 +194,45 @@ make opts ms = do
go initEnvironment desugared
where
- go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
- go _ [] = return ()
+ go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m Environment
+ go env [] = return env
go env ((False, m) : ms') = do
(_, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
go env' ms'
go env ((True, m@(Module moduleName' _ exps)) : ms') = do
- let filePath = toFileName moduleName'
- jsFile = "js" ++ pathSeparator : filePath ++ ".js"
- externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
+ let filePath = runModuleName moduleName'
+ jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"
+ externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"
+
+ progress $ "Compiling " ++ runModuleName moduleName'
(Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
let mod' = Module moduleName' regrouped exps
- js = moduleToJs opts mod' env'
+ js = prettyPrintJS $ moduleToJs CommonJS opts mod' env'
exts = moduleToPs mod' env'
- js' = maybe "" (prettyPrintJS . return . wrapExportsContainer opts . return) js
- writeTextFile jsFile js'
+ writeTextFile jsFile js
writeTextFile externsFile exts
go env' ms'
-toFileName :: ModuleName -> FilePath
-toFileName (ModuleName ps) = intercalate [pathSeparator] . map runProperName $ ps
-
-rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
-rebuildIfNecessary _ _ [] = return []
-rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms) | moduleName' `S.member` toRebuild = do
- let deps = fromMaybe [] $ moduleName' `M.lookup` graph
- toRebuild' = toRebuild `S.union` S.fromList deps
- (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms
-rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms) = do
- let externsFile = "externs" ++ pathSeparator : toFileName moduleName' ++ ".externs"
- externs <- readTextFile externsFile
- externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs
- case externsModules of
- [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms
- _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
+ rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
+ rebuildIfNecessary _ _ [] = return []
+ rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
+ let deps = fromMaybe [] $ moduleName' `M.lookup` graph
+ toRebuild' = toRebuild `S.union` S.fromList deps
+ (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
+ rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
+ let externsFile = outputDir ++ pathSeparator : runModuleName moduleName' ++ pathSeparator : "externs.purs"
+ externs <- readTextFile externsFile
+ externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs
+ case externsModules of
+ [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
+ _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
diff --git a/src/Language/PureScript/CodeGen/Common.hs b/src/Language/PureScript/CodeGen/Common.hs
index 661ce59..297bdc4 100644
--- a/src/Language/PureScript/CodeGen/Common.hs
+++ b/src/Language/PureScript/CodeGen/Common.hs
@@ -106,6 +106,7 @@ nameIsJsReserved name =
, "long"
, "native"
, "new"
+ , "null"
, "package"
, "private"
, "protected"
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 694542b..e49738d 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -17,14 +17,16 @@
module Language.PureScript.CodeGen.JS (
module AST,
+ ModuleType(..),
declToJs,
moduleToJs,
- wrapExportsContainer,
isIdent
) where
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromJust, fromMaybe, mapMaybe)
import Data.Function (on)
+import Data.List (nub, (\\))
+import Data.Generics (mkQ, everything)
import Control.Arrow (second)
import Control.Monad (replicateM, forM)
@@ -41,26 +43,46 @@ import Language.PureScript.Types
import Language.PureScript.Optimizer
import Language.PureScript.CodeGen.Common
import Language.PureScript.Environment
-import qualified Language.PureScript.Constants as C
+
+-- |
+-- Different types of modules which are supported
+--
+data ModuleType = CommonJS | Globals
-- |
-- Generate code in the simplified Javascript intermediate representation for all declarations in a
-- module.
--
-moduleToJs :: Options -> Module -> Environment -> Maybe JS
-moduleToJs opts (Module name decls (Just exps)) env =
- case jsDecls of
- [] -> Nothing
- _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar C._ps)) $
- JSApp (JSFunction Nothing [] (JSBlock $
- JSVariableIntroduction "module" (Just $ JSObjectLiteral []) :
- jsDecls ++
- jsExports ++
- [JSReturn $ JSVar "module"])) []
+moduleToJs :: ModuleType -> Options -> Module -> Environment -> [JS]
+moduleToJs mt opts (Module name decls (Just exps)) env = case mt of
+ CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
+ Globals ->
+ [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))
+ (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )
+ , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))
+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
+ ]
where
+ moduleBody = JSStringLiteral "use strict" : jsImports ++ jsDecls
+ moduleExports = JSObjectLiteral $ concatMap exportToJs exps
jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls)
- jsExports = concatMap exportToJs exps
-moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"
+ jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls
+moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"
+
+importToJs :: ModuleType -> Options -> ModuleName -> JS
+importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
+ where
+ moduleBody = case mt of
+ CommonJS -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
+ Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))
+
+imports :: Declaration -> [ModuleName]
+imports = everything (++) (mkQ [] collect)
+ where
+ collect :: Value -> [ModuleName]
+ collect (Var (Qualified (Just mn) _)) = [mn]
+ collect (Constructor (Qualified (Just mn) _)) = [mn]
+ collect _ = []
-- |
-- Generate code in the simplified Javascript intermediate representation for a declaration
@@ -87,23 +109,15 @@ declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
declToJs _ _ _ _ = Nothing
-- |
--- Generate code in the simplified Javascript intermediate representation for an export from a
--- module.
+-- Generate key//value pairs for an object literal exporting values from a module.
--
-exportToJs :: DeclarationRef -> [JS]
-exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Ident . runProperName)
-exportToJs (ValueRef name) = [export name]
-exportToJs (TypeInstanceRef name) = [export name]
+exportToJs :: DeclarationRef -> [(String, JS)]
+exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors
+exportToJs (ValueRef name) = [(runIdent name, var name)]
+exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]
exportToJs _ = []
-- |
--- Generate code in the simplified Javascript intermediate representation for assigning an exported
--- value to the current module object.
---
-export :: Ident -> JS
-export ident = JSAssignment (accessor ident (JSVar "module")) (var ident)
-
--- |
-- Generate code in the simplified Javascript intermediate representation for a variable based on a
-- PureScript identifier.
--
@@ -225,7 +239,7 @@ varToJs m qual = qualifiedToJS m id qual
-- variable that may have a qualified name.
--
qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
-qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar C._ps)
+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
-- |
@@ -328,13 +342,3 @@ isOnlyConstructor e ctor =
numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e
typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)
typeConstructor _ = error "Invalid argument to isOnlyConstructor"
-
-wrapExportsContainer :: Options -> [JS] -> JS
-wrapExportsContainer opts modules = JSApp (JSFunction Nothing [C._ps] $ JSBlock $ JSStringLiteral "use strict" : modules) [exportSelector]
- where
- exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))
- (JSAccessor "exports" (JSVar "module"))
- (JSConditional (JSBinary NotEqualTo (JSTypeOf $ JSVar "window") (JSStringLiteral "undefined"))
- (JSAssignment (JSAccessor browserNamespace (JSVar "window")) (JSBinary Or (JSAccessor browserNamespace (JSVar "window")) (JSObjectLiteral [])))
- (JSApp (JSFunction Nothing [] $ JSBlock [JSThrow $ JSStringLiteral "PureScript doesn't know how to export modules in the current environment"]) []))
- browserNamespace = optionsBrowserNamespace opts
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index beca0fe..34c66a9 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -23,9 +23,6 @@ module Language.PureScript.Constants where
(#) :: String
(#) = "#"
-(!!) :: String
-(!!) = "!!"
-
(++) :: String
(++) = "++"
@@ -80,6 +77,9 @@ bar = "|"
(||) :: String
(||) = "||"
+unsafeIndex :: String
+unsafeIndex = "unsafeIndex"
+
-- Prelude Operator Functions
negate :: String
@@ -180,9 +180,6 @@ main = "main"
-- Code Generation
-_ps :: String
-_ps = "_ps"
-
__superclasses :: String
__superclasses = "__superclasses"
@@ -194,6 +191,9 @@ prim = "Prim"
prelude :: String
prelude = "Prelude"
+preludeUnsafe :: String
+preludeUnsafe = "Prelude_Unsafe"
+
eff :: String
eff = "Control_Monad_Eff"
diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
index a384266..1b64423 100644
--- a/src/Language/PureScript/Names.hs
+++ b/src/Language/PureScript/Names.hs
@@ -33,6 +33,10 @@ data Ident
--
| Op String deriving (Eq, Ord, Data, Typeable)
+runIdent :: Ident -> String
+runIdent (Ident i) = i
+runIdent (Op op) = op
+
instance Show Ident where
show (Ident s) = s
show (Op op) = '(':op ++ ")"
diff --git a/src/Language/PureScript/Optimizer.hs b/src/Language/PureScript/Optimizer.hs
index 16d60dc..b06ff4d 100644
--- a/src/Language/PureScript/Optimizer.hs
+++ b/src/Language/PureScript/Optimizer.hs
@@ -63,9 +63,9 @@ optimize opts | optionsNoOptimizations opts = id
, etaConvert
, evaluateIifes
, inlineVariables
- , inlineOperator (C.$) $ \f x -> JSApp f [x]
- , inlineOperator (C.#) $ \x f -> JSApp f [x]
- , inlineOperator (C.!!) $ flip JSIndexer
+ , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
+ , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer
, inlineCommonOperators ])
untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs
index 10dddfe..d8a8b55 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -75,18 +75,14 @@ inlineVariables = everywhere (mkT $ removeFromBlock go)
go (replaceIdent var js sts)
go (s:sts) = s : go sts
-inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS
-inlineOperator op f = everywhere (mkT convert)
+inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
+inlineOperator (m, op) f = everywhere (mkT convert)
where
convert :: JS -> JS
convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
convert other = other
- isOp (JSAccessor longForm (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
- _ps == C._ps &&
- longForm == identToJs (Op op) = True
- isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
- _ps == C._ps &&
- op == op' = True
+ isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)
+ isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'
isOp _ = False
inlineCommonOperators :: JS -> JS
@@ -131,11 +127,8 @@ inlineCommonOperators = applyAll
convert :: JS -> JS
convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
convert other = other
- isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) | prelude == C.prelude &&
- longForm == identToJs (Op opString) = True
- isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
- _ps == C._ps &&
- opString == op' = True
+ isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)
+ isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'
isOp _ = False
binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
binaryFunction dictName fnName op = everywhere (mkT convert)
@@ -143,9 +136,7 @@ inlineCommonOperators = applyAll
convert :: JS -> JS
convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
convert other = other
- isOp (JSAccessor fnName' (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
- _ps == C._ps &&
- fnName == fnName' = True
+ isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'
isOp _ = False
unary :: String -> String -> UnaryOperator -> JS -> JS
unary dictName fnName op = everywhere (mkT convert)
@@ -153,11 +144,7 @@ inlineCommonOperators = applyAll
convert :: JS -> JS
convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
convert other = other
- isOp (JSAccessor fnName' (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
- _ps == C._ps &&
- fnName' == fnName = True
+ isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
isOp _ = False
- isOpDict dictName (JSApp (JSAccessor prop (JSAccessor prelude (JSVar _ps))) [JSObjectLiteral []]) | prelude == C.prelude &&
- _ps == C._ps &&
- prop == dictName = True
+ isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) [JSObjectLiteral []]) = prelude == C.prelude && prop == dictName
isOpDict _ _ = False
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs
index 3cdc6b5..4c7c0e3 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -80,31 +80,19 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
isReturn _ = False
-- Check if an expression represents the polymorphic >>= function
- isBindPoly (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
- _ps == C._ps &&
- prop == identToJs (Op (C.>>=)) = True
- isBindPoly (JSIndexer (JSStringLiteral bind) (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
- _ps == C._ps &&
- bind == (C.>>=) = True
+ isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op (C.>>=))
+ isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == (C.>>=)
isBindPoly _ = False
-- Check if an expression represents the polymorphic return function
- isRetPoly (JSAccessor returnEscaped (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
- _ps == C._ps &&
- returnEscaped == C.returnEscaped = True
- isRetPoly (JSIndexer (JSStringLiteral return') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
- _ps == C._ps &&
- return' == C.return = True
+ isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
+ isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return
isRetPoly _ = False
-- Check if an expression represents a function in the Ef module
- isEffFunc name (JSAccessor name' (JSAccessor eff (JSVar _ps))) | eff == C.eff &&
- _ps == C._ps &&
- name == name' = True
+ isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'
isEffFunc _ _ = False
-- Check if an expression represents the Monad Eff dictionary
isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = True
- isEffDict name (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&
- _ps == C._ps &&
- prop == name = True
+ isEffDict name (JSApp (JSAccessor prop (JSVar eff)) [JSObjectLiteral []]) = eff == C.eff && prop == name
isEffDict _ _ = False
-- Remove __do function applications which remain after desugaring
undo :: JS -> JS
@@ -147,9 +135,7 @@ inlineST = everywhere (mkT convertBlock)
JSAssignment (JSIndexer i arr) val
convert _ other = other
-- Check if an expression represents a function in the ST module
- isSTFunc name (JSAccessor name' (JSAccessor st (JSVar _ps))) | st == C.st &&
- _ps == C._ps &&
- name == name' = True
+ isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'
isSTFunc _ _ = False
-- Find all ST Refs initialized in this block
findSTRefsIn = everything (++) (mkQ [] isSTRef)
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 6a65d05..9aadedb 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -48,7 +48,7 @@ data Options = Options {
-- Specify the namespace that PureScript modules will be exported to when running in the
-- browser.
--
- , optionsBrowserNamespace :: String
+ , optionsBrowserNamespace :: Maybe String
-- |
-- The modules to keep while enabling dead code elimination
--
@@ -67,4 +67,4 @@ data Options = Options {
-- Default compiler options
--
defaultOptions :: Options
-defaultOptions = Options False False False False Nothing False "PS" [] [] False
+defaultOptions = Options False False False False Nothing False Nothing [] [] False
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 4390621..b627d0a 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -145,7 +145,7 @@ typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> D
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
ExternDeclaration TypeClassAccessorImport ident
(Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSIndexer (JSStringLiteral (identToProperty ident)) (JSVar "dict"))])))
- (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
+ (moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty)))
typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
@@ -169,7 +169,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
case mapMaybe declName tyDecls \\ mapMaybe declName decls of
x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
[] -> do
-
+
let instanceTys = map memberToNameAndType tyDecls
-- Replace the type arguments with the appropriate types in the member types
@@ -192,16 +192,16 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
dictTy = foldl TypeApp (TypeConstructor className) tys
constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'
-
+
return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
-
+
where
declName :: Declaration -> Maybe Ident
declName (PositionedDeclaration _ d) = declName d
declName (ValueDeclaration ident _ _ _ _) = Just ident
declName (TypeDeclaration ident _) = Just ident
- declName _ = Nothing
+ declName _ = Nothing
memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index adcafc1..072fcd4 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -675,6 +675,11 @@ infer' _ = error "Invalid argument to infer"
inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)
inferLetBinding seen [] ret j = (,) seen <$> j ret
+inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do
+ Just moduleName <- checkCurrentModule <$> get
+ let dict = if isFunction val then M.singleton (moduleName, ident) (ty, nameKind) else M.empty
+ TypedValue _ val' ty' <- if checkType then bindNames dict (check val ty) else return tv
+ bindNames (M.singleton (moduleName, ident) (ty', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing (TypedValue checkType val' ty')]) rest ret j
inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do
valTy <- fresh
Just moduleName <- checkCurrentModule <$> get
@@ -1103,3 +1108,4 @@ subsumes' val ty1 ty2 = do
+
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 0244c1f..2d3e6c4 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -182,3 +182,22 @@ freeTypeVariables = nub . go []
--
quantify :: Type -> Type
quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty
+
+-- |
+-- Move all universal quantifiers to the front of a type
+--
+moveQuantifiersToFront :: Type -> Type
+moveQuantifiersToFront = go [] []
+ where
+ go qs cs (ForAll q ty sco) = go ((q, sco) : qs) cs ty
+ go qs cs (ConstrainedType cs' ty) = go qs (cs ++ cs') ty
+ go qs cs ty =
+ let constrained = case cs of
+ [] -> ty
+ cs' -> ConstrainedType cs' ty
+ in case qs of
+ [] -> constrained
+ qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'
+
+
+
diff --git a/tests/Main.hs b/tests/Main.hs
index 7981faf..4d9e8b7 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -54,12 +54,13 @@ assert preludeExterns opts inputFile f = do
Just err -> putStrLn err >> exitFailure
Nothing -> return ()
-assertCompiles :: FilePath -> FilePath -> FilePath -> IO ()
+assertCompiles :: String -> FilePath -> FilePath -> IO ()
assertCompiles preludeJs preludeExterns inputFile = do
putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"
- let options = P.defaultOptions { P.optionsMain = Just "Main", P.optionsModules = ["Main"], P.optionsCodeGenModules = ["Main"] }
+ let options = P.defaultOptions { P.optionsMain = Just "Main", P.optionsModules = ["Main"], P.optionsCodeGenModules = ["Main"], P.optionsBrowserNamespace = Just "Tests" }
assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do
process <- findNodeProcess
+ putStrLn $ preludeJs ++ js
result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process
case result of
Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
@@ -69,7 +70,7 @@ assertCompiles preludeJs preludeExterns inputFile = do
assertDoesNotCompile :: FilePath -> FilePath -> IO ()
assertDoesNotCompile preludeExterns inputFile = do
putStrLn $ "Assert " ++ inputFile ++ " does not compile"
- assert preludeExterns P.defaultOptions inputFile $ \e ->
+ assert preludeExterns (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) inputFile $ \e ->
case e of
Left _ -> return Nothing
Right _ -> return $ Just "Should not have compiled"
@@ -82,7 +83,7 @@ main :: IO ()
main = do
prelude <- preludeFilename
putStrLn "Compiling Prelude"
- preludeResult <- compile P.defaultOptions [prelude]
+ preludeResult <- compile (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) [prelude]
case preludeResult of
Left err -> putStrLn err >> exitFailure
Right (preludeJs, exts, _) -> do