76fb7f8 · rowtype-yoga/purescript-native

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

refactor PSCi code

76fb7f8Zhen Zhang11 years ago

CONTRIBUTORS.md+1

@@ -65,6 +65,7 @@ This file lists the contributors to the PureScript compiler project, and the ter

65- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

66- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

67- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

68+- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

69### Companies

70### Companies

psci/PSCi.hs+119−449

@@ -7,16 +7,14 @@

7-- |

8-- PureScript Compiler Interactive.

9--

10−module PSCi where

10+module PSCi (runPSCi) where

12import Prelude ()

13import Prelude.Compat

15import Data.Foldable (traverse_)

16−import Data.Maybe (mapMaybe)

17−import Data.List (intersperse, intercalate, nub, sort, find)

16+import Data.List (intercalate, nub, sort, find)

18import Data.Tuple (swap)

17import Data.Tuple (swap)

19−import Data.Version (showVersion)

20import qualified Data.Map as M

18import qualified Data.Map as M

22import Control.Arrow (first)

20import Control.Arrow (first)

@@ -24,102 +22,87 @@ import Control.Monad

24import Control.Monad.Error.Class (MonadError(..))

22import Control.Monad.Error.Class (MonadError(..))

25import Control.Monad.Trans.Class

23import Control.Monad.Trans.Class

26import Control.Monad.Trans.Except (ExceptT(), runExceptT)

24import Control.Monad.Trans.Except (ExceptT(), runExceptT)

27−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

28import Control.Monad.Trans.State.Strict

25import Control.Monad.Trans.State.Strict

29import Control.Monad.IO.Class (liftIO)

26import Control.Monad.IO.Class (liftIO)

30import Control.Monad.Writer.Strict (Writer(), runWriter)

27import Control.Monad.Writer.Strict (Writer(), runWriter)

32−import Options.Applicative as Opts

33−

34import System.Console.Haskeline

29import System.Console.Haskeline

35−import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)

30+import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory)

36import System.Exit

31import System.Exit

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

32+import System.FilePath ((</>))

38import System.FilePath.Glob (glob)

33import System.FilePath.Glob (glob)

39import System.Process (readProcessWithExitCode)

34import System.Process (readProcessWithExitCode)

40import System.IO.Error (tryIOError)

35import System.IO.Error (tryIOError)

41−import qualified Text.PrettyPrint.Boxes as Box

43import qualified Language.PureScript as P

37import qualified Language.PureScript as P

44import qualified Language.PureScript.Names as N

38import qualified Language.PureScript.Names as N

45−import qualified Paths_purescript as Paths

47−import qualified PSCi.Directive as D

48import PSCi.Completion (completion)

40import PSCi.Completion (completion)

49−import PSCi.IO (mkdirp)

50import PSCi.Parser (parseCommand)

41import PSCi.Parser (parseCommand)

42+import PSCi.Option

51import PSCi.Types

43import PSCi.Types

52−

53−-- | The name of the PSCI support module

54−supportModuleName :: P.ModuleName

55−supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]

56−

57−-- | Support module, contains code to evaluate terms

58−supportModule :: P.Module

59−supportModule =

60− case P.parseModulesFromFiles id [("", code)] of

61− Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps

62− _ -> P.internalError "Support module could not be parsed"

63− where

64− code :: String

65− code = unlines

66− [ "module S where"

67− , ""

68− , "import Prelude"

44+import PSCi.Message

69− , "import Control.Monad.Eff"

45+import PSCi.IO

70− , "import Control.Monad.Eff.Console"

46+import PSCi.Printer

71− , "import Control.Monad.Eff.Unsafe"

47+import PSCi.Module

72− , ""

73− , "class Eval a where"

74− , " eval :: a -> Eff (console :: CONSOLE) Unit"

75− , ""

76− , "instance evalShow :: (Show a) => Eval a where"

77− , " eval = print"

78− , ""

79− , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"

80− , " eval x = unsafeInterleaveEff x >>= eval"

81− ]

82−

83−-- File helpers

84−

85−onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)

86−onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants

88-- |

49-- |

89−-- Locates the node executable.

50+-- PSCI monad

90−-- Checks for either @nodejs@ or @node@.

91--

51--

92−findNodeProcess :: IO (Maybe String)

52+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)

93−findNodeProcess = onFirstFileMatching findExecutable names

94− where names = ["nodejs", "node"]

96−-- |

54+psciIO :: IO a -> PSCI a

97−-- Grabs the filename where the history is stored.

55+psciIO io = PSCI . lift $ lift io

98−--

99−getHistoryFilename :: IO FilePath

100−getHistoryFilename = do

101− home <- getHomeDirectory

102− let filename = home </> ".purescript" </> "psci_history"

103− mkdirp filename

104− return filename

105

106-- |

57-- |

107−-- Loads a file for use with imports.

58+-- The runner

108--

59--

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

60+runPSCi :: IO ()

110−loadModule filename = do

61+runPSCi = getOpt >>= loop

111− content <- readFile filename

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

113

114-- |

63-- |

115−-- Load all modules.

64+-- The PSCI main loop.

116--

