tkyprof (empty) → 0.0.1

raw patch · 13 files changed

+870/−0 lines, 13 filesdep +aesondep +attoparsecdep +attoparsec-enumeratorsetup-changed

Dependencies added: aeson, attoparsec, attoparsec-enumerator, base, blaze-builder, bytestring, containers, directory, enumerator, filepath, hamlet, mtl, rosezipper, stm, template-haskell, text, time, transformers, vector, wai, wai-extra, wai-handler-webkit, warp, web-routes, yesod-core, yesod-form, yesod-json, yesod-static

Files

Controller.hs +46/−0
Handler/Home.hs +20/−0
Handler/Reports.hs +81/−0
LICENSE +25/−0
Model.hs +50/−0
ProfilingReport.hs +270/−0
Setup.hs +2/−0
TKYProf.hs +107/−0
bin/prof2json.hs +29/−0
bin/tkyprof.hs +23/−0
config/Settings.hs +110/−0
config/StaticFiles.hs +10/−0
tkyprof.cabal +97/−0

+ Controller.hs view

@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Controller+  ( withTKYProf+  , withDevelApp+  ) where++import TKYProf+import Settings+import Yesod.Helpers.Static+import Data.ByteString (ByteString)+import Network.Wai (Application)+import Data.Dynamic (Dynamic, toDyn)++-- Import all relevant handler modules here.+import Handler.Home+import Handler.Reports++-- This line actually creates our YesodSite instance. It is the second half+-- of the call to mkYesodData which occurs in TKYProf.hs. Please see+-- the comments there for more details.+mkYesodDispatch "TKYProf" resourcesTKYProf++-- Some default handlers that ship with the Yesod site template. You will+-- very rarely need to modify this.+getFaviconR :: Handler ()+getFaviconR = sendFile "image/x-icon" "config/favicon.ico"++getRobotsR :: Handler RepPlain+getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)++-- This function allocates resources (such as a database connection pool),+-- performs initialization and creates a WAI application. This is also the+-- place to put your migrate statements to have automatic database+-- migrations handled by Yesod.+withTKYProf :: (Application -> IO a) -> IO a+withTKYProf f = do+  rs <- atomically $ emptyReports+  let h = TKYProf { getStatic  = s+                  , getReports = rs }+  toWaiApp h >>= f+  where+    s = static Settings.staticdir++withDevelApp :: Dynamic+withDevelApp = toDyn (withTKYProf :: (Application -> IO ()) -> IO ())

+ Handler/Home.hs view

@@ -0,0 +1,20 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}+module Handler.Home where+import TKYProf+import Yesod.Form (Enctype(Multipart))++-- This is a handler function for the GET request method on the RootR+-- resource pattern. All of your resource patterns are defined in+-- TKYProf.hs; look for the line beginning with mkYesodData.+--+-- The majority of the code you will write in Yesod lives in these handler+-- functions. You can spread them across multiple files if you are so+-- inclined, or create a single monolithic file.+getHomeR :: Handler RepHtml+getHomeR = do+  defaultLayout $ do+    setTitle "Devel.TKYProf Home"+    addScript $ StaticR js_jquery_ui_widgets_min_js+    addScript $ StaticR js_jquery_iframe_transport_js+    addScript $ StaticR js_jquery_fileupload_js+    addWidget $(widgetFile "home")

+ Handler/Reports.hs view

