cf17f6e · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Make PSCi work again

commitcf17f6e4da7d6de2e3885521e8f8f4fcefa89e90 authorGary Burgess <gary.burgess@gmail.com> dateSat 9 May 2015, 15:34 (11 years ago) parentaca96b2

5 files changed+180−65

compare with golang

unifiedsplit

psci/IO.hs+21 psci/Make.hs+124 psci/PSCi.hs+32−64 psci/Types.hs+2 purescript.cabal+1−1

psci/IO.hsnew file+21

@@ -0,0 +1,21 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : IO

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module IO where

16+

17+import System.Directory (createDirectoryIfMissing)

18+import System.FilePath (takeDirectory)

19+

20+mkdirp :: FilePath -> IO ()

21+mkdirp = createDirectoryIfMissing True . takeDirectory

psci/Make.hsnew file+124

@@ -0,0 +1,124 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Make

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DataKinds #-}

16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17+{-# LANGUAGE TupleSections #-}

18+

19+module Make where

20+

21+import Data.List (isPrefixOf)

22+import Data.Maybe (fromMaybe)

23+import Data.Time.Clock

24+import Data.Traversable (traverse)

25+import qualified Data.Map as M

26+

27+import Control.Applicative

28+import Control.Monad

29+import Control.Monad.Error.Class (MonadError(..))

30+import Control.Monad.IO.Class (MonadIO, liftIO)

31+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)

32+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)

33+import Control.Monad.Writer (MonadWriter, WriterT, runWriterT)

34+

35+import System.Directory (getModificationTime, doesFileExist)

36+import System.FilePath ((</>), pathSeparator)

37+import System.IO.Error (tryIOError)

38+

39+import qualified Language.PureScript as P

40+import qualified Language.PureScript.CodeGen.JS as J

41+import qualified Language.PureScript.CoreFn as CF

42+

43+import IO (mkdirp)

44+

45+options :: P.Options P.Make

46+options = P.Options False False False Nothing False False False P.MakeOptions

47+

48+modulesDir :: FilePath

49+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"

50+

51+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }

52+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))

53+

54+runMake :: Make a -> IO (Either P.MultipleErrors a)

55+runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake

56+

57+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a

58+makeIO f io = do

59+ e <- liftIO $ tryIOError io

60+ either (throwError . P.singleError . f) return e

61+

62+-- Traverse (Either e) instance (base 4.7)

63+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)

64+traverseEither _ (Left x) = pure (Left x)

65+traverseEither f (Right y) = Right <$> f y

66+

67+buildMakeActions :: M.Map P.ModuleName (Either P.RebuildPolicy String)

68+ -> M.Map P.ModuleName P.ForeignJS

69+ -> P.MakeActions Make

70+buildMakeActions filePathMap foreigns =

71+ P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress

72+ where

73+

74+ getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))

75+ getInputTimestamp mn = do

76+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap

77+ traverseEither getTimestamp path

78+

79+ getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)

80+ getOutputTimestamp mn = do

81+ let filePath = P.runModuleName mn

82+ jsFile = modulesDir </> filePath </> "index.js"

83+ externsFile = modulesDir </> filePath </> "externs.purs"

84+ min <$> getTimestamp jsFile <*> getTimestamp externsFile

85+

86+ readExterns :: P.ModuleName -> Make (FilePath, String)

87+ readExterns mn = do

88+ let path = modulesDir </> P.runModuleName mn </> "externs.purs"

89+ (path, ) <$> readTextFile path

90+

91+ codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()

92+ codegen m _ nextVar exts = do

93+ foreignInclude <- case CF.moduleName m `M.lookup` foreigns of

94+ Just _ | not $ requiresForeign m -> error "Found unnecessary foreign module"

95+ | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]

96+ Nothing | requiresForeign m -> error "Foreign module missing"

97+ | otherwise -> return Nothing

98+ pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude

99+ let filePath = P.runModuleName $ CF.moduleName m

100+ jsFile = modulesDir </> filePath </> "index.js"

101+ externsFile = modulesDir </> filePath </> "externs.purs"

102+ foreignFile = modulesDir </> filePath </> "foreign.js"

103+ writeTextFile jsFile pjs

104+ maybe (return ()) (writeTextFile foreignFile) $ CF.moduleName m `M.lookup` foreigns

105+ writeTextFile externsFile exts

106+

107+ requiresForeign :: CF.Module a -> Bool

108+ requiresForeign = not . null . CF.moduleForeign

109+

110+ getTimestamp :: FilePath -> Make (Maybe UTCTime)

111+ getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do

112+ exists <- doesFileExist path

113+ traverse (const $ getModificationTime path) $ guard exists

114+

115+ readTextFile :: FilePath -> Make String