65--

117−loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])

66+loop :: PSCiOptions -> IO ()

118−loadAllModules files = do

67+loop PSCiOptions{..} = do

119− filesAndContent <- forM files $ \filename -> do

68+ config <- loadUserConfig

120− content <- readFile filename

69+ inputFiles <- concat <$> traverse glob psciInputFile

121− return (filename, content)

70+ foreignFiles <- concat <$> traverse glob psciForeignInputFiles

122− return $ P.parseModulesFromFiles id filesAndContent

71+ modulesOrFirstError <- loadAllModules inputFiles

72+ case modulesOrFirstError of

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

74+ Right modules -> do

75+ historyFilename <- getHistoryFilename

76+ let settings = defaultSettings { historyFile = Just historyFilename }

77+ foreignsOrError <- runMake $ do

78+ foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))

79+ P.parseForeignModulesFromFiles foreignFilesContent

80+ case foreignsOrError of

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

82+ Right foreigns ->

83+ flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do

84+ outputStrLn prologueMessage

85+ traverse_ (traverse_ (runPSCI . handleCommand)) config

86+ modules' <- lift $ gets psciLoadedModules

87+ unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines

88+ [ "PSCi requires the purescript-console module to be installed."

89+ , "For help getting started, visit http://wiki.purescript.org/PSCi"

90+ ]

91+ go

92+ where

93+ go :: InputT (StateT PSCiState IO) ()

94+ go = do

95+ c <- getCommand (not psciMultiLineMode)

96+ case c of

97+ Left err -> outputStrLn err >> go

98+ Right Nothing -> go

99+ Right (Just QuitPSCi) -> outputStrLn quitMessage

100+ Right (Just c') -> do

101+ handleInterrupt (outputStrLn "Interrupted.")

102+ (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))

103+ go

104+

105+-- Compile the module

123

106

124-- |

107-- |

125-- Load all modules, updating the application state

108-- Load all modules, updating the application state

@@ -129,116 +112,9 @@ loadAllImportedModules = do

129 files <- PSCI . lift $ fmap psciImportedFilenames get

112 files <- PSCI . lift $ fmap psciImportedFilenames get

130 modulesOrFirstError <- psciIO $ loadAllModules files

113 modulesOrFirstError <- psciIO $ loadAllModules files

131 case modulesOrFirstError of

114 case modulesOrFirstError of

132− Left errs -> printErrors errs

115+ Left errs -> PSCI $ printErrors errs

133 Right modules -> PSCI . lift . modify $ updateModules modules

116 Right modules -> PSCI . lift . modify $ updateModules modules

134

117

135−-- |

136−-- Expands tilde in path.

137−--

138−expandTilde :: FilePath -> IO FilePath

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

140−expandTilde p = return p

141−

142−-- Messages

143−

144−-- |

145−-- The help message.

146−--

147−helpMessage :: String

148−helpMessage = "The following commands are available:\n\n " ++

149− intercalate "\n " (map line D.help) ++

150− "\n\n" ++ extraHelp

151− where

152− line :: (Directive, String, String) -> String

153− line (dir, arg, desc) =

154− let cmd = ':' : D.stringFor dir

155− in unwords [ cmd

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

157− , arg

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

159− , desc

160− ]

161−

162− extraHelp =

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

164− " --> https://github.com/purescript/purescript/wiki/psci"

165−

166−

167−-- |

168−-- The welcome prologue.

169−--

170−prologueMessage :: String

171−prologueMessage = intercalate "\n"

172− [ " ____ ____ _ _ "

173− , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "

174− , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"

175− , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "

176− , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"

177− , " |_| "

178− , ""

179− , ":? shows help"

180− ]

181−

182−-- |

183−-- The quit message.

184−--

185−quitMessage :: String

186−quitMessage = "See ya!"

187−

188−-- |

189−-- PSCI monad

190−--

191−newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)

192−

193−psciIO :: IO a -> PSCI a

194−psciIO io = PSCI . lift $ lift io

195−

196−-- |

197−-- Makes a volatile module to execute the current expression.

198−--

199−createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module

200−createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =

201− let

202− moduleName = P.ModuleName [P.ProperName "$PSCI"]

203− trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))

204− mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))

205− itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val

206− mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue

207− decls = if exec then [itDecl, mainDecl] else [itDecl]

208− in

209− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing

210−

211−

212−-- |

213−-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.

214−--

215−createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module

216−createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ =

217− let

218− moduleName = P.ModuleName [P.ProperName "$PSCI"]

219− itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ

220− in

221− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing

222−

223−-- |

224−-- Makes a volatile module to execute the current imports.

225−--

226−createTemporaryModuleForImports :: PSCiState -> P.Module

227−createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =

228− let

229− moduleName = P.ModuleName [P.ProperName "$PSCI"]

230− in

231− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing

232−

233−importDecl :: ImportedModule -> P.Declaration

234−importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False

235−

236−indexFile :: FilePath

237−indexFile = ".psci_modules" ++ pathSeparator : "index.js"

238−

239−modulesDir :: FilePath

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

241−

242-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the

118-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the

