profile2html.icl 7.65 KB
Newer Older
Camil Staps's avatar
Camil Staps committed
1 2 3
module profile2html

import StdEnv
Camil Staps's avatar
Camil Staps committed
4
import StdMaybe
Camil Staps's avatar
Camil Staps committed
5 6 7

import Data.Error
import Data.Func
8
import qualified Data.Set
Camil Staps's avatar
Camil Staps committed
9 10 11 12
import System.CommandLine
import System.File
import System.FilePath
import System.Options
13
import System.OS
14
import System.Process
15
import System._Pointer
Camil Staps's avatar
Camil Staps committed
16 17 18
from Text import class Text(concat,join), instance Text String, <+
import qualified Text.HTML

19
import PGCL
Camil Staps's avatar
Camil Staps committed
20 21

:: Options =
22 23 24 25
	{ input                :: !FilePath
	, output               :: !FilePath
	, min_cumulative_ticks :: !Int
	, exclude              :: !'Data.Set'.Set String
Camil Staps's avatar
Camil Staps committed
26 27
	}
defaultOptions =
28 29 30 31
	{ input                = ""
	, output               = ""
	, min_cumulative_ticks = 0
	, exclude              = 'Data.Set'.newSet
Camil Staps's avatar
Camil Staps committed
32 33 34 35 36 37
	}

Start w
	# ([prog:args],w) = getCommandLine w
	# args = parseOptions option_description args defaultOptions
	| isError args
Camil Staps's avatar
Camil Staps committed
38
		= exit (join "\n" [usage prog,"":fromError args]) w
Camil Staps's avatar
Camil Staps committed
39
	# args = fromOk args
Camil Staps's avatar
Camil Staps committed
40 41 42 43 44
	| size args.input==0
		= exit "Specify an input file" w
	# args & output = if (size args.output==0)
		(addExtension args.input "html")
		args.output
Camil Staps's avatar
Camil Staps committed
45 46 47 48 49 50 51 52
	# (ok,input,w) = fopen args.input FReadData w
	| not ok
		= exit "Could not open input file" w
	# (profile,input) = read_profile input
	# (_,w) = fclose input w
	| isError profile
		= exit ("Could not parse input: "+++fromError profile) w
	# profile = prepare args.min_cumulative_ticks args.exclude (fromOk profile)
53 54 55 56 57 58 59 60
	# (css,w) = readFile (exec_directory </> "profile.css") w
	| isError css
		= exit ("Could not open supporting CSS: "+++toString (fromError css)) w
	# css = fromOk css
	# (js,w) = readFile (exec_directory </> "profile.js") w
	| isError js
		= exit ("Could not open supporting JavaScript: "+++toString (fromError js)) w
	# js = fromOk js
Camil Staps's avatar
Camil Staps committed
61 62 63
	# (ok,f,w) = fopen args.output FWriteText w
	| not ok
		= exit "Could not open output file" w
64
	# f = write_profile css js profile f
Camil Staps's avatar
Camil Staps committed
65
	# (_,w) = fclose f w
66
	# w = open_file_in_browser args.output w
Camil Staps's avatar
Camil Staps committed
67 68
	= w
where
Camil Staps's avatar
Camil Staps committed
69 70 71 72 73 74 75 76
	usage prog = concat
		[ "Usage: "
		, prog
		, " [options] INPUT"
		]
	option_description =
		WithHelp True $ Options
		[ Shorthand "-o" "--output" $ Option "--output"
Camil Staps's avatar
Camil Staps committed
77 78 79
			(\op opts -> Ok {opts & output=op})
			"OUTPUT"
			"The output file"
80 81 82 83
		, Shorthand "-e" "--exclude" $ Option "--exclude"
			(\e opts -> Ok {opts & exclude='Data.Set'.insert e opts.exclude})
			"MODULE:FUNCTION"
			"A function to exclude (may be specified multiple times)"
84 85 86 87 88 89 90 91 92 93
		, Option "--min-ticks"
			(\t opts -> case toInt t of
				0
					| t=="0"
						-> Ok {opts & min_cumulative_ticks=0}
						-> Error [concat ["--min-ticks: invalid integer '",t,"'"]]
				t
					-> Ok {opts & min_cumulative_ticks=t})
			"N"
			"Only include cost centres with at least N ticks (cumulatively)"
Camil Staps's avatar
Camil Staps committed
94 95 96 97 98 99 100 101
		, Operand
			False
			(\ip opts
				| size opts.input==0
					-> Just (Ok {opts & input=ip})
					-> Nothing)
			"INPUT"
			"The input file"
Camil Staps's avatar
Camil Staps committed
102 103 104 105 106 107
		]

	exit err w
		# (_,w) = fclose (stderr <<< err <<< '\n') w
		= setReturnCode -1 w

