diff --git a/ghc-core.cabal b/ghc-core.cabal --- a/ghc-core.cabal +++ b/ghc-core.cabal @@ -1,5 +1,5 @@ name: ghc-core -version: 0.5.5 +version: 0.5.6 license: BSD3 license-file: LICENSE author: Don Stewart @@ -12,7 +12,7 @@ readable, colourised manner, in a pager. Unix systems only, currently. . - Usage: + Usage: . > ghc-core A.hs . @@ -21,8 +21,6 @@ build-type: Simple cabal-version: >= 1.2 --- Technically, hscolour-1.10.* will work too if we replace the --- 'NoLit' constructor with 'False' in the call to 'hscolour'. executable ghc-core build-depends: base >= 4 && < 5, process >=1.0.1, @@ -31,5 +29,4 @@ directory, filepath main-is: ghc-core.hs - ghc-options: -Wall - extensions: PatternGuards + ghc-options: -Wall -O2 diff --git a/ghc-core.hs b/ghc-core.hs --- a/ghc-core.hs +++ b/ghc-core.hs @@ -17,35 +17,27 @@ -- -- > ghc-core zipwith -- --- > ghc-core -fvia-C zipwith +-- > ghc-core -fvia-C zipwith -- ------------------------------------------------------------------------ -import Control.Concurrent +import Control.Applicative import Control.Exception as E -import Control.Monad +import Data.Maybe import System.Console.GetOpt import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO -import System.Process hiding (readProcess) -import Text.Printf +import System.Process import Text.Regex.PCRE.Light.Char8 -- BSD-licensed Haskell syntax highlighting, based on Programmatica import Language.Haskell.Colorize -{- -import Language.Haskell.HsColour -import Language.Haskell.HsColour.Colourise --- 'Literate' is hscolour-1.11 only. 'Bool' was used in hscolour-1.10 -import Language.Haskell.HsColour.Options (Literate(..)) --} - ------------------------------------------------------------------------ -- -- Command line parsing @@ -53,7 +45,6 @@ data Options = Options { optHelp :: Bool --- , optFormat :: Output , optGhcExe :: String , optAsm :: Bool , optSyntax :: Bool @@ -63,47 +54,33 @@ defaultOptions :: Options defaultOptions = Options { optHelp = False --- , optFormat = TTY , optGhcExe = "ghc" , optAsm = True , optSyntax = True , optCast = True } --- formats :: [(String, Output)] --- formats = [("css", CSS), ("html", HTML), ("tty", TTY)] - options :: [OptDescr (Options -> Options)] options = - [ -- Option ['f'] ["format"] - -- (ReqArg (\x opts -> opts { optFormat = fromString x }) "FORMAT") - -- ("Output format " ++ formats' ++ ".") - Option ['h'] ["help"] - (NoArg (\opts -> opts { optHelp = True })) - "Print this help message." - ,Option [] ["with-ghc"] - (ReqArg (\x opts -> opts { optGhcExe = x }) "PROGRAM") - "Ghc executable to use." - ,Option [] ["no-asm"] - (NoArg (\opts -> opts { optAsm = False })) - "Don't output generated assembly code." - ,Option [] ["no-syntax"] - (NoArg (\opts -> opts { optSyntax = False })) - "Don't colorize generated code." - ,Option [] ["no-cast"] - (NoArg (\opts -> opts { optCast = False })) - "Don't output calls to cast in generated code." + [ Option ['h'] ["help"] + (NoArg (\opts -> opts { optHelp = True })) + "Print this help message." + , Option ['w'] ["with-ghc"] + (ReqArg (\x opts -> opts { optGhcExe = x }) "PROGRAM") + "Ghc executable to use." + , Option [] ["no-asm"] + (NoArg (\opts -> opts { optAsm = False })) + "Don't output generated assembly code." + , Option [] ["no-syntax"] + (NoArg (\opts -> opts { optSyntax = False })) + "Don't colorize generated code." + , Option [] ["no-cast"] + (NoArg (\opts -> opts { optCast = False })) + "Don't output calls to cast in generated code." ] - where -{- fromString f = fromMaybe (formatError f) (lookup f formats) - formatError f = error $ - "invalid format `" ++ f ++ "'" - ++ ", must be one of " ++ formats' ++ "." - formats' = "(" ++ concat (intersperse ", " (map fst formats)) ++ ")" --} parseOptions :: [String] -> IO (Options, [String]) -parseOptions argv = +parseOptions argv = case getOpt RequireOrder options argv of (o, n, []) -> let o' = foldl (flip ($)) defaultOptions o in if optHelp o' @@ -111,7 +88,8 @@ exitWith ExitSuccess else return (o', n) (_, _, es) -> ioError (userError (concat es ++ usageInfo header options)) - where header = "Usage: ghc-core [OPTION...] [--] [GHC_OPTION...] [files...]" + where + header = "Usage: ghc-core [OPTION...] [--] [GHC_OPTION...] [files...]" isExtCoreFile :: FilePath -> Bool isExtCoreFile = (== ".hcr") . takeExtension @@ -122,78 +100,42 @@ -- Parse command line (opts, args) <- getArgs >>= parseOptions - -- Read colors from .hscolour --- colourPrefs <- readColourPrefs - - mv <- getEnvMaybe "PAGER" - let less = case mv of Just s -> case s of "less" -> "less -f" ; _ -> s - _ -> "less -f" - - (strs, tmps) <- case args of - [fp] | isExtCoreFile fp -> do - contents <- readFile fp - return (contents, Nothing) - _ -> do - strs1 <- compileWithCore (optGhcExe opts) - args (optAsm opts) - let strs2 = polish strs1 - let strs3 | optCast opts = strs2 - | otherwise = castKill strs2 - -- TODO this is a bit lazy on my part... - x <- readProcess "sh" ["-c","ls /tmp/ghc*/*.s | head -1"] [] - case x of - Left _ -> return (strs3, Nothing) - Right s -> if "-fvia-C" `elem` args || "-fllvm" `elem` args - then do asm <- readFile (init s) - return ((strs3 ++ asm), Just $ takeDirectory s) - else return (strs3, Just $ takeDirectory s) + code <- case args of + [fp] | isExtCoreFile fp -> readFile fp + _ -> do + strs <- compileWithCore opts args + return (polish strs) -{- - -- If we replace the 'NoLit' constructor with 'False' (and - -- remove the include for the Literate type), then this will - -- work with older hscolour-1.10.* versions. - let nice = hscolour - (optFormat opts) - colourPrefs False True NoLit [] strs --} - let nice | optSyntax opts = render ansiLight strs [] - | otherwise = strs + let niceCode | optSyntax opts = render ansiLight code [] + | otherwise = code bracket (openTempFile "/tmp" "ghc-core-XXXX.hcr") - (\(f,h) -> do hClose h - removeFile f - case tmps of - Just g -> system ("rm -rf " ++ g) >> return () - _ -> return () - ) + (\(f,h) -> hClose h >> removeFile f) (\(f,h) -> do - hPutStrLn h nice >> hFlush h - e <- system $ less ++ " -r " ++ f + hPutStrLn h niceCode >> hFlush h + e <-showInPager f exitWith e) --- --- Clean up the output with some regular expressions. --- +showInPager :: FilePath -> IO ExitCode +showInPager file = do + mv <- getEnvMaybe "PAGER" + let pager = fromMaybe "less" mv + pagerOpts = if pager == "less" then ["-f", "-r"] else [] + rawSystem pager (pagerOpts ++ [file]) + +-- +-- Clean up the output with some regular expressions. +-- polish :: String -> String polish = unlines . dups . map polish' . lines where polish' [] = [] polish' s - | Just [_,a,b] <- match name s [] = polish' (a ++ b) - | Just [_,a,b] <- match local s [] = polish' (a ++ b) - | Just _ <- match core s [] = "------------------------------- Core -----------------------------------" - | Just _ <- match asm s [] = "------------------------------- Assembly -------------------------------" - - | Just _ <- match junk s [] = [] - | Just _ <- match junk2 s [] = [] - | Just _ <- match junk3 s [] = [] - | Just _ <- match junk4 s [] = [] - | Just _ <- match junk5 s [] = [] - | Just _ <- match junk6 s [] = [] - | Just _ <- match junk7 s [] = [] - - | otherwise = s + | Just [_,a,b] <- match name s [] = polish' (a ++ b) + | Just [_,a,b] <- match local s [] = polish' (a ++ b) + | isJunk s = "" + | otherwise = s -- simplify some qualified names name = compile @@ -204,93 +146,45 @@ "^(.*)Main\\.(.*)$" [ungreedy] - -- remove boring things - core = compile "Tidy Core" [ungreedy] - asm = compile "Asm code" [ungreedy] + isJunk s = any (\r -> isJust (match r s [])) junks - junk = compile "^.GlobalId" [] - junk2 = compile "^.Arity .*" [] - junk3 = compile "^Rec {|^end Rec" [] - junk4 = compile "DmdType" [] - junk5 = compile "NoCafRefs" [] - junk6 = compile "^\\[\\]$" [] - junk7 = compile "==========" [] + junks = map (\r -> compile r []) + [ "^.GlobalId" + , "^.Arity .*" + , "^Rec {|^end Rec" + , "DmdType" + , "NoCafRefs" + , "^\\[\\]$" + ] -- remove duplicate blank lines dups [] = [] dups ([]:[]:xs) = dups ([]:xs) dups (x:xs) = x : dups xs --- --- Eliminate calls to infix cast from output. --- -castKill :: String -> String -castKill ('`':'c':'a':'s':'t':'`':' ':'(':xs) = parenMunch 1 xs - where - parenMunch :: Int -> String -> String - parenMunch 0 xs = castKill xs - parenMunch n (')':xs) = parenMunch (n-1) xs - parenMunch n ('(':xs) = parenMunch (n+1) xs - parenMunch n (_:xs) = parenMunch n xs -castKill (x:xs) = x : castKill xs -castKill [] = [] - ------------------------------------------------------------------------ -compileWithCore :: String -> [String] -> Bool -> IO String -compileWithCore ghc opts asm = do - let args = words $ "-O2 -keep-tmp-files -ddump-simpl -ddump-simpl-stats -fforce-recomp --make" ++ if asm then " -ddump-asm" else "" +compileWithCore :: Options -> [String] -> IO String +compileWithCore opts args = do + -- TODO: Show generated assembly for -fllvm (previously implemented with + -- -keep-tmp-files) + -- TODO: Does -ddump-simpl-stats belong here? + let defaultArgs = words "-O2 -ddump-simpl -fforce-recomp --make" + ++ (if optAsm opts then ["-ddump-asm"] else []) + ++ (if optCast opts then [] else ["-dsuppress-coercions"]) - x <- readProcess ghc (args ++ opts) [] + x <- readProcessWithExitCode (optGhcExe opts) (defaultArgs ++ args) [] case x of - Left (err,str,std) -> do + (err@(ExitFailure _),str,std) -> do mapM_ putStrLn (lines str) mapM_ putStrLn (lines std) - printf "GHC failed to compile %s\n" (show err) + hPutStrLn stderr ("GHC failed to compile " ++ show err) exitWith (ExitFailure 1) -- fatal - Right str -> return str + (ExitSuccess, str, _) -> return str ------------------------------------------------------------------------ --- --- Strict process reading --- -readProcess :: FilePath -- ^ command to run - -> [String] -- ^ any arguments - -> String -- ^ standard input - -> IO (Either (ExitCode,String,String) String) -- ^ either the stdout, or an exitcode and any output - -readProcess cmd args input = handle (return . Left . handler) $ do - (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing - - output <- hGetContents outh - outMVar <- newEmptyMVar - forkIO $ (evaluate (length output) >> putMVar outMVar ()) - - errput <- hGetContents errh - errMVar <- newEmptyMVar - forkIO $ (evaluate (length errput) >> putMVar errMVar ()) - - when (not (null input)) $ hPutStr inh input - takeMVar outMVar - takeMVar errMVar - ex <- E.catch (waitForProcess pid) (\(_::SomeException) -> return ExitSuccess) - hClose outh - hClose inh -- done with stdin - hClose errh -- ignore stderr - - return $ case ex of - ExitSuccess -> Right output - ExitFailure _ -> Left (ex, errput, output) - - where - handler :: SomeException -> (ExitCode,String,String) - handler ex - | Just (e::ExitCode) <- fromException ex = (e,"","") - | otherwise = (ExitFailure 1, show ex, "") - - -- Safe wrapper for getEnv getEnvMaybe :: String -> IO (Maybe String) -getEnvMaybe name = handle (\(_::SomeException) -> return Nothing) (Just `fmap` getEnv name) +getEnvMaybe name = handle (\(_::SomeException) -> return Nothing) (Just <$> getEnv name)