module profile2html import StdEnv import StdMaybe import Data.Error import Data.Func import qualified Data.Set import System.CommandLine import System.File import System.FilePath import System.Options import System.OS import System.Process import System._Pointer from Text import class Text(concat,join), instance Text String, <+ import qualified Text.HTML import PGCL :: Options = { input :: !FilePath , output :: !FilePath , min_cumulative_ticks :: !Int , exclude :: !'Data.Set'.Set String } defaultOptions = { input = "" , output = "" , min_cumulative_ticks = 0 , exclude = 'Data.Set'.newSet } Start w # ([prog:args],w) = getCommandLine w # args = parseOptions option_description args defaultOptions | isError args = exit (join "\n" [usage prog,"":fromError args]) w # args = fromOk args | size args.input==0 = exit "Specify an input file" w # args & output = if (size args.output==0) (addExtension args.input "html") args.output # (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) # (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 # (ok,f,w) = fopen args.output FWriteText w | not ok = exit "Could not open output file" w # f = write_profile css js profile f # (_,w) = fclose f w # w = open_file_in_browser args.output w = w where usage prog = concat [ "Usage: " , prog , " [options] INPUT" ] option_description = WithHelp True $ Options [ Shorthand "-o" "--output" $ Option "--output" (\op opts -> Ok {opts & output=op}) "OUTPUT" "The output file" , 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)" , 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)" , Operand False (\ip opts | size opts.input==0 -> Just (Ok {opts & input=ip}) -> Nothing) "INPUT" "The input file" ] exit err w # (_,w) = fclose (stderr <<< err <<< '\n') w = setReturnCode -1 w write_profile :: !String !String !Profile !*File -> *File write_profile css js p f # f = f <<< "" <<< "" <<< "" <<< "Profile" <<< "" <<< "" <<< "" <<< "" <<< "
" <<< "Function" <<< "Words" <<< "Ticks" <<< "Curried calls" <<< "Lazy calls" <<< "Strict calls" <<< "
" # f = write_stack p p.profile f = f <<< "" <<< "" <<< "" write_stack :: !Profile !ProfileStack !*File -> *File write_stack p s f = write s.cumulative_ticks s.cumulative_words s f where write :: !Int !Int !ProfileStack !*File -> *File write parent_ticks parent_words s f # f = f <<< "
" <<< "
" <<< if (isEmpty s.children) "" "" <<< "" <<< 'Text.HTML'.escapeStr p.modules.[cost_centre.cc_module] <<< ": " <<< 'Text.HTML'.escapeStr cost_centre.cc_name <<< "" <<< " " <<< "" <<< if (parent_words==0) "" (concat [""]) <<< "" <<< "" <<< if (parent_ticks==0) "" (concat [""]) <<< "" <<< "" <<< if (s.ccalls==0) " " (toString s.ccalls) <<< "" <<< "" <<< if (s.lcalls==0) " " (toString s.lcalls) <<< "" <<< "" <<< if (s.scalls==0) " " (toString s.scalls) <<< "" <<< "
" # f = foldl (\f c -> write s.cumulative_ticks s.cumulative_words c f) f s.children = f <<< "
" where cost_centre = p.cost_centres.[s.cost_centre] ticks = if (isEmpty s.children) (toString s.ticks) (concat [toString s.cumulative_ticks," (",toString s.ticks,")"]) ticks_width = toWidth (toReal s.cumulative_ticks / toReal parent_ticks) words = if (isEmpty s.children) (toString s.words) (concat [toString s.cumulative_words," (",toString s.words,")"]) words_width = toWidth (toReal s.cumulative_words / toReal parent_words) 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' , '%',';' } where wi = toInt (w * 10000.0) 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 } 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]