ghc-core 0.1 → 0.2

raw patch · 2 files changed

+62/−26 lines, 2 files

Files

• ghc-core.cabal +1/−1
• ghc-core.hs +61/−25

@@ -1,5 +1,5 @@ name:           ghc-core-version:        0.1+version:        0.2 license:        BSD3 license-file:   LICENSE author:         Don Stewart

@@ -26,7 +26,9 @@ import Control.Exception import Control.Monad import Data.List+import Data.Maybe import System.Cmd+import System.Console.GetOpt import System.Directory import System.Environment import System.Exit@@ -42,37 +44,70 @@ import Language.Haskell.HsColour.Colourise  ------------------------------------------------------------------------+--+-- Command line parsing+-- --- default hscolours-defaultColourPrefs :: ColourPrefs-defaultColourPrefs = ColourPrefs-  { keyword  = [Foreground Green,Underscore]-  , keyglyph = [Foreground Red]-  , layout   = [Foreground Cyan]-  , comment  = [Foreground Blue]-  , conid    = [Normal]-  , varid    = [Normal]-  , conop    = [Foreground Red,Bold]-  , varop    = [Foreground Cyan]-  , string   = [Foreground Magenta]-  , char     = [Foreground Magenta]-  , number   = [Foreground Magenta]-  , cpp      = [Foreground Magenta,Dim]-  , selection = [Bold, Foreground Magenta]-  , variantselection = [Dim, Foreground Red, Underscore]-  , definition = [Foreground Blue]+data Options = Options+  { optHelp   :: Bool+  , optFormat :: Output+  , optGhcExe :: String+  } deriving (Eq, Show)++defaultOptions :: Options+defaultOptions = Options+  { optHelp    = False+  , optFormat  = TTY+  , optGhcExe  = "ghc"   } +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."+    ]+    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 = +    case getOpt RequireOrder options argv of+        (o, n, []) -> let o' = foldl (flip ($)) defaultOptions o in+                        if optHelp o'+                            then do hPutStr stderr (usageInfo header options)+                                    exitWith ExitSuccess+                            else return (o', n)+        (_, _, es) -> ioError (userError (concat es ++ usageInfo header options))+    where header = "Usage: ghc-core [OPTION...] [--] [GHC_OPTION...] [files...]"+ ------------------------------------------------------------------------  main :: IO () main = do-    args  <- getArgs+    -- Parse command line+    (opts, args) <- getArgs >>= parseOptions +    -- Read colors from .hscolour+    colourPrefs <- readColourPrefs+     mv <- getEnvMaybe "PAGER"     let less = case mv of Just s -> s ; _ -> "less" -    strs' <- polish `fmap` compileWithCore args+    strs' <- polish `fmap` compileWithCore (optGhcExe opts) args     (strs,tmps) <- do         x <- readProcess "sh" ["-c","ls /tmp/ghc*/*.s | head -1"] []         case x of@@ -82,7 +117,9 @@                                     return ((strs' ++ asm), Just $ takeDirectory s)                             else return (strs', Just $ takeDirectory s) -    let nice = hscolour TTY defaultColourPrefs False True False strs+    let nice = hscolour+                (optFormat opts)+                colourPrefs False True False strs      bracket         (openTempFile "/tmp" "ghc-core-XXXX.hcr")@@ -148,10 +185,9 @@  ------------------------------------------------------------------------ -compileWithCore :: [String] -> IO String-compileWithCore opts = do-    let ghc  = "ghc"-        args = words "-O2 -keep-tmp-files -ddump-simpl -ddump-asm -ddump-simpl-stats -no-recomp --make"+compileWithCore :: String -> [String] -> IO String+compileWithCore ghc opts = do+    let args = words "-O2 -keep-tmp-files -ddump-simpl -ddump-asm -ddump-simpl-stats -no-recomp --make"      x <- readProcess ghc (opts ++ args) []     case x of