module Language.HERMIT.Dictionary
(
Dictionary
, all_externals
, dictionary
, pp_dictionary
, metaCmd
) where
import Data.Dynamic
import Data.List
import Data.Map (Map, fromList, toList)
import Language.HERMIT.Core
import Language.HERMIT.Kure
import Language.HERMIT.External
import qualified Language.HERMIT.Primitive.AlphaConversion as Alpha
import qualified Language.HERMIT.Primitive.Debug as Debug
import qualified Language.HERMIT.Primitive.FixPoint as FixPoint
import qualified Language.HERMIT.Primitive.Fold as Fold
import qualified Language.HERMIT.Primitive.GHC as GHC
import qualified Language.HERMIT.Primitive.Inline as Inline
import qualified Language.HERMIT.Primitive.Kure as Kure
import qualified Language.HERMIT.Primitive.Local as Local
import qualified Language.HERMIT.Primitive.Navigation as Navigation
import qualified Language.HERMIT.Primitive.New as New
import qualified Language.HERMIT.Primitive.Unfold as Unfold
import Language.HERMIT.PrettyPrinter.Common
import qualified Language.HERMIT.PrettyPrinter.AST as AST
import qualified Language.HERMIT.PrettyPrinter.Clean as Clean
import qualified Language.HERMIT.PrettyPrinter.GHC as GHCPP
type Dictionary = Map String [Dynamic]
prim_externals :: [External]
prim_externals =
Alpha.externals
++ Debug.externals
++ FixPoint.externals
++ Fold.externals
++ Inline.externals
++ Kure.externals
++ Local.externals
++ Navigation.externals
++ New.externals
++ Unfold.externals
all_externals :: [External] -> [External]
all_externals my_externals = prim_externals ++ my_externals ++ GHC.externals
dictionary :: [External] -> Dictionary
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)
]
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] ])