@@ -0,0 +1,81 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns, TemplateHaskell, QuasiQuotes, OverloadedStrings #-}+module Handler.Reports+  ( getReportsR+  , postReportsR+  , getReportsIdR+  ) where++import TKYProf+import ProfilingReport+import Control.Applicative+import Yesod.Request+import qualified Data.Attoparsec as A+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Aeson as A (encode)+import qualified Data.Text.Lazy.Encoding as T (decodeUtf8)++getReportsR :: Handler RepHtml+getReportsR = do+  reports <- getAllReports+  defaultLayout $ do+    setTitle "Devel.TKYProf Report"+    addWidget $(widgetFile "reports")++postReportsR :: Handler ()+postReportsR = do+  FileInfo {fileContent} <- getPostedReport+  prof <- parseFileContent fileContent+  postProfilingReport prof++getReportsIdR :: ReportID -> Handler RepHtml+getReportsIdR reportId = do+  report@ProfilingReport {..} <- getProfilingReport reportId+  let json = T.decodeUtf8 $ A.encode reportCostCentres+  defaultLayout $ do+    setTitle "Devel.TKYProf Report"+    addScript $ StaticR js_d3_js+    addScript $ StaticR js_d3_layout_js+    addWidget $(widgetFile "reports-id")++-- Helper functions+runReports :: STM a -> Handler a+runReports = liftIO . atomically++getReports' :: Handler Reports+getReports' = getReports <$> getYesod++getAllReports :: Handler [(ReportID, ProfilingReport)]+getAllReports = do+  rs <- getReports'+  runReports $ allReports rs++getAllProfilingReports :: Handler [ProfilingReport]+getAllProfilingReports = map snd <$> getAllReports++getProfilingReport :: ReportID -> Handler ProfilingReport+getProfilingReport reportId = do+  rs <- getReports'+  mreport <- runReports $ lookupReport reportId rs+  case mreport of+    Just r  -> return r+    Nothing -> notFound++postProfilingReport :: ProfilingReport -> Handler ()+postProfilingReport prof = do+  rs <- getReports'+  reportId <- runReports $ insertReport prof rs+  sendResponseCreated (ReportsIdR reportId)++getPostedReport :: Handler FileInfo+getPostedReport = do+  (_, files) <- runRequestBody+  case lookup "reports" files of+    Nothing   -> invalidArgs ["Missing files"]+    Just file -> return file++parseFileContent :: L.ByteString -> Handler ProfilingReport+parseFileContent content =+  case A.parseOnly profilingReport (S.concat $ L.toChunks content) of+    Left err   -> invalidArgs ["Invalid format", toMessage err]+    Right tree -> return tree

+ LICENSE view

@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2011, Mitsutoshi Aoe. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Model.hs view

