cf0d9d3 · rowtype-yoga/purescript-native

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

Merge pull request #1631 from soupi/psci-browse

cf0d9d3Phil Freeman11 years ago

CONTRIBUTORS.md+1

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

56- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, 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).

57- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, 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).

58<http://opensource.org/licenses/MIT>.

59+- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, 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).

60### Companies

61### Companies

psci/PSCi.hs+101−15

@@ -24,7 +24,8 @@ import Prelude ()

24import Prelude.Compat

26import Data.Foldable (traverse_)

27+import Data.Maybe (mapMaybe)

27−import Data.List (intercalate, nub, sort)

28+import Data.List (intersperse, intercalate, nub, sort)

28import Data.Tuple (swap)

29import Data.Tuple (swap)

29import Data.Version (showVersion)

30import Data.Version (showVersion)

30import qualified Data.Map as M

31import qualified Data.Map as M

@@ -48,6 +49,7 @@ import System.FilePath (pathSeparator, (</>), isPathSeparator)

48import System.FilePath.Glob (glob)

49import System.FilePath.Glob (glob)

49import System.Process (readProcessWithExitCode)

50import System.Process (readProcessWithExitCode)

50import System.IO.Error (tryIOError)

51import System.IO.Error (tryIOError)

52+import qualified Text.PrettyPrint.Boxes as Box

52import qualified Language.PureScript as P

54import qualified Language.PureScript as P

53import qualified Language.PureScript.Names as N

55import qualified Language.PureScript.Names as N

@@ -374,20 +376,104 @@ handleTypeOf val = do

374-- Pretty print a module's signatures

376-- Pretty print a module's signatures

375--

377--

376printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()

378printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()

377−printModuleSignatures moduleName env =

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

378− PSCI $ let namesEnv = P.names env

380+ PSCI $

379− moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv

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

380− in case moduleNamesIdent of

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

381− [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."

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

382− _ -> ( outputStrLn

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

383− . unlines

385+

384− . sort

386+ in

385− . map (showType . findType namesEnv)) moduleNamesIdent

387+ -- print each component

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

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

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

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

392+ ]

393+

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

395+

386− where findType :: 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))

396+ 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))

387− findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

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

398+

388− showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String

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

389− showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType

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

390− showType _ = P.internalError "The impossible happened in printModuleSignatures."

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

402+

403+ findTypeClass :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

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

405+

406+ showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box

407+ showTypeClass (_, Nothing) = Nothing

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

409+ let constraints =

410+ if null constrs

411+ then Box.text ""

412+ else Box.text "("

413+ 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)

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

415+ className =

416+ Box.text (P.runProperName name)

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

418+ classBody =

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

420+

421+ in

422+ Just $

423+ (Box.text "class "

424+ Box.<> constraints

425+ Box.<> className

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

427+ Box.// Box.moveRight 2 classBody

428+

429+

430+ findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))

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

432+

433+ showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

434+ -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident])

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

436+ -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))

437+ -> Maybe Box.Box

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

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

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

441+ if M.member n typeClassesEnv

442+ then

443+ Nothing

444+ else

445+ Just $

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

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

448+

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

450+ let prefix =

451+ case pt of

452+ [(dtProperName,_)] ->

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

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

455+ _ -> "data"

456+ _ -> "data"

457+

458+ in

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

460+

461+ _ ->

462+ Nothing

463+

464+ where printCons pt =

465+ Box.moveRight 2 $

466+ Box.vcat Box.left $

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

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

469+

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

471+

472+ mapFirstRest _ _ [] = []

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

474+

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

476+

391

477

392-- |

478-- |

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

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

purescript.cabal+3−2

@@ -197,7 +197,8 @@ executable psci

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

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

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

200− transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0

200+ transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0,

201+ boxes >= 0.1.4 && < 0.2.0

201

202

202 main-is: Main.hs

203 main-is: Main.hs

203 buildable: True

204 buildable: True

@@ -272,7 +273,7 @@ test-suite psci-tests

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

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

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

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

274 transformers-compat -any, process -any, HUnit -any, time -any,

275 transformers-compat -any, process -any, HUnit -any, time -any,

275− Glob -any, base-compat >=0.6.0

276+ Glob -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0

276 type: exitcode-stdio-1.0

277 type: exitcode-stdio-1.0

277 main-is: Main.hs

278 main-is: Main.hs

278 other-modules: TestsSetup

279 other-modules: TestsSetup