243-- options and ignores the warning messages.

119-- options and ignores the warning messages.

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

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

@@ -258,6 +134,58 @@ make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)

258 loadedModules = psciLoadedModules st

134 loadedModules = psciLoadedModules st

259 allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms

135 allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms

260

136

137+

138+-- Commands

139+

140+-- |

141+-- Parses the input and returns either a Metacommand, or an error as a string.

142+--

143+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))

144+getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do

145+ firstLine <- withInterrupt $ getInputLine "> "

146+ case firstLine of

147+ Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty

148+ Just "" -> return (Right Nothing)

149+ Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s

150+ Just s -> fmap Just . parseCommand <$> go [s]

151+ where

152+ go :: [String] -> InputT (StateT PSCiState IO) String

153+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "

154+

155+-- |

156+-- Performs an action for each meta-command given, and also for expressions.

157+--

158+handleCommand :: Command -> PSCI ()

159+handleCommand (Expression val) = handleExpression val

160+handleCommand ShowHelp = PSCI $ outputStrLn helpMessage

161+handleCommand (Import im) = handleImport im

162+handleCommand (Decls l) = handleDecls l

163+handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> do

164+ m <- lift . lift $ loadModule absPath

165+ case m of

166+ Left err -> outputStrLn err

167+ Right mods -> lift $ modify (updateModules (map (absPath,) mods))

168+handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do

169+ foreignsOrError <- lift . lift . runMake $ do

170+ foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)

171+ P.parseForeignModulesFromFiles [(absPath, foreignFile)]

172+ case foreignsOrError of

173+ Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err

174+ Right foreigns -> lift $ modify (updateForeignFiles foreigns)

175+handleCommand ResetState = do

176+ PSCI . lift . modify $ \st ->

177+ st { psciImportedModules = []

178+ , psciLetBindings = []

179+ }

180+ loadAllImportedModules

181+handleCommand (TypeOf val) = handleTypeOf val

182+handleCommand (KindOf typ) = handleKindOf typ

183+handleCommand (BrowseModule moduleName) = handleBrowse moduleName

184+handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules

185+handleCommand (ShowInfo QueryImport) = handleShowImportedModules

186+handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."

187+

188+

261-- |

189-- |

262-- Takes a value expression and evaluates it with the current state.

190-- Takes a value expression and evaluates it with the current state.

263--

191--

@@ -268,7 +196,7 @@ handleExpression val = do

268 let nodeArgs = psciNodeFlags st ++ [indexFile]

196 let nodeArgs = psciNodeFlags st ++ [indexFile]

269 e <- psciIO . runMake $ make st [supportModule, m]

197 e <- psciIO . runMake $ make st [supportModule, m]

270 case e of

198 case e of

271− Left errs -> printErrors errs

199+ Left errs -> PSCI $ printErrors errs

272 Right _ -> do

200 Right _ -> do

273 psciIO $ writeFile indexFile "require('$PSCI')['$main']();"

201 psciIO $ writeFile indexFile "require('$PSCI')['$main']();"

274 process <- psciIO findNodeProcess

202 process <- psciIO findNodeProcess

@@ -289,7 +217,7 @@ handleDecls ds = do

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

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

290 e <- psciIO . runMake $ make st' [m]

218 e <- psciIO . runMake $ make st' [m]

291 case e of

219 case e of

292− Left err -> printErrors err

220+ Left err -> PSCI $ printErrors err

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

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

294

222

295-- |

223-- |

@@ -344,7 +272,7 @@ handleImport im = do

344 let m = createTemporaryModuleForImports st

272 let m = createTemporaryModuleForImports st

345 e <- psciIO . runMake $ make st [m]

273 e <- psciIO . runMake $ make st [m]

346 case e of

274 case e of

347− Left errs -> printErrors errs

275+ Left errs -> PSCI $ printErrors errs

348 Right _ -> do

276 Right _ -> do

349 PSCI $ lift $ put st

277 PSCI $ lift $ put st

350 return ()

278 return ()

@@ -358,124 +286,12 @@ handleTypeOf val = do

358 let m = createTemporaryModule False st val

286 let m = createTemporaryModule False st val

359 e <- psciIO . runMake $ make st [m]

287 e <- psciIO . runMake $ make st [m]

360 case e of

288 case e of

361− Left errs -> printErrors errs

289+ Left errs -> PSCI $ printErrors errs

362 Right env' ->

290 Right env' ->

363 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

291 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

364 Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

292 Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

365 Nothing -> PSCI $ outputStrLn "Could not find type"

293 Nothing -> PSCI $ outputStrLn "Could not find type"

366

294

367−-- |

368−-- Pretty print a module's signatures

369−--

370−printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()

371−printModuleSignatures moduleName (P.Environment {..}) =

372− PSCI $

373− -- get relevant components of a module from environment

374− let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names

375− moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses

376− moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types

377−

378− in

379− -- print each component

380− (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)

381− [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses

382− , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types

383− , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions

384− ]

385−

386− where printModule's showF = Box.vsep 1 Box.left . showF

387−

388− findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

389− findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

390−

391− showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

392− showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

