git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge branch 'make'
ec1ee67Phil Freeman
psc/Main.hs+71−25
compare with golang
unifiedsplit
@@ -12,17 +12,21 @@
12--
12--
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+
15module Main where
17module Main where
16
18
17import Control.Applicative
19import Control.Applicative
18−import Control.Monad (forM)
20+import Control.Monad.Error
19
21
20import Data.Version (showVersion)
22import Data.Version (showVersion)
21
23
22import System.Console.CmdTheLine
24import System.Console.CmdTheLine
23−import System.Directory (createDirectoryIfMissing)
25+import System.Directory
26+ (doesFileExist, getModificationTime, createDirectoryIfMissing)
24import System.FilePath (takeDirectory)
27import System.FilePath (takeDirectory)
25import System.Exit (exitSuccess, exitFailure)
28import System.Exit (exitSuccess, exitFailure)
29+import System.IO.Error (tryIOError)
26
30
27import Text.Parsec (ParseError)
31import Text.Parsec (ParseError)
28
32
@@ -33,35 +37,73 @@ import qualified System.IO.UTF8 as U
33preludeFilename :: IO FilePath
37preludeFilename :: IO FilePath
34preludeFilename = Paths.getDataFileName "prelude/prelude.purs"
38preludeFilename = Paths.getDataFileName "prelude/prelude.purs"
35
39
36−readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])
40+readInput :: Maybe [FilePath] -> IO (Either ParseError [(FilePath, P.Module)])
41+readInput Nothing = do
42+ text <- getContents
37−readInput Nothing = P.runIndentParser "" P.parseModules <$> getContents
43+ return $ map ((,) undefined) <$> P.runIndentParser "" P.parseModules text
38−readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do
44+readInput (Just input) = fmap collect $ forM input $ \inputFile -> do
39 text <- U.readFile inputFile
45 text <- U.readFile inputFile
40− return $ P.runIndentParser inputFile P.parseModules text
46+ return $ (inputFile, P.runIndentParser inputFile P.parseModules text)
41−
47+ where
48+ collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]
49+ collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)
50+
51+newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Monad, MonadIO, MonadError String)
52+
53+runMake :: Make a -> IO (Either String a)
54+runMake = runErrorT . unMake
55+
56+makeIO :: IO a -> Make a
57+makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
58+
59+instance P.MonadMake Make where
60+ getTimestamp path = makeIO $ do
61+ exists <- doesFileExist path
62+ case exists of
63+ True -> Just <$> getModificationTime path
64+ False -> return Nothing
65+ readTextFile path = makeIO $ do
66+ U.putStrLn $ "Reading " ++ path
67+ U.readFile path
68+ writeTextFile path text = makeIO $ do
69+ mkdirp path
70+ U.putStrLn $ "Writing " ++ path
71+ U.writeFile path text
72+ liftError = either throwError return
73+
42−compile :: P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
74+compile :: Bool -> P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
43−compile opts input output externs = do
75+compile makeMode opts input output externs = do
44 modules <- readInput input
76 modules <- readInput input
45 case modules of
77 case modules of
46 Left err -> do
78 Left err -> do
47 U.print err
79 U.print err
48 exitFailure
80 exitFailure
49 Right ms ->
81 Right ms ->
82+ case makeMode of
83+ True -> do
84+ e <- runMake $ P.make opts ms
85+ case e of
86+ Left err -> do
87+ U.putStrLn err
88+ exitFailure
89+ Right _ -> do
90+ exitSuccess
91+ False ->
50− case P.compile opts ms of
92+ case P.compile opts (map snd ms) of
51− Left err -> do
93+ Left err -> do
52− U.putStrLn err
94+ U.putStrLn err
53− exitFailure
95+ exitFailure
54− Right (js, exts, _) -> do
96+ Right (js, exts, _) -> do
55− case output of
97+ case output of
56− Just path -> mkdirp path >> U.writeFile path js
98+ Just path -> mkdirp path >> U.writeFile path js
57− Nothing -> U.putStrLn js
99+ Nothing -> U.putStrLn js
58− case externs of
100+ case externs of
59− Just path -> mkdirp path >> U.writeFile path exts
101+ Just path -> mkdirp path >> U.writeFile path exts
60− Nothing -> return ()
102+ Nothing -> return ()
61− exitSuccess
103+ exitSuccess
62− where
104+
63− mkdirp :: FilePath -> IO ()
105+mkdirp :: FilePath -> IO ()
64− mkdirp = createDirectoryIfMissing True . takeDirectory
106+mkdirp = createDirectoryIfMissing True . takeDirectory
65
107
66useStdIn :: Term Bool
108useStdIn :: Term Bool
67useStdIn = value . flag $ (optInfo [ "s", "stdin" ])
109useStdIn = value . flag $ (optInfo [ "s", "stdin" ])
@@ -103,6 +145,10 @@ noOpts :: Term Bool
103noOpts = value $ flag $ (optInfo [ "no-opts" ])
145noOpts = value $ flag $ (optInfo [ "no-opts" ])
104 { optDoc = "Skip the optimization phase." }
146 { optDoc = "Skip the optimization phase." }
105
147
148+make :: Term Bool
149+make = value $ flag $ (optInfo [ "make" ])
150+ { optDoc = "Run in make mode" }
151+
106browserNamespace :: Term String
152browserNamespace :: Term String
107browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
153browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
108 { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
154 { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
@@ -126,7 +172,7 @@ stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inp
126 combine True _ _ = Nothing
172 combine True _ _ = Nothing
127
173
128term :: FilePath -> Term (IO ())
174term :: FilePath -> Term (IO ())
129−term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile
175+term prelude = compile <$> make <*> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile
130
176
131termInfo :: TermInfo
177termInfo :: TermInfo
132termInfo = defTI
178termInfo = defTI
purescript.cabal+1−1
@@ -21,7 +21,7 @@ library
21 build-depends: base >=4 && <5, cmdtheline -any, containers -any,
21 build-depends: base >=4 && <5, cmdtheline -any, containers -any,
22 directory -any, filepath -any, mtl -any, parsec -any, syb -any,
22 directory -any, filepath -any, mtl -any, parsec -any, syb -any,
23 transformers -any, utf8-string -any, pattern-arrows -any, monad-unify >= 0.2 && < 0.3,
23 transformers -any, utf8-string -any, pattern-arrows -any, monad-unify >= 0.2 && < 0.3,
24− xdg-basedir -any
24+ xdg-basedir -any, time -any
25 if (!os(windows))
25 if (!os(windows))
26 build-depends: unix -any
26 build-depends: unix -any
27 exposed-modules: Data.Generics.Extras
27 exposed-modules: Data.Generics.Extras
src/Language/PureScript.hs+105−5
@@ -13,7 +13,7 @@
13--
13--
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15
15
16−module Language.PureScript (module P, compile) where
16+module Language.PureScript (module P, compile, MonadMake(..), make) where
17
17
18import Language.PureScript.Values as P
18import Language.PureScript.Values as P
19import Language.PureScript.Types as P
19import Language.PureScript.Types as P
@@ -34,10 +34,12 @@ import Language.PureScript.DeadCodeElimination as P
34import qualified Language.PureScript.Constants as C
34import qualified Language.PureScript.Constants as C
35
35
36import Data.List (intercalate)
36import Data.List (intercalate)
37−import Data.Maybe (mapMaybe)
37+import Data.Time.Clock
38+import Data.Maybe (fromMaybe, mapMaybe)
38import Control.Monad.State.Lazy
39import Control.Monad.State.Lazy
39import Control.Applicative ((<$>), (<*>), pure)
40import Control.Applicative ((<$>), (<*>), pure)
40import qualified Data.Map as M
41import qualified Data.Map as M
42+import System.FilePath (pathSeparator)
41
43
42-- |
44-- |
43-- Compile a collection of modules
45-- Compile a collection of modules
@@ -72,12 +74,110 @@ compile opts ms = do
72 let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
74 let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
73 let js = mapMaybe (flip (moduleToJs opts) env) modulesToCodeGen
75 let js = mapMaybe (flip (moduleToJs opts) env) modulesToCodeGen
74 let exts = intercalate "\n" . map (`moduleToPs` env) $ modulesToCodeGen
76 let exts = intercalate "\n" . map (`moduleToPs` env) $ modulesToCodeGen
77+ js' <- generateMain env opts js
78+ return (prettyPrintJS [wrapExportsContainer opts js'], exts, env)
79+ where
75− js' <- case mainModuleIdent of
80+ mainModuleIdent = moduleNameFromString <$> optionsMain opts
81+
82+generateMain :: Environment -> Options -> [JS] -> Either String [JS]
83+generateMain env opts js =
84+ case moduleNameFromString <$> optionsMain opts of
76 Just mmi -> do
85 Just mmi -> do
77 when ((mmi, Ident C.main) `M.notMember` names env) $
86 when ((mmi, Ident C.main) `M.notMember` names env) $
78 Left $ show mmi ++ "." ++ C.main ++ " is undefined"
87 Left $ show mmi ++ "." ++ C.main ++ " is undefined"
79 return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar C._ps))) []]
88 return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar C._ps))) []]
80 _ -> return js
89 _ -> return js
81− return (prettyPrintJS [wrapExportsContainer opts js'], exts, env)
90+
91+-- |
92+-- A type class which collects the IO actions we need to be able to run in "make" mode
93+--
94+class MonadMake m where
95+ -- |
96+ -- Get a file timestamp
97+ --
98+ getTimestamp :: FilePath -> m (Maybe UTCTime)
99+
100+ -- |
101+ -- Read a file as a string
102+ --
103+ readTextFile :: FilePath -> m String
104+
105+ -- |
106+ -- Write a text file
107+ --
108+ writeTextFile :: FilePath -> String -> m ()
109+
110+ -- |
111+ -- Report an error
112+ --
113+ liftError :: Either String a -> m a
114+
115+
116+-- |
117+-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
118+--
119+-- If timestamps have not changed, the externs file can be used to provide the module's types without
120+-- having to typecheck the module again.
121+--
122+make :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] -> m ()
123+make opts ms = do
124+ let filePathMap = M.fromList (map (\(fp, (Module mn _ _)) -> (mn, fp)) ms)
125+
126+ sorted <- liftError $ sortModules (map snd ms)
127+
128+ marked <- forM sorted $ \m@(Module moduleName' _ _) -> do
129+ let filePath = toFileName moduleName'
130+
131+ jsFile = "js" ++ pathSeparator : filePath ++ ".js"
132+ externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
133+ inputFile = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap
134+
135+ jsTimestamp <- getTimestamp jsFile
136+ externsTimestamp <- getTimestamp externsFile
137+ inputTimestamp <- getTimestamp inputFile
138+
139+ case inputTimestamp < min jsTimestamp externsTimestamp of
140+ True -> do
141+ externs <- readTextFile externsFile
142+ externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs
143+ case externsModules of
144+ [m'@(Module moduleName'' _ _)] | moduleName' == moduleName'' -> return (True, m')
145+ _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
146+ False -> return (False, m)
147+
148+ desugared <- liftError $ zip (map fst marked) <$> desugar (map snd marked)
149+
150+ go initEnvironment desugared
151+
82 where
152 where
83− mainModuleIdent = moduleNameFromString <$> optionsMain opts
153+ go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
154+ go _ [] = return ()
155+ go env ((True, Module moduleName' typings _) : ms') = do
156+ (_, env') <- liftError . runCheck' env $ do
157+ modify (\s -> s { checkCurrentModule = Just moduleName' })
158+ typeCheckAll Nothing moduleName' typings
159+
160+ go env' ms'
161+ go env ((False, Module moduleName' decls exps) : ms') = do
162+ let filePath = toFileName moduleName'
163+ jsFile = "js" ++ pathSeparator : filePath ++ ".js"
164+ externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
165+
166+ (elaborated, env') <- liftError . runCheck' env $ do
167+ modify (\s -> s { checkCurrentModule = Just moduleName' })
168+ typeCheckAll Nothing moduleName' decls
169+
170+ regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
171+
172+ let mod' = Module moduleName' regrouped exps
173+ js = moduleToJs opts mod' env'
174+ exts = moduleToPs mod' env'
175+ js' = maybe "" (prettyPrintJS . return . wrapExportsContainer opts . return) js
176+
177+ writeTextFile jsFile js'
178+ writeTextFile externsFile exts
179+
180+ go env' ms'
181+
182+ toFileName :: ModuleName -> FilePath
183+ toFileName (ModuleName ps) = intercalate [pathSeparator] . map runProperName $ ps
src/Language/PureScript/TypeChecker/Monad.hs+9−3
@@ -153,11 +153,17 @@ modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
153modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
153modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
154
154
155-- |
155-- |
156−-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
156+-- Run a computation in the Check monad, starting with an empty @Environment@
157--
157--
158runCheck :: Check a -> Either String (a, Environment)
158runCheck :: Check a -> Either String (a, Environment)
159−runCheck c = do
159+runCheck = runCheck' initEnvironment
160+
161+-- |
162+-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
163+--
164+runCheck' :: Environment -> Check a -> Either String (a, Environment)
165+runCheck' env c = do
160− (a, s) <- flip runStateT (CheckState initEnvironment 0 0 Nothing) $ unCheck c
166+ (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
161 return (a, checkEnv s)
167 return (a, checkEnv s)
162
168
163-- |
169-- |