@@ -0,0 +1,50 @@+{-# LANGUAGE RecordWildCards #-}+module Model where+import ProfilingReport+import Data.Map (Map)+import qualified Data.Map as M+import Control.Applicative+import Control.Concurrent.STM++type ReportID = Integer++data Reports = Reports+  { newReportId :: TVar ReportID+  , reports     :: TVar (Map ReportID ProfilingReport)+  }++emptyReports :: STM Reports+emptyReports = do+  uid <- newTVar 0+  rs  <- newTVar M.empty+  return $ Reports { newReportId = uid+                   , reports     = rs }++insertReport :: ProfilingReport -> Reports -> STM ReportID+insertReport r Reports{..} = do+  uid <- readTVar newReportId+  rs  <- readTVar reports+  writeTVar newReportId (succ uid)+  writeTVar reports (M.insert uid r rs)+  return uid++deleteReport :: ReportID -> Reports -> STM ()+deleteReport i Reports{..} = do+  rs <- readTVar reports+  writeTVar reports (M.delete i rs)++lookupReport :: ReportID -> Reports -> STM (Maybe ProfilingReport)+lookupReport i Reports{..} = do+  rs <- readTVar reports+  return $ M.lookup i rs++memberReport :: ReportID -> Reports -> STM Bool+memberReport i Reports{..} = do+  rs <- readTVar reports+  return $ M.member i rs++allReports :: Reports -> STM [(ReportID, ProfilingReport)]+allReports (Reports _ rs) = M.toList <$> readTVar rs++allProfilingReports :: Reports -> STM [ProfilingReport]+allProfilingReports r = map snd <$> allReports r

+ ProfilingReport.hs view

@@ -0,0 +1,270 @@+{-# LANGUAGE FlexibleInstances, RecordWildCards, OverloadedStrings, BangPatterns #-}+module ProfilingReport+  ( -- * Parsers for profiling reports+    profilingReport+  , profilingReportI+    -- * Parsers for sub-parts of the report+  , timestamp+  , title+  , commandLine +  , totalTime+  , totalAlloc+  , hotCostCentres+  , costCentres+    -- * Data types+  , ProfilingReport(..)+  , Timestamp+  , CommandLine+  , TotalTime(..)+  , TotalAlloc(..)+  , BriefCostCentre(..)+  , CostCentre(..)+    -- * Re-exported modules+  , module Data.Tree+  ) where++import Control.Applicative hiding (many)+import Data.Aeson+import Data.Attoparsec.Char8 as A8+import Data.Attoparsec.Enumerator (iterParser)+import Data.ByteString (ByteString)+import Data.Enumerator (Iteratee)+import Data.Foldable (foldl')+import Data.Time (UTCTime(..), TimeOfDay(..), timeOfDayToTime, fromGregorian)+import Data.Tree (Tree(..), Forest)+import Data.Tree.Zipper (TreePos, Full)+import Prelude hiding (takeWhile)+import qualified Data.Attoparsec as A+import qualified Data.Map as M+import qualified Data.Tree.Zipper as Z+import qualified Data.Vector as V+import Data.Text (Text)+import qualified Data.Text.Encoding as T++data ProfilingReport = ProfilingReport+  { reportTimestamp      :: Timestamp+  , reportCommandLine    :: CommandLine+  , reportTotalTime      :: TotalTime+  , reportTotalAlloc     :: TotalAlloc+  , reportHotCostCentres :: [BriefCostCentre]+  , reportCostCentres    :: Tree CostCentre+  } deriving Show++type Timestamp = UTCTime++type CommandLine = Text++data TotalTime = TotalTime+  { totalSecs  :: Double+  , totalTicks :: Integer+  , resolution :: Integer+  } deriving Show++newtype TotalAlloc = TotalAlloc+  { totalAllocBytes :: Integer+  } deriving Show++data BriefCostCentre = BriefCostCentre+  { briefCostCentreName   :: Text+  , briefCostCentreModule :: Text+  , briefCostCentreTime   :: Double+  , briefCostCentreAlloc  :: Double+  } deriving Show++data CostCentre = CostCentre+  { costCentreName    :: ByteString+  , costCentreModule  :: ByteString+  , costCentreNo      :: Integer+  , costCentreEntries :: Integer+  , individualTime    :: Double+  , individualAlloc   :: Double+  , inheritedTime     :: Double+  , inheritedAlloc    :: Double+  } deriving Show++profilingReportI :: Monad m => Iteratee ByteString m ProfilingReport+profilingReportI = iterParser profilingReport++profilingReport :: Parser ProfilingReport+profilingReport = spaces >>+  ProfilingReport <$> timestamp+                  <*  title          <* spaces+                  <*> commandLine    <* spaces+                  <*> totalTime      <* spaces+                  <*> totalAlloc     <* spaces+                  <*> hotCostCentres <* spaces+                  <*> costCentres++timestamp :: Parser Timestamp+timestamp = do+  dayOfTheWeek     <* spaces+  m   <- month     <* spaces+  d   <- day       <* spaces+  tod <- timeOfDay <* spaces+  y   <- year      <* spaces+  return UTCTime { utctDay     = fromGregorian y m d+                 , utctDayTime = timeOfDayToTime tod }+  where+    year = decimal+    month = toNum <$> A8.take 3+      where toNum m = case m of+                        "Jan" -> 1; "Feb" -> 2; "Mar" -> 3; "Apr" -> 4;+                        "May" -> 5; "Jun" -> 6; "Jul" -> 7; "Aug" -> 8;+                        "Sep" -> 9; "Oct" -> 10; "Nov" -> 11; "Dec" -> 12+                        _ -> error "timestamp.toNum: impossible"+    day = decimal+    timeOfDay = TimeOfDay <$> decimal <* string ":" <*> decimal <*> pure 0+    dayOfTheWeek = takeTill isSpace++title :: Parser ByteString+title = string "Time and Allocation Profiling Report  (Final)"++commandLine :: Parser CommandLine+commandLine = T.decodeUtf8 <$> line++totalTime :: Parser TotalTime+totalTime = do+  string "total time  ="; spaces+  secs <- double+  string " secs"; spaces+  (ticks, res) <- parens $+    (,) <$> decimal <* string " ticks @ "+        <*> decimal <* string " ms"+  return TotalTime { totalSecs  = secs+                   , totalTicks = ticks+                   , resolution = res }++totalAlloc :: Parser TotalAlloc+totalAlloc = do+  string "total alloc ="; spaces+  n <- groupedDecimal+  string " bytes" <* spaces <* parens (string "excludes profiling overheads")+  return TotalAlloc { totalAllocBytes = n }++groupedDecimal :: Parser Integer+groupedDecimal = foldl' go 0 <$> decimal `sepBy` char8 ','+  where go z n = z*1000 + n++hotCostCentres :: Parser [BriefCostCentre]+hotCostCentres = header *> spaces *> many1 briefCostCentre+  where header :: Parser ByteString+        header = line++briefCostCentre :: Parser BriefCostCentre+briefCostCentre =+  BriefCostCentre <$> symbolText <* spaces+                  <*> symbolText <* spaces+                  <*> double     <* spaces+                  <*> double     <* spaces++costCentres :: Parser (Tree CostCentre)+costCentres = header *> spaces *> costCentreTree+  where header = count 2 line++-- Internal functions+costCentreTree :: Parser (Tree CostCentre)+costCentreTree = buildTree <$> costCentreMap >>= maybe empty pure+  where+    costCentreMap = nestedCostCentre `sepBy1` endOfLine+    nestedCostCentre = (,) <$> nestLevel <*> costCentre++nestLevel :: Parser Int+nestLevel = howMany space++costCentre :: Parser CostCentre+costCentre = CostCentre <$> takeWhile (not . isSpace) <* spaces+                        <*> takeWhile (not . isSpace) <* spaces+                        <*> decimal                   <* spaces+                        <*> decimal                   <* spaces+                        <*> double                    <* spaces+                        <*> double                    <* spaces+                        <*> double                    <* spaces+                        <*> double++type Zipper = TreePos Full+type Level = Int++buildTree :: [(Level, a)] -> Maybe (Tree a)+buildTree [] = Nothing+buildTree ((lvl, t):xs) = Z.toTree <$> snd (foldl' go (lvl, Just z) xs)+  where+    z = Z.fromTree $ Node t []+    go :: (Level, Maybe (Zipper a)) -> (Level, a) -> (Level, Maybe (Zipper a))+    go (curLvl, mzipper) a@(lvl', x)+      | curLvl > lvl' = go (curLvl-1, mzipper >>= Z.parent) a+      | curLvl < lvl' = case mzipper >>= Z.lastChild of+                          Nothing  -> (lvl', Z.insert (Node x []) . Z.children <$> mzipper)+                          mzipper' -> go (curLvl+1, mzipper') a+      | otherwise     = (lvl', Z.insert (Node x []) . Z.nextSpace <$> mzipper)+++-- Small utilities+howMany :: Parser a -> Parser Int+howMany p = howMany' 0+  where howMany' !n = (p >> howMany' (succ n)) <|> return n++spaces :: Parser ()+spaces = () <$ many space++line :: Parser ByteString+line = A.takeWhile (not . isEndOfLine) <* spaces++parens :: Parser a -> Parser a+parens p = string "(" *> p <* string ")"++symbol :: Parser ByteString+symbol = takeWhile (not . isSpace)++symbolText :: Parser Text+symbolText = T.decodeUtf8 <$> symbol++-- Aeson+instance ToJSON ProfilingReport where+  toJSON ProfilingReport {..} =+    object [ "timestamp"      .= reportTimestamp+           , "commandLine"    .= reportCommandLine+           , "totalTime"      .= reportTotalTime+           , "totalAlloc"     .= reportTotalAlloc+           , "hotCostCentres" .= reportHotCostCentres+           , "costCentres"    .= reportCostCentres+           ]++instance ToJSON TotalTime where+  toJSON TotalTime {..} =+    object [ "secs"       .= totalSecs+           , "ticks"      .= totalTicks+           , "resolution" .= resolution+           ]++instance ToJSON TotalAlloc where+  toJSON TotalAlloc {..} =+    object [ "bytes" .= totalAllocBytes ]++instance ToJSON BriefCostCentre where+  toJSON BriefCostCentre {..} =+    object [ "name"   .= briefCostCentreName+           , "module" .= briefCostCentreModule+           , "time"   .= briefCostCentreTime+           , "alloc"  .= briefCostCentreAlloc+           ]++instance ToJSON (Tree CostCentre) where+  toJSON (Node cc@(CostCentre {..}) subForest)+    | null subForest = cc'+    | otherwise      = branch+    where+      branch = Object $ M.insert "subForest" subForestWithParent unwrappedCC+      parent = Object $ M.insert "isParent" (toJSON True) unwrappedCC+      subForestWithParent = Array $ V.fromList $ parent:map toJSON subForest+      cc'@(Object unwrappedCC) = toJSON cc++instance ToJSON CostCentre where+  toJSON CostCentre {..} =+    object [ "name"            .= costCentreName+           , "module"          .= costCentreModule+           , "no"              .= costCentreNo+           , "entries"         .= costCentreEntries+           , "individualTime"  .= individualTime+           , "individualAlloc" .= individualAlloc+           , "inheritedTime"   .= inheritedTime+           , "inheritedAlloc"  .= inheritedAlloc ]

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ TKYProf.hs view

@@ -0,0 +1,107 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}+module TKYProf+  ( TKYProf (..)+  , TKYProfRoute (..)+  , resourcesTKYProf+  , Handler+  , Widget+  , module Yesod.Core+  , module Settings+  , module StaticFiles+  , module Model+  , module Control.Monad.STM+  , StaticRoute (..)+  , lift+  , liftIO+  ) where++import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.STM (STM, atomically)+import Control.Monad.Trans.Class (lift)+import Model+import Settings (hamletFile, luciusFile, juliusFile, widgetFile)+import StaticFiles+import System.Directory+import Yesod.Core+import Yesod.Helpers.Static+import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T+import qualified Settings++-- | The site argument for your application. This can be a good place to+-- keep settings and values requiring initialization before your application+-- starts running, such as database connections. Every handler will have+-- access to the data present here.+data TKYProf = TKYProf+  { getStatic  :: Static -- ^ Settings for static file serving.+  , getReports :: Reports+  }++-- | A useful synonym; most of the handler functions in your application+-- will need to be of this type.+type Handler = GHandler TKYProf TKYProf++-- | A useful synonym; most of the widgets functions in your application+-- will need to be of this type.+type Widget = GWidget TKYProf TKYProf++-- This is where we define all of the routes in our application. For a full+-- explanation of the syntax, please see:+-- http://docs.yesodweb.com/book/web-routes-quasi/+--+-- This function does three things:+--+-- * Creates the route datatype TKYProfRoute. Every valid URL in your+--   application can be represented as a value of this type.+-- * Creates the associated type:+--       type instance Route TKYProf = TKYProfRoute+-- * Creates the value resourcesTKYProf which contains information on the+--   resources declared below. This is used in Controller.hs by the call to+--   mkYesodDispatch+--+-- What this function does *not* do is create a YesodSite instance for+-- TKYProf. Creating that instance requires all of the handler functions+-- for our application to be in scope. However, the handler functions+-- usually require access to the TKYProfRoute datatype. Therefore, we+-- split these actions into two functions and place them in separate files.+mkYesodData "TKYProf" $(parseRoutesFile "config/routes")++-- Please see the documentation for the Yesod typeclass. There are a number+-- of settings which can be configured by overriding methods here.+instance Yesod TKYProf where+  approot _ = Settings.approot++  defaultLayout widget = do+    mmsg <- getMessage+    (title, bcs) <- breadcrumbs+    pc <- widgetToPageContent $ do+      widget+      addLucius $(Settings.luciusFile "default-layout")+    hamletToRepHtml $(Settings.hamletFile "default-layout")++  -- This is done to provide an optimization for serving static files from+  -- a separate domain. Please see the staticroot setting in Settings.hs+  urlRenderOverride a (StaticR s) =+    Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s+  urlRenderOverride _ _ = Nothing++  -- This function creates static content files in the static folder+  -- and names them based on a hash of their content. This allows+  -- expiration dates to be set far in the future without worry of+  -- users receiving stale content.+  addStaticContent ext' _ content = do+    let fn = base64md5 content ++ '.' : T.unpack ext'+    let statictmp = Settings.staticdir ++ "/tmp/"+    liftIO $ createDirectoryIfMissing True statictmp+    let fn' = statictmp ++ fn+    exists <- liftIO $ doesFileExist fn'+    unless exists $ liftIO $ L.writeFile fn' content+    return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])++instance YesodBreadcrumbs TKYProf where+  breadcrumb HomeR            = return ("Home", Nothing)+  breadcrumb ReportsR         = return ("Reports", Just HomeR)+  breadcrumb (ReportsIdR rid) = return ("Report #" `T.append` T.pack (show rid), Just ReportsR)+  breadcrumb _                = return ("Not found", Just HomeR)+

+ bin/prof2json.hs view

@@ -0,0 +1,29 @@+module Main where+import Blaze.ByteString.Builder (toByteStringIO)+import Control.Applicative+import Control.Exception (bracket)+import Control.Monad.Trans (liftIO)+import Data.Aeson (toJSON)+import Data.Aeson.Encode (fromValue)+import Data.Enumerator (Iteratee, ($$), run_)+import ProfilingReport (ProfilingReport(..), profilingReportI)+import System.Environment (getArgs)+import System.FilePath (dropExtension)+import System.IO (IOMode(WriteMode), openFile, hClose)+import qualified Data.ByteString as S+import qualified Data.Enumerator.Binary as E++main :: IO ()+main = getArgs >>= mapM_ (run_ . job)++job :: FilePath -> Iteratee S.ByteString IO ()+job f = E.enumFile f $$ iterJob json+  where+    json = dropExtension f ++ ".json"++iterJob :: FilePath -> Iteratee S.ByteString IO ()+iterJob fpath = do+  builder <- fromValue . toJSON . reportCostCentres <$> profilingReportI+  liftIO $ bracket (openFile fpath WriteMode)+                   hClose+                   (\h -> toByteStringIO (S.hPut h) builder)

+ bin/tkyprof.hs view

@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}+import Controller (withTKYProf)+#if PRODUCTION+import Network.Wai.Handler.Webkit (run)++main :: IO ()+main = withTKYProf $ run "Devel.TKYProf"+#elif WEB+import Network.Wai.Handler.Warp (run)++main :: IO ()+main = withTKYProf $ run 3000+#else+import System.IO (hPutStrLn, stderr)+import Network.Wai.Middleware.Debug (debug)+import Network.Wai.Handler.Warp (run)++main :: IO ()+main = do+  let port = 3000+  hPutStrLn stderr $ "Application launched, listening on port " ++ show port+  withTKYProf $ run port . debug+#endif