393− showNameType _ = P.internalError "The impossible happened in printModuleSignatures."

394−

395− findTypeClass

396− :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

397− -> P.Qualified (P.ProperName 'P.ClassName)

398− -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

399− findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)

400−

401− showTypeClass

402− :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

403− -> Maybe Box.Box

404− showTypeClass (_, Nothing) = Nothing

405− showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =

406− let constraints =

407− if null constrs

408− then Box.text ""

409− else Box.text "("

410− Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)

411− Box.<> Box.text ") <= "

412− className =

413− Box.text (P.runProperName name)

414− Box.<> Box.text (concatMap ((' ':) . fst) vars)

415− classBody =

416− Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)

417−

418− in

419− Just $

420− (Box.text "class "

421− Box.<> constraints

422− Box.<> className

423− Box.<+> if null body then Box.text "" else Box.text "where")

424− Box.// Box.moveRight 2 classBody

425−

426−

427− findType

428− :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)

429− -> P.Qualified (P.ProperName 'P.TypeName)

430− -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

431− findType envTypes name = (name, M.lookup name envTypes)

432−

433− showType

434− :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

435− -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])

436− -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)

437− -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

438− -> Maybe Box.Box

439− showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =

440− case (typ, M.lookup n typeSynonymsEnv) of

441− (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->

442− if M.member (fmap P.coerceProperName n) typeClassesEnv

443− then

444− Nothing

445− else

446− Just $

447− Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)

448− Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)

449−

450− (Just (_, P.DataType typevars pt), _) ->

451− let prefix =

452− case pt of

453− [(dtProperName,_)] ->

454− case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of

455− Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType

456− _ -> "data"

457− _ -> "data"

458−

459− in

460− Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt

461−

462− _ ->

463− Nothing

464−

465− where printCons pt =

466− Box.moveRight 2 $

467− Box.vcat Box.left $

468− mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $

469− map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt

470−

471− prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t

472−

473− mapFirstRest _ _ [] = []

474− mapFirstRest f g (x:xs) = f x : map g xs

475−

476− trimEnd = reverse . dropWhile (== ' ') . reverse

477−

478−

479-- |

295-- |

480-- Browse a module and displays its signature (if module exists).

296-- Browse a module and displays its signature (if module exists).

481--

297--

@@ -484,14 +300,14 @@ handleBrowse moduleName = do

484 st <- PSCI $ lift get

300 st <- PSCI $ lift get

485 env <- psciIO . runMake $ make st []

301 env <- psciIO . runMake $ make st []

486 case env of

302 case env of

487− Left errs -> printErrors errs

303+ Left errs -> PSCI $ printErrors errs

488 Right env' ->

304 Right env' ->

489 if isModInEnv moduleName st

305 if isModInEnv moduleName st

490− then printModuleSignatures moduleName env'

306+ then PSCI $ printModuleSignatures moduleName env'

491 else case lookupUnQualifiedModName moduleName st of

307 else case lookupUnQualifiedModName moduleName st of

492 Just unQualifiedName ->

308 Just unQualifiedName ->

493 if isModInEnv unQualifiedName st

309 if isModInEnv unQualifiedName st

494− then printModuleSignatures unQualifiedName env'

310+ then PSCI $ printModuleSignatures unQualifiedName env'

495 else failNotInEnv moduleName

311 else failNotInEnv moduleName

496 Nothing ->

312 Nothing ->

497 failNotInEnv moduleName

313 failNotInEnv moduleName

@@ -503,10 +319,6 @@ handleBrowse moduleName = do

503 lookupUnQualifiedModName quaModName st =

319 lookupUnQualifiedModName quaModName st =

504 (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)

320 (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)

505

321

506−-- | Pretty-print errors

507−printErrors :: P.MultipleErrors -> PSCI ()

508−printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False

509−

510-- |

322-- |

511-- Takes a value and prints its kind

323-- Takes a value and prints its kind

512--

324--

@@ -517,7 +329,7 @@ handleKindOf typ = do

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

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

518 e <- psciIO . runMake $ make st [m]

330 e <- psciIO . runMake $ make st [m]

519 case e of

331 case e of

520− Left errs -> printErrors errs

332+ Left errs -> PSCI $ printErrors errs

521 Right env' ->

333 Right env' ->

522 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

334 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

523 Just (_, typ') -> do

335 Just (_, typ') -> do

@@ -531,63 +343,7 @@ handleKindOf typ = do

531 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

343 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

532 Nothing -> PSCI $ outputStrLn "Could not find kind"

344 Nothing -> PSCI $ outputStrLn "Could not find kind"

533

345

534−-- Commands

346+-- Misc

535−

536−-- |

537−-- Parses the input and returns either a Metacommand, or an error as a string.

538−--

539−getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))

540−getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do

541− firstLine <- withInterrupt $ getInputLine "> "

542− case firstLine of

543− Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty

544− Just "" -> return (Right Nothing)

545− Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s

546− Just s -> fmap Just . parseCommand <$> go [s]

547− where

548− go :: [String] -> InputT (StateT PSCiState IO) String

549− go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "

550−

551−-- |

552−-- Performs an action for each meta-command given, and also for expressions.

