module HERMIT.Shell.Dictionary
( mkDictionary
, addToDictionary
, pp_dictionary
) where
import Data.Dynamic
import Data.List
import Data.Map (Map, fromList, toList, fromListWith)
import HERMIT.External
import HERMIT.PrettyPrinter.Common
import qualified HERMIT.PrettyPrinter.AST as AST
import qualified HERMIT.PrettyPrinter.Clean as Clean
import qualified HERMIT.PrettyPrinter.GHC as GHCPP
type Dictionary = Map ExternalName [Dynamic]
toDictionary :: [External] -> Dictionary
toDictionary = fromListWith (++) . map toEntry
toEntry :: External -> (ExternalName, [Dynamic])
toEntry e = (externName e, [externDyn e])
addToDictionary :: External -> Dictionary -> Dictionary
addToDictionary ex d = fromListWith (++) $ toEntry ex : toList d
mkDictionary :: [External] -> Dictionary
mkDictionary externs = toDictionary externs'
where
msg = layoutTxt 60 (map (show . fst) dictionaryOfTags)
externs' = externs ++
[ external "help" (help_command externs' "help")
[ "(this message)" ] .+ Query .+ Shell
, external "help" (help_command externs')
([ "help <command>|<category>|categories|all|<search-string>"
, "Displays help about a command, or all commands in a category."
, "Multiple items may match."
, ""
, "Categories: " ++ head msg
] ++ map (" " ++) (tail msg)) .+ Query .+ Shell
]
pp_dictionary :: Map String PrettyPrinter
pp_dictionary = fromList
[ ("clean", Clean.pretty)
, ("ast", AST.pretty)
, ("ghc", GHCPP.pretty)
]
make_help :: [External] -> [String]
make_help = concatMap snd . toList . toHelp
help_command :: [External] -> String -> String
help_command exts m
| [(ct :: CmdTag,"")] <- reads m
= unlines $ make_help $ filter (tagMatch ct) exts
help_command exts "all"
= unlines $ make_help exts
help_command _ "categories" = unlines $
[ "Categories" ] ++
[ "----------" ] ++
[ txt ++ " " ++ replicate (16 length txt) '.' ++ " " ++ desc
| (cmd,desc) <- dictionaryOfTags
, let txt = show cmd
]
help_command exts m = unlines $ make_help $ pathPrefix m
where pathPrefix p = filter (isInfixOf p . externName) exts
layoutTxt :: Int -> [String] -> [String]
layoutTxt n (w1:w2:ws) | length w1 + length w2 >= n = w1 : layoutTxt n (w2:ws)
| otherwise = layoutTxt n ((w1 ++ " " ++ w2) : ws)
layoutTxt _ other = other