git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
psc --make #218
1efe77bPhil Freeman
psc/Main.hs+76−29
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." }
@@ -119,14 +165,15 @@ options :: Term P.Options
119options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules
165options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules
120
166
121stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
167stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
122−stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
168+stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles <*> make
123 where
169 where
170+ combine _ _ input True = Just input
124− combine False True input = Just (prelude : input)
171+ combine False True input _ = Just (prelude : input)
125− combine False False input = Just input
172+ combine False False input _ = Just input
126− combine True _ _ = Nothing
173+ combine True _ _ _ = Nothing
127
174
128term :: FilePath -> Term (IO ())
175term :: FilePath -> Term (IO ())
129−term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile
176+term prelude = compile <$> make <*> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile
130
177
131termInfo :: TermInfo
178termInfo :: TermInfo
132termInfo = defTI
179termInfo = 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+93−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,98 @@ 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 :: (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+ desugared <- liftError $ do
127+ sorted <- sortModules (map snd ms)
128+ desugar sorted
129+ go initEnvironment filePathMap desugared
130+
82 where
131 where
83− mainModuleIdent = moduleNameFromString <$> optionsMain opts
132+ go :: (Monad m, MonadMake m) => Environment -> M.Map ModuleName FilePath -> [Module] -> m ()
133+ go _ _ [] = return ()
134+ go env filePathMap (Module moduleName' decls exps : ms') = do
135+ let filePath = toFileName moduleName'
136+ let jsFile = "js" ++ pathSeparator : filePath ++ ".js"
137+ externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
138+
139+ jsTimestamp <- getTimestamp jsFile
140+ externsTimestamp <- getTimestamp externsFile
141+
142+ let inputFile = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap
143+ inputTimestamp <- getTimestamp inputFile
144+
145+ env' <- case () of
146+ _ | inputTimestamp < min jsTimestamp externsTimestamp -> do
147+ externs <- readTextFile externsFile
148+ externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs
149+ case externsModules of
150+ [Module moduleName'' typings _] | moduleName' == moduleName'' -> do
151+ (_, env') <- liftError . runCheck' env $ do
152+ modify (\s -> s { checkCurrentModule = Just moduleName' })
153+ typeCheckAll Nothing moduleName' typings
154+ return env'
155+ _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
156+ | otherwise -> do
157+ (elaborated, env') <- liftError . runCheck' env $ do
158+ modify (\s -> s { checkCurrentModule = Just moduleName' })
159+ typeCheckAll Nothing moduleName' decls
160+ regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
161+ let mod' = Module moduleName' regrouped exps
162+ js = moduleToJs opts mod' env'
163+ exts = moduleToPs mod' env'
164+ js' = maybe "" (prettyPrintJS . return . wrapExportsContainer opts . return) js
165+ writeTextFile jsFile js'
166+ writeTextFile externsFile exts
167+ return env'
168+ go env' filePathMap ms'
169+
170+ toFileName :: ModuleName -> FilePath
171+ 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-- |