+ config/Settings.hs view

@@ -0,0 +1,110 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Settings are centralized, as much as possible, into this file. This+-- includes database connection settings, static file locations, etc.+-- In addition, you can configure a number of different aspects of Yesod+-- by overriding methods in the Yesod typeclass. That instance is+-- declared in the tkyprof.hs file.+module Settings+  ( hamletFile+  , juliusFile+  , luciusFile+  , widgetFile+  , approot+  , staticroot+  , staticdir+  ) where++import qualified Text.Hamlet as H+import qualified Text.Julius as H+import qualified Text.Lucius as H+import Language.Haskell.TH.Syntax+import Yesod.Widget (addWidget, addJulius, addLucius)+import Data.Monoid (mempty, mappend)+import System.Directory (doesFileExist)+import Data.Text (Text)++-- | The base URL for your application. This will usually be different for+-- development and production. Yesod automatically constructs URLs for you,+-- so this value must be accurate to create valid links.+approot :: Text+#ifdef PRODUCTION+-- You probably want to change this. If your domain name was "yesod.com",+-- you would probably want it to be:+-- > approot = "http://www.yesod.com"+-- Please note that there is no trailing slash.+approot = "http://localhost:3000"+#else+approot = "http://localhost:3000"+#endif++-- | The location of static files on your system. This is a file system+-- path. The default value works properly with your scaffolded site.+staticdir :: FilePath+staticdir = "static"++-- | The base URL for your static files. As you can see by the default+-- value, this can simply be "static" appended to your application root.+-- A powerful optimization can be serving static files from a separate+-- domain name. This allows you to use a web server optimized for static+-- files, more easily set expires and cache values, and avoid possibly+-- costly transference of cookies on static files. For more information,+-- please see:+--   http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain+--+-- If you change the resource pattern for StaticR in tkyprof.hs, you will+-- have to make a corresponding change here.+--+-- To see how this value is used, see urlRenderOverride in tkyprof.hs+staticroot :: Text+staticroot = approot `mappend` "/static"++-- The rest of this file contains settings which rarely need changing by a+-- user.++-- The following three functions are used for calling HTML, CSS and+-- Javascript templates from your Haskell code. During development,+-- the "Debug" versions of these functions are used so that changes to+-- the templates are immediately reflected in an already running+-- application. When making a production compile, the non-debug version+-- is used for increased performance.+--+-- You can see an example of how to call these functions in Handler/Root.hs+--+-- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer+-- used; to get the same auto-loading effect, it is recommended that you+-- use the devel server.++toHamletFile, toJuliusFile, toLuciusFile :: String -> FilePath+toHamletFile x = "hamlet/" ++ x ++ ".hamlet"+toJuliusFile x = "julius/" ++ x ++ ".julius"+toLuciusFile x = "lucius/" ++ x ++ ".lucius"++hamletFile :: FilePath -> Q Exp+hamletFile = H.hamletFile . toHamletFile++luciusFile :: FilePath -> Q Exp+#ifdef PRODUCTION+luciusFile = H.luciusFile . toLuciusFile+#else+luciusFile = H.luciusFileDebug . toLuciusFile+#endif++juliusFile :: FilePath -> Q Exp+#ifdef PRODUCTION+juliusFile = H.juliusFile . toJuliusFile+#else+juliusFile = H.juliusFileDebug . toJuliusFile+#endif++widgetFile :: FilePath -> Q Exp+widgetFile x = do+  let h = unlessExists toHamletFile hamletFile+  let j = unlessExists toJuliusFile juliusFile+  let l = unlessExists toLuciusFile luciusFile+  [|addWidget $h >> addJulius $j >> addLucius $l|]+  where+    unlessExists tofn f = do+      e <- qRunIO $ doesFileExist $ tofn x+      if e then f x else [|mempty|]

