module Language.HERMIT.Dictionary
(
all_externals
, dictionary
, pp_dictionary
) where
import Data.Default (def)
import Data.Dynamic
import Data.List
import Data.Map (Map, fromList, toList)
import Language.HERMIT.Kure
import Language.HERMIT.External
import qualified Language.HERMIT.Primitive.Kure as Kure
import qualified Language.HERMIT.Primitive.Navigation as Navigation
import qualified Language.HERMIT.Primitive.Inline as Inline
import qualified Language.HERMIT.Primitive.Local as Local
import qualified Language.HERMIT.Primitive.New as New
import qualified Language.HERMIT.Primitive.Debug as Debug
import qualified Language.HERMIT.Primitive.GHC as GHC
import qualified Language.HERMIT.Primitive.Fold as Fold
import qualified Language.HERMIT.Primitive.Unfold as Unfold
import qualified Language.HERMIT.Primitive.AlphaConversion as Alpha
import Language.HERMIT.PrettyPrinter
import qualified Language.HERMIT.PrettyPrinter.AST as AST
import qualified Language.HERMIT.PrettyPrinter.Clean as Clean
import qualified Language.HERMIT.PrettyPrinter.GHC as GHCPP
prim_externals :: [External]
prim_externals
= Kure.externals
++ Navigation.externals
++ Inline.externals
++ Local.externals
++ Debug.externals
++ New.externals
++ Fold.externals
++ Unfold.externals
++ Alpha.externals
all_externals :: [External] -> [External]
all_externals my_externals = prim_externals ++ my_externals ++ GHC.externals
dictionary :: [External] -> Map String [Dynamic]
dictionary 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 category."
, "Multiple items may match."
, ""
, "categories: " ++ head msg
] ++ map (" " ++) (tail msg)) .+ Query .+ Shell
, let bashPredicate = Bash
in external "bash"
(metaCmd externs bashPredicate (setFailMsg "Nothing to do." . innermostR . orR))
(metaHelp externs bashPredicate
[ "Iteratively apply the following rewrites until nothing changes:" ])
.+ Eval .+ Deep .+ Loop
]
pp_dictionary :: Map String (PrettyOptions -> PrettyH Core)
pp_dictionary = fromList
[ ("clean", Clean.corePrettyH)
, ("ast", AST.corePrettyH)
, ("ghc", GHCPP.corePrettyH)
]
pp_opt_dictionary :: Map String PrettyOptions
pp_opt_dictionary = fromList
[ ("clean", def)
, ("ast", def)
, ("ghc", def)
]
make_help :: [External] -> [String]
make_help = concatMap snd . toList . toHelp
help_command :: [External] -> String -> String
help_command externals m
| [(ct :: CmdTag,"")] <- reads m
= unlines $ make_help $ filter (tagMatch ct) externals
help_command externals "all"
= unlines $ make_help externals
help_command _ "categories" = unlines $
[ "categories" ] ++
[ "----------" ] ++
[ txt ++ " " ++ replicate (16 length txt) '.' ++ " " ++ desc
| (cmd,desc) <- dictionaryOfTags
, let txt = show cmd
]
help_command externals m = unlines $ make_help $ pathPrefix m
where pathPrefix p = filter (isInfixOf p . externName) externals
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
metaCmd :: Tag a
=> [External]
-> a
-> ([RewriteH Core] -> RewriteH Core)
-> RewriteH Core
metaCmd externs p = ($ [ rw | e <- externs
, tagMatch p e
, Just rw <- [fmap unbox $ fromDynamic $ externFun e] ])
metaHelp :: Tag a
=> [External]
-> a
-> [String]
-> [String]
metaHelp externs p = (++ [ externName e
| e <- externs
, tagMatch p e
, Just (_ :: RewriteH Core) <- [fmap unbox $ fromDynamic $ externFun e] ])