553−--

554−handleCommand :: Command -> PSCI ()

555−handleCommand (Expression val) = handleExpression val

556−handleCommand ShowHelp = PSCI $ outputStrLn helpMessage

557−handleCommand (Import im) = handleImport im

558−handleCommand (Decls l) = handleDecls l

559−handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do

560− m <- psciIO $ loadModule absPath

561− case m of

562− Left err -> PSCI $ outputStrLn err

563− Right mods -> PSCI . lift $ modify (updateModules (map (absPath,) mods))

564−handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do

565− foreignsOrError <- psciIO . runMake $ do

566− foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)

567− P.parseForeignModulesFromFiles [(absPath, foreignFile)]

568− case foreignsOrError of

569− Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err

570− Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)

571−handleCommand ResetState = do

572− PSCI . lift . modify $ \st ->

573− st { psciImportedModules = []

574− , psciLetBindings = []

575− }

576− loadAllImportedModules

577−handleCommand (TypeOf val) = handleTypeOf val

578−handleCommand (KindOf typ) = handleKindOf typ

579−handleCommand (BrowseModule moduleName) = handleBrowse moduleName

580−handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules

581−handleCommand (ShowInfo QueryImport) = handleShowImportedModules

582−handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."

583−

584−whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()

585−whenFileExists filePath f = do

586− absPath <- psciIO $ expandTilde filePath

587− exists <- psciIO $ doesFileExist absPath

588− if exists

589− then f absPath

590− else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath

591

347

592-- |

348-- |

593-- Attempts to read initial commands from '.psci' in the present working

349-- Attempts to read initial commands from '.psci' in the present working

@@ -610,92 +366,6 @@ loadUserConfig = onFirstFileMatching readCommands pathGetters

610 else

366 else

611 return Nothing

367 return Nothing

612

368

613−

614-- | Checks if the Console module is defined

369-- | Checks if the Console module is defined

615consoleIsDefined :: [P.Module] -> Bool

370consoleIsDefined :: [P.Module] -> Bool

616consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)

371consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)

617−

618−-- |

619−-- The PSCI main loop.

620−--

621−loop :: PSCiOptions -> IO ()

622−loop PSCiOptions{..} = do

623− config <- loadUserConfig

624− inputFiles <- concat <$> traverse glob psciInputFile

625− foreignFiles <- concat <$> traverse glob psciForeignInputFiles

626− modulesOrFirstError <- loadAllModules inputFiles

627− case modulesOrFirstError of

628− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

629− Right modules -> do

630− historyFilename <- getHistoryFilename

631− let settings = defaultSettings { historyFile = Just historyFilename }

632− foreignsOrError <- runMake $ do

633− foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))

634− P.parseForeignModulesFromFiles foreignFilesContent

635− case foreignsOrError of

636− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure

637− Right foreigns ->

638− flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do

639− outputStrLn prologueMessage

640− traverse_ (traverse_ (runPSCI . handleCommand)) config

641− modules' <- lift $ gets psciLoadedModules

642− unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines

643− [ "PSCi requires the purescript-console module to be installed."

644− , "For help getting started, visit http://wiki.purescript.org/PSCi"

645− ]

646− go

647− where

648− go :: InputT (StateT PSCiState IO) ()

649− go = do

650− c <- getCommand (not psciMultiLineMode)

651− case c of

652− Left err -> outputStrLn err >> go

653− Right Nothing -> go

654− Right (Just QuitPSCi) -> outputStrLn quitMessage

655− Right (Just c') -> do

656− handleInterrupt (outputStrLn "Interrupted.")

657− (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))

658− go

659−

660−multiLineMode :: Parser Bool

661−multiLineMode = switch $

662− long "multi-line-mode"

663− <> short 'm'

664− <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"

665−

666−inputFile :: Parser FilePath

667−inputFile = strArgument $

668− metavar "FILE"

669− <> Opts.help "Optional .purs files to load on start"

670−

671−inputForeignFile :: Parser FilePath

672−inputForeignFile = strOption $

673− short 'f'

674− <> long "ffi"

675− <> help "The input .js file(s) providing foreign import implementations"

676−

677−nodeFlagsFlag :: Parser [String]

678−nodeFlagsFlag = option parser $

679− long "node-opts"

680− <> metavar "NODE_OPTS"

681− <> value []

682− <> Opts.help "Flags to pass to node, separated by spaces"

683− where

684− parser = words <$> str

685−

686−psciOptions :: Parser PSCiOptions

687−psciOptions = PSCiOptions <$> multiLineMode

688− <*> many inputFile

689− <*> many inputForeignFile

690− <*> nodeFlagsFlag

691−

692−runPSCi :: IO ()

693−runPSCi = execParser opts >>= loop

694− where

695− opts = info (version <*> helper <*> psciOptions) infoModList

696− infoModList = fullDesc <> headerInfo <> footerInfo

697− headerInfo = header "psci - Interactive mode for PureScript"

698− footerInfo = footer $ "psci " ++ showVersion Paths.version

699−

700− version :: Parser (a -> a)

701− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden

psci/PSCi/Directive.hs+4

@@ -15,6 +15,10 @@

16module PSCi.Directive where

18+import Prelude ()

19+import Prelude.Compat

20+

21+

18import Data.Maybe (fromJust, listToMaybe)

22import Data.Maybe (fromJust, listToMaybe)

19import Data.List (isPrefixOf)

23import Data.List (isPrefixOf)

20import Data.Tuple (swap)

24import Data.Tuple (swap)

psci/PSCi/IO.hs+49−2

@@ -14,8 +14,55 @@

15module PSCi.IO where

17+import Prelude ()

18+import Prelude.Compat

19+

17−import System.Directory (createDirectoryIfMissing)

20+import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable, doesFileExist)

18−import System.FilePath (takeDirectory)

21+import System.FilePath (takeDirectory, (</>), isPathSeparator)

22+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

23+import Control.Monad (msum)

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

25+import System.Console.Haskeline (outputStrLn, InputT)

20mkdirp :: FilePath -> IO ()

27mkdirp :: FilePath -> IO ()

21mkdirp = createDirectoryIfMissing True . takeDirectory

28mkdirp = createDirectoryIfMissing True . takeDirectory

29+

30+-- File helpers

31+

32+onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)

33+onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants

34+

35+-- |

36+-- Locates the node executable.

37+-- Checks for either @nodejs@ or @node@.

38+--

39+findNodeProcess :: IO (Maybe String)

40+findNodeProcess = onFirstFileMatching findExecutable names

41+ where names = ["nodejs", "node"]

42+

43+-- |

44+-- Grabs the filename where the history is stored.

45+--

46+getHistoryFilename :: IO FilePath

47+getHistoryFilename = do

48+ home <- getHomeDirectory

49+ let filename = home </> ".purescript" </> "psci_history"

50+ mkdirp filename

51+ return filename

52+

53+

54+-- |

55+-- Expands tilde in path.

56+--

57+expandTilde :: FilePath -> IO FilePath

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

59+expandTilde p = return p

60+

61+

62+whenFileExists :: MonadIO m => FilePath -> (FilePath -> InputT m ()) -> InputT m ()

63+whenFileExists filePath f = do

64+ absPath <- liftIO $ expandTilde filePath

65+ exists <- liftIO $ doesFileExist absPath

66+ if exists

67+ then f absPath

68+ else outputStrLn $ "Couldn't locate: " ++ filePath

psci/PSCi/Message.hsnew file+53

@@ -0,0 +1,53 @@

1+module PSCi.Message where

4+import Data.List (intercalate)

5+import qualified PSCi.Directive as D

6+import PSCi.Types

8+-- Messages

10+-- |

11+-- The help message.

12+--

13+helpMessage :: String

14+helpMessage = "The following commands are available:\n\n " ++

15+ intercalate "\n " (map line D.help) ++

16+ "\n\n" ++ extraHelp

17+ where

18+ line :: (Directive, String, String) -> String

19+ line (dir, arg, desc) =

20+ let cmd = ':' : D.stringFor dir

21+ in unwords [ cmd

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

23+ , arg

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

25+ , desc

26+ ]

27+

28+ extraHelp =

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

30+ " --> https://github.com/purescript/purescript/wiki/psci"

31+

32+

33+-- |

34+-- The welcome prologue.

35+--

36+prologueMessage :: String

37+prologueMessage = intercalate "\n"

38+ [ " ____ ____ _ _ "

39+ , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "

40+ , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"

41+ , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "

42+ , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"

43+ , " |_| "

44+ , ""

45+ , ":? shows help"

46+ ]

47+

48+-- |

49+-- The quit message.

50+--

51+quitMessage :: String

52+quitMessage = "See ya!"

53+

psci/PSCi/Module.hsnew file+106

@@ -0,0 +1,106 @@

1+module PSCi.Module where

3+import Prelude ()

4+import Prelude.Compat

6+import qualified Language.PureScript as P

7+import PSCi.Types

8+import System.FilePath (pathSeparator)

9+import Control.Monad

10+

11+-- | The name of the PSCI support module

12+supportModuleName :: P.ModuleName

13+supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]

14+

15+-- | Support module, contains code to evaluate terms

16+supportModule :: P.Module

17+supportModule =

18+ case P.parseModulesFromFiles id [("", code)] of

19+ Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps

20+ _ -> P.internalError "Support module could not be parsed"

21+ where

22+ code :: String

23+ code = unlines

24+ [ "module S where"

25+ , ""

26+ , "import Prelude"

27+ , "import Control.Monad.Eff"

28+ , "import Control.Monad.Eff.Console"

29+ , "import Control.Monad.Eff.Unsafe"

30+ , ""

31+ , "class Eval a where"

32+ , " eval :: a -> Eff (console :: CONSOLE) Unit"

33+ , ""

34+ , "instance evalShow :: (Show a) => Eval a where"

35+ , " eval = print"

36+ , ""

37+ , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"

38+ , " eval x = unsafeInterleaveEff x >>= eval"

39+ ]

40+

41+-- Module Management

42+

43+-- |

44+-- Loads a file for use with imports.

