{-# LANGUAGE OverloadedStrings #-} module Main where import Text.Parsec import Text.Parsec.String import System.Environment import System.Console.GetOpt import Control.Monad import Data.Maybe (isJust) import Data.Monoid import Data.List import qualified Data.Foldable as F import Text.Blaze.Html5 (toHtml) import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5 ((!)) import qualified Text.Blaze.Html5.Attributes as HA import Text.Blaze.Html.Renderer.Utf8 import qualified Data.ByteString.Lazy.Char8 as LC import System.IO import System.Exit import System.Process import Text.Printf import qualified Data.Map as M import GhcCore.Parser import Paths_ghc_core_html -- | Print raw result of parse printRaw :: [Atom] -> IO () printRaw xs = do mapM_ print xs let (nJ,nF,nO) = foldl acc (0,0,0) xs printf "Parsed %i / %i (%i junks)" nO (nO+nF) nJ where acc :: (Int,Int,Int) -> Atom -> (Int,Int,Int) acc (nJ,nF,nO) (Junk _) = (nJ+1,nF,nO) acc (nJ,nF,nO) (RawBinding {}) = (nJ,nF+1,nO) acc (nJ,nF,nO) (BindingP {}) = (nJ,nF,nO+1) go :: [Flag] -> [String] -> IO () go _ [] = error "no file specified" go opts (f:_) = do -- Read CSS file css <- readFile =<< getDataFileName "css/default.css" js <- readFile =<< getDataFileName "js/page.js" -- read the core file, either directly if it's specified as a file, or -- by running ghc on the source file. result <- if CoreFile `elem` opts then parseFromFile core f else do let args = "-O2":"-ddump-simpl":"-fforce-recomp":"--make": (if WithCast `elem` opts then [] else ["-dsuppress-coercions"]) let ghcProgram = case [ p | Ghc p <- opts ] of p:_ -> p _ -> "ghc" (x,out,err) <- readProcessWithExitCode ghcProgram (args ++ [f]) [] case x of ExitFailure _ -> error ("dumping ghc core failed: " ++ err) ExitSuccess -> return $ runP core () "core" out case result of Left err -> print err Right xs | Raw `elem` opts -> printRaw xs | otherwise -> do -- default HTML output let table = allSyms xs LC.hPutStrLn stdout $ renderHtml $ onPage css js $ do H.header $ do H.a ! HA.id "buttonToggleBody" $ "toggle bodies" _ <- " - " indexify table F.foldMap (atomToHtml table) xs where onPage css js p = H.html $ do H.head $ do H.title "core-2-html" H.style $ toHtml css H.script ! HA.src "http://code.jquery.com/jquery-1.9.1.min.js" $ "" H.script ! HA.type_ "text/javascript" $ toHtml js H.body p allSyms = foldl i M.empty where i a (Junk _) = a i a (RawBinding sym _ _) = M.insert sym () a i a (BindingP bind) = M.insert (bindSymbol bind) () a indexify table = do --let allToplevelSyms = foldl i [] atoms let t = foldl prefixify pempty $ map fst $ M.toList table H.ul $ H.li ! HA.class_ "idxdir" $ do treeToHtml "Index" t where prefixify a s = case wordsWhen (== '.') s of l@[_] -> pinsert s ("$ANONYMOUS":l) a l -> pinsert s l a treeToHtml n (Leaf m) = toAnchor m $ toHtml n treeToHtml n (PTree m) = do H.span $ toHtml n H.ul $ do forM_ (M.toList m) $ \(k,v) -> do H.li ! HA.class_ "idxdir" $ do treeToHtml k v atomToHtml :: M.Map String a -> Atom -> H.Html atomToHtml _ (Junk s) = H.section $ H.pre (toHtml s) atomToHtml table (BindingP bind) = H.section ! HA.class_ "binding" $ do anchor (bindSymbol bind) let (first:after) = lines $ bindBody bind H.pre ! HA.class_ "header" ! HA.title (H.toValue $ signatureRaw $ bindSignature bind) $ colorify table first H.pre ! HA.class_ "body" $ colorify table $ unlines after atomToHtml _ (RawBinding sym t errs) = H.section $ do anchor sym H.p (toHtml errs) H.pre (toHtml t) tokenToHtml :: M.Map String a -> Token -> H.Html tokenToHtml table (Symbol s) = let mn = case s of _ | "GHC.Types." `isPrefixOf` s -> Just $ drop 10 s | "GHC.CString." `isPrefixOf` s -> Just $ drop 12 s | "GHC.Prim." `isPrefixOf` s -> Just $ drop 9 s | "GHC.Base." `isPrefixOf` s -> Just $ drop 9 s | "GHC.Word." `isPrefixOf` s -> Just $ drop 9 s | otherwise -> Nothing found = isJust $ M.lookup s table manchor = if found then toAnchor s else id in case mn of Nothing -> manchor (H.span ! HA.class_ "sym" $ toHtml s) Just n -> manchor (H.span ! HA.class_ "sym" ! HA.title (H.toValue s) $ toHtml n) tokenToHtml _ (Number n) = H.span ! HA.class_ "nu" ! HA.title hexVal $ toHtml n where hexVal = H.toValue ( printf "hex: 0x%x" (read n :: Integer) :: String) tokenToHtml _ (Spaces s) = toHtml s tokenToHtml _ (StringT s) = H.span ! HA.class_ "str" $ toHtml ("\"" ++ s ++ "\"") tokenToHtml _ (CharT c) = H.span ! HA.class_ "str" $ toHtml ("\'" ++ [c] ++ "\'") tokenToHtml _ (TypeDef s) = ":: " `mappend` (H.span ! HA.class_ "ty" $ toHtml s) tokenToHtml _ Arrow = "->" tokenToHtml _ Dot = "." tokenToHtml _ BSlash = "\\" tokenToHtml _ Equal = "=" tokenToHtml _ LBrace = "{" tokenToHtml _ RBrace = "}" tokenToHtml _ LBrack = "[" tokenToHtml _ RBrack = "]" tokenToHtml _ LParen = "(" tokenToHtml _ RParen = ")" tokenToHtml _ Unit = "()" tokenToHtml _ LParenHash = "(#" tokenToHtml _ RParenHash = "#)" tokenToHtml _ Case = H.span ! HA.class_ "kw" $ "case" tokenToHtml _ Of = H.span ! HA.class_ "kw" $ "of" tokenToHtml _ Forall = H.span ! HA.class_ "kw" $ "forall" tokenToHtml _ Underscore = "_" tokenToHtml _ (Unknown s) = toHtml s colorify :: M.Map String a -> String -> H.Html colorify table = F.foldMap (tokenToHtml table) . tokenify anchor :: H.ToValue a => a -> H.Html anchor sym = H.a ! HA.name (H.toValue sym) $ "" toAnchor :: String -> H.Html -> H.Html toAnchor sym c = H.a ! HA.href (H.toValue ('#' : sym)) $ c ---------------------------------------------------------------- -- Main ---------------------------------------------------------------- data Flag = Raw | CoreFile | WithCast | Help | Ghc String deriving (Show,Eq) options :: [OptDescr Flag] options = [ Option ['r'] ["raw"] (NoArg Raw) "output raw instead of html" , Option ['c'] ["core"] (NoArg CoreFile) "argument is already a core file" , Option [] ["cast"] (NoArg WithCast) "don't hide cast / coercions" , Option ['h'] ["help"] (NoArg Help) "show help" , Option [] ["ghc"] (ReqArg (\x -> Ghc x) "PROGRAM") "ghc executable to use (default ghc)" ] help :: IO b help = do putStrLn "usage: ghc-core-html [-r|--raw] [-c|--core] [--ghc program] [--cast] " exitSuccess main :: IO () main = do args <- getArgs case getOpt Permute options args of (o,n,[]) | Help `elem` o -> help | otherwise -> go o n (_,_,err) -> error (show err) ---------------------------------------------------------------- -- Helpers ---------------------------------------------------------------- -- Split string into words using predicate wordsWhen :: (Char -> Bool) -> String -> [String] wordsWhen p s = case dropWhile p s of "" -> [] s' -> w : wordsWhen p s'' where (w, s'') = break p s'