+ config/StaticFiles.hs view

@@ -0,0 +1,10 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}+module StaticFiles where++import Yesod.Helpers.Static++-- | This generates easy references to files in the static directory at compile time.+--   The upside to this is that you have compile-time verification that referenced files+--   exist. However, any files added to your static directory during run-time can't be+--   accessed this way. You'll have to use their FilePath or URL to access them.+staticFiles "static"

+ tkyprof.cabal view

@@ -0,0 +1,97 @@+name:                 tkyprof+version:              0.0.1+license:              BSD3+license-file:         LICENSE+author:               Mitsutoshi Aoe+maintainer:           Mitsutoshi Aoe <maoe@foldr.in>+synopsis:             A visualizer for GHC Profiling Reports+description:          A visualizer for GHC Profiling Reports+category:             Devel+stability:            Experimental+cabal-version:        >= 1.6+build-type:           Simple+homepage:             https://github.com/maoe/tkyprof++flag production+  description:        Build the production executable.+  default:            False++flag web+  description:        Build the production executable.+  default:            True++flag devel+  description:        Build for use with "yesod devel"+  default:            False++executable tkyprof+  if flag(devel)+    buildable:        False++  if flag(production)+    if flag(web)+      ghc-options:      -Wall -threaded -O2 -fno-warn-unused-do-bind+      cpp-options:    -DWEB+    else+      cpp-options:    -DPRODUCTION+      ghc-options:    -Wall -fno-warn-unused-do-bind -pgmc g++ -pgml g+++      pkgconfig-depends: QtWebKit+      build-depends:  wai-handler-webkit+  else+    ghc-options:      -Wall -threaded++  main-is:            bin/tkyprof.hs+  hs-source-dirs:     ., config, bin++  build-depends:      base >= 4 && < 5+                    , aeson >= 0.3 && < 0.4+                    , attoparsec >= 0.9 && < 0.10+                    , attoparsec-enumerator >= 0.2 && < 0.3+                    , bytestring >= 0.9 && < 0.10+                    , containers < 0.5+                    , directory < 2+                    , enumerator >= 0.4 && < 0.5+                    , hamlet >= 0.8 && < 0.10+                    , rosezipper >= 0.2 && < 0.3+                    , stm < 3+                    , template-haskell < 3+                    , text >= 0.11 && < 0.12+                    , time >= 1.2 && < 1.3+                    , transformers >= 0.2 && < 0.3+                    , wai >= 0.4 && < 0.5+                    , wai-extra >= 0.4 && < 0.5+                    , warp >= 0.4 && < 0.5+                    , web-routes >= 0.23 && < 0.26+                    , yesod-core >= 0.8 && < 0.9+                    , yesod-form >= 0.1 && < 0.2+                    , yesod-json >= 0.1 && < 0.2+                    , yesod-static >= 0.1 && < 0.2+  ghc-options:        -Wall -threaded++library+  if flag(devel)+    buildable:        True+  else+    buildable:        False+  exposed-modules:    Controller+  hs-source-dirs:     ., config, bin+  other-modules:      TKYProf+                      Handler.Home+                      Handler.Reports+                      Model+                      ProfilingReport+                      Settings+                      StaticFiles++executable prof2json+  buildable:          False+  hs-source-dirs:     ., bin+  main-is:            prof2json.hs+  build-depends:      filepath+                    , mtl+                    , blaze-builder+                    , vector++source-repository head+  type:               git+  location:           git@github.com:maoe/tkyprof.git