116+ readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path

117+

118+ writeTextFile :: FilePath -> String -> Make ()

119+ writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do

120+ mkdirp path

121+ writeFile path text

122+

123+ progress :: String -> Make ()

124+ progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s

psci/PSCi.hs+32−64

@@ -13,39 +13,35 @@

1313--

1414-----------------------------------------------------------------------------

1515

16−{-# LANGUAGE DataKinds #-}

1716{-# LANGUAGE DoAndIfThenElse #-}

18−{-# LANGUAGE FlexibleContexts #-}

1917{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2018{-# LANGUAGE RecordWildCards #-}

2119

2220module PSCi where

2321

2422import Data.Foldable (traverse_)

25−import Data.List (intercalate, nub, sort, isPrefixOf)

23+import Data.List (intercalate, nub, sort)

2624import Data.Traversable (traverse)

25+import Data.Tuple (swap)

2726import Data.Version (showVersion)

2827import qualified Data.Map as M

2928

3029import Control.Applicative

30+import Control.Arrow (first)

3131import Control.Monad

32−import Control.Monad.IO.Class (MonadIO, liftIO)

33−import Control.Monad.Error.Class (MonadError(..))

34−import Control.Monad.Trans.Except (ExceptT(..), runExceptT)

35−import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)

36−import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, runWriter)

3732import Control.Monad.Trans.Class

33+import Control.Monad.Trans.Except (runExceptT)

3834import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

3935import Control.Monad.Trans.State.Strict

36+import Control.Monad.Writer (runWriter)

4037import qualified Control.Monad.Trans.State.Lazy as L

4138

4239import Options.Applicative as Opts

4340

4441import System.Console.Haskeline

45−import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)

42+import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)

4643import System.Exit

47−import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)

48−import System.IO.Error (tryIOError)

44+import System.FilePath (pathSeparator, (</>), isPathSeparator)

4945import System.Process (readProcessWithExitCode)

5046

5147import qualified Language.PureScript as P

@@ -53,8 +49,10 @@ import qualified Language.PureScript.Names as N

5349import qualified Paths_purescript as Paths

5450

5551import qualified Directive as D

56−import Parser (parseCommand)

5752import Completion (completion)

53+import IO (mkdirp)

54+import Make

55+import Parser (parseCommand)

5856import Types

5957

6058-- | The name of the PSCI support module

@@ -88,6 +86,7 @@ supportModule =

8886 ]

8987

9088-- File helpers

89+

9190-- |

9291-- Load the necessary modules.

9392--

@@ -118,7 +117,7 @@ getHistoryFilename = do

118117loadModule :: FilePath -> IO (Either String [P.Module])

119118loadModule filename = do

120119 content <- readFile filename

121− return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]

120+ return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]

122121

123122-- |

124123-- Load all modules, including the Prelude

@@ -147,6 +146,7 @@ loadAllImportedModules = do

147146expandTilde :: FilePath -> IO FilePath

148147expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory

149148expandTilde p = return p

149+

150150-- Messages

151151

152152-- |

@@ -160,13 +160,12 @@ helpMessage = "The following commands are available:\n\n " ++

160160 line :: (Directive, String, String) -> String

161161 line (dir, arg, desc) =

162162 let cmd = ':' : D.stringFor dir

163− in intercalate " "

164− [ cmd

165− , replicate (11 - length cmd) ' '

166− , arg

167− , replicate (11 - length arg) ' '

168− , desc

169− ]

163+ in unwords [ cmd

164+ , replicate (11 - length cmd) ' '

165+ , arg

166+ , replicate (11 - length arg) ' '

167+ , desc

168+ ]

170169

171170 extraHelp =

172171 "Further information is available on the PureScript wiki:\n" ++

@@ -194,14 +193,6 @@ prologueMessage = intercalate "\n"

194193quitMessage :: String

195194quitMessage = "See ya!"

196195

197−

198−-- Compilation

199−

200−-- | Compilation options.

201−--

202−options :: P.Options P.Make

203−options = P.Options False False False Nothing False False False P.MakeOptions

204−

205196-- |

206197-- PSCI monad

207198--

@@ -210,30 +201,6 @@ newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Fu

210201psciIO :: IO a -> PSCI a

211202psciIO io = PSCI . lift $ lift io

212203

213−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }

214− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))

215−

216−runMake :: Make a -> IO (Either P.MultipleErrors a)

217−runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake

218−

219−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a

220−makeIO f io = do

221− e <- liftIO $ tryIOError io

222− either (throwError . P.singleError . f) return e

223−

224−instance P.MonadMake Make where

225− getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do

226− exists <- doesFileExist path

227− traverse (const $ getModificationTime path) $ guard exists

228− readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path

229− writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do

230− mkdirp path

231− writeFile path text

232− progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s

233−

234−mkdirp :: FilePath -> IO ()

235−mkdirp = createDirectoryIfMissing True . takeDirectory

236−

237204-- |

238205-- Makes a volatile module to execute the current expression.

239206--

@@ -274,12 +241,14 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =

274241importDecl :: ImportedModule -> P.Declaration

275242importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ

276243

277−modulesDir :: FilePath

278−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"

279−

280244indexFile :: FilePath

281245indexFile = ".psci_modules" ++ pathSeparator : "index.js"

282246

247+make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> Make P.Environment

248+make PSCiState{..} ms =

249+ let filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)

250+ in P.make (buildMakeActions filePathMap M.empty) (psciLoadedModules ++ ms)

251+

283252-- |

284253-- Takes a value declaration and evaluates it with the current state.

285254--

@@ -288,7 +257,7 @@ handleDeclaration val = do

288257 st <- PSCI $ lift get

289258 let m = createTemporaryModule True st val

290259 let nodeArgs = psciNodeFlags st ++ [indexFile]

291− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)]) []

260+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)]

292261 case e of

293262 Left errs -> printErrors errs

294263 Right _ -> do

@@ -309,7 +278,7 @@ handleDecls ds = do

309278 st <- PSCI $ lift get

310279 let st' = updateLets ds st

311280 let m = createTemporaryModule False st' (P.ObjectLiteral [])

312− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []

281+ e <- psciIO . runMake $ make st' [(Left P.RebuildAlways, m)]

313282 case e of

314283 Left err -> printErrors err

315284 Right _ -> PSCI $ lift (put st')

@@ -362,7 +331,7 @@ handleImport :: ImportedModule -> PSCI ()

362331handleImport im = do

363332 st <- updateImportedModules im <$> PSCI (lift get)

364333 let m = createTemporaryModuleForImports st

365− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

334+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]

366335 case e of

367336 Left errs -> printErrors errs

368337 Right _ -> do

@@ -376,7 +345,7 @@ handleTypeOf :: P.Expr -> PSCI ()

376345handleTypeOf val = do

377346 st <- PSCI $ lift get

378347 let m = createTemporaryModule False st val

379− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

348+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]

380349 case e of

381350 Left errs -> printErrors errs

382351 Right env' ->

@@ -409,12 +378,11 @@ printModuleSignatures moduleName env =

409378handleBrowse :: P.ModuleName -> PSCI ()

410379handleBrowse moduleName = do

411380 st <- PSCI $ lift get

412− let loadedModules = psciLoadedModules st

413− env <- psciIO . runMake $ P.make modulesDir loadedModules []

381+ env <- psciIO . runMake $ make st []

414382 case env of

415383 Left errs -> printErrors errs

416384 Right env' ->

417− if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules

385+ if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)

418386 then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."

419387 else printModuleSignatures moduleName env'

420388

@@ -430,7 +398,7 @@ handleKindOf typ = do

430398 st <- PSCI $ lift get

431399 let m = createTemporaryModuleForKind st typ

432400 mName = P.ModuleName [P.ProperName "$PSCI"]

433− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

401+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]

434402 case e of

435403 Left errs -> printErrors errs

436404 Right env' ->

@@ -519,7 +487,7 @@ loop PSCiOptions{..} = do

519487 config <- loadUserConfig

520488 modulesOrFirstError <- loadAllModules psciInputFile

521489 case modulesOrFirstError of

522− Left err -> print err >> exitFailure

490+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

523491 Right modules -> do

524492 historyFilename <- getHistoryFilename

525493 let settings = defaultSettings { historyFile = Just historyFilename }

psci/Types.hs+2

@@ -15,6 +15,7 @@

1515

1616module Types where

1717

18+import qualified Data.Map as M

1819import qualified Language.PureScript as P

1920

2021data PSCiOptions = PSCiOptions

@@ -33,6 +34,7 @@ data PSCiState = PSCiState

3334 { psciImportedFilenames :: [FilePath]

3435 , psciImportedModules :: [ImportedModule]

3536 , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]

37+ --, psciForeignFiles :: M.Map P.ModuleName P.ForeignJS

3638 , psciLetBindings :: [P.Declaration]

3739 , psciNodeFlags :: [String]

3840 }

purescript.cabal+1−1

@@ -166,7 +166,7 @@ executable psci

166166 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

167167 mtl -any, optparse-applicative >= 0.10.0, parsec -any,

168168 haskeline >= 0.7.0.0, purescript -any, transformers -any,

169− transformers-compat -any, process -any

169+ transformers-compat -any, process -any, time -any

170170

171171 main-is: Main.hs

172172 buildable: True