45+--

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

47+loadModule filename = do

48+ content <- readFile filename

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

50+

51+-- |

52+-- Load all modules.

53+--

54+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])

55+loadAllModules files = do

56+ filesAndContent <- forM files $ \filename -> do

57+ content <- readFile filename

58+ return (filename, content)

59+ return $ P.parseModulesFromFiles id filesAndContent

60+

61+

62+-- |

63+-- Makes a volatile module to execute the current expression.

64+--

65+createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module

66+createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =

67+ let

68+ moduleName = P.ModuleName [P.ProperName "$PSCI"]

69+ trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))

70+ mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))

71+ itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val

72+ mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue

73+ decls = if exec then [itDecl, mainDecl] else [itDecl]

74+ in

75+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing

76+

77+

78+-- |

79+-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.

80+--

81+createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module

82+createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ =

83+ let

84+ moduleName = P.ModuleName [P.ProperName "$PSCI"]

85+ itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ

86+ in

87+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing

88+

89+-- |

90+-- Makes a volatile module to execute the current imports.

91+--

92+createTemporaryModuleForImports :: PSCiState -> P.Module

93+createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =

94+ let

95+ moduleName = P.ModuleName [P.ProperName "$PSCI"]

96+ in

97+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing

98+

99+importDecl :: ImportedModule -> P.Declaration

100+importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False

101+

102+indexFile :: FilePath

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

104+

105+modulesDir :: FilePath

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

psci/PSCi/Option.hsnew file+57

@@ -0,0 +1,57 @@

1+module PSCi.Option (

2+ getOpt

3+) where

5+import Prelude ()

6+import Prelude.Compat

8+import Options.Applicative as Opts

9+import Data.Version (showVersion)

10+

11+import PSCi.Types

12+import qualified Paths_purescript as Paths

13+

14+-- Parse Command line option

15+

16+multiLineMode :: Parser Bool

17+multiLineMode = switch $

18+ long "multi-line-mode"

19+ <> short 'm'

20+ <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"

21+

22+inputFile :: Parser FilePath

23+inputFile = strArgument $

24+ metavar "FILE"

25+ <> Opts.help "Optional .purs files to load on start"

26+

27+inputForeignFile :: Parser FilePath

28+inputForeignFile = strOption $

29+ short 'f'

30+ <> long "ffi"

31+ <> help "The input .js file(s) providing foreign import implementations"

32+

33+nodeFlagsFlag :: Parser [String]

34+nodeFlagsFlag = option parser $

35+ long "node-opts"

36+ <> metavar "NODE_OPTS"

37+ <> value []

38+ <> Opts.help "Flags to pass to node, separated by spaces"

39+ where

40+ parser = words <$> str

41+

42+psciOptions :: Parser PSCiOptions

43+psciOptions = PSCiOptions <$> multiLineMode

44+ <*> many inputFile

45+ <*> many inputForeignFile

46+ <*> nodeFlagsFlag

47+

48+version :: Parser (a -> a)

49+version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden

50+

51+getOpt :: IO PSCiOptions

52+getOpt = execParser opts

53+ where

54+ opts = info (version <*> helper <*> psciOptions) infoModList

55+ infoModList = fullDesc <> headerInfo <> footerInfo

56+ headerInfo = header "psci - Interactive mode for PureScript"

57+ footerInfo = footer $ "psci " ++ showVersion Paths.version

psci/PSCi/Printer.hsnew file+131

@@ -0,0 +1,131 @@

1+{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE DataKinds #-}

4+module PSCi.Printer where

6+import Prelude ()

7+import Prelude.Compat

9+import qualified Language.PureScript as P

10+import qualified Text.PrettyPrint.Boxes as Box

11+import qualified Data.Map as M

12+import System.Console.Haskeline

13+import Data.Maybe (mapMaybe)

14+import Data.List (intersperse)

15+import Control.Monad.IO.Class (MonadIO)

16+

17+-- Printers

18+

19+-- |

20+-- Pretty print a module's signatures

21+--

22+printModuleSignatures :: MonadIO m => P.ModuleName -> P.Environment -> InputT m ()

23+printModuleSignatures moduleName (P.Environment {..}) =

24+ -- get relevant components of a module from environment

25+ let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names

26+ moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses

27+ moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types

28+

29+ in

30+ -- print each component

31+ (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)

32+ [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses

33+ , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types

34+ , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions

35+ ]

36+

37+ where printModule's showF = Box.vsep 1 Box.left . showF

38+

39+ findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

40+ findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

41+

42+ showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

43+ showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

44+ showNameType _ = P.internalError "The impossible happened in printModuleSignatures."

45+

46+ findTypeClass

47+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

48+ -> P.Qualified (P.ProperName 'P.ClassName)

49+ -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

50+ findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)

51+

52+ showTypeClass

53+ :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

54+ -> Maybe Box.Box

55+ showTypeClass (_, Nothing) = Nothing

56+ showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =

57+ let constraints =

58+ if null constrs

59+ then Box.text ""

60+ else Box.text "("

61+ Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)

62+ Box.<> Box.text ") <= "

