@@ -24,7 +24,8 @@ import Prelude ()
2424import Prelude.Compat
2525
2626import Data.Foldable (traverse_)
27−import Data.List (intercalate, nub, sort)
27+import Data.Maybe (mapMaybe)
28+import Data.List (intersperse, intercalate, nub, sort)
2829import Data.Tuple (swap)
2930import Data.Version (showVersion)
3031import qualified Data.Map as M
@@ -48,6 +49,7 @@ import System.FilePath (pathSeparator, (</>), isPathSeparator)
4849import System.FilePath.Glob (glob)
4950import System.Process (readProcessWithExitCode)
5051import System.IO.Error (tryIOError)
52+import qualified Text.PrettyPrint.Boxes as Box
5153
5254import qualified Language.PureScript as P
5355import qualified Language.PureScript.Names as N
@@ -374,20 +376,104 @@ handleTypeOf val = do
374376-- Pretty print a module's signatures
375377--
376378printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
377−printModuleSignatures moduleName env =
378− PSCI $ let namesEnv = P.names env
379− moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv
380− in case moduleNamesIdent of
381− [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."
382− _ -> ( outputStrLn
383− . unlines
384− . sort
385− . map (showType . findType namesEnv)) moduleNamesIdent
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))
387− findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
388− showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String
389− showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType
390− showType _ = P.internalError "The impossible happened in printModuleSignatures."
379+printModuleSignatures moduleName (P.Environment {..}) =
380+ PSCI $
381+ -- get relevant components of a module from environment
382+ let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names
383+ moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses
384+ moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types
385+
386+ in
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+
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))
397+ findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
398+
399+ showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box
400+ showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType
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+
391477
392478-- |
393479-- Browse a module and displays its signature (if module exists).