Verified Commit 59d2e47c authored by Camil Staps's avatar Camil Staps 🚀

Copy supporting CSS and JS into the generated HTML to create a standalone file

parent a9291252
...@@ -10,6 +10,8 @@ import System.CommandLine ...@@ -10,6 +10,8 @@ import System.CommandLine
import System.File import System.File
import System.FilePath import System.FilePath
import System.Options import System.Options
import System.OS
import System._Pointer
from Text import class Text(concat,join), instance Text String, <+ from Text import class Text(concat,join), instance Text String, <+
import qualified Text.HTML import qualified Text.HTML
...@@ -47,10 +49,18 @@ Start w ...@@ -47,10 +49,18 @@ Start w
| isError profile | isError profile
= exit ("Could not parse input: "+++fromError profile) w = exit ("Could not parse input: "+++fromError profile) w
# profile = prepare args.min_cumulative_ticks args.exclude (fromOk profile) # 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 # (ok,f,w) = fopen args.output FWriteText w
| not ok | not ok
= exit "Could not open output file" w = exit "Could not open output file" w
# f = f <<< profile # f = write_profile css js profile f
# (_,w) = fclose f w # (_,w) = fclose f w
= w = w
where where
...@@ -93,30 +103,29 @@ where ...@@ -93,30 +103,29 @@ where
# (_,w) = fclose (stderr <<< err <<< '\n') w # (_,w) = fclose (stderr <<< err <<< '\n') w
= setReturnCode -1 w = setReturnCode -1 w
instance <<< Profile write_profile :: !String !String !Profile !*File -> *File
where write_profile css js p f
<<< f p # f = f <<< "<!DOCTYPE html>"
# f = f <<< "<!DOCTYPE html>" <<< "<html lang=\"en\">"
<<< "<html lang=\"en\">" <<< "<head>"
<<< "<head>" <<< "<title>Profile</title>"
<<< "<title>Profile</title>" <<< "<meta charset=\"utf-8\">"
<<< "<meta charset=\"utf-8\">" <<< "<style type=\"text/css\">" <<< css <<< "</style>"
<<< "<link rel=\"stylesheet\" type=\"text/css\" href=\"profile.css\">" <<< "</head>"
<<< "</head>" <<< "<body>"
<<< "<body>" <<< "<div class=\"header\">"
<<< "<div class=\"header\">" <<< "<span class=\"entry-data\">Function</span>"
<<< "<span class=\"entry-data\">Function</span>" <<< "<span class=\"progress-header\">Words</span>"
<<< "<span class=\"progress-header\">Words</span>" <<< "<span class=\"progress-header\">Ticks</span>"
<<< "<span class=\"progress-header\">Ticks</span>" <<< "<span class=\"entry-data\">Curried calls</span>"
<<< "<span class=\"entry-data\">Curried calls</span>" <<< "<span class=\"entry-data\">Lazy calls</span>"
<<< "<span class=\"entry-data\">Lazy calls</span>" <<< "<span class=\"entry-data\">Strict calls</span>"
<<< "<span class=\"entry-data\">Strict calls</span>" <<< "</div>"
<<< "</div>" # f = write_stack p p.profile f
# f = write_stack p p.profile f = f
= f <<< "<script>" <<< js <<< "</script>"
<<< "<script defer=\"defer\" src=\"profile.js\"></script>" <<< "</body>"
<<< "</body>" <<< "</html>"
<<< "</html>"
write_stack :: !Profile !ProfileStack !*File -> *File write_stack :: !Profile !ProfileStack !*File -> *File
write_stack p s f = write s.cumulative_ticks s.cumulative_words s f write_stack p s f = write s.cumulative_ticks s.cumulative_words s f
...@@ -169,3 +178,72 @@ where ...@@ -169,3 +178,72 @@ where
} }
where where
wi = toInt (w * 10000.0) 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
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment