├── templates
    ├── reports.lucius
    ├── reports.julius
    ├── reports.hamlet
    ├── header.hamlet
    ├── home.julius
    ├── header.lucius
    ├── default-layout.hamlet
    ├── default-layout.lucius
    ├── home.hamlet
    ├── home.lucius
    ├── reports-id.hamlet
    ├── reports-id.lucius
    └── reports-id.julius
├── static
    ├── js
    │   ├── d3.min.js
    │   ├── d3.layout.min.js
    │   ├── jquery.ui.widget.js
    │   ├── jquery.fileupload.js
    │   ├── jquery.iframe-transport.js
    │   ├── tkyprof.js
    │   └── jquery.pjax.js
    └── images
    │   └── tkyprof-logo-orange.png
├── Setup.hs
├── config
    ├── favicon.png
    ├── routes
    ├── StaticFiles.hs
    └── Settings.hs
├── materials
    ├── snail.svgz
    └── snail-black.svgz
├── .gitignore
├── .gitmodules
├── Handler
    ├── Home.hs
    ├── Reports
    │   └── Helpers.hs
    └── Reports.hs
├── bin
    ├── prof2json.hs
    └── tkyprof.hs
├── README.markdown
├── LICENSE
├── Model.hs
├── Controller.hs
├── TKYProf.hs
├── .travis.yml
├── tkyprof.cabal
└── ProfilingReport.hs


/templates/reports.lucius:
--------------------------------------------------------------------------------
1 | 


--------------------------------------------------------------------------------
/static/js/d3.min.js:
--------------------------------------------------------------------------------
1 | ../../modules/d3/d3.min.js


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/static/js/d3.layout.min.js:
--------------------------------------------------------------------------------
1 | ../../modules/d3/d3.layout.min.js


--------------------------------------------------------------------------------
/static/js/jquery.ui.widget.js:
--------------------------------------------------------------------------------
1 | ../../modules/jquery-ui/ui/jquery.ui.widget.js


--------------------------------------------------------------------------------
/templates/reports.julius:
--------------------------------------------------------------------------------
1 | $(function() {
2 |   console.log("reports");
3 | });


--------------------------------------------------------------------------------
/static/js/jquery.fileupload.js:
--------------------------------------------------------------------------------
1 | ../../modules/jQuery-File-Upload/jquery.fileupload.js


--------------------------------------------------------------------------------
/config/favicon.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/maoe/tkyprof/HEAD/config/favicon.png


--------------------------------------------------------------------------------
/materials/snail.svgz:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/maoe/tkyprof/HEAD/materials/snail.svgz


--------------------------------------------------------------------------------
/static/js/jquery.iframe-transport.js:
--------------------------------------------------------------------------------
1 | ../../modules/jQuery-File-Upload/jquery.iframe-transport.js


--------------------------------------------------------------------------------
/materials/snail-black.svgz:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/maoe/tkyprof/HEAD/materials/snail-black.svgz


--------------------------------------------------------------------------------
/static/images/tkyprof-logo-orange.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/maoe/tkyprof/HEAD/static/images/tkyprof-logo-orange.png


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | .dist-scion/
2 | dist/
3 | client_session_key.aes
4 | static/tmp/
5 | /*.sublime-*
6 | /cabal-dev/
7 | /.cabal-sandbox/
8 | /cabal.sandbox.config
9 | 


--------------------------------------------------------------------------------
/templates/reports.hamlet:
--------------------------------------------------------------------------------
1 | <h2>All reports
2 | $maybe _ <- listToMaybe reports
3 |   <ul>
4 |     $forall report <- reports
5 |       <li>
6 |         <a href=@{ReportsIdR (fst report)}>#{reportCommandLine (snd report)}
7 | $nothing
8 |   <p>There are currently no reports available. First of all, upload your profiling reports please.
9 | 


--------------------------------------------------------------------------------
/.gitmodules:
--------------------------------------------------------------------------------
 1 | [submodule "modules/d3"]
 2 | 	path = modules/d3
 3 | 	url = https://github.com/maoe/d3.git
 4 | [submodule "modules/jQuery-File-Upload"]
 5 | 	path = modules/jQuery-File-Upload
 6 | 	url = https://github.com/blueimp/jQuery-File-Upload.git
 7 | [submodule "modules/jquery-ui"]
 8 | 	path = modules/jquery-ui
 9 | 	url = https://github.com/jquery/jquery-ui.git
10 | 


--------------------------------------------------------------------------------
/templates/header.hamlet:
--------------------------------------------------------------------------------
 1 | <div #header>
 2 |   <nav #breadcrumbs>
 3 |     <h1>
 4 |       <a href=@{HomeR}>
 5 |         <img #logo src=@{StaticR images_tkyprof_logo_orange_png} alt="Home">
 6 |         TKYPr
 7 |         <span #o>o
 8 |         f
 9 |     $forall bc <- bcs
10 |       <a href=@{fst bc}>#{snd bc}
11 |       <span .breadcrumbs-delimiter>>
12 |     #{title}
13 | 
14 | 


--------------------------------------------------------------------------------
/templates/home.julius:
--------------------------------------------------------------------------------
 1 | $(function() {
 2 |   var uploader = $('#uploader');
 3 | 
 4 |   uploader.bind('fileuploaddone', function(e, data) {
 5 |     top.location.href = data.jqXHR.getResponseHeader('Location');
 6 |   });
 7 | 
 8 |   uploader.fileupload({
 9 |     url:               "/reports",
10 |     paramName:         "reports",
11 |     singleFileUploads: false
12 |   });
13 | });
14 | 


--------------------------------------------------------------------------------
/config/routes:
--------------------------------------------------------------------------------
1 | /                              HomeR           GET
2 | /reports                       ReportsR        GET POST
3 | /reports/#Integer              ReportsIdR      GET
4 | /reports/#Integer/time/*Texts  ReportsIdTimeR  GET
5 | /reports/#Integer/alloc/*Texts ReportsIdAllocR GET
6 | /static                        StaticR         Static getStatic
7 | /favicon.png                   FaviconR        GET
8 | /robots.txt                    RobotsR         GET
9 | 


--------------------------------------------------------------------------------
/config/StaticFiles.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
 2 | module StaticFiles where
 3 | 
 4 | import Yesod.Static
 5 | 
 6 | -- | This generates easy references to files in the static directory at compile time.
 7 | --   The upside to this is that you have compile-time verification that referenced files
 8 | --   exist. However, any files added to your static directory during run-time can't be
 9 | --   accessed this way. You'll have to use their FilePath or URL to access them.
10 | staticFiles "static"
11 | 


--------------------------------------------------------------------------------
/templates/header.lucius:
--------------------------------------------------------------------------------
 1 | #header {
 2 |   height: 38px;
 3 |   width: 100%;
 4 | }
 5 | 
 6 | #header h1 {
 7 |   font-family: 'Amaranth', sans-serif;
 8 |   font-weight: 700;
 9 |   font-size: 30px;
10 |   margin: 0px;
11 |   margin-right: 10px;
12 |   display: inline;
13 | }
14 | 
15 | #header h1 #logo {
16 |   margin-right: 5px;
17 | }
18 | 
19 | #header h1 #o {
20 |   color: #e6550d;
21 | }
22 | 
23 | /* breadcrumbs */
24 | #breadcrumbs {
25 |   font-family: sans-serif;
26 |   font-size: 0.75em;
27 | }
28 | 
29 | .breadcrumbs-delimiter {
30 |   margin-left: 0.5em;
31 |   margin-right: 0.5em;
32 | }
33 | 


--------------------------------------------------------------------------------
/templates/default-layout.hamlet:
--------------------------------------------------------------------------------
 1 | !!!
 2 | <html lang="en">
 3 |   <head>
 4 |     <meta charset="utf-8" />
 5 |     <link rel="shortcut icon" type=image/png href=@{FaviconR}>
 6 |     <link href="http://fonts.googleapis.com/css?family=Amaranth:400,700" rel="stylesheet" type="text/css">
 7 |     <script src="//ajax.googleapis.com/ajax/libs/jquery/1.6.2/jquery.min.js">
 8 |     <title>#{pageTitle pc}
 9 |     ^{pageHead pc}
10 |   <body>
11 |     $maybe msg <- mmsg
12 |       <div #message>#{msg}
13 |     ^{pageBody pc}
14 |     <footer>
15 |       Copyright &copy;<time datetime="2011-08-02">2011</time>Mitsutoshi Aoe
16 | 


--------------------------------------------------------------------------------
/templates/default-layout.lucius:
--------------------------------------------------------------------------------
 1 | /* body */
 2 | body {
 3 |   color: #f3f3e3;
 4 |   background: #212121;
 5 |   font-family: sans-serif;
 6 | }
 7 | 
 8 | /* hx */
 9 | h1, h2, h3, h4 {
10 |   font-family: 'Amaranth', sans-serif;
11 |   font-weight: 400;
12 | }
13 | 
14 | h1 {
15 |   font-size: 2em;
16 | }
17 | 
18 | h2 {
19 |   font-size: 1.5em;
20 | }
21 | 
22 | /* a */
23 | a {
24 |   color: #f3f3e3;
25 |   text-decoration: none;
26 | }
27 | 
28 | section a:hover {
29 |   color: #e6550d;
30 |   text-decoration: underline;
31 | }
32 | 
33 | /* footer */
34 | footer {
35 |   text-align: right;
36 |   font-size: 0.75em;
37 |   visibility: hidden;
38 | }


--------------------------------------------------------------------------------
/templates/home.hamlet:
--------------------------------------------------------------------------------
 1 | <h2>1. Select your profiling reports
 2 | <form #uploader action=@{ReportsR} method=post enctype=#{Multipart}>
 3 |   <div #box-wrapper>
 4 |     <div #uploader-dropbox .box>
 5 |       <p>Drop files here!
 6 |     <div #uploader-filedialog .box>
 7 |       <p>Click to select files.
 8 |       <input type=file>
 9 | <h2>
10 |   <a href=@{ReportsR}>2. View reports
11 | $maybe _ <- listToMaybe reports
12 |   <ul>
13 |     $forall report <- reports
14 |       <li>
15 |         <a href=@{ReportsIdR (fst report)}>#{reportCommandLine (snd report)}
16 | $nothing
17 |   <p>There are currently no reports available. First of all, upload your profiling reports please.
18 | 


--------------------------------------------------------------------------------
/Handler/Home.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
 2 | module Handler.Home where
 3 | import TKYProf hiding (reports)
 4 | import Yesod.Form (Enctype(Multipart))
 5 | import Data.Maybe (listToMaybe)
 6 | import Handler.Reports.Helpers (getAllReports)
 7 | import ProfilingReport (ProfilingReport(..))
 8 | 
 9 | -- This is a handler function for the GET request method on the RootR
10 | -- resource pattern. All of your resource patterns are defined in
11 | -- TKYProf.hs; look for the line beginning with mkYesodData.
12 | --
13 | -- The majority of the code you will write in Yesod lives in these handler
14 | -- functions. You can spread them across multiple files if you are so
15 | -- inclined, or create a single monolithic file.
16 | getHomeR :: Handler Html
17 | getHomeR = do
18 |   reports <- getAllReports
19 |   defaultLayout $ do
20 |     setTitle "TKYProf"
21 |     addScript $ StaticR js_jquery_ui_widget_js
22 |     addScript $ StaticR js_jquery_iframe_transport_js
23 |     addScript $ StaticR js_jquery_fileupload_js
24 |     $(widgetFile "home")
25 | 


--------------------------------------------------------------------------------
/templates/home.lucius:
--------------------------------------------------------------------------------
 1 | #box-wrapper {
 2 |   width: 100%;
 3 | 
 4 |   display: -webkit-box;
 5 |   display: -moz-box;
 6 |   display: box;
 7 | 
 8 |   -webkit-box-align: center;
 9 |   -moz-box-align: center;
10 |   box-align: center;
11 | 
12 |   -webkit-box-pack: center;
13 |   -moz-box-pack: center;
14 |   box-pack: center;
15 | }
16 | 
17 | .box {
18 |   width: 50%;
19 |   text-align: center;
20 |   box-sizing: border-box;
21 | }
22 | 
23 | /* dropbox */
24 | #uploader-dropbox {
25 |   height: 200px;
26 |   border: 2px dashed #fd8d38;
27 | 
28 |   -webkit-border-radius: 10px;
29 |   -moz-border-radius: 10px;
30 |   border-radius: 10px;
31 | 
32 |   display: -webkit-box;
33 |   display: -moz-box;
34 |   display: box;
35 | 
36 |   -webkit-box-align: center;
37 |   -moz-box-align: center;
38 |   box-align: center;
39 | 
40 |   -webkit-box-pack: center;
41 |   -moz-box-pack: center;
42 |   box-pack: center;
43 | }
44 | 
45 | #uploader-dropbox:hover {
46 |   border: 2px solid #e6550d;
47 | }
48 | 
49 | /* file dialog */
50 | #uploader-filedialog {
51 |   /* do nothing */
52 | }
53 | 


--------------------------------------------------------------------------------
/bin/prof2json.hs:
--------------------------------------------------------------------------------
 1 | module Main where
 2 | import Blaze.ByteString.Builder (toByteStringIO)
 3 | import Control.Applicative
 4 | import Control.Exception (bracket)
 5 | import Control.Monad.Trans (liftIO)
 6 | import Data.Aeson (toJSON)
 7 | import Data.Aeson.Encode (fromValue)
 8 | import Data.Enumerator (Iteratee, ($$), run_)
 9 | import ProfilingReport (ProfilingReport(..), profilingReportI)
10 | import System.Environment (getArgs)
11 | import System.FilePath (dropExtension)
12 | import System.IO (IOMode(WriteMode), openFile, hClose)
13 | import qualified Data.ByteString as S
14 | import qualified Data.Enumerator.Binary as E
15 | 
16 | main :: IO ()
17 | main = getArgs >>= mapM_ (run_ . job)
18 | 
19 | job :: FilePath -> Iteratee S.ByteString IO ()
20 | job f = E.enumFile f $$ iterJob json
21 |   where
22 |     json = dropExtension f ++ ".json"
23 | 
24 | iterJob :: FilePath -> Iteratee S.ByteString IO ()
25 | iterJob fpath = do
26 |   builder <- fromValue . toJSON . reportCostCentres <$> profilingReportI
27 |   liftIO $ bracket (openFile fpath WriteMode)
28 |                    hClose
29 |                    (\h -> toByteStringIO (S.hPut h) builder)
30 | 


--------------------------------------------------------------------------------
/bin/tkyprof.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveDataTypeable, CPP #-}
 2 | import Controller (withTKYProf)
 3 | import System.IO (hPutStrLn, stderr)
 4 | 
 5 | #if PRODUCTION
 6 | import Data.Version (showVersion)
 7 | import Network.Wai.Handler.Warp (Port, run)
 8 | import Paths_tkyprof (getDataDir, version)
 9 | import System.Console.CmdArgs
10 | import System.Directory (setCurrentDirectory)
11 | 
12 | main :: IO ()
13 | main = do
14 |   getDataDir >>= setCurrentDirectory
15 |   TKYProfArg p <- cmdArgs tkyProfArg
16 |   hPutStrLn stderr $ "TKYProf " ++ showVersion version ++ " launched, listening on http://localhost:" ++ show p ++ "/"
17 |   withTKYProf $ run p
18 | 
19 | data TKYProfArg = TKYProfArg
20 |   { port    :: Port
21 |   } deriving (Show, Data, Typeable)
22 | 
23 | tkyProfArg :: TKYProfArg
24 | tkyProfArg = TKYProfArg { port = 3000 &= help "Port number" }
25 |              &= summary ("TKYProf " ++ showVersion version)
26 | #else
27 | import Network.Wai.Middleware.Debug (debug)
28 | import Network.Wai.Handler.Warp (run)
29 | 
30 | main :: IO ()
31 | main = do
32 |   let port = 3000
33 |   hPutStrLn stderr $ "Application launched, listening on port " ++ show port
34 |   withTKYProf $ run port . debug
35 | #endif
36 | 
37 | {-
38 | import Network.Wai.Handler.Webkit (run)
39 | 
40 | main :: IO ()
41 | main = withTKYProf $ run "TKYProf"
42 | -}
43 | 


--------------------------------------------------------------------------------
/templates/reports-id.hamlet:
--------------------------------------------------------------------------------
 1 | <section #cost-centres>
 2 |   <header>
 3 |     <div .button-group>
 4 |       <h2 #time .button>Time profiling
 5 |       <h2 #alloc .button>Alloc profiling
 6 |   <div #chart-container>
 7 |     <figure #chart>
 8 |     <div #sidebox>
 9 |       <div #current-node>
10 |         <h2>Current node
11 |         <dl>
12 |           <dt>Module
13 |           <dd #current-node-module>
14 |           <dt>Name
15 |           <dd #current-node-name>
16 |           <dt>Number
17 |           <dd #current-node-number>
18 |           <dt>Entries
19 |           <dd #current-node-entries>
20 |           <dt>Individual %time
21 |           <dd #current-node-ind-time>
22 |           <dt>Individual %alloc
23 |           <dd #current-node-ind-alloc>
24 |           <dt>Inherited %time
25 |           <dd #current-node-inh-time>
26 |           <dt>Inherited %alloc
27 |           <dd #current-node-inh-alloc>
28 |       <div #children>
29 |         <h2>Children
30 |         <ol>
31 | <section #summary>
32 |   <h2>Summary
33 |   <div #report-summary .box>
34 |     <dl>
35 |       <dt>Timestamp
36 |       <dd>#{show reportTimestamp}
37 |       <dt>Command line
38 |       <dd>#{reportCommandLine}
39 |       <dt>Total time
40 |       <dd>#{totalSecs reportTotalTime} seconds
41 |       <dd>#{totalTicks reportTotalTime} ticks @ #{resolution reportTotalTime} ms
42 |       <dt>Total allocations
43 |       <dd>#{totalAllocBytes reportTotalAlloc} bytes
44 | 


--------------------------------------------------------------------------------
/Handler/Reports/Helpers.hs:
--------------------------------------------------------------------------------
 1 | module Handler.Reports.Helpers
 2 |   ( runReports
 3 |   , getReports'
 4 |   , getAllReports
 5 |   , getAllProfilingReports
 6 |   , getProfilingReport
 7 |   , postProfilingReport
 8 |   ) where
 9 | 
10 | import Control.Applicative
11 | import Control.Monad.STM (STM, atomically)
12 | import Control.Monad.Trans (liftIO)
13 | import Model (Reports(..), ReportID, allReports, lookupReport, insertReport)
14 | import ProfilingReport (ProfilingReport)
15 | import TKYProf (Handler, TKYProf(getReports))
16 | import Yesod.Core (getYesod)
17 | import Yesod.Core.Handler (notFound)
18 | 
19 | runReports :: STM a -> Handler a
20 | runReports = liftIO . atomically
21 | 
22 | getReports' :: Handler Reports
23 | getReports' = getReports <$> getYesod
24 | 
25 | getAllReports :: Handler [(ReportID, ProfilingReport)]
26 | getAllReports = do
27 |   rs <- getReports'
28 |   runReports $ allReports rs
29 | 
30 | getAllProfilingReports :: Handler [ProfilingReport]
31 | getAllProfilingReports = map snd <$> getAllReports
32 | 
33 | getProfilingReport :: ReportID -> Handler ProfilingReport
34 | getProfilingReport reportId = do
35 |   rs <- getReports'
36 |   mreport <- runReports $ lookupReport reportId rs
37 |   case mreport of
38 |     Just r  -> return r
39 |     Nothing -> notFound
40 | 
41 | postProfilingReport :: ProfilingReport -> Handler ReportID
42 | postProfilingReport prof = do
43 |   rs <- getReports'
44 |   runReports $ insertReport prof rs
45 | 


--------------------------------------------------------------------------------
/README.markdown:
--------------------------------------------------------------------------------
 1 | TKYProf
 2 | ========================
 3 | [![Build Status](https://travis-ci.org/maoe/tkyprof.png)](https://travis-ci.org/maoe/tkyprof)
 4 | 
 5 | TKYProf is a web-based interactive visualizer for [GHC Time and Allocation Profiling Reports](http://www.haskell.org/ghc/dist/stable/docs/html/users_guide/prof-time-options.html). It helps you to find the performance bottlenecks of your code quickly.
 6 | 
 7 | ![TKYProf](http://cdn-ak.f.st-hatena.com/images/fotolife/m/maoe/20110816/20110816185419.png)
 8 | 
 9 | Prerequistes
10 | ------------------------
11 | 
12 | * TKYProf uses some of HTML5 features, but does not support graceful downgrading. You need a modern browser supporting HTML5 and CSS3 for now.
13 | * TKYProf is written in Haskell. Haskell Platform and Cabal are required.
14 | 
15 | How to use TKYProf
16 | ------------------------
17 | 
18 | 1. `cabal install tkyprof` installs the executable `tkyprof`.
19 | 2. Run `tkyprof` on your terminal.
20 | 3. Access [http://localhost:3000/](http://localhost:3000/).
21 | 4. Drag and drop your profiling reports.
22 | 5. TKYProf draws a pretty chart.
23 | 
24 | ![screenshot](http://cdn-ak.f.st-hatena.com/images/fotolife/m/maoe/20110817/20110817100841.png)
25 | 
26 | Developers
27 | ------------------------
28 | 
29 | This tool is written and maintained by Mitsutoshi Aoe, <maoe@foldr.in>.
30 | And thanks to the following contributors:
31 | 
32 | * Ben Gamari (@bgamari)
33 | * Jasper Van der Jeugt (@jaspervdj)
34 | 


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


--------------------------------------------------------------------------------
/Model.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE RecordWildCards #-}
 2 | module Model where
 3 | import Control.Applicative
 4 | import Control.Concurrent.STM (STM, TVar, newTVar, readTVar, writeTVar)
 5 | import Data.Map (Map)
 6 | import ProfilingReport (ProfilingReport(..))
 7 | import qualified Data.Map as M
 8 | 
 9 | type ReportID = Integer
10 | 
11 | data Reports = Reports
12 |   { newReportId :: TVar ReportID
13 |   , reports     :: TVar (Map ReportID ProfilingReport)
14 |   }
15 | 
16 | emptyReports :: STM Reports
17 | emptyReports = do
18 |   uid <- newTVar 0
19 |   rs  <- newTVar M.empty
20 |   return $ Reports { newReportId = uid
21 |                    , reports     = rs }
22 | 
23 | insertReport :: ProfilingReport -> Reports -> STM ReportID
24 | insertReport r Reports{..} = do
25 |   uid <- readTVar newReportId
26 |   rs  <- readTVar reports
27 |   writeTVar newReportId (succ uid)
28 |   writeTVar reports (M.insert uid r rs)
29 |   return uid
30 | 
31 | deleteReport :: ReportID -> Reports -> STM ()
32 | deleteReport i Reports{..} = do
33 |   rs <- readTVar reports
34 |   writeTVar reports (M.delete i rs)
35 | 
36 | lookupReport :: ReportID -> Reports -> STM (Maybe ProfilingReport)
37 | lookupReport i Reports{..} = do
38 |   rs <- readTVar reports
39 |   return $ M.lookup i rs
40 | 
41 | memberReport :: ReportID -> Reports -> STM Bool
42 | memberReport i Reports{..} = do
43 |   rs <- readTVar reports
44 |   return $ M.member i rs
45 | 
46 | allReports :: Reports -> STM [(ReportID, ProfilingReport)]
47 | allReports (Reports _ rs) = M.toList <$> readTVar rs
48 | 
49 | allProfilingReports :: Reports -> STM [ProfilingReport]
50 | allProfilingReports r = map snd <$> allReports r
51 | 


--------------------------------------------------------------------------------
/Controller.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, OverloadedStrings, ViewPatterns #-}
 2 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 3 | module Controller
 4 |   ( withTKYProf
 5 |   , withDevelApp
 6 |   ) where
 7 | 
 8 | import Data.ByteString (ByteString)
 9 | import Data.Dynamic (Dynamic, toDyn)
10 | import Settings
11 | import TKYProf
12 | import Yesod.Static
13 | -- Import all relevant handler modules here.
14 | import Handler.Home
15 | import Handler.Reports
16 | 
17 | -- This line actually creates our YesodSite instance. It is the second half
18 | -- of the call to mkYesodData which occurs in TKYProf.hs. Please see
19 | -- the comments there for more details.
20 | mkYesodDispatch "TKYProf" resourcesTKYProf
21 | 
22 | -- Some default handlers that ship with the Yesod site template. You will
23 | -- very rarely need to modify this.
24 | getFaviconR :: Handler ()
25 | getFaviconR = sendFile "image/png" "config/favicon.png"
26 | 
27 | getRobotsR :: Handler RepPlain
28 | getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)
29 | 
30 | -- This function allocates resources (such as a database connection pool),
31 | -- performs initialization and creates a WAI application. This is also the
32 | -- place to put your migrate statements to have automatic database
33 | -- migrations handled by Yesod.
34 | withTKYProf :: (Application -> IO a) -> IO a
35 | withTKYProf f = do
36 |   rs <- atomically $ emptyReports
37 |   s <- static Settings.staticdir
38 |   let h = TKYProf { getStatic  = s
39 |                   , getReports = rs }
40 |   toWaiApp h >>= f
41 | 
42 | withDevelApp :: Dynamic
43 | withDevelApp = toDyn (withTKYProf :: (Application -> IO ()) -> IO ())
44 | 


--------------------------------------------------------------------------------
/config/Settings.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | {-# LANGUAGE TemplateHaskell #-}
 3 | {-# LANGUAGE OverloadedStrings #-}
 4 | -- | Settings are centralized, as much as possible, into this file. This
 5 | -- includes database connection settings, static file locations, etc.
 6 | -- In addition, you can configure a number of different aspects of Yesod
 7 | -- by overriding methods in the Yesod typeclass. That instance is
 8 | -- declared in the tkyprof.hs file.
 9 | module Settings
10 |   ( H.hamletFile
11 |   , H.juliusFile
12 |   , H.luciusFile
13 |   , widgetFile
14 |   , staticdir
15 |   ) where
16 | 
17 | import qualified Text.Hamlet as H
18 | import qualified Text.Julius as H
19 | import qualified Text.Lucius as H
20 | import Language.Haskell.TH.Syntax
21 | import Yesod.Default.Util
22 | import Data.Default (def)
23 | 
24 | -- | The location of static files on your system. This is a file system
25 | -- path. The default value works properly with your scaffolded site.
26 | staticdir :: FilePath
27 | staticdir = "static"
28 | 
29 | -- The rest of this file contains settings which rarely need changing by a
30 | -- user.
31 | 
32 | -- The following three functions are used for calling HTML, CSS and
33 | -- Javascript templates from your Haskell code. During development,
34 | -- the "Debug" versions of these functions are used so that changes to
35 | -- the templates are immediately reflected in an already running
36 | -- application. When making a production compile, the non-debug version
37 | -- is used for increased performance.
38 | --
39 | -- You can see an example of how to call these functions in Handler/Root.hs
40 | --
41 | -- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer
42 | -- used; to get the same auto-loading effect, it is recommended that you
43 | -- use the devel server.
44 | 
45 | widgetFile :: FilePath -> Q Exp
46 | widgetFile = widgetFileNoReload def
47 | 


--------------------------------------------------------------------------------
/static/js/tkyprof.js:
--------------------------------------------------------------------------------
 1 | // Quoted by "JavsScrpt: The Good Parts"
 2 | 
 3 | Function.prototype.method = function(name, func) {
 4 |   if (!this.prototype[name]) {
 5 |     this.prototype[name] = func;
 6 |     return this;
 7 |   }
 8 | }
 9 | 
10 | Function.method('curry', function() {
11 |   var slice = Array.prototype.slice,
12 |       args = slice.apply(arguments),
13 |       that = this;
14 |   return function() {
15 |     return that.apply(null, args.concat(slice.apply(arguments)));
16 |   };
17 | });
18 | 
19 | Array.method('shift', function() {
20 |   return this.splice(0, 1)[0];
21 | });
22 | 
23 | Array.method('splice', function(start, deleteCount) {
24 |   var max = Math.max,
25 |       min = Math.min,
26 |       delta,
27 |       element,
28 |       insertCount = max(arguments.length - 2, 0),
29 |       k = 0,
30 |       len = this.length,
31 |       newLen,
32 |       result = [],
33 |       shiftCount;
34 | 
35 |   start = start || 0;
36 |   if (start < 0) {
37 |     start += len;
38 |   }
39 |   start = max(min(start, len), 0);
40 |   deleteCount = max(
41 |     min(
42 |       typeof deleteCount === 'number'
43 |         ? deleteCount
44 |         : len,
45 |       len - start
46 |     ),
47 |     0
48 |   );
49 |   delta = insertCount - deleteCount;
50 |   newLen = len + delta;
51 |   while (k < deleteCount) {
52 |     element = this[start + k];
53 |     if (element !== undefined) {
54 |       result[k] = element;
55 |     }
56 |     k += 1;
57 |   }
58 |   shiftCount = len - start - deleteCount;
59 |   if (delta < 0) {
60 |     k = start + insertCount;
61 |     while (shiftCount) {
62 |       this[k] = this[k - delta];
63 |       k += 1;
64 |       shiftCount -= 1;
65 |     }
66 |     this.length = newLen;
67 |   } else if (delta > 0) {
68 |     k = 1;
69 |     while (shiftCount) {
70 |       this[newLen - k] = this[len - k];
71 |       k += 1;
72 |       shiftCount -= 1;
73 |     }
74 |   }
75 |   for (k = 0; k < insertCount; k += 1) {
76 |     this[start + k] = arguments[k + 2];
77 |   }
78 |   return result;
79 | });
80 | 
81 | Array.method('unshift', function() {
82 |   this.splice.apply(
83 |     this,
84 |     [0, 0].concat(Array.prototype.slice.apply(arguments))
85 |   );
86 |   return this.length;
87 | });
88 | 


--------------------------------------------------------------------------------
/templates/reports-id.lucius:
--------------------------------------------------------------------------------
  1 | /* title and buttons */
  2 | #cost-centres > header {
  3 |   margin: 1em;
  4 | }
  5 | #cost-centres h2 {
  6 |   display: inline;
  7 |   font-size: 1.5em;
  8 | }
  9 | 
 10 | #cost-centres .button {
 11 |   border: 1.5px solid transparent;
 12 |   padding-left: 4px;
 13 |   padding-right: 4px;
 14 |   cursor: pointer;
 15 | }
 16 | 
 17 | #cost-centres .button:hover {
 18 |   /* border: 1.5px solid #fd8d38; */
 19 |   border: 1.5px solid #f3f3e3;
 20 | }
 21 | 
 22 | #cost-centres .active {
 23 |   /* border: 1.5px solid #fd8d38; */
 24 |   /* background: #fd8d38; */
 25 |   border: 1.5px solid #f3f3e3;
 26 |   background: #f3f3e3;
 27 |   color: #212121;
 28 | }
 29 | 
 30 | #cost-centres .button:first-child {
 31 |   -webkit-border-top-left-radius: 0.5em;
 32 |   -moz-border-top-left-radius: 0.5em;
 33 |   border-top-left-radius: 0.5em;
 34 |   -webkit-border-bottom-left-radius: 0.5em;
 35 |   -moz-border-bottom-left-radius: 0.5em;
 36 |   border-bottom-left-radius: 0.5em;
 37 | }
 38 | 
 39 | #cost-centres .button:last-child {
 40 |   -webkit-border-top-right-radius: 0.5em;
 41 |   -moz-border-top-right-radius: 0.5em;
 42 |   border-top-right-radius: 0.5em;
 43 |   -webkit-border-bottom-right-radius: 0.5em;
 44 |   -moz-border-bottom-right-radius: 0.5em;
 45 |   border-bottom-right-radius: 0.5em;
 46 | }
 47 | 
 48 | 
 49 | /* chart */
 50 | #chart-container {
 51 |   width: 100%;
 52 |   font-size: 0.85em;
 53 | 
 54 |   display: -webkit-box;
 55 |   display: -moz-box;
 56 |   display: box;
 57 | }
 58 | 
 59 | #chart {
 60 |   -webkit-box-flex: 1;
 61 |   -moz-box-flex: 1;
 62 |   box-flex: 1;
 63 |   min-height: 400px;
 64 |   -webkit-box-ordinal-group: 1;
 65 |   -moz-box-ordinal-group: 1;
 66 |   box-ordinal-group: 1;
 67 | }
 68 | 
 69 | #chart path {
 70 |   stroke: #212121;
 71 |   stroke-width: 0.5;
 72 |   fill-rule: evenodd;
 73 |   opacity: 1;
 74 | }
 75 | 
 76 | /* sidebox */
 77 | #sidebox {
 78 |   background: #353535;
 79 |   padding: 1em;
 80 |   padding-top: 0.5em;
 81 |   width: 18em;
 82 |   min-height: 37em;
 83 |   -webkit-box-ordinal-group: 2;
 84 |   -moz-box-ordinal-group: 2;
 85 |   box-ordinal-group: 2;
 86 |   text-overflow: ellipsis;
 87 |   overflow: hidden;
 88 | 
 89 |   -webkit-border-radius: 10px;
 90 |   -moz-border-radius: 10px;
 91 |   border-radius: 10px;
 92 | }
 93 | 
 94 | #sidebox dt {
 95 |   float: left;
 96 | }
 97 | 
 98 | #sidebox dd {
 99 |   margin-left: 10em;
100 | }
101 | 
102 | /* summary */
103 | #report-summary {
104 |   font-size: 0.85em;
105 | }
106 | 
107 | #report-summary dt {
108 |   float: left;
109 | }
110 | 
111 | #report-summary dd {
112 |   margin-left: 10em;
113 | }


--------------------------------------------------------------------------------
/Handler/Reports.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE RecordWildCards, NamedFieldPuns, TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
 2 | module Handler.Reports
 3 |   ( getReportsR
 4 |   , postReportsR
 5 |   , getReportsIdR
 6 |   , getReportsIdTimeR
 7 |   , getReportsIdAllocR
 8 |   ) where
 9 | 
10 | import Data.Maybe (listToMaybe)
11 | import Data.Text (Text)
12 | import Handler.Reports.Helpers (getAllReports, getProfilingReport, postProfilingReport)
13 | import ProfilingReport
14 | import TKYProf hiding (lift)
15 | import Yesod.Core (lift)
16 | import qualified Data.Aeson as A (encode)
17 | import qualified Data.Text.Lazy.Encoding as T (decodeUtf8)
18 | import Network.HTTP.Types.Status (seeOther303)
19 | import Data.Conduit (($$))
20 | import Control.Monad.Trans.Resource (runResourceT)
21 | import Text.Julius
22 | 
23 | getReportsR :: Handler Html
24 | getReportsR = do
25 |   reports <- getAllReports
26 |   defaultLayout $ do
27 |     setTitle "TKYProf Reports"
28 |     $(widgetFile "reports")
29 | 
30 | postReportsR :: Handler ()
31 | postReportsR = do
32 |   files <- getPostedReports
33 |   case files of
34 |     [fileInfo] -> do reportId <- postFileInfo fileInfo
35 |                      sendResponseCreated $ ReportsIdR reportId
36 |     _          -> do mapM_ postFileInfo files
37 |                      sendResponseCreated ReportsR
38 | 
39 | getReportsIdR :: ReportID -> Handler Html
40 | getReportsIdR reportId = redirectWith seeOther303 (ReportsIdTimeR reportId [])
41 | 
42 | getReportsIdTimeR :: ReportID -> [a] -> Handler Html
43 | getReportsIdTimeR reportId _ = getReportsIdCommon reportId "time"
44 | 
45 | getReportsIdAllocR :: ReportID -> [a] -> Handler Html
46 | getReportsIdAllocR reportId _ = getReportsIdCommon reportId "alloc"
47 | 
48 | -- Helper functions
49 | getPostedReports :: Handler [FileInfo]
50 | getPostedReports = do
51 |   (_, files) <- runRequestBody
52 |   case [ file | (header, file) <- files, header == "reports" ] of
53 |     []    -> invalidArgs ["Missing files"]
54 |     found -> return found
55 | 
56 | postFileInfo :: FileInfo -> Handler ReportID
57 | postFileInfo info = do
58 |   prof <- runResourceT $ lift $ (fileSource info) $$ profilingReportI
59 |   postProfilingReport prof
60 | 
61 | getReportsIdCommon :: ReportID -> Text -> Handler Html
62 | getReportsIdCommon reportId profilingType = do
63 |   report@ProfilingReport {..} <- getProfilingReport reportId
64 |   let json = rawJS $ T.decodeUtf8 $ A.encode reportCostCentres
65 |   defaultLayout $ do
66 |     setTitle $ "TKYProf Reports"
67 |     addScript $ StaticR js_tkyprof_js
68 |     addScript $ StaticR js_d3_min_js
69 |     addScript $ StaticR js_d3_layout_min_js
70 |     $(widgetFile "reports-id")
71 | 


--------------------------------------------------------------------------------
/TKYProf.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, ViewPatterns #-}
 2 | module TKYProf
 3 |   ( TKYProf (..)
 4 |   , Route (..)
 5 |   , resourcesTKYProf
 6 |   , Handler
 7 |   , Widget
 8 |   , module Yesod.Core
 9 |   , module Settings
10 |   , module StaticFiles
11 |   , module Model
12 |   , module Control.Monad.STM
13 |   , StaticRoute
14 |   , lift
15 |   ) where
16 | 
17 | import Control.Monad (unless)
18 | import Control.Monad.STM (STM, atomically)
19 | import Control.Monad.Trans.Class (lift)
20 | import Model
21 | import Settings (hamletFile, luciusFile, juliusFile, widgetFile)
22 | import StaticFiles
23 | import System.Directory
24 | import System.FilePath ((</>))
25 | import Yesod.Core hiding (lift)
26 | import Yesod.Static
27 | import qualified Data.ByteString.Lazy as L
28 | import qualified Data.Text as T
29 | import qualified Settings
30 | 
31 | -- | The site argument for your application. This can be a good place to
32 | -- keep settings and values requiring initialization before your application
33 | -- starts running, such as database connections. Every handler will have
34 | -- access to the data present here.
35 | data TKYProf = TKYProf
36 |   { getStatic  :: Static -- ^ Settings for static file serving.
37 |   , getReports :: Reports
38 |   }
39 | 
40 | -- This is where we define all of the routes in our application. For a full
41 | -- explanation of the syntax, please see:
42 | -- http://docs.yesodweb.com/book/web-routes-quasi/
43 | --
44 | -- This function does three things:
45 | --
46 | -- * Creates the route datatype TKYProfRoute. Every valid URL in your
47 | --   application can be represented as a value of this type.
48 | -- * Creates the associated type:
49 | --       type instance Route TKYProf = TKYProfRoute
50 | -- * Creates the value resourcesTKYProf which contains information on the
51 | --   resources declared below. This is used in Controller.hs by the call to
52 | --   mkYesodDispatch
53 | --
54 | -- What this function does *not* do is create a YesodSite instance for
55 | -- TKYProf. Creating that instance requires all of the handler functions
56 | -- for our application to be in scope. However, the handler functions
57 | -- usually require access to the TKYProfRoute datatype. Therefore, we
58 | -- split these actions into two functions and place them in separate files.
59 | mkYesodData "TKYProf" $(parseRoutesFile "config/routes")
60 | 
61 | -- Please see the documentation for the Yesod typeclass. There are a number
62 | -- of settings which can be configured by overriding methods here.
63 | instance Yesod TKYProf where
64 |   approot = ApprootRelative
65 | 
66 |   defaultLayout widget = do
67 |     mmsg <- getMessage
68 |     (title, bcs) <- breadcrumbs
69 |     pc <- widgetToPageContent $ do
70 |       $(Settings.widgetFile "header")
71 |       widget
72 |       toWidget $(Settings.luciusFile "templates/default-layout.lucius")
73 |     withUrlRenderer $(Settings.hamletFile "templates/default-layout.hamlet")
74 | 
75 |   -- This function creates static content files in the static folder
76 |   -- and names them based on a hash of their content. This allows
77 |   -- expiration dates to be set far in the future without worry of
78 |   -- users receiving stale content.
79 |   addStaticContent ext' _ content = do
80 |     let fn = base64md5 content ++ '.' : T.unpack ext'
81 |     let statictmp = Settings.staticdir </> "tmp/"
82 |     liftIO $ createDirectoryIfMissing True statictmp
83 |     let fn' = statictmp ++ fn
84 |     exists <- liftIO $ doesFileExist fn'
85 |     unless exists $ liftIO $ L.writeFile fn' content
86 |     return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])
87 | 
88 |   maximumContentLength _ _ = Just $ 20*1024*1024
89 | 
90 | instance YesodBreadcrumbs TKYProf where
91 |   breadcrumb HomeR                   = return ("Home", Nothing)
92 |   breadcrumb ReportsR                = return ("Reports", Just HomeR)
93 |   breadcrumb (ReportsIdTimeR rid _)  = return ("Report #" `T.append` T.pack (show rid), Just ReportsR)
94 |   breadcrumb (ReportsIdAllocR rid _) = return ("Report #" `T.append` T.pack (show rid), Just ReportsR)
95 |   breadcrumb _                       = return ("Not found", Just HomeR)
96 | 


--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
 1 | # NB: don't set `language: haskell` here
 2 | 
 3 | # See also https://github.com/hvr/multi-ghc-travis for more information
 4 | 
 5 | # The following lines enable several GHC versions and/or HP versions
 6 | # to be tested; often it's enough to test only against the last
 7 | # release of a major GHC version. Setting HPVER implictly sets
 8 | # GHCVER. Omit lines with versions you don't need/want testing for.
 9 | env:
10 |  - GHCVER=7.6.3
11 |  - GHCVER=7.8.1
12 |  - HPVER=2013.2.0.0
13 | 
14 | # Note: the distinction between `before_install` and `install` is not
15 | #       important.
16 | before_install:
17 |  - case "$HPVER" in
18 |     "") ;;
19 | 
20 |     "2013.2.0.0")
21 |       export GHCVER=7.6.3 ;
22 |       echo "constraints:async==2.0.1.4,attoparsec==0.10.4.0,case-insensitive==1.0.0.1,cgi==3001.1.7.5,fgl==5.4.2.4,GLUT==2.4.0.0,GLURaw==1.3.0.0,haskell-src==1.0.1.5,hashable==1.1.2.5,html==1.0.1.2,HTTP==4000.2.8,HUnit==1.2.5.2,mtl==2.1.2,network==2.4.1.2,OpenGL==2.8.0.0,OpenGLRaw==1.3.0.0,parallel==3.2.0.3,parsec==3.1.3,QuickCheck==2.6,random==1.0.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.2,split==0.2.2,stm==2.4.2,syb==0.4.0,text==0.11.3.1,transformers==0.3.0.0,unordered-containers==0.2.3.0,vector==0.10.0.1,xhtml==3000.2.1,zlib==0.5.4.1" > cabal.config ;;
23 | 
24 |     "2012.4.0.0")
25 |       export GHCVER=7.6.2 ;
26 |       echo "constraints:async==2.0.1.3,cgi==3001.1.7.4,fgl==5.4.2.4,GLUT==2.1.2.1,haskell-src==1.0.1.5,html==1.0.1.2,HTTP==4000.2.5,HUnit==1.2.5.1,mtl==2.1.2,network==2.3.1.0,OpenGL==2.2.3.1,parallel==3.2.0.3,parsec==3.1.3,QuickCheck==2.5.1.1,random==1.0.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.2,split==0.2.1.1,stm==2.4,syb==0.3.7,text==0.11.2.3,transformers==0.3.0.0,vector==0.10.0.1,xhtml==3000.2.1,zlib==0.5.4.0" > cabal.config ;;
27 | 
28 |     "2012.2.0.0")
29 |       export GHCVER=7.4.1 ;
30 |       echo "constraints:cgi==3001.1.7.4,fgl==5.4.2.4,GLUT==2.1.2.1,haskell-src==1.0.1.5,html==1.0.1.2,HTTP==4000.2.3,HUnit==1.2.4.2,mtl==2.1.1,network==2.3.0.13,OpenGL==2.2.3.1,parallel==3.2.0.2,parsec==3.1.2,QuickCheck==2.4.2,random==1.0.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.1,stm==2.3,syb==0.3.6.1,text==0.11.2.0,transformers==0.3.0.0,xhtml==3000.2.1,zlib==0.5.3.3" > cabal.config ;;
31 | 
32 |     "2011.4.0.0")
33 |       export GHCVER=7.0.4 ;
34 |       echo "constraints:cgi==3001.1.7.4,fgl==5.4.2.4,GLUT==2.1.2.1,haskell-src==1.0.1.4,html==1.0.1.2,HUnit==1.2.4.2,network==2.3.0.5,OpenGL==2.2.3.0,parallel==3.1.0.1,parsec==3.1.1,QuickCheck==2.4.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.1,stm==2.2.0.1,syb==0.3.3,xhtml==3000.2.0.4,zlib==0.5.3.1,HTTP==4000.1.2,deepseq==1.1.0.2" > cabal.config ;;
35 | 
36 |     *)
37 |       export GHCVER=unknown ;
38 |       echo "unknown/invalid Haskell Platform requested" ;
39 |       exit 1 ;;
40 | 
41 |    esac
42 | 
43 |  - sudo add-apt-repository -y ppa:hvr/ghc
44 |  - sudo apt-get update
45 |  - sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy
46 |  - export PATH=/opt/ghc/$GHCVER/bin:$PATH
47 | 
48 | install:
49 |  - cabal-1.18 update
50 |  - cabal-1.18 install --only-dependencies --enable-tests --enable-benchmarks
51 | 
52 | # Here starts the actual work to be performed for the package under
53 | # test; any command which exits with a non-zero exit code causes the
54 | # build to fail.
55 | script:
56 |  # -v2 provides useful information for debugging
57 |  - cabal-1.18 configure --enable-tests --enable-benchmarks -v2
58 | 
59 |  # this builds all libraries and executables
60 |  # (including tests/benchmarks)
61 |  - cabal-1.18 build
62 | 
63 |  - cabal-1.18 test
64 |  - cabal-1.18 check
65 | 
66 |  # tests that a source-distribution can be generated
67 |  - cabal-1.18 sdist
68 | 
69 |  # check that the generated source-distribution can be built & installed
70 |  - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ;
71 |    cd dist/;
72 |    if [ -f "$SRC_TGZ" ]; then
73 |       cabal-1.18 install "$SRC_TGZ";
74 |    else
75 |       echo "expected '$SRC_TGZ' not found";
76 |       exit 1;
77 |    fi
78 | 
79 | notifications:
80 |   webhooks:
81 |     urls:
82 |       - https://webhooks.gitter.im/e/f3e6eab7b19a14343262
83 |     on_success: change  # options: [always|never|change] default: always
84 |     on_failure: always  # options: [always|never|change] default: always
85 |     on_start: false     # default: false
86 | 
87 | # EOF
88 | 


--------------------------------------------------------------------------------
/tkyprof.cabal:
--------------------------------------------------------------------------------
  1 | name:                 tkyprof
  2 | version:              0.2.2.2
  3 | license:              BSD3
  4 | license-file:         LICENSE
  5 | author:               Mitsutoshi Aoe
  6 | maintainer:           Mitsutoshi Aoe <maoe@foldr.in>
  7 | copyright:            Copyright (C) 2011-2014 Mitsutoshi Aoe
  8 | synopsis:             A web-based visualizer for GHC Profiling Reports
  9 | description:          A web-based visualizer for GHC Profiling Reports
 10 | category:             Development, Profiling
 11 | stability:            Experimental
 12 | cabal-version:        >= 1.6
 13 | build-type:           Simple
 14 | homepage:             https://github.com/maoe/tkyprof
 15 | bug-reports:          https://github.com/maoe/tkyprof/issues
 16 | tested-with:          GHC == 7.6.3
 17 | 
 18 | data-files:           static/js/d3.layout.min.js
 19 |                       static/js/d3.min.js
 20 |                       static/js/jquery.fileupload.js
 21 |                       static/js/jquery.iframe-transport.js
 22 |                       static/js/jquery.pjax.js
 23 |                       static/js/jquery.ui.widget.js
 24 |                       static/js/tkyprof.js
 25 |                       static/images/*.png
 26 |                       config/favicon.png
 27 |                       LICENSE
 28 |                       README.markdown
 29 | 
 30 | extra-source-files:   config/routes
 31 |                       templates/*.hamlet
 32 |                       templates/*.julius
 33 |                       templates/*.lucius
 34 | 
 35 | flag production
 36 |   description:        Build the production executable.
 37 |   default:            True
 38 | 
 39 | flag devel
 40 |   description:        Build for use with "yesod devel"
 41 |   default:            False
 42 | 
 43 | executable tkyprof
 44 |   if flag(devel)
 45 |     buildable:        False
 46 | 
 47 |   if flag(production)
 48 |     ghc-options:      -O2
 49 |     cpp-options:      -DPRODUCTION
 50 | 
 51 |     -- ghc-options:    -pgmc g++ -pgml g++
 52 |     -- pkgconfig-depends: QtWebKit
 53 |     -- build-depends:  wai-handler-webkit
 54 | 
 55 |   main-is:            bin/tkyprof.hs
 56 |   hs-source-dirs:     ., config, bin
 57 |   other-modules:      Paths_tkyprof
 58 |   ghc-options:        -Wall -threaded
 59 |   extensions:         TemplateHaskell
 60 |   build-depends:      base >= 4 && < 5
 61 |                     , aeson >= 0.3 && < 0.10
 62 |                     , attoparsec >= 0.9 && < 0.13
 63 |                     , conduit-extra >= 1.0 && < 1.2
 64 |                     , bytestring >= 0.9 && < 0.11
 65 |                     , cmdargs >= 0.7 && < 0.11
 66 |                     , containers < 0.6
 67 |                     , unordered-containers >= 0.2 && < 0.3
 68 |                     , directory < 2
 69 |                     , data-default < 0.6
 70 |                     , filepath >= 1.1 && < 2
 71 |                     , mtl >= 1.1 && < 3
 72 |                     , rosezipper >= 0.2 && < 0.3
 73 |                     , stm < 3
 74 |                     , exceptions >= 0.8 && < 1.0
 75 |                     , template-haskell < 3
 76 |                     , text >= 0.11 && < 1.3
 77 |                     , time >= 1.2 && < 1.6
 78 |                     , transformers >= 0.2 && < 0.5
 79 |                     , vector >= 0.6 && < 1
 80 |                     , wai >= 0.4 && < 3.1
 81 |                     , wai-extra >= 0.4 && < 3.2
 82 |                     , warp >= 0.4 && < 3.1
 83 |                     , web-routes >= 0.23 && < 0.28
 84 |                     , yesod >= 1.2 && < 1.5
 85 |                     , yesod-core >= 1.2 && < 1.5
 86 |                     , yesod-form >= 1.3 && < 1.5
 87 |                     , yesod-static >= 1.2 && < 1.6
 88 |                     , shakespeare >= 1.0 && < 2.1
 89 |                     , http-types >= 0.7 && < 1.0
 90 |                     , conduit >= 1.0 && < 1.3
 91 |                     , resourcet >= 0.4 && < 1.2
 92 | 
 93 | library
 94 |   if flag(devel)
 95 |     buildable:        True
 96 |   else
 97 |     buildable:        False
 98 |   exposed-modules:    Controller
 99 |   hs-source-dirs:     ., config, bin
100 |   other-modules:      TKYProf
101 |                       Handler.Home
102 |                       Handler.Reports
103 |                       Handler.Reports.Helpers
104 |                       Model
105 |                       Paths_tkyprof
106 |                       ProfilingReport
107 |                       Settings
108 |                       StaticFiles
109 | 
110 | executable prof2json
111 |   buildable:          False
112 |   hs-source-dirs:     ., bin
113 |   main-is:            prof2json.hs
114 |   build-depends:      filepath
115 |                     , mtl
116 |                     , blaze-builder
117 | 
118 | source-repository head
119 |   type:               git
120 |   branch:             develop
121 |   location:           https://github.com/maoe/tkyprof.git
122 | 
123 | source-repository this
124 |   type:               git
125 |   tag:                v0.2.2.2
126 |   location:           https://github.com/maoe/tkyprof.git
127 | 


--------------------------------------------------------------------------------
/templates/reports-id.julius:
--------------------------------------------------------------------------------
  1 | $(function() {
  2 |   var data = #{json};
  3 |   var parmalink = costCentreParmalink();
  4 |   var chart = costCentreChart({
  5 |     data: data,
  6 |     parmalink: parmalink
  7 |   });
  8 |   var button = profilingModeButton({
  9 |     chart: chart,
 10 |     parmalink: parmalink
 11 |   });
 12 | 
 13 |   chart.transposeById(parmalink.id());
 14 |   $(window).bind('popstate', function(event) {
 15 |     if (!window.history.ready && !event.originalEvent.state) {
 16 |       return; // workaround for popstate on load
 17 |     }
 18 |     parmalink.popstate(location.pathname);
 19 |     button.mode(parmalink.mode());
 20 |     chart.mode(parmalink.mode());
 21 |     chart.transposeById(parmalink.id());
 22 |   });
 23 | });
 24 | 
 25 | function costCentreParmalink(spec) {
 26 |   var that = {};
 27 |   var parsed = parse(location.pathname),
 28 |       prefix = parsed[1],
 29 |       mode   = parsed[2],
 30 |       suffix = parsed[3];
 31 | 
 32 |   function pathname() {
 33 |     return prefix + mode + suffix;
 34 |   };
 35 | 
 36 |   function parse(path) {
 37 |     var regex = /^(\/reports\/[0-9]+\/)(time|alloc)(.*)$/;
 38 |     return regex.exec(path);
 39 |   }
 40 | 
 41 |   that.mode = function(newMode) {
 42 |     if (!newMode)
 43 |       return mode; // getter
 44 | 
 45 |     mode = newMode;
 46 |     window.history.ready = true; // workaround for popstate on load
 47 |     history.pushState(null, null, pathname()); // HTML 5 History API
 48 |     return mode;
 49 |   };
 50 | 
 51 |   that.transpose = function(node) {
 52 |     var cursor = node, path = [];
 53 |     for (cursor = node; cursor.parent; cursor = cursor.parent) {
 54 |       path.unshift(cursor.no);
 55 |     }
 56 |     if (path.length > 0) {
 57 |       suffix = "/" + path.join("/");
 58 |     } else {
 59 |       suffix = "";
 60 |     }
 61 |   };
 62 | 
 63 |   that.popstate = function(url) {
 64 |     var parsed = parse(url);
 65 |     mode   = parsed[2];
 66 |     suffix = parsed[3];
 67 |   };
 68 | 
 69 |   that.id = function() {
 70 |     var regex = /^.*\/([0-9]*)$/;
 71 |     var matched = regex.exec(suffix);
 72 |     return matched ? matched[1] : null;
 73 |   };
 74 | 
 75 |   that.pathname = pathname;
 76 | 
 77 |   return that;
 78 | }
 79 | 
 80 | function profilingModeButton(spec) {
 81 |   var that = {};
 82 |   var chart = spec.chart, parmalink = spec.parmalink;
 83 |   var timeButton  = $("#time"),
 84 |       allocButton = $("#alloc"),
 85 |       _mode;
 86 | 
 87 |   // methods
 88 |   var mode = function(newMode) {
 89 |     if (!newMode)
 90 |       return _mode; // getter
 91 | 
 92 |     _mode = newMode;
 93 |     // buttons
 94 |     if (_mode == "time") {
 95 |       timeButton.addClass("active");
 96 |       allocButton.removeClass("active");
 97 |     } else {
 98 |       timeButton.removeClass("active");
 99 |       allocButton.addClass("active");
100 |     }
101 |     // chart
102 |     chart.mode(_mode);
103 |     return _mode;
104 |   };
105 | 
106 |   // setup initial states and event handlers
107 |   mode(parmalink.mode());
108 |   timeButton.click(function(event) {
109 |     parmalink.mode("time");
110 |     mode(parmalink.mode());
111 |   });
112 |   allocButton.click(function(event) {
113 |     parmalink.mode("alloc");
114 |     mode(parmalink.mode());
115 |   });
116 | 
117 |   // public slots
118 |   that.mode = mode;
119 | 
120 |   return that;
121 | }
122 | 
123 | function costCentreChart(spec) {
124 |   var that = {};
125 | 
126 |   var cursor = spec.data,
127 |       selector = spec.selector,
128 |       parmalink = spec.parmalink;
129 |   var context = costCentreContext({cursor: cursor});
130 | 
131 |   // chart
132 |   var chart = $("#chart"),
133 |       w = spec.w || chart.width(),
134 |       h = spec.h || chart.height(),
135 |       r = Math.min(w, h) / 2,
136 |       x = d3.scale.linear().range([0, 2*Math.PI]),
137 |       y = d3.scale.sqrt().range([0, r]),
138 |       color = spec.color || d3.scale.category20c();
139 | 
140 |   var vis = d3.select("#chart")
141 |     .append("svg:svg")
142 |     .attr("width", w)
143 |     .attr("height", h)
144 |     .append("svg:g")
145 |     .attr("transform", "translate(" + w/2 + "," + h/2 + ")");
146 | 
147 |   var partition = d3.layout.partition()
148 |     .children(function(d) { return d.subForest; })
149 |     .value(value(parmalink.mode()));
150 | 
151 |   var arc = d3.svg.arc()
152 |     .startAngle(function(d) { return Math.max(0, Math.min(2*Math.PI, x(d.x))); })
153 |     .endAngle(function(d) { return Math.max(0, Math.min(2*Math.PI, x(d.x + d.dx))); })
154 |     .innerRadius(function(d) { return Math.max(0, y(d.y)); })
155 |     .outerRadius(function(d) { return Math.max(0, y(d.y + d.dy)); });
156 | 
157 |   var path = vis.data([cursor]).selectAll("path")
158 |     .data(partition.nodes)
159 |     .enter().append("svg:path")
160 |     .attr("d", arc)
161 |     .attr("id", function(d) { return "cc" + d.no + (d.isParent ? "p" : ""); })
162 |     .style("fill", function(d) { return color((d.children ? d : d.parent).name); })
163 |     .on("click", click)
164 |     .on("mouseover", mouseover)
165 |     .each(function(d) { d.x0 = d.x; d.dx0 = d.dx; }); // stash the old values for transition
166 | 
167 |   // event handlers
168 |   function click(d) {
169 |     transpose(d);
170 |     parmalink.transpose(d);
171 |     window.history.ready = true; // workaround for popstate on load
172 |     history.pushState(null, null, parmalink.pathname()); // HTML 5 History API
173 |   }
174 | 
175 |   function mouseover(d) {
176 |     // XXX
177 |   }
178 | 
179 |   // tweeners
180 |   function arcTween(a) {
181 |     var i = d3.interpolate({x: a.x0, dx: a.dx0}, a);
182 |     return function(t) {
183 |       var b = i(t);
184 |       a.x0  = b.x;
185 |       a.dx0 = b.dx;
186 |       return arc(b);
187 |     };
188 |   }
189 | 
190 |   function zoomTween(d) {
191 |     var xd = d3.interpolate(x.domain(), [d.x, d.x + d.dx]),
192 |         yd = d3.interpolate(y.domain(), [d.y, 1]),
193 |         yr = d3.interpolate(y.range(), [d.y ? 20 : 0, r]);
194 |     return function(d, i) {
195 |       return i
196 |         ? function(t) { return arc(d); }
197 |         : function(t) { x.domain(xd(t)); y.domain(yd(t)).range(yr(t)); return arc(d); };
198 |     };
199 |   }
200 | 
201 |   // helper functions
202 |   function value(mode) {
203 |     if (mode === "time")
204 |       return function(d) { return d.individualTime; };
205 |     else
206 |       return function(d) { return d.individualAlloc; };
207 |   }
208 | 
209 |   function nodeFromId(id) {
210 |     if (!id)
211 |       return null;
212 |     var elem = d3.select("#cc" + id);
213 |     return elem.node().__data__; // XXX: __data__ is not a public API
214 |   }
215 | 
216 |   var mode = function(mode) {
217 |     path.data(partition.value(value(mode)))
218 |       .transition()
219 |       .duration(500)
220 |       .attrTween("d", arcTween);
221 |   };
222 | 
223 |   var transpose = function(node) {
224 |     cursor = node;
225 |     context.transpose(cursor);
226 |     path.transition()
227 |       .duration(500)
228 |       .attrTween("d", zoomTween(node));
229 |   };
230 | 
231 |   var transposeById = function(id) {
232 |     transpose(nodeFromId(id) || spec.data);
233 |   };
234 | 
235 |   // public slots
236 |   that.mode = mode;
237 |   that.transpose = transpose;
238 |   that.transposeById = transposeById;
239 | 
240 |   // setup initial states
241 |   mode(parmalink.mode());
242 |   transposeById(parmalink.id());
243 | 
244 |   return that;
245 | }
246 | 
247 | function costCentreContext(spec) {
248 |   var that = {};
249 |   var cursor = spec.cursor;
250 | 
251 |   var showCostCentre = function(node) {
252 |     var currentNode = $("#current-node dl");
253 |     $("#current-node-module",    currentNode).text(node.module);
254 |     $("#current-node-name",      currentNode).text(node.name);
255 |     $("#current-node-number",    currentNode).text(node.no);
256 |     $("#current-node-entries",   currentNode).text(node.entries);
257 |     $("#current-node-ind-time",  currentNode).text(node.individualTime);
258 |     $("#current-node-ind-alloc", currentNode).text(node.individualAlloc);
259 |     $("#current-node-inh-time",  currentNode).text(node.inheritedTime);
260 |     $("#current-node-inh-alloc", currentNode).text(node.inheritedAlloc);
261 |   };
262 | 
263 |   var showChildren = function(node) {
264 |     $("#children ol li").remove();
265 |     var children = $("#children ol");
266 |     var cs = node.children;
267 |     if (cs) {
268 |       var n = cs.length < 10 ? cs.length : 10;
269 |       for (var i = 0; i < n; i++) {
270 |         children.append("<li>" + cs[i].name + "</li>");
271 |       }
272 |     }
273 |   };
274 | 
275 |   // setup
276 |   showCostCentre(cursor);
277 |   showChildren(cursor);
278 | 
279 |   // public slots
280 |   that.transpose = function(node) {
281 |     cursor = node;
282 |     showCostCentre(cursor);
283 |     showChildren(cursor);
284 |   };
285 | 
286 |   return that;
287 | }
288 | 


--------------------------------------------------------------------------------
/static/js/jquery.pjax.js:
--------------------------------------------------------------------------------
  1 | // jquery.pjax.js
  2 | // copyright chris wanstrath
  3 | // https://github.com/defunkt/jquery-pjax
  4 | 
  5 | (function($){
  6 | 
  7 | // When called on a link, fetches the href with ajax into the
  8 | // container specified as the first parameter or with the data-pjax
  9 | // attribute on the link itself.
 10 | //
 11 | // Tries to make sure the back button and ctrl+click work the way
 12 | // you'd expect.
 13 | //
 14 | // Accepts a jQuery ajax options object that may include these
 15 | // pjax specific options:
 16 | //
 17 | // container - Where to stick the response body. Usually a String selector.
 18 | //             $(container).html(xhr.responseBody)
 19 | //      push - Whether to pushState the URL. Defaults to true (of course).
 20 | //   replace - Want to use replaceState instead? That's cool.
 21 | //
 22 | // For convenience the first parameter can be either the container or
 23 | // the options object.
 24 | //
 25 | // Returns the jQuery object
 26 | $.fn.pjax = function( container, options ) {
 27 |   if ( options )
 28 |     options.container = container
 29 |   else
 30 |     options = $.isPlainObject(container) ? container : {container:container}
 31 | 
 32 |   // We can't persist $objects using the history API so we must use
 33 |   // a String selector. Bail if we got anything else.
 34 |   if ( options.container && typeof options.container !== 'string' ) {
 35 |     throw "pjax container must be a string selector!"
 36 |     return false
 37 |   }
 38 | 
 39 |   return this.live('click', function(event){
 40 |     // Middle click, cmd click, and ctrl click should open
 41 |     // links in a new tab as normal.
 42 |     if ( event.which > 1 || event.metaKey )
 43 |       return true
 44 | 
 45 |     var defaults = {
 46 |       url: this.href,
 47 |       container: $(this).attr('data-pjax'),
 48 |       clickedElement: $(this),
 49 |       fragment: null
 50 |     }
 51 | 
 52 |     $.pjax($.extend({}, defaults, options))
 53 | 
 54 |     event.preventDefault()
 55 |   })
 56 | }
 57 | 
 58 | 
 59 | // Loads a URL with ajax, puts the response body inside a container,
 60 | // then pushState()'s the loaded URL.
 61 | //
 62 | // Works just like $.ajax in that it accepts a jQuery ajax
 63 | // settings object (with keys like url, type, data, etc).
 64 | //
 65 | // Accepts these extra keys:
 66 | //
 67 | // container - Where to stick the response body. Must be a String.
 68 | //             $(container).html(xhr.responseBody)
 69 | //      push - Whether to pushState the URL. Defaults to true (of course).
 70 | //   replace - Want to use replaceState instead? That's cool.
 71 | //
 72 | // Use it just like $.ajax:
 73 | //
 74 | //   var xhr = $.pjax({ url: this.href, container: '#main' })
 75 | //   console.log( xhr.readyState )
 76 | //
 77 | // Returns whatever $.ajax returns.
 78 | $.pjax = function( options ) {
 79 |   var $container = $(options.container),
 80 |       success = options.success || $.noop
 81 | 
 82 |   // We don't want to let anyone override our success handler.
 83 |   delete options.success
 84 | 
 85 |   // We can't persist $objects using the history API so we must use
 86 |   // a String selector. Bail if we got anything else.
 87 |   if ( typeof options.container !== 'string' )
 88 |     throw "pjax container must be a string selector!"
 89 | 
 90 |   var defaults = {
 91 |     timeout: 650,
 92 |     push: true,
 93 |     replace: false,
 94 |     // We want the browser to maintain two separate internal caches: one for
 95 |     // pjax'd partial page loads and one for normal page loads. Without
 96 |     // adding this secret parameter, some browsers will often confuse the two.
 97 |     data: { _pjax: true },
 98 |     type: 'GET',
 99 |     dataType: 'html',
100 |     beforeSend: function(xhr){
101 |       $container.trigger('start.pjax')
102 |       xhr.setRequestHeader('X-PJAX', 'true')
103 |     },
104 |     error: function(){
105 |       window.location = options.url
106 |     },
107 |     complete: function(){
108 |       $container.trigger('end.pjax')
109 |     },
110 |     success: function(data){
111 |       if ( options.fragment ) {
112 |         // If they specified a fragment, look for it in the response
113 |         // and pull it out.
114 |         var $fragment = $(data).find(options.fragment)
115 |         if ( $fragment.length )
116 |           data = $fragment.children()
117 |         else
118 |           return window.location = options.url
119 |       } else {
120 |           // If we got no data or an entire web page, go directly
121 |           // to the page and let normal error handling happen.
122 |           if ( !$.trim(data) || /<html/i.test(data) )
123 |             return window.location = options.url
124 |       }
125 | 
126 |       // Make it happen.
127 |       $container.html(data)
128 | 
129 |       // If there's a <title> tag in the response, use it as
130 |       // the page's title.
131 |       var oldTitle = document.title,
132 |           title = $.trim( $container.find('title').remove().text() )
133 |       if ( title ) document.title = title
134 | 
135 |       var state = {
136 |         pjax: options.container,
137 |         fragment: options.fragment,
138 |         timeout: options.timeout
139 |       }
140 | 
141 |       // If there are extra params, save the complete URL in the state object
142 |       var query = $.param(options.data)
143 |       if ( query != "_pjax=true" )
144 |         state.url = options.url + (/\?/.test(options.url) ? "&" : "?") + query
145 | 
146 |       if ( options.replace ) {
147 |         window.history.replaceState(state, document.title, options.url)
148 |       } else if ( options.push ) {
149 |         // this extra replaceState before first push ensures good back
150 |         // button behavior
151 |         if ( !$.pjax.active ) {
152 |           window.history.replaceState($.extend({}, state, {url:null}), oldTitle)
153 |           $.pjax.active = true
154 |         }
155 | 
156 |         window.history.pushState(state, document.title, options.url)
157 |       }
158 | 
159 |       // Google Analytics support
160 |       if ( (options.replace || options.push) && window._gaq )
161 |         _gaq.push(['_trackPageview'])
162 | 
163 |       // If the URL has a hash in it, make sure the browser
164 |       // knows to navigate to the hash.
165 |       var hash = window.location.hash.toString()
166 |       if ( hash !== '' ) {
167 |         window.location.href = hash
168 |       }
169 | 
170 |       // Invoke their success handler if they gave us one.
171 |       success.apply(this, arguments)
172 |     }
173 |   }
174 | 
175 |   options = $.extend(true, {}, defaults, options)
176 | 
177 |   if ( $.isFunction(options.url) ) {
178 |     options.url = options.url()
179 |   }
180 | 
181 |   // Cancel the current request if we're already pjaxing
182 |   var xhr = $.pjax.xhr
183 |   if ( xhr && xhr.readyState < 4) {
184 |     xhr.onreadystatechange = $.noop
185 |     xhr.abort()
186 |   }
187 | 
188 |   $.pjax.xhr = $.ajax(options)
189 |   $(document).trigger('pjax', $.pjax.xhr, options)
190 | 
191 |   return $.pjax.xhr
192 | }
193 | 
194 | 
195 | // Used to detect initial (useless) popstate.
196 | // If history.state exists, assume browser isn't going to fire initial popstate.
197 | var popped = ('state' in window.history), initialURL = location.href
198 | 
199 | 
200 | // popstate handler takes care of the back and forward buttons
201 | //
202 | // You probably shouldn't use pjax on pages with other pushState
203 | // stuff yet.
204 | $(window).bind('popstate', function(event){
205 |   // Ignore inital popstate that some browsers fire on page load
206 |   var initialPop = !popped && location.href == initialURL
207 |   popped = true
208 |   if ( initialPop ) return
209 | 
210 |   var state = event.state
211 | 
212 |   if ( state && state.pjax ) {
213 |     var container = state.pjax
214 |     if ( $(container+'').length )
215 |       $.pjax({
216 |         url: state.url || location.href,
217 |         fragment: state.fragment,
218 |         container: container,
219 |         push: false,
220 |         timeout: state.timeout
221 |       })
222 |     else
223 |       window.location = location.href
224 |   }
225 | })
226 | 
227 | 
228 | // Add the state property to jQuery's event object so we can use it in
229 | // $(window).bind('popstate')
230 | if ( $.inArray('state', $.event.props) < 0 )
231 |   $.event.props.push('state')
232 | 
233 | 
234 | // Is pjax supported by this browser?
235 | $.support.pjax =
236 |   window.history && window.history.pushState && window.history.replaceState
237 |   // pushState isn't reliable on iOS yet.
238 |   && !navigator.userAgent.match(/(iPod|iPhone|iPad|WebApps\/.+CFNetwork)/)
239 | 
240 | 
241 | // Fall back to normalcy for older browsers.
242 | if ( !$.support.pjax ) {
243 |   $.pjax = function( options ) {
244 |     window.location = $.isFunction(options.url) ? options.url() : options.url
245 |   }
246 |   $.fn.pjax = function() { return this }
247 | }
248 | 
249 | })(jQuery);
250 | 


--------------------------------------------------------------------------------
/ProfilingReport.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances, RecordWildCards, OverloadedStrings, BangPatterns #-}
  2 | {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
  3 | module ProfilingReport
  4 |   ( -- * Parsers for profiling reports
  5 |     profilingReport
  6 |   , profilingReportI
  7 |     -- * Parsers for sub-parts of the report
  8 |   , timestamp
  9 |   , title
 10 |   , commandLine
 11 |   , totalTime
 12 |   , totalAlloc
 13 |   , hotCostCentres
 14 |   , costCentres
 15 |     -- * Data types
 16 |   , ProfilingReport(..)
 17 |   , Timestamp
 18 |   , CommandLine
 19 |   , TotalTime(..)
 20 |   , TotalAlloc(..)
 21 |   , BriefCostCentre(..)
 22 |   , CostCentre(..)
 23 |     -- * Re-exported modules
 24 |   , module Data.Tree
 25 |   ) where
 26 | 
 27 | import Control.Applicative hiding (many)
 28 | import Control.Monad.Catch (MonadThrow(..))
 29 | import Data.Aeson
 30 | import Data.Attoparsec.Char8 as A8
 31 | import Data.Conduit.Attoparsec (sinkParser)
 32 | import Data.ByteString (ByteString)
 33 | import Data.Conduit
 34 | import Data.Foldable (asum, foldl')
 35 | import Data.Time (UTCTime(..), TimeOfDay(..), timeOfDayToTime, fromGregorian)
 36 | import Data.Tree (Tree(..), Forest)
 37 | import Data.Tree.Zipper (TreePos, Full)
 38 | import Prelude hiding (takeWhile)
 39 | import qualified Data.Attoparsec as A
 40 | import qualified Data.HashMap.Strict as M
 41 | import qualified Data.Tree.Zipper as Z
 42 | import qualified Data.Vector as V
 43 | import Data.Text (Text)
 44 | import qualified Data.Text.Encoding as T
 45 | 
 46 | data ProfilingReport = ProfilingReport
 47 |   { reportTimestamp      :: Timestamp
 48 |   , reportCommandLine    :: CommandLine
 49 |   , reportTotalTime      :: TotalTime
 50 |   , reportTotalAlloc     :: TotalAlloc
 51 |   , reportHotCostCentres :: [BriefCostCentre]
 52 |   , reportCostCentres    :: Tree CostCentre
 53 |   } deriving Show
 54 | 
 55 | type Timestamp = UTCTime
 56 | 
 57 | type CommandLine = Text
 58 | 
 59 | data TotalTime = TotalTime
 60 |   { totalSecs  :: Double
 61 |   , totalTicks :: Integer
 62 |   , resolution :: Integer
 63 |   , processors :: Integer
 64 |   } deriving Show
 65 | 
 66 | newtype TotalAlloc = TotalAlloc
 67 |   { totalAllocBytes :: Integer
 68 |   } deriving Show
 69 | 
 70 | data BriefCostCentre = BriefCostCentre
 71 |   { briefCostCentreName   :: Text
 72 |   , briefCostCentreModule :: Text
 73 |   , briefCostCentreTime   :: Double
 74 |   , briefCostCentreAlloc  :: Double
 75 |   } deriving Show
 76 | 
 77 | data CostCentre = CostCentre
 78 |   { costCentreName    :: Text
 79 |   , costCentreModule  :: Text
 80 |   , costCentreNo      :: Integer
 81 |   , costCentreEntries :: Integer
 82 |   , individualTime    :: Double
 83 |   , individualAlloc   :: Double
 84 |   , inheritedTime     :: Double
 85 |   , inheritedAlloc    :: Double
 86 |   } deriving Show
 87 | 
 88 | profilingReportI :: MonadThrow m => Sink ByteString m ProfilingReport
 89 | profilingReportI = sinkParser profilingReport
 90 | 
 91 | profilingReport :: Parser ProfilingReport
 92 | profilingReport = spaces >>
 93 |   ProfilingReport <$> timestamp
 94 |                   <*  title          <* spaces
 95 |                   <*> commandLine    <* spaces
 96 |                   <*> totalTime      <* spaces
 97 |                   <*> totalAlloc     <* spaces
 98 |                   <*> hotCostCentres <* spaces
 99 |                   <*> costCentres
100 | 
101 | timestamp :: Parser Timestamp
102 | timestamp = do
103 |   dayOfTheWeek     <* spaces
104 |   m   <- month     <* spaces
105 |   d   <- day       <* spaces
106 |   tod <- timeOfDay <* spaces
107 |   y   <- year      <* spaces
108 |   return UTCTime { utctDay     = fromGregorian y m d
109 |                  , utctDayTime = timeOfDayToTime tod }
110 |   where
111 |     year = decimal
112 |     month = toNum <$> A8.take 3
113 |       where toNum m = case m of
114 |                         "Jan" -> 1; "Feb" -> 2; "Mar" -> 3; "Apr" -> 4;
115 |                         "May" -> 5; "Jun" -> 6; "Jul" -> 7; "Aug" -> 8;
116 |                         "Sep" -> 9; "Oct" -> 10; "Nov" -> 11; "Dec" -> 12
117 |                         _ -> error "timestamp.toNum: impossible"
118 |     day = decimal
119 |     timeOfDay = TimeOfDay <$> decimal <* string ":" <*> decimal <*> pure 0
120 |     dayOfTheWeek = takeTill isSpace
121 | 
122 | title :: Parser ByteString
123 | title = string "Time and Allocation Profiling Report  (Final)"
124 | 
125 | commandLine :: Parser CommandLine
126 | commandLine = T.decodeUtf8 <$> line
127 | 
128 | totalTime :: Parser TotalTime
129 | totalTime = do
130 |   string "total time  ="; spaces
131 |   secs <- double
132 |   string " secs"; spaces
133 |   (ticks, res, procs) <- parens $ (,,)
134 |     <$> decimal <* string " ticks @ "
135 |     <*> time <* string ", "
136 |     <*> decimal <* many1 (notChar ')')
137 |   return TotalTime { totalSecs  = secs
138 |                    , totalTicks = ticks
139 |                    , resolution = res
140 |                    , processors = procs }
141 |   where
142 |     time = asum
143 |       [ decimal <* string " us"
144 |       , pure (*1000) <*> decimal <* string " ms"
145 |       ]
146 | 
147 | totalAlloc :: Parser TotalAlloc
148 | totalAlloc = do
149 |   string "total alloc ="; spaces
150 |   n <- groupedDecimal
151 |   string " bytes" <* spaces <* parens (string "excludes profiling overheads")
152 |   return TotalAlloc { totalAllocBytes = n }
153 | 
154 | groupedDecimal :: Parser Integer
155 | groupedDecimal = foldl' go 0 <$> decimal `sepBy` char8 ','
156 |   where go z n = z*1000 + n
157 | 
158 | hotCostCentres :: Parser [BriefCostCentre]
159 | hotCostCentres = header *> spaces *> many1 briefCostCentre
160 |   where header :: Parser ByteString
161 |         header = line
162 | 
163 | briefCostCentre :: Parser BriefCostCentre
164 | briefCostCentre =
165 |   BriefCostCentre <$> symbolText <* spaces
166 |                   <*> symbolText <* spaces
167 |                   <*> double     <* spaces
168 |                   <*> double     <* spaces
169 | 
170 | costCentres :: Parser (Tree CostCentre)
171 | costCentres = header *> spaces *> costCentreTree
172 |   where header = count 2 line
173 | 
174 | -- Internal functions
175 | costCentreTree :: Parser (Tree CostCentre)
176 | costCentreTree = buildTree <$> costCentreMap >>= maybe empty pure
177 |   where
178 |     costCentreMap = nestedCostCentre `sepBy1` endOfLine
179 |     nestedCostCentre = (,) <$> nestLevel <*> costCentre
180 | 
181 | nestLevel :: Parser Int
182 | nestLevel = howMany space
183 | 
184 | costCentre :: Parser CostCentre
185 | costCentre =
186 |     CostCentre <$> (T.decodeUtf8 <$> takeWhile (not . isSpace)) <* spaces
187 |                <*> (T.decodeUtf8 <$> takeWhile (not . isSpace)) <* spaces
188 |                <*> decimal                                      <* spaces
189 |                <*> decimal                                      <* spaces
190 |                <*> double                                       <* spaces
191 |                <*> double                                       <* spaces
192 |                <*> double                                       <* spaces
193 |                <*> double
194 | 
195 | type Zipper = TreePos Full
196 | type Level = Int
197 | 
198 | buildTree :: [(Level, a)] -> Maybe (Tree a)
199 | buildTree [] = Nothing
200 | buildTree ((lvl, t):xs) = Z.toTree <$> snd (foldl' go (lvl, Just z) xs)
201 |   where
202 |     z = Z.fromTree $ Node t []
203 |     go :: (Level, Maybe (Zipper a)) -> (Level, a) -> (Level, Maybe (Zipper a))
204 |     go (curLvl, mzipper) a@(lvl', x)
205 |       | curLvl > lvl' = go (curLvl-1, mzipper >>= Z.parent) a
206 |       | curLvl < lvl' = case mzipper >>= Z.lastChild of
207 |                           Nothing  -> (lvl', Z.insert (Node x []) . Z.children <$> mzipper)
208 |                           mzipper' -> go (curLvl+1, mzipper') a
209 |       | otherwise     = (lvl', Z.insert (Node x []) . Z.nextSpace <$> mzipper)
210 | 
211 | 
212 | -- Small utilities
213 | howMany :: Parser a -> Parser Int
214 | howMany p = howMany' 0
215 |   where howMany' !n = (p >> howMany' (succ n)) <|> return n
216 | 
217 | spaces :: Parser ()
218 | spaces = () <$ skipMany space
219 | 
220 | line :: Parser ByteString
221 | line = A.takeWhile (not . isEndOfLine) <* spaces
222 | 
223 | parens :: Parser a -> Parser a
224 | parens p = string "(" *> p <* string ")"
225 | 
226 | symbol :: Parser ByteString
227 | symbol = takeWhile (not . isSpace)
228 | 
229 | symbolText :: Parser Text
230 | symbolText = T.decodeUtf8 <$> symbol
231 | 
232 | -- Aeson
233 | instance ToJSON ProfilingReport where
234 |   toJSON ProfilingReport {..} =
235 |     object [ "timestamp"      .= reportTimestamp
236 |            , "commandLine"    .= reportCommandLine
237 |            , "totalTime"      .= reportTotalTime
238 |            , "totalAlloc"     .= reportTotalAlloc
239 |            , "hotCostCentres" .= reportHotCostCentres
240 |            , "costCentres"    .= reportCostCentres
241 |            ]
242 | 
243 | instance ToJSON TotalTime where
244 |   toJSON TotalTime {..} =
245 |     object [ "secs"       .= totalSecs
246 |            , "ticks"      .= totalTicks
247 |            , "resolution" .= resolution
248 |            ]
249 | 
250 | instance ToJSON TotalAlloc where
251 |   toJSON TotalAlloc {..} =
252 |     object [ "bytes" .= totalAllocBytes ]
253 | 
254 | instance ToJSON BriefCostCentre where
255 |   toJSON BriefCostCentre {..} =
256 |     object [ "name"   .= briefCostCentreName
257 |            , "module" .= briefCostCentreModule
258 |            , "time"   .= briefCostCentreTime
259 |            , "alloc"  .= briefCostCentreAlloc
260 |            ]
261 | 
262 | instance ToJSON (Tree CostCentre) where
263 |   toJSON (Node cc@(CostCentre {..}) subForest)
264 |     | null subForest = cc'
265 |     | otherwise      = branch
266 |     where
267 |       branch = Object $ M.insert "subForest" subForestWithParent unwrappedCC
268 |       parent = Object $ M.insert "isParent" (toJSON True) unwrappedCC
269 |       subForestWithParent = Array $ V.fromList $ parent:map toJSON subForest
270 |       cc'@(Object unwrappedCC) = toJSON cc
271 | 
272 | instance ToJSON CostCentre where
273 |   toJSON CostCentre {..} =
274 |     object [ "name"            .= costCentreName
275 |            , "module"          .= costCentreModule
276 |            , "no"              .= costCentreNo
277 |            , "entries"         .= costCentreEntries
278 |            , "individualTime"  .= individualTime
279 |            , "individualAlloc" .= individualAlloc
280 |            , "inheritedTime"   .= inheritedTime
281 |            , "inheritedAlloc"  .= inheritedAlloc ]
282 | 


--------------------------------------------------------------------------------