108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130
write_profile :: !String !String !Profile !*File -> *File
write_profile css js p f
	# f = f <<< "<!DOCTYPE html>"
		<<< "<html lang=\"en\">"
		<<< "<head>"
		<<< "<title>Profile</title>"
		<<< "<meta charset=\"utf-8\">"
		<<< "<style type=\"text/css\">" <<< css <<< "</style>"
		<<< "</head>"
		<<< "<body>"
		<<< "<div class=\"header\">"
		<<< "<span class=\"entry-data\">Function</span>"
		<<< "<span class=\"progress-header\">Words</span>"
		<<< "<span class=\"progress-header\">Ticks</span>"
		<<< "<span class=\"entry-data\">Curried calls</span>"
		<<< "<span class=\"entry-data\">Lazy calls</span>"
		<<< "<span class=\"entry-data\">Strict calls</span>"
		<<< "</div>"
	# f = write_stack p p.profile f
	= f
		<<< "<script>" <<< js <<< "</script>"
		<<< "</body>"
		<<< "</html>"
Camil Staps's avatar
Camil Staps committed
131

132
write_stack :: !Profile !ProfileStack !*File -> *File
Camil Staps's avatar
Camil Staps committed
133
write_stack p s f = write s.cumulative_ticks s.cumulative_words s f
Camil Staps's avatar
Camil Staps committed
134
where
135
	write :: !Int !Int !ProfileStack !*File -> *File
Camil Staps's avatar
Camil Staps committed
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
	write parent_ticks parent_words s f
		# f = f <<< "<div class=\"entry\">"
			<<< "<div class=\"entry-header\">"
			<<< if (isEmpty s.children) "" "<span class=\"toggler open\">&#x229f;</span>"
			<<< "<span class=\"entry-content\">" <<< 'Text.HTML'.escapeStr p.modules.[cost_centre.cc_module]
				<<< ": <span class=\"function\">" <<< 'Text.HTML'.escapeStr cost_centre.cc_name <<< "</span></span>"
			<<< "&nbsp;"
			<<< "<span class=\"progress words\" title=\"" <<< words <<< "\">"
				<<< if (parent_words==0) "" (concat ["<span class=\"bar\" style=\"",words_width,"\"></span>"])
				<<< "</span>"
			<<< "<span class=\"progress ticks\" title=\"" <<< ticks <<< "\">"
				<<< if (parent_ticks==0) "" (concat ["<span class=\"bar\" style=\"",ticks_width,"\"></span>"])
				<<< "</span>"
			<<< "<span class=\"entry-data\">" <<< if (s.ccalls==0) "&nbsp;" (toString s.ccalls) <<< "</span>"
			<<< "<span class=\"entry-data\">" <<< if (s.lcalls==0) "&nbsp;" (toString s.lcalls) <<< "</span>"
			<<< "<span class=\"entry-data\">" <<< if (s.scalls==0) "&nbsp;" (toString s.scalls) <<< "</span>"
			<<< "</div>"
Camil Staps's avatar
Camil Staps committed
153
		# f = foldl (\f c -> write s.cumulative_ticks s.cumulative_words c f) f s.children
Camil Staps's avatar
Camil Staps committed
154
		= f <<< "</div>"
Camil Staps's avatar
Camil Staps committed
155
	where
Camil Staps's avatar
Camil Staps committed
156 157 158 159
		cost_centre = p.cost_centres.[s.cost_centre]

		ticks = if (isEmpty s.children)
			(toString s.ticks)
Camil Staps's avatar
Camil Staps committed
160 161
			(concat [toString s.cumulative_ticks," (",toString s.ticks,")"])
		ticks_width = toWidth (toReal s.cumulative_ticks / toReal parent_ticks)
Camil Staps's avatar
Camil Staps committed
162 163 164

		words = if (isEmpty s.children)
			(toString s.words)
Camil Staps's avatar
Camil Staps committed
165 166
			(concat [toString s.cumulative_words," (",toString s.words,")"])
		words_width = toWidth (toReal s.cumulative_words / toReal parent_words)
Camil Staps's avatar
Camil Staps committed
167 168 169 170 171 172 173 174 175 176 177 178 179 180

		toWidth :: !Real -> String
		toWidth w
			| wi>=10000
				= "width:100%;"
				=
					{ 'w','i','d','t','h',':'
					, toChar (wi/1000)+'0'
					, toChar ((wi rem 1000)/100)+'0'
					, '.'
					, toChar ((wi rem 100)/10)+'0'
					, toChar (wi rem 10)+'0'
					, '%',';'
					}
Camil Staps's avatar
Camil Staps committed
181
		where
Camil Staps's avatar
Camil Staps committed
182
			wi = toInt (w * 10000.0)
183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251

exec_directory :: String
exec_directory =: takeDirectory (IF_LINUX get_linux (IF_WINDOWS get_windows get_macosx))
where
	get_linux
		# buf = createArray 8192 '\0'
		# n = readlink "/proc/self/exe\0" (get_string_pointer buf) 8192
		| n<0 || n>=8192
			= abort "exec_directory failed\n"
			= buf % (0,n-1)
	where
		readlink :: !String !Pointer !Int -> Int
		readlink _ _ _ = code {
			ccall readlink "spI:I"
		}

	get_windows
		# buf = createArray 8192 '\0'
		# n = GetModuleFileNameA 0 (get_string_pointer buf) 8192
		| n==0
			= abort "exec_directory failed"
			= buf % (0,n-1)
	where
		GetModuleFileNameA :: !Int !Pointer !Int -> Int
		GetModuleFileNameA _ _ _ = code {
			ccall GetModuleFileNameA "IpI:I"
		}

	get_macosx
		# buf = createArray 8192 '\0'
		# bufp = get_string_pointer buf
		# sz = createArray 1 8192
		# n = get_executable_path bufp (get_array_pointer sz)
		| n<>0
			= abort "exec_directory failed\n"
		# buf2 = createArray 8192 '\0'
		# buf2p = get_string_pointer buf2
		# r = realpath bufp buf2p
		| r<>r || buf.[0]=='\0' || buf2.[0]=='\0' /* keep buf and buf2 in memory */
			= abort "exec_directory failed\n"
			= derefString buf2p
	where
		get_executable_path :: !Pointer !Pointer -> Int
		get_executable_path _ _ = code {
			ccall _NSGetExecutablePath "pp:I"
		}

		realpath :: !Pointer !Pointer -> Pointer
		realpath _ _ = code {
			ccall realpath "pp:p"
		}

	get_string_pointer :: !String -> Pointer
	get_string_pointer arr = get arr + IF_INT_64_OR_32 16 8
	where
		get :: !String -> Pointer
		get _ = code {
			push_a_b 0
			pop_a 1
		}

	get_array_pointer :: !{#Int} -> Pointer
	get_array_pointer arr = get arr + IF_INT_64_OR_32 24 12
	where
		get :: !{#Int} -> Pointer
		get _ = code {
			push_a_b 0
			pop_a 1
		}
252 253 254 255 256 257

open_file_in_browser :: !String !*World -> *World
open_file_in_browser file w = snd (callProcess open args Nothing w)
where
	open = IF_LINUX "xdg-open" (IF_WINDOWS "C:\\Windows\\System32\\cmd.exe" "open")
	args = IF_WINDOWS ["/c","start",file] [file]