purescript 0.4.6 → 0.4.7
raw patch · 6 files changed
+232/−79 lines, 6 filesnew-component:exe:psc-make
Files
- psc-make/Main.hs +140/−0
- psc/Main.hs +17/−56
- purescript.cabal +11/−1
- src/Language/PureScript.hs +36/−16
- src/Language/PureScript/ModuleDependencies.hs +11/−3
- src/Language/PureScript/Sugar/Names.hs +17/−3
+ psc-make/Main.hs view
@@ -0,0 +1,140 @@+-----------------------------------------------------------------------------+--+-- Module : Main+-- Copyright : (c) Phil Freeman 2013+-- License : MIT+--+-- Maintainer : Phil Freeman <paf31@cantab.net>+-- Stability : experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Main where++import Control.Applicative+import Control.Monad.Error++import Data.Version (showVersion)++import System.Console.CmdTheLine+import System.Directory+ (doesFileExist, getModificationTime, createDirectoryIfMissing)+import System.FilePath (takeDirectory)+import System.Exit (exitSuccess, exitFailure)+import System.IO.Error (tryIOError)++import Text.Parsec (ParseError)++import qualified Language.PureScript as P+import qualified Paths_purescript as Paths+import qualified System.IO.UTF8 as U++preludeFilename :: IO FilePath+preludeFilename = Paths.getDataFileName "prelude/prelude.purs"++readInput :: [FilePath] -> IO (Either ParseError [(FilePath, P.Module)])+readInput input = fmap collect $ forM input $ \inputFile -> do+ text <- U.readFile inputFile+ return $ (inputFile, P.runIndentParser inputFile P.parseModules text)+ where+ collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]+ collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)++newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Monad, MonadIO, 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 $ do+ U.putStrLn $ "Reading " ++ path+ U.readFile path+ writeTextFile path text = makeIO $ do+ mkdirp path+ U.putStrLn $ "Writing " ++ path+ U.writeFile path text+ liftError = either throwError return++compile :: P.Options -> [FilePath] -> IO ()+compile 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+ case e of+ Left err -> do+ U.putStrLn err+ exitFailure+ Right _ -> do+ exitSuccess++mkdirp :: FilePath -> IO ()+mkdirp = createDirectoryIfMissing True . takeDirectory++inputFiles :: Term [FilePath]+inputFiles = value $ posAny [] $ posInfo+ { posDoc = "The input .ps files" }++tco :: Term Bool+tco = value $ flag $ (optInfo [ "tco" ])+ { optDoc = "Perform tail call optimizations" }++performRuntimeTypeChecks :: Term Bool+performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])+ { optDoc = "Generate runtime type checks" }++noPrelude :: Term Bool+noPrelude = value $ flag $ (optInfo [ "no-prelude" ])+ { optDoc = "Omit the Prelude" }++magicDo :: Term Bool+magicDo = value $ flag $ (optInfo [ "magic-do" ])+ { optDoc = "Overload the do keyword to generate efficient code specifically for the Eff monad." }++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." }++options :: Term P.Options+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure []++inputFilesAndPrelude :: FilePath -> Term [FilePath]+inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles+ where+ combine True input = prelude : input+ combine False input = input++term :: FilePath -> Term (IO ())+term prelude = compile <$> options <*> inputFilesAndPrelude prelude++termInfo :: TermInfo+termInfo = defTI+ { termName = "psc-make"+ , version = showVersion Paths.version+ , termDoc = "Compiles PureScript to Javascript"+ }++main :: IO ()+main = do+ prelude <- preludeFilename+ run (term prelude, termInfo)
psc/Main.hs view
@@ -22,11 +22,9 @@ import Data.Version (showVersion) import System.Console.CmdTheLine-import System.Directory- (doesFileExist, getModificationTime, createDirectoryIfMissing)+import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) import System.Exit (exitSuccess, exitFailure)-import System.IO.Error (tryIOError) import Text.Parsec (ParseError) @@ -48,59 +46,26 @@ collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)] collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e) -newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Monad, MonadIO, 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 $ do- U.putStrLn $ "Reading " ++ path- U.readFile path- writeTextFile path text = makeIO $ do- mkdirp path- U.putStrLn $ "Writing " ++ path- U.writeFile path text- liftError = either throwError return--compile :: Bool -> P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()-compile makeMode opts input output externs = do+compile :: P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()+compile opts input output externs = do modules <- readInput input case modules of Left err -> do U.print err exitFailure- Right ms ->- case makeMode of- True -> do- e <- runMake $ P.make opts ms- case e of- Left err -> do- U.putStrLn err- exitFailure- Right _ -> do- exitSuccess- False ->- case P.compile opts (map snd ms) of- Left err -> do- U.putStrLn err- exitFailure- Right (js, exts, _) -> do- case output of- Just path -> mkdirp path >> U.writeFile path js- Nothing -> U.putStrLn js- case externs of- Just path -> mkdirp path >> U.writeFile path exts- Nothing -> return ()- exitSuccess+ Right ms -> do+ case P.compile opts (map snd ms) of+ Left err -> do+ U.putStrLn err+ exitFailure+ Right (js, exts, _) -> do+ case output of+ Just path -> mkdirp path >> U.writeFile path js+ Nothing -> U.putStrLn js+ case externs of+ Just path -> mkdirp path >> U.writeFile path exts+ Nothing -> return ()+ exitSuccess mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory@@ -145,10 +110,6 @@ noOpts = value $ flag $ (optInfo [ "no-opts" ]) { optDoc = "Skip the optimization phase." } -make :: Term Bool-make = value $ flag $ (optInfo [ "make" ])- { optDoc = "Run in make mode" }- 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." }@@ -172,7 +133,7 @@ combine True _ _ = Nothing term :: FilePath -> Term (IO ())-term prelude = compile <$> make <*> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile+term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile termInfo :: TermInfo termInfo = defTI
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.4.6+version: 0.4.7 cabal-version: >=1.8 build-type: Custom license: MIT@@ -90,6 +90,16 @@ main-is: Main.hs buildable: True hs-source-dirs: psc+ other-modules:+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind++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+ main-is: Main.hs+ buildable: True+ hs-source-dirs: psc-make other-modules: ghc-options: -Wall -O2 -fno-warn-unused-do-bind
src/Language/PureScript.hs view
@@ -33,12 +33,15 @@ import qualified Language.PureScript.Constants as C -import Data.List (intercalate)+import Data.List (sortBy, groupBy, intercalate) import Data.Time.Clock+import Data.Function (on) import Data.Maybe (fromMaybe, mapMaybe) import Control.Monad.State.Lazy+import Control.Arrow ((&&&)) import Control.Applicative ((<$>), (<*>), pure) import qualified Data.Map as M+import qualified Data.Set as S import System.FilePath (pathSeparator) -- |@@ -65,7 +68,7 @@ compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment) compile' env opts ms = do- sorted <- sortModules ms+ (sorted, _) <- sortModules ms desugared <- desugar sorted (elaborated, env') <- runCheck' env $ forM desugared $ \(Module moduleName' decls exps) -> do modify (\s -> s { checkCurrentModule = Just moduleName' })@@ -126,9 +129,9 @@ make opts ms = do let filePathMap = M.fromList (map (\(fp, (Module mn _ _)) -> (mn, fp)) ms) - sorted <- liftError $ sortModules (map snd ms)+ (sorted, graph) <- liftError $ sortModules (map snd ms) - marked <- forM sorted $ \m@(Module moduleName' _ _) -> do+ toRebuild <- foldM (\s (Module moduleName' _ _) -> do let filePath = toFileName moduleName' jsFile = "js" ++ pathSeparator : filePath ++ ".js"@@ -139,15 +142,12 @@ externsTimestamp <- getTimestamp externsFile inputTimestamp <- getTimestamp inputFile - case inputTimestamp < min jsTimestamp externsTimestamp of- True -> do- externs <- readTextFile externsFile- externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs- case externsModules of- [m'@(Module moduleName'' _ _)] | moduleName' == moduleName'' -> return (True, m')- _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"- False -> return (False, m)+ return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of+ (Just t1, Just t2, Just t3) | t1 < min t2 t3 -> s+ _ -> S.insert moduleName' s) S.empty sorted + marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted+ desugared <- liftError $ zip (map fst marked) <$> desugar (map snd marked) go initEnvironment desugared@@ -155,13 +155,13 @@ where go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m () go _ [] = return ()- go env ((True, Module moduleName' typings _) : ms') = do+ go env ((False, Module moduleName' typings _) : ms') = do (_, env') <- liftError . runCheck' env $ do modify (\s -> s { checkCurrentModule = Just moduleName' }) typeCheckAll Nothing moduleName' typings go env' ms'- go env ((False, Module moduleName' decls exps) : ms') = do+ go env ((True, Module moduleName' decls exps) : ms') = do let filePath = toFileName moduleName' jsFile = "js" ++ pathSeparator : filePath ++ ".js" externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"@@ -182,5 +182,25 @@ go env' ms' - toFileName :: ModuleName -> FilePath- toFileName (ModuleName ps) = intercalate [pathSeparator] . map runProperName $ ps+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"++reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]+reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]+ where+ combine :: (Ord a) => [(a, b)] -> M.Map a [b]+ combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
src/Language/PureScript/ModuleDependencies.hs view
@@ -13,7 +13,8 @@ ----------------------------------------------------------------------------- module Language.PureScript.ModuleDependencies (- sortModules+ sortModules,+ ModuleGraph ) where import Data.Data@@ -25,14 +26,21 @@ import Language.PureScript.Names -- |+-- A list of modules with their dependencies+--+type ModuleGraph = [(ModuleName, [ModuleName])]++-- | -- Sort a collection of modules based on module dependencies. -- -- Reports an error if the module graph contains a cycle. ---sortModules :: [Module] -> Either String [Module]+sortModules :: [Module] -> Either String ([Module], ModuleGraph) sortModules ms = do let verts = map (\m -> (m, getModuleName m, usedModules m)) ms- mapM toModule $ stronglyConnComp verts+ ms' <- mapM toModule $ stronglyConnComp verts+ let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts+ return (ms', moduleGraph) -- | -- Calculate a list of used modules based on explicit imports and qualified names
src/Language/PureScript/Sugar/Names.hs view
@@ -134,9 +134,10 @@ -- desugarImports :: [Module] -> Either String [Module] desugarImports modules = do- unfilteredExports <- findExports modules- exports <- foldM filterModuleExports unfilteredExports modules- mapM (renameInModule' unfilteredExports exports) modules+ let modules' = importPrelude `map` modules+ unfilteredExports <- findExports modules'+ exports <- foldM filterModuleExports unfilteredExports modules'+ mapM (renameInModule' unfilteredExports exports) modules' where -- Filters the exports for a module in the global exports environment so that only explicitly@@ -154,6 +155,19 @@ let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports imports <- resolveImports env m renameInModule imports env (elaborateExports exps m)++-- |+-- Add an import declaration for the Prelude to a module if it does not already explicitly import+-- it.+--+importPrelude :: Module -> Module+importPrelude m@(Module mn decls exps) =+ if isPreludeImport `any` decls then m+ else Module mn (preludeImport : decls) exps+ where+ isPreludeImport (ImportDeclaration (ModuleName [ProperName "Prelude"]) _ _) = True+ isPreludeImport _ = False+ preludeImport = ImportDeclaration (ModuleName [ProperName "Prelude"]) Nothing Nothing -- | -- Rethrow an error with the name of the current module in the case of a failure