summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-03-19 03:31:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-03-19 03:31:00 (GMT)
commitbf87ee05e1265213864f784b3c11140f4a3642dd (patch)
tree8db150629fe7378ae3a727ae561e51bb95639f17
parent22f2ab9d5dabb1a6265ce8308bf7ef2c6cd05983 (diff)
version 0.4.70.4.7
-rw-r--r--psc-make/Main.hs140
-rw-r--r--psc/Main.hs73
-rw-r--r--purescript.cabal12
-rw-r--r--src/Language/PureScript.hs52
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs14
-rw-r--r--src/Language/PureScript/Sugar/Names.hs20
6 files changed, 232 insertions, 79 deletions
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
new file mode 100644
index 0000000..877c96c
--- /dev/null
+++ b/psc-make/Main.hs
@@ -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)
diff --git a/psc/Main.hs b/psc/Main.hs
index bb6bd9c..b37fae8 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -22,11 +22,9 @@ import Control.Monad.Error
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 @@ readInput (Just input) = fmap collect $ forM input $ \inputFile -> do
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 :: Term Bool
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 @@ stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inp
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
diff --git a/purescript.cabal b/purescript.cabal
index 78b6568..6973b9a 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.6
+version: 0.4.7
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -93,6 +93,16 @@ executable 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
+
executable psci
build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
mtl -any, parsec -any, haskeline -any, purescript -any,
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index ad3c08c..09a364b 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -33,12 +33,15 @@ import Language.PureScript.DeadCodeElimination as P
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 = compile' initEnvironment
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 :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] ->
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,14 +142,11 @@ make opts ms = do
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)
@@ -155,13 +155,13 @@ make opts ms = do
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 @@ make opts ms = do
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)
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 77446ca..9f4a148 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -13,7 +13,8 @@
-----------------------------------------------------------------------------
module Language.PureScript.ModuleDependencies (
- sortModules
+ sortModules,
+ ModuleGraph
) where
import Data.Data
@@ -25,14 +26,21 @@ import Language.PureScript.Declarations
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
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 92eb722..d739176 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -134,9 +134,10 @@ addExport exports name =
--
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
@@ -156,6 +157,19 @@ desugarImports modules = do
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
--
rethrowForModule :: Module -> Either String a -> Either String a