63+ className =

64+ Box.text (P.runProperName name)

65+ Box.<> Box.text (concatMap ((' ':) . fst) vars)

66+ classBody =

67+ Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)

68+

69+ in

70+ Just $

71+ (Box.text "class "

72+ Box.<> constraints

73+ Box.<> className

74+ Box.<+> if null body then Box.text "" else Box.text "where")

75+ Box.// Box.moveRight 2 classBody

76+

77+

78+ findType

79+ :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)

80+ -> P.Qualified (P.ProperName 'P.TypeName)

81+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

82+ findType envTypes name = (name, M.lookup name envTypes)

83+

84+ showType

85+ :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

86+ -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])

87+ -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)

88+ -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))

89+ -> Maybe Box.Box

90+ showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =

91+ case (typ, M.lookup n typeSynonymsEnv) of

92+ (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->

93+ if M.member (fmap P.coerceProperName n) typeClassesEnv

94+ then

95+ Nothing

96+ else

97+ Just $

98+ Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)

99+ Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)

100+

101+ (Just (_, P.DataType typevars pt), _) ->

102+ let prefix =

103+ case pt of

104+ [(dtProperName,_)] ->

105+ case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of

106+ Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType

107+ _ -> "data"

108+ _ -> "data"

109+

110+ in

111+ Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt

112+

113+ _ ->

114+ Nothing

115+

116+ where printCons pt =

117+ Box.moveRight 2 $

118+ Box.vcat Box.left $

119+ mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $

120+ map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt

121+

122+ prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t

123+

124+ mapFirstRest _ _ [] = []

125+ mapFirstRest f g (x:xs) = f x : map g xs

126+

127+ trimEnd = reverse . dropWhile (== ' ') . reverse

128+

129+-- | Pretty-print errors

130+printErrors :: MonadIO m => P.MultipleErrors -> InputT m ()

131+printErrors = outputStrLn . P.prettyPrintMultipleErrors False

psci/PSCi/Types.hs+3

@@ -15,6 +15,9 @@

16module PSCi.Types where

18+import Prelude ()

19+import Prelude.Compat

20+

18import Control.Arrow (second)

21import Control.Arrow (second)

19import Data.Map (Map)

22import Data.Map (Map)

20import qualified Data.Map as Map

23import qualified Data.Map as Map

purescript.cabal+10−2

@@ -206,7 +206,7 @@ executable psc

206 main-is: Main.hs

207 buildable: True

208 hs-source-dirs: psc

209− other-modules: JSON

209+ other-modules: JSON, Paths_purescript

210 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"

211

212executable psci

@@ -225,6 +225,11 @@ executable psci

225 PSCi.Directive

226 PSCi.Completion

227 PSCi.IO

228+ PSCi.Message

229+ PSCi.Option

230+ PSCi.Module

231+ PSCi.Printer

232+ Paths_purescript

228 ghc-options: -Wall -O2

233 ghc-options: -Wall -O2

229

234

230executable psc-docs

235executable psc-docs

@@ -234,6 +239,7 @@ executable psc-docs

234 filepath -any, Glob -any, transformers -any,

239 filepath -any, Glob -any, transformers -any,

235 transformers-compat -any

240 transformers-compat -any

236 main-is: Main.hs

241 main-is: Main.hs

242+ other-modules: Paths_purescript

237 buildable: True

243 buildable: True

238 hs-source-dirs: psc-docs

244 hs-source-dirs: psc-docs

239 other-modules: Ctags

245 other-modules: Ctags

@@ -244,6 +250,7 @@ executable psc-docs

244executable psc-publish

250executable psc-publish

245 build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any

251 build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any

246 main-is: Main.hs

252 main-is: Main.hs

253+ other-modules: Paths_purescript

247 buildable: True

254 buildable: True

248 hs-source-dirs: psc-publish

255 hs-source-dirs: psc-publish

249 ghc-options: -Wall -O2

256 ghc-options: -Wall -O2

@@ -253,6 +260,7 @@ executable psc-hierarchy

253 process -any, mtl -any, parsec -any, filepath -any, directory -any,

260 process -any, mtl -any, parsec -any, filepath -any, directory -any,

254 Glob -any

261 Glob -any

255 main-is: Main.hs

262 main-is: Main.hs

263+ other-modules: Paths_purescript

256 buildable: True

264 buildable: True

257 hs-source-dirs: hierarchy

265 hs-source-dirs: hierarchy

258 other-modules:

266 other-modules:

@@ -260,7 +268,7 @@ executable psc-hierarchy

260

268

261executable psc-bundle

269executable psc-bundle

262 main-is: Main.hs

270 main-is: Main.hs

263− other-modules:

271+ other-modules: Paths_purescript

264 other-extensions:

272 other-extensions:

265 build-depends: base >=4 && <5,

273 build-depends: base >=4 && <5,

266 purescript -any,

274 purescript -any,

tests/TestPsci.hs+1−1

@@ -23,7 +23,7 @@ import Test.HUnit

24import qualified Language.PureScript as P

26−import PSCi

26+import PSCi.Module (loadAllModules)

27import PSCi.Completion

28import PSCi.Types