purescript 0.4.17.1 → 0.4.18
raw patch · 18 files changed
+311/−211 lines, 18 filesdep ~sybPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: syb
API changes (from Hackage documentation)
- Language.PureScript.CodeGen.JS: wrapExportsContainer :: Options -> [JS] -> JS
- Language.PureScript.Constants: (!!) :: String
- Language.PureScript.Constants: _ps :: String
+ Language.PureScript: progress :: MonadMake m => String -> m ()
+ Language.PureScript.CodeGen.JS: CommonJS :: ModuleType
+ Language.PureScript.CodeGen.JS: Globals :: ModuleType
+ Language.PureScript.CodeGen.JS: data ModuleType
+ Language.PureScript.Constants: preludeUnsafe :: String
+ Language.PureScript.Constants: unsafeIndex :: String
+ Language.PureScript.Names: runIdent :: Ident -> String
+ Language.PureScript.Types: moveQuantifiersToFront :: Type -> Type
- Language.PureScript: make :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] -> m ()
+ Language.PureScript: make :: (Functor m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment
- Language.PureScript.CodeGen.JS: moduleToJs :: Options -> Module -> Environment -> Maybe JS
+ Language.PureScript.CodeGen.JS: moduleToJs :: ModuleType -> Options -> Module -> Environment -> [JS]
- Language.PureScript.Optimizer.Inliner: inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS
+ Language.PureScript.Optimizer.Inliner: inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
- Language.PureScript.Options: Options :: Bool -> Bool -> Bool -> Bool -> Maybe String -> Bool -> String -> [String] -> [String] -> Bool -> Options
+ Language.PureScript.Options: Options :: Bool -> Bool -> Bool -> Bool -> Maybe String -> Bool -> Maybe String -> [String] -> [String] -> Bool -> Options
- Language.PureScript.Options: optionsBrowserNamespace :: Options -> String
+ Language.PureScript.Options: optionsBrowserNamespace :: Options -> Maybe String
Files
- prelude/prelude.purs +47/−13
- psc-make/Main.hs +10/−9
- psc/Main.hs +2/−1
- psci/Main.hs +101/−47
- purescript.cabal +6/−6
- src/Language/PureScript.hs +35/−33
- src/Language/PureScript/CodeGen/Common.hs +1/−0
- src/Language/PureScript/CodeGen/JS.hs +43/−39
- src/Language/PureScript/Constants.hs +6/−6
- src/Language/PureScript/Names.hs +4/−0
- src/Language/PureScript/Optimizer.hs +3/−3
- src/Language/PureScript/Optimizer/Inliner.hs +9/−22
- src/Language/PureScript/Optimizer/MagicDo.hs +7/−21
- src/Language/PureScript/Options.hs +2/−2
- src/Language/PureScript/Sugar/TypeClasses.hs +5/−5
- src/Language/PureScript/TypeChecker/Types.hs +6/−0
- src/Language/PureScript/Types.hs +19/−0
- tests/Main.hs +5/−4
prelude/prelude.purs view
@@ -6,9 +6,6 @@ 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 @@ (#) :: 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 @@ 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 @@ 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 @@ 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 @@ (++) :: 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@@ -379,6 +404,15 @@ instance eqRef :: Eq (Ref a) 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
psc-make/Main.hs view
@@ -67,16 +67,17 @@ 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 = 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 = 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 @@ 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
psc/Main.hs view
@@ -127,7 +127,7 @@ { 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 = do prelude <- preludeFilename run (term prelude, termInfo)+
psci/Main.hs view
@@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DoAndIfThenElse, FlexibleContexts #-}+{-# LANGUAGE DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-} module Main where @@ -24,29 +24,36 @@ 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 @@ data PSCiState = PSCiState { psciImportedFilenames :: [FilePath] , psciImportedModuleNames :: [P.ModuleName]- , psciLoadedModules :: [P.Module]+ , psciLoadedModules :: [(FilePath, P.Module)] , psciLetBindings :: [P.Value -> P.Value] } @@ -78,7 +85,7 @@ -- | -- 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 @@ 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,9 +204,41 @@ -- | 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. -- createTemporaryModule :: Bool -> PSCiState -> P.Value -> P.Module@@ -217,34 +256,45 @@ 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 @@ -- | -- 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 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 @@ 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 @@ 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 @@ main :: IO () main = Cmd.run (term, termInfo)-
purescript.cabal view
@@ -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 @@ 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 @@ 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-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 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 @@ 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
src/Language/PureScript.hs view
@@ -37,7 +37,7 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ -- 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 @@ 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 ]
src/Language/PureScript/CodeGen/Common.hs view
@@ -106,6 +106,7 @@ , "long" , "native" , "new"+ , "null" , "package" , "private" , "protected"
src/Language/PureScript/CodeGen/JS.hs view
@@ -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,27 +43,47 @@ 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 _ _ _ _ = 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 @@ -- 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 @@ 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
src/Language/PureScript/Constants.hs view
@@ -23,9 +23,6 @@ (#) :: String (#) = "#" -(!!) :: String-(!!) = "!!"- (++) :: String (++) = "++" @@ -80,6 +77,9 @@ (||) :: String (||) = "||" +unsafeIndex :: String+unsafeIndex = "unsafeIndex"+ -- Prelude Operator Functions negate :: String@@ -180,9 +180,6 @@ -- Code Generation -_ps :: String-_ps = "_ps"- __superclasses :: String __superclasses = "__superclasses" @@ -193,6 +190,9 @@ prelude :: String prelude = "Prelude"++preludeUnsafe :: String+preludeUnsafe = "Prelude_Unsafe" eff :: String eff = "Control_Monad_Eff"
src/Language/PureScript/Names.hs view
@@ -33,6 +33,10 @@ -- | 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 ++ ")"
src/Language/PureScript/Optimizer.hs view
@@ -63,9 +63,9 @@ , 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
src/Language/PureScript/Optimizer/Inliner.hs view
@@ -75,18 +75,14 @@ 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 @@ 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 @@ 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 @@ 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
src/Language/PureScript/Optimizer/MagicDo.hs view
@@ -80,31 +80,19 @@ 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 @@ 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)
src/Language/PureScript/Options.hs view
@@ -48,7 +48,7 @@ -- 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 @@ -- 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
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -145,7 +145,7 @@ 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 @@ 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 @@ 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
src/Language/PureScript/TypeChecker/Types.hs view
@@ -675,6 +675,11 @@ 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@@ -1100,6 +1105,7 @@ subsumes' val ty1 ty2 = do ty1 =?= ty2 return val+
src/Language/PureScript/Types.hs view
@@ -182,3 +182,22 @@ -- 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'+++
tests/Main.hs view
@@ -54,12 +54,13 @@ 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 @@ 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 = 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