236 lines
7.1 KiB
Haskell
236 lines
7.1 KiB
Haskell
module Main where
|
|
|
|
import Control.Exception hiding (try)
|
|
import Data.Char
|
|
import Data.List
|
|
import Language.Haskell.Exts.Extension
|
|
import Language.Haskell.Exts.Parser hiding (parse)
|
|
import Language.Haskell.Exts.Syntax
|
|
import Prelude hiding (catch)
|
|
import System.Console.GetOpt
|
|
import System.Environment
|
|
import System.IO
|
|
import System.Process
|
|
import Text.ParserCombinators.Parsec
|
|
|
|
----------------------------------------------------------------
|
|
|
|
usage :: String
|
|
usage = "ghc-mod putStrLn version 0.1.0\n"
|
|
++ "Usage:\n"
|
|
++ "\t ghc-mod list\n"
|
|
++ "\t ghc-mod browse <module>\n"
|
|
++ "\t ghc-mod help\n"
|
|
|
|
----------------------------------------------------------------
|
|
|
|
data Options = Options { optToLisp :: Bool
|
|
} deriving Show
|
|
|
|
defaultOptions :: Options
|
|
defaultOptions = Options { optToLisp = False
|
|
}
|
|
|
|
argspec :: [OptDescr (Options -> Options)]
|
|
argspec = [ Option ['l'] ["tolisp"]
|
|
(NoArg (\opts -> opts { optToLisp = True }))
|
|
"print as a list of Lisp"
|
|
]
|
|
|
|
parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
|
|
parseArgs spec argv
|
|
= case getOpt Permute spec argv of
|
|
(o,n,[] ) -> (foldl (flip id) defaultOptions o, n)
|
|
(_,_,errs) -> error (concat errs ++ usageInfo usage argspec)
|
|
|
|
----------------------------------------------------------------
|
|
|
|
main :: IO ()
|
|
main = flip catch handler $ do
|
|
args <- getArgs
|
|
let (opt,cmdArg) = parseArgs argspec args
|
|
transform = if optToLisp opt then toLisp else toPlain
|
|
ll <- case cmdArg !! 0 of
|
|
cmd | cmd == "browse" -> browseModule $ cmdArg !! 1
|
|
| cmd == "list" -> listModules
|
|
_ -> error usage
|
|
putStr $ transform $ nub $ sort $ ll
|
|
where
|
|
handler :: ErrorCall -> IO ()
|
|
-- handler _ = print usage
|
|
handler e = print e
|
|
|
|
----------------------------------------------------------------
|
|
|
|
browseModule :: String -> IO [String]
|
|
browseModule mname = do
|
|
xs <- getSyntax mname
|
|
let ys = preprocess xs
|
|
return $ parseSyntax ys
|
|
|
|
getSyntax :: String -> IO String
|
|
getSyntax mname = do
|
|
(inp,out,_,_) <- runInteractiveProcess "ghci" [] Nothing Nothing
|
|
mapM_ setFD [inp,out]
|
|
hPutStrLn inp ":set prompt \"\""
|
|
hPutStrLn inp "1"
|
|
hPutStrLn inp $ ":browse " ++ mname
|
|
hPutStrLn inp ":set prompt \"Prelude>\""
|
|
hPutStrLn inp ":quit"
|
|
cs <- hGetContents out
|
|
return $ unlines $ dropTailer $ dropHeader $ lines $ cs
|
|
where
|
|
isNotPrefixOf x y = not (x `isPrefixOf` y)
|
|
dropHeader xs = tail $ dropWhile (isNotPrefixOf "Prelude>") xs
|
|
dropTailer = takeWhile (isNotPrefixOf "Prelude>")
|
|
setFD h = do
|
|
hSetBinaryMode h False
|
|
hSetBuffering h LineBuffering
|
|
|
|
parseSyntax :: String -> [String]
|
|
parseSyntax xs = do
|
|
let mode = defaultParseMode { extensions = NewQualifiedOperators : ExplicitForall : glasgowExts }
|
|
res = parseModuleWithMode mode xs
|
|
case res of
|
|
ParseOk x -> identifiers x
|
|
-- e -> error $ show e
|
|
_ -> []
|
|
|
|
----------------------------------------------------------------
|
|
|
|
listModules :: IO [String]
|
|
listModules = do
|
|
cs <- getDump
|
|
return $ exposedModules cs
|
|
|
|
getDump :: IO String
|
|
getDump = do
|
|
(_,hout,_,_) <- runInteractiveProcess "ghc-pkg" ["dump"] Nothing Nothing
|
|
hGetContents hout
|
|
|
|
exposedModules :: String -> [String]
|
|
exposedModules cs = let ls = unfoldLines cs
|
|
ns = values "name: " ls
|
|
ms = values "exposed-modules: " ls
|
|
zs = zip ns ms
|
|
xs = filter (\(nm,_) -> nm `notElem` ["ghc", "ghc-prim", "rts", "integer"]) zs
|
|
ss = map snd xs
|
|
in filter (\x -> not ("GHC" `isPrefixOf` x)) $ concatMap words ss
|
|
|
|
values :: String -> [String] -> [String]
|
|
values tag ls = let len = length tag
|
|
fs = filter (tag `isPrefixOf`) ls
|
|
in map (drop len) fs
|
|
|
|
----------------------------------------------------------------
|
|
|
|
unfoldLines :: String -> [String]
|
|
unfoldLines xs = self xs
|
|
where
|
|
splitNL = break (== '\n')
|
|
self "" = []
|
|
self s = let (l, s') = splitNL s
|
|
in case s' of
|
|
[] -> [l]
|
|
(_:' ':s'') -> cont s'' l
|
|
(_:s'') -> l : self s''
|
|
cont s a = let (l, s') = splitNL $ dropWhile (== ' ') s
|
|
a' = a ++ " " ++ l
|
|
in case s' of
|
|
[] -> [a']
|
|
(_:' ':s'') -> cont s'' a'
|
|
(_:s'') -> a' : self s''
|
|
|
|
toLisp :: [String] -> String
|
|
toLisp ms = "(" ++ unwords quoted ++ ")\n"
|
|
where
|
|
quote x = "\"" ++ x ++ "\""
|
|
quoted = map quote ms
|
|
|
|
toPlain :: [String] -> String
|
|
toPlain = unlines
|
|
|
|
----------------------------------------------------------------
|
|
|
|
preprocess :: String -> String
|
|
preprocess cs = case parse remove "remove" cs of
|
|
Right a -> a
|
|
Left e -> error $ show e
|
|
|
|
modName :: Parser String
|
|
modName = do c <- oneOf ['A'..'Z']
|
|
cs <- many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#"
|
|
return $ c:cs
|
|
|
|
anyName :: Parser String
|
|
anyName = many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#"
|
|
|
|
manyBefore :: Show tok => GenParser tok st a -> GenParser tok st [tok] -> GenParser tok st [a]
|
|
manyBefore p anchor = manyTill p (eof <|> try anc)
|
|
where
|
|
anc = do pos <- getPosition
|
|
s <- anchor
|
|
ss <- getInput
|
|
setInput $ s ++ ss
|
|
setPosition pos
|
|
return ()
|
|
|
|
keyword :: Parser String
|
|
keyword = do ms <- modName
|
|
char '.'
|
|
return $ ms ++ ['.']
|
|
|
|
ghcName :: Parser String
|
|
ghcName = do keyword
|
|
try sep <|> end
|
|
where
|
|
sep = do
|
|
ws <- sepBy1 anyName (char '.')
|
|
return $ last ws
|
|
end = do
|
|
endBy1 anyName (char '.')
|
|
return ""
|
|
|
|
nonGhcName :: Parser String
|
|
nonGhcName = do c <- anyChar -- making this func non-empty
|
|
cs <- manyBefore anyChar keyword
|
|
return $ c:cs
|
|
|
|
remove :: Parser String
|
|
remove = do l1 <- try ghcName <|> return ""
|
|
l2 <- nonGhcName
|
|
ll <- many (do x <- ghcName
|
|
y <- nonGhcName
|
|
return $ x ++ y)
|
|
return $ concat $ l1 : l2 : ll
|
|
|
|
----------------------------------------------------------------
|
|
|
|
identifiers :: Module -> [String]
|
|
identifiers (Module _ _ _ _ _ _ x) = filter hid $ concatMap decl x
|
|
where
|
|
hid = all (\c -> isAlphaNum c || elem c "_'")
|
|
|
|
decl :: Decl -> [String]
|
|
decl (TypeSig _ [x] _) = [name x]
|
|
decl (DataDecl _ _ _ x _ y _) = name x : (map qualConDecl y)
|
|
decl (ClassDecl _ _ x _ _ y) = name x : (map classDecl y)
|
|
decl (TypeDecl _ x _ _) = [name x]
|
|
decl x = [show x]
|
|
|
|
qualConDecl :: QualConDecl -> String
|
|
qualConDecl (QualConDecl _ _ _ x) = conDecl x
|
|
|
|
conDecl :: ConDecl -> String
|
|
conDecl (ConDecl (Ident x) _) = x
|
|
conDecl (InfixConDecl _ (Ident x) _) = x
|
|
conDecl x = show x
|
|
|
|
classDecl :: ClassDecl -> String
|
|
classDecl (ClsDecl x) = concat $ decl x -- xxx
|
|
classDecl x = show x
|
|
|
|
name :: Name -> String
|
|
name (Symbol x) = x
|
|
name